diff --git a/bindings/dune b/bindings/dune index dd52004..8b2de9e 100644 --- a/bindings/dune +++ b/bindings/dune @@ -1,5 +1,4 @@ (library - (name pci_bindings) - (public_name pci.bindings) - (libraries ctypes.stubs ctypes ctypes.foreign.threaded) -) + (name pci_bindings) + (public_name pci.bindings) + (libraries ctypes.stubs ctypes ctypes.foreign.threaded)) diff --git a/bindings/ffi_bindings.ml b/bindings/ffi_bindings.ml index ea9858d..14e6b05 100644 --- a/bindings/ffi_bindings.ml +++ b/bindings/ffi_bindings.ml @@ -1,67 +1,118 @@ open Ctypes -module Types (F: Cstubs.Types.TYPE) = struct +module Types (F : Cstubs.Types.TYPE) = struct module Lookup_mode = struct let lookup_vendor = F.constant "PCI_LOOKUP_VENDOR" F.int + let lookup_device = F.constant "PCI_LOOKUP_DEVICE" F.int + let lookup_class = F.constant "PCI_LOOKUP_CLASS" F.int + let lookup_subsystem = F.constant "PCI_LOOKUP_SUBSYSTEM" F.int + let lookup_progif = F.constant "PCI_LOOKUP_PROGIF" F.int + let lookup_numeric = F.constant "PCI_LOOKUP_NUMERIC" F.int + let lookup_no_numbers = F.constant "PCI_LOOKUP_NO_NUMBERS" F.int + let lookup_mixed = F.constant "PCI_LOOKUP_MIXED" F.int + let lookup_network = F.constant "PCI_LOOKUP_NETWORK" F.int + let lookup_skip_local = F.constant "PCI_LOOKUP_SKIP_LOCAL" F.int + let lookup_cache = F.constant "PCI_LOOKUP_CACHE" F.int + let lookup_refresh_cache = F.constant "PCI_LOOKUP_REFRESH_CACHE" F.int end + module Fill_flag = struct let fill_ident = F.constant "PCI_FILL_IDENT" F.int + let fill_irq = F.constant "PCI_FILL_IRQ" F.int + let fill_bases = F.constant "PCI_FILL_BASES" F.int + let fill_rom_base = F.constant "PCI_FILL_ROM_BASE" F.int + let fill_sizes = F.constant "PCI_FILL_SIZES" F.int + let fill_class = F.constant "PCI_FILL_CLASS" F.int + let fill_caps = F.constant "PCI_FILL_CAPS" F.int + let fill_ext_caps = F.constant "PCI_FILL_EXT_CAPS" F.int + let fill_phys_slot = F.constant "PCI_FILL_PHYS_SLOT" F.int + let fill_module_alias = F.constant "PCI_FILL_MODULE_ALIAS" F.int + let fill_rescan = F.constant "PCI_FILL_RESCAN" F.int end + module Pci_class = struct let class_not_defined = F.constant "PCI_CLASS_NOT_DEFINED" F.int + let base_class_storage = F.constant "PCI_BASE_CLASS_STORAGE" F.int + let base_class_network = F.constant "PCI_BASE_CLASS_NETWORK" F.int + let base_class_display = F.constant "PCI_BASE_CLASS_DISPLAY" F.int + let base_class_multimedia = F.constant "PCI_BASE_CLASS_MULTIMEDIA" F.int + let base_class_memory = F.constant "PCI_BASE_CLASS_MEMORY" F.int + let base_class_bridge = F.constant "PCI_BASE_CLASS_BRIDGE" F.int - let base_class_communication = F.constant "PCI_BASE_CLASS_COMMUNICATION" F.int + + let base_class_communication = + F.constant "PCI_BASE_CLASS_COMMUNICATION" F.int + let base_class_system = F.constant "PCI_BASE_CLASS_SYSTEM" F.int + let base_class_input = F.constant "PCI_BASE_CLASS_INPUT" F.int + let base_class_docking = F.constant "PCI_BASE_CLASS_DOCKING" F.int + let base_class_processor = F.constant "PCI_BASE_CLASS_PROCESSOR" F.int + let base_class_serial = F.constant "PCI_BASE_CLASS_SERIAL" F.int + let base_class_wireless = F.constant "PCI_BASE_CLASS_WIRELESS" F.int + let base_class_intelligent = F.constant "PCI_BASE_CLASS_INTELLIGENT" F.int + let base_class_satellite = F.constant "PCI_BASE_CLASS_SATELLITE" F.int + let base_class_crypt = F.constant "PCI_BASE_CLASS_CRYPT" F.int + let base_class_signal = F.constant "PCI_BASE_CLASS_SIGNAL" F.int + let class_others = F.constant "PCI_CLASS_OTHERS" F.int end + module Header = struct (* A subset of the PCI configuration address space (see pci/header.h) *) let header_type = F.constant "PCI_HEADER_TYPE" F.int + let header_type_normal = F.constant "PCI_HEADER_TYPE_NORMAL" F.int + let subsystem_vendor_id = F.constant "PCI_SUBSYSTEM_VENDOR_ID" F.int + let subsystem_id = F.constant "PCI_SUBSYSTEM_ID" F.int + let header_type_cardbus = F.constant "PCI_HEADER_TYPE_CARDBUS" F.int + let cb_subsystem_vendor_id = F.constant "PCI_CB_SUBSYSTEM_VENDOR_ID" F.int + let cb_subsystem_id = F.constant "PCI_CB_SUBSYSTEM_ID" F.int end + module Access_type = struct (* Just a subset of the access types we'll need internally *) let auto = F.constant "PCI_ACCESS_AUTO" F.uint + let dump = F.constant "PCI_ACCESS_DUMP" F.uint end end @@ -71,139 +122,219 @@ module Bindings (F : Cstubs.FOREIGN) = struct module Pci_cap = struct type pci_cap + let pci_cap : pci_cap structure typ = structure "pci_cap" - let (-:) ty label = field pci_cap label ty - let next = (ptr_opt pci_cap) -: "next" + + let ( -: ) ty label = field pci_cap label ty + + let next = ptr_opt pci_cap -: "next" + let id = uint16_t -: "id" - let type_ = uint16_t -: "type" - let addr = int -: "addr" + + let type_ = uint16_t -: "type" + + let addr = int -: "addr" + let () = seal pci_cap type t = pci_cap structure ptr + let t = ptr pci_cap end module Pci_dev = struct type pci_dev + let pci_dev : pci_dev structure typ = structure "pci_dev" - let (-:) ty label = field pci_dev label ty - let next = (ptr_opt pci_dev) -: "next" + + let ( -: ) ty label = field pci_dev label ty + + let next = ptr_opt pci_dev -: "next" + let domain = uint16_t -: "domain" + let bus = uint8_t -: "bus" + let dev = uint8_t -: "dev" + let func = uint8_t -: "func" + let known_fields = int -: "known_fields" + let vendor_id = uint16_t -: "vendor_id" + let device_id = uint16_t -: "device_id" + let device_class = uint16_t -: "device_class" + let irq = int -: "irq" - let pciaddr_t = nativeint (* TODO: this is derived at compile time in pci/types.h... *) - let base_addr = (array 6 pciaddr_t) -: "base_addr" - let size = (array 6 pciaddr_t) -: "size" + + let pciaddr_t = nativeint + + (* TODO: this is derived at compile time in pci/types.h... *) + + let base_addr = array 6 pciaddr_t -: "base_addr" + + let size = array 6 pciaddr_t -: "size" + let rom_base_addr = pciaddr_t -: "rom_base_addr" + let rom_size = pciaddr_t -: "rom_size" + let first_cap = Pci_cap.t -: "first_cap" + let phy_slot = string_opt -: "phy_slot" + let module_alias = string_opt -: "module_alias" + (* Fields used internally *) - let access = (ptr void) -: "access" - let methods = (ptr void) -: "methods" - let cache = (ptr uint8_t) -: "cache" + let access = ptr void -: "access" + + let methods = ptr void -: "methods" + + let cache = ptr uint8_t -: "cache" + let cache_len = int -: "cache_len" + let hdrtype = int -: "hdrtype" - let aux = (ptr void) -: "aux" + + let aux = ptr void -: "aux" + let () = seal pci_dev type t = pci_dev structure ptr + let t = ptr pci_dev end module Pci_param = struct type pci_param + let pci_param : pci_param structure typ = structure "pci_param" - let (-:) ty label = field pci_param label ty + + let ( -: ) ty label = field pci_param label ty + let next = ptr_opt pci_param -: "next" + let param = string -: "param" + let value = string -: "value" + let value_malloced = int -: "value_malloced" + let help = string -: "help" + let () = seal pci_param type t = pci_param structure ptr + let t = ptr pci_param end module Pci_filter = struct type pci_filter + let pci_filter : pci_filter structure typ = structure "pci_filter" - let (-:) ty label = field pci_filter label ty + + let ( -: ) ty label = field pci_filter label ty + let domain = int -: "domain" + let bus = int -: "bus" + let slot = int -: "slot" + let func = int -: "func" + let vendor = int -: "vendor" + let device = int -: "device" + let () = seal pci_filter type t = pci_filter structure ptr + let t = ptr pci_filter end module Pci_access = struct open Pci_dev + type pci_access + let pci_access : pci_access structure typ = structure "pci_access" - let (-:) ty label = field pci_access label ty + + let ( -: ) ty label = field pci_access label ty + let method_ = uint -: "method" + let writeable = int -: "writeable" + let buscentric = int -: "buscentric" + let id_file_name = string -: "id_file_name" + let free_id_name = int -: "free_id_name" + let numeric_ids = int -: "numeric_ids" + let lookup_mode = uint -: "lookup_mode" + let debugging = int -: "debugging" - let error = (ptr void) -: "error" - let warning = (ptr void) -: "warning" - let debug = (ptr void) -: "debug" + + let error = ptr void -: "error" + + let warning = ptr void -: "warning" + + let debug = ptr void -: "debug" + let devices = field pci_access "devices" (ptr_opt pci_dev) + (* Fields used internally *) - let methods = (ptr void) -: "methods" - let params = (ptr void) -: "params" - let id_hash = (ptr (ptr void)) -: "id_hash" - let current_id_bucket = (ptr void) -: "current_id_bucket" + let methods = ptr void -: "methods" + + let params = ptr void -: "params" + + let id_hash = ptr (ptr void) -: "id_hash" + + let current_id_bucket = ptr void -: "current_id_bucket" + let id_load_failed = int -: "id_load_failed" + let id_cache_status = int -: "id_cache_status" + let fd = int -: "fd" + let fd_rw = int -: "fd_rw" + let fd_pos = int -: "fd_pos" + let fd_vpd = int -: "fd_vpd" - let cached_dev = (ptr_opt pci_dev) -: "cached_dev" + + let cached_dev = ptr_opt pci_dev -: "cached_dev" + let () = seal pci_access type t = pci_access structure ptr + let t = ptr pci_access end - let pci_alloc = - foreign "pci_alloc" (void @-> returning Pci_access.t) + let pci_alloc = foreign "pci_alloc" (void @-> returning Pci_access.t) - let pci_init = - foreign "pci_init" (Pci_access.t @-> returning void) + let pci_init = foreign "pci_init" (Pci_access.t @-> returning void) - let pci_cleanup = - foreign "pci_cleanup" (Pci_access.t @-> returning void) + let pci_cleanup = foreign "pci_cleanup" (Pci_access.t @-> returning void) - let pci_scan_bus = - foreign "pci_scan_bus" (Pci_access.t @-> returning void) + let pci_scan_bus = foreign "pci_scan_bus" (Pci_access.t @-> returning void) let pci_get_dev = - foreign "pci_get_dev" (Pci_access.t @-> int @-> int @-> int @-> int @-> returning Pci_dev.t) + foreign "pci_get_dev" + (Pci_access.t @-> int @-> int @-> int @-> int @-> returning Pci_dev.t) - let pci_free_dev = - foreign "pci_free_dev" (Pci_dev.t @-> returning void) + let pci_free_dev = foreign "pci_free_dev" (Pci_dev.t @-> returning void) - let pci_lookup_method = - foreign "pci_lookup_method" (string @-> returning int) + let pci_lookup_method = foreign "pci_lookup_method" (string @-> returning int) let pci_get_method_name = foreign "pci_get_method_name" (int @-> returning string) @@ -212,10 +343,12 @@ module Bindings (F : Cstubs.FOREIGN) = struct foreign "pci_get_param" (Pci_access.t @-> string @-> returning string) let pci_set_param = - foreign "pci_set_param" (Pci_access.t @-> string @-> string @-> returning int) + foreign "pci_set_param" + (Pci_access.t @-> string @-> string @-> returning int) let pci_walk_params = - foreign "pci_walk_params" (Pci_access.t @-> Pci_param.t @-> returning Pci_param.t) + foreign "pci_walk_params" + (Pci_access.t @-> Pci_param.t @-> returning Pci_param.t) let pci_read_byte = foreign "pci_read_byte" (Pci_dev.t @-> int @-> returning uint8_t) @@ -227,10 +360,12 @@ module Bindings (F : Cstubs.FOREIGN) = struct foreign "pci_read_long" (Pci_dev.t @-> int @-> returning uint32_t) let pci_read_block = - foreign "pci_read_block" (Pci_dev.t @-> int @-> ptr uint8_t @-> int @-> returning int) + foreign "pci_read_block" + (Pci_dev.t @-> int @-> ptr uint8_t @-> int @-> returning int) let pci_read_vpd = - foreign "pci_read_vpd" (Pci_dev.t @-> int @-> ptr uint8_t @-> int @-> returning int) + foreign "pci_read_vpd" + (Pci_dev.t @-> int @-> ptr uint8_t @-> int @-> returning int) let pci_write_byte = foreign "pci_write_byte" (Pci_dev.t @-> int @-> uint8_t @-> returning int) @@ -239,13 +374,15 @@ module Bindings (F : Cstubs.FOREIGN) = struct foreign "pci_write_long" (Pci_dev.t @-> int @-> uint16_t @-> returning int) let pci_write_block = - foreign "pci_write_block" (Pci_dev.t @-> int @-> ptr uint8_t @-> int @-> returning int) + foreign "pci_write_block" + (Pci_dev.t @-> int @-> ptr uint8_t @-> int @-> returning int) let pci_fill_info = foreign "pci_fill_info" (Pci_dev.t @-> int @-> returning int) let pci_setup_cache = - foreign "pci_setup_cache" (Pci_dev.t @-> ptr uint8_t @-> int @-> returning void) + foreign "pci_setup_cache" + (Pci_dev.t @-> ptr uint8_t @-> int @-> returning void) let pci_find_cap = foreign "pci_find_cap" (Pci_dev.t @-> uint @-> uint @-> returning Pci_cap.t) @@ -254,7 +391,8 @@ module Bindings (F : Cstubs.FOREIGN) = struct foreign "pci_filter_init" (Pci_access.t @-> Pci_filter.t @-> returning void) let pci_filter_parse_slot = - foreign "pci_filter_parse_slot" (Pci_filter.t @-> string @-> returning string) + foreign "pci_filter_parse_slot" + (Pci_filter.t @-> string @-> returning string) let pci_filter_parse_id = foreign "pci_filter_parse_id" (Pci_filter.t @-> string @-> returning string) @@ -264,15 +402,37 @@ module Bindings (F : Cstubs.FOREIGN) = struct let pci_lookup_name_1_ary = foreign "pci_lookup_name" - (Pci_access.t @-> ptr char @-> int @-> int @-> int @-> returning string_opt) + (Pci_access.t + @-> ptr char + @-> int + @-> int + @-> int + @-> returning string_opt + ) let pci_lookup_name_2_ary = foreign "pci_lookup_name" - (Pci_access.t @-> ptr char @-> int @-> int @-> int @-> int @-> returning string_opt) + (Pci_access.t + @-> ptr char + @-> int + @-> int + @-> int + @-> int + @-> returning string_opt + ) let pci_lookup_name_4_ary = foreign "pci_lookup_name" - (Pci_access.t @-> ptr char @-> int @-> int @-> int @-> int @-> int @-> int @-> returning string_opt) + (Pci_access.t + @-> ptr char + @-> int + @-> int + @-> int + @-> int + @-> int + @-> int + @-> returning string_opt + ) let pci_load_name_list = foreign "pci_load_name_list" (Pci_access.t @-> returning int) @@ -281,7 +441,8 @@ module Bindings (F : Cstubs.FOREIGN) = struct foreign "pci_free_name_list" (Pci_access.t @-> returning void) let pci_set_name_list_path = - foreign "pci_set_name_list_path" (Pci_access.t @-> string @-> int @-> returning void) + foreign "pci_set_name_list_path" + (Pci_access.t @-> string @-> int @-> returning void) let pci_id_cache_flush = foreign "pci_id_cache_flush" (Pci_access.t @-> returning void) diff --git a/examples/dune b/examples/dune index e6bf6bf..08de44b 100644 --- a/examples/dune +++ b/examples/dune @@ -1,4 +1,3 @@ (executable - (name lspci) - (libraries pci) -) + (name lspci) + (libraries pci)) diff --git a/examples/lspci.ml b/examples/lspci.ml index 61ba348..0afcaef 100644 --- a/examples/lspci.ml +++ b/examples/lspci.ml @@ -4,48 +4,60 @@ open Pci let lspci_nnnDv pci_access = let default v = match v with Some v -> v | None -> "" in let devs = get_devices pci_access in - List.iter (fun d -> - let open Pci_dev in - Printf.printf "Device: %04x:%02x:%02x.%d\n" - d.domain d.bus d.dev d.func; - Printf.printf "Class: %s [%04x]\n" - (lookup_class_name pci_access d.device_class |> default) d.device_class; - Printf.printf "Vendor: %s [%04x]\n" - (lookup_vendor_name pci_access d.vendor_id |> default) d.vendor_id; - Printf.printf "Device: %s [%04x]\n" - (lookup_device_name pci_access d.vendor_id d.device_id |> default) d.device_id; - begin match d.subsystem_id with - | Some (sv_id, sd_id) -> - Printf.printf "SVendor:\t%s [%04x]\n" - (lookup_subsystem_vendor_name pci_access sv_id |> default) sv_id; - Printf.printf "SDevice:\t%s [%04x]\n" - (lookup_subsystem_device_name pci_access d.vendor_id d.device_id sv_id sd_id |> default) sd_id - | None -> () - end; - begin match d.phy_slot with - | Some slot -> Printf.printf "PhySlot:\t%s\n" slot - | None -> () - end; - print_endline "" - ) devs; + List.iter + (fun d -> + let open Pci_dev in + Printf.printf "Device: %04x:%02x:%02x.%d\n" d.domain d.bus d.dev d.func ; + Printf.printf "Class: %s [%04x]\n" + (lookup_class_name pci_access d.device_class |> default) + d.device_class ; + Printf.printf "Vendor: %s [%04x]\n" + (lookup_vendor_name pci_access d.vendor_id |> default) + d.vendor_id ; + Printf.printf "Device: %s [%04x]\n" + (lookup_device_name pci_access d.vendor_id d.device_id |> default) + d.device_id ; + ( match d.subsystem_id with + | Some (sv_id, sd_id) -> + Printf.printf "SVendor:\t%s [%04x]\n" + (lookup_subsystem_vendor_name pci_access sv_id |> default) + sv_id ; + Printf.printf "SDevice:\t%s [%04x]\n" + (lookup_subsystem_device_name pci_access d.vendor_id d.device_id + sv_id sd_id + |> default + ) + sd_id + | None -> + () + ) ; + ( match d.phy_slot with + | Some slot -> + Printf.printf "PhySlot:\t%s\n" slot + | None -> + () + ) ; + print_endline "") + devs ; - begin match devs with - | [] -> () - | d::ds -> - let open Pci_dev in - Printf.printf "Getting region sizes for device %04x:%02x:%02x.%d\n" - d.domain d.bus d.dev d.func; - List.iteri (fun i size -> - Printf.printf "\tRegion %d has size %nd\n" i size - ) d.size - end; + ( match devs with + | [] -> + () + | d :: ds -> + let open Pci_dev in + Printf.printf "Getting region sizes for device %04x:%02x:%02x.%d\n" + d.domain d.bus d.dev d.func ; + List.iteri + (fun i size -> Printf.printf "\tRegion %d has size %nd\n" i size) + d.size + ) ; - Printf.printf "Looking up name of NVIDIA GRID K160Q..."; - let nv_vid = 0x10de - and k1_did = 0x0ff7 - and id_160 = 0x113b in - let n = lookup_subsystem_device_name pci_access nv_vid k1_did nv_vid id_160 - |> default in + Printf.printf "Looking up name of NVIDIA GRID K160Q..." ; + let nv_vid = 0x10de and k1_did = 0x0ff7 and id_160 = 0x113b in + let n = + lookup_subsystem_device_name pci_access nv_vid k1_did nv_vid id_160 + |> default + in Printf.printf "\"%s\"\n" n let () = with_access lspci_nnnDv diff --git a/lib/dune b/lib/dune index 9171db5..cade737 100644 --- a/lib/dune +++ b/lib/dune @@ -1,25 +1,33 @@ (rule - (targets ffi_generated.ml) - (deps ../stubgen/ffi_stubgen.exe) - (action (with-stdout-to %{targets} (bash "%{deps} -ml"))) -) + (targets ffi_generated.ml) + (deps ../stubgen/ffi_stubgen.exe) + (action + (with-stdout-to + %{targets} + (bash "%{deps} -ml")))) (rule - (targets ffi_generated_stubs.c) - (deps ../stubgen/ffi_stubgen.exe) - (action (with-stdout-to %{targets} (bash "%{deps} -c"))) -) + (targets ffi_generated_stubs.c) + (deps ../stubgen/ffi_stubgen.exe) + (action + (with-stdout-to + %{targets} + (bash "%{deps} -c")))) (rule - (targets ffi_generated_types.ml) - (deps ../stubgen/ffi_ml_types_stubgen.exe) - (action (with-stdout-to %{targets} (bash "%{deps} -c"))) -) + (targets ffi_generated_types.ml) + (deps ../stubgen/ffi_ml_types_stubgen.exe) + (action + (with-stdout-to + %{targets} + (bash "%{deps} -c")))) (library - (name pci) - (public_name pci) - (foreign_stubs (language c) (names ffi_generated_stubs) (flags -lpci)) - (c_library_flags -lpci) - (libraries pci_bindings ctypes.stubs) -) + (name pci) + (public_name pci) + (foreign_stubs + (language c) + (names ffi_generated_stubs) + (flags -lpci)) + (c_library_flags -lpci) + (libraries pci_bindings ctypes.stubs)) diff --git a/lib/pci.ml b/lib/pci.ml index 3fadb30..adc86ab 100644 --- a/lib/pci.ml +++ b/lib/pci.ml @@ -1,54 +1,57 @@ open Ctypes - -module B = Pci_bindings.Ffi_bindings.Bindings(Ffi_generated) -module T = Pci_bindings.Ffi_bindings.Types(Ffi_generated_types) - +module B = Pci_bindings.Ffi_bindings.Bindings (Ffi_generated) +module T = Pci_bindings.Ffi_bindings.Types (Ffi_generated_types) module U8 = Unsigned.UInt8 module U16 = Unsigned.UInt16 module Pci_dev = struct type t = { - domain : int; - bus : int; - dev : int; - func : int; - vendor_id : int; - device_id : int; - device_class : int; - irq : int; - base_addr : nativeint list; - size : nativeint list; - rom_base_addr : nativeint; - rom_size : nativeint; - phy_slot : string option; - subsystem_id : (int * int) option; + domain: int + ; bus: int + ; dev: int + ; func: int + ; vendor_id: int + ; device_id: int + ; device_class: int + ; irq: int + ; base_addr: nativeint list + ; size: nativeint list + ; rom_base_addr: nativeint + ; rom_size: nativeint + ; phy_slot: string option + ; subsystem_id: (int * int) option } - let make (_t: B.Pci_dev.t) = + + let make (_t : B.Pci_dev.t) = { - domain = getf !@_t B.Pci_dev.domain |> U16.to_int; - bus = getf !@_t B.Pci_dev.bus |> U8.to_int; - dev = getf !@_t B.Pci_dev.dev |> U8.to_int; - func = getf !@_t B.Pci_dev.func |> U8.to_int; - vendor_id = getf !@_t B.Pci_dev.vendor_id |> U16.to_int; - device_id = getf !@_t B.Pci_dev.device_id |> U16.to_int; - device_class = getf !@_t B.Pci_dev.device_class |> U16.to_int; - irq = getf !@_t B.Pci_dev.irq; - base_addr = getf !@_t B.Pci_dev.base_addr |> CArray.to_list; - size = getf !@_t B.Pci_dev.size |> CArray.to_list; - rom_base_addr = getf !@_t B.Pci_dev.rom_base_addr; - rom_size = getf !@_t B.Pci_dev.rom_size; - phy_slot = getf !@_t B.Pci_dev.phy_slot; - subsystem_id = - match (B.pci_read_byte _t T.Header.header_type |> U8.to_int) land 0x7f with + domain= getf !@_t B.Pci_dev.domain |> U16.to_int + ; bus= getf !@_t B.Pci_dev.bus |> U8.to_int + ; dev= getf !@_t B.Pci_dev.dev |> U8.to_int + ; func= getf !@_t B.Pci_dev.func |> U8.to_int + ; vendor_id= getf !@_t B.Pci_dev.vendor_id |> U16.to_int + ; device_id= getf !@_t B.Pci_dev.device_id |> U16.to_int + ; device_class= getf !@_t B.Pci_dev.device_class |> U16.to_int + ; irq= getf !@_t B.Pci_dev.irq + ; base_addr= getf !@_t B.Pci_dev.base_addr |> CArray.to_list + ; size= getf !@_t B.Pci_dev.size |> CArray.to_list + ; rom_base_addr= getf !@_t B.Pci_dev.rom_base_addr + ; rom_size= getf !@_t B.Pci_dev.rom_size + ; phy_slot= getf !@_t B.Pci_dev.phy_slot + ; subsystem_id= + ( match + (B.pci_read_byte _t T.Header.header_type |> U8.to_int) land 0x7f + with | x when x = T.Header.header_type_normal -> - Some ( - B.pci_read_word _t T.Header.subsystem_vendor_id |> U16.to_int, - B.pci_read_word _t T.Header.subsystem_id |> U16.to_int) + Some + ( B.pci_read_word _t T.Header.subsystem_vendor_id |> U16.to_int + , B.pci_read_word _t T.Header.subsystem_id |> U16.to_int ) | x when x = T.Header.header_type_cardbus -> - Some ( - B.pci_read_word _t T.Header.cb_subsystem_vendor_id |> U16.to_int, - B.pci_read_word _t T.Header.cb_subsystem_id |> U16.to_int) - | _ -> None + Some + ( B.pci_read_word _t T.Header.cb_subsystem_vendor_id |> U16.to_int + , B.pci_read_word _t T.Header.cb_subsystem_id |> U16.to_int ) + | _ -> + None + ) } end @@ -57,22 +60,23 @@ module Pci_access = struct let devices t = let rec list_of_linked_list acc = function - | None -> acc - | Some d -> list_of_linked_list (d::acc) (getf !@d B.Pci_dev.next) in + | None -> + acc + | Some d -> + list_of_linked_list (d :: acc) (getf !@d B.Pci_dev.next) + in list_of_linked_list [] (getf !@t B.Pci_access.devices) end -let crush_flags f = - List.fold_left (fun i o -> i lor (f o)) 0 +let crush_flags f = List.fold_left (fun i o -> i lor f o) 0 + let id x = x -let maybe f = function - | Some x -> f x - | None -> () +let maybe f = function Some x -> f x | None -> () let scan_bus = B.pci_scan_bus -let with_string ?(size=1024) f = +let with_string ?(size = 1024) f = (* Using an ocaml string violates this rule from the ctypes FAQ: * string is unsuitable for binding to C functions that write * into the string. @@ -86,65 +90,82 @@ let with_string ?(size=1024) f = let s = CArray.start buf in let r = f s size in (* Keep `s` alive through the C binding invocation in `f` *) - ignore (Sys.opaque_identity (List.hd [s])); + ignore (Sys.opaque_identity (List.hd [s])) ; r let lookup_class_name pci_access class_id = with_string (fun buf size -> - B.pci_lookup_name_1_ary pci_access buf size T.Lookup_mode.lookup_class - class_id) + B.pci_lookup_name_1_ary pci_access buf size T.Lookup_mode.lookup_class + class_id) let lookup_progif_name pci_access class_id progif_id = with_string (fun buf size -> - B.pci_lookup_name_2_ary pci_access buf size T.Lookup_mode.lookup_progif - class_id progif_id) + B.pci_lookup_name_2_ary pci_access buf size T.Lookup_mode.lookup_progif + class_id progif_id) let lookup_vendor_name pci_access vendor_id = with_string (fun buf size -> - B.pci_lookup_name_1_ary pci_access buf size T.Lookup_mode.lookup_vendor - vendor_id) + B.pci_lookup_name_1_ary pci_access buf size T.Lookup_mode.lookup_vendor + vendor_id) let lookup_device_name pci_access vendor_id device_id = with_string (fun buf size -> - B.pci_lookup_name_2_ary pci_access buf size T.Lookup_mode.lookup_device - vendor_id device_id) + B.pci_lookup_name_2_ary pci_access buf size T.Lookup_mode.lookup_device + vendor_id device_id) let lookup_subsystem_vendor_name pci_access subv_id = with_string (fun buf size -> - let lookup_flags = T.Lookup_mode.([ lookup_subsystem; lookup_vendor ]) in - B.pci_lookup_name_1_ary pci_access buf size (crush_flags id lookup_flags) - subv_id) + let lookup_flags = T.Lookup_mode.[lookup_subsystem; lookup_vendor] in + B.pci_lookup_name_1_ary pci_access buf size + (crush_flags id lookup_flags) + subv_id) -let lookup_subsystem_device_name pci_access vendor_id device_id subv_id subd_id = +let lookup_subsystem_device_name pci_access vendor_id device_id subv_id subd_id + = with_string (fun buf size -> - let lookup_flags = T.Lookup_mode.([ lookup_subsystem; lookup_device ]) in - B.pci_lookup_name_4_ary pci_access buf size (crush_flags id lookup_flags) - vendor_id device_id subv_id subd_id) + let lookup_flags = T.Lookup_mode.[lookup_subsystem; lookup_device] in + B.pci_lookup_name_4_ary pci_access buf size + (crush_flags id lookup_flags) + vendor_id device_id subv_id subd_id) -let with_access ?(cleanup=true) ?from_dump f = +let with_access ?(cleanup = true) ?from_dump f = let pci_access = B.pci_alloc () in - maybe (fun path -> - setf !@pci_access B.Pci_access.method_ T.Access_type.dump; - ignore @@ B.pci_set_param pci_access "dump.name" path; - ) from_dump; - B.pci_init pci_access; - if not cleanup then f pci_access + maybe + (fun path -> + setf !@pci_access B.Pci_access.method_ T.Access_type.dump ; + ignore @@ B.pci_set_param pci_access "dump.name" path) + from_dump ; + B.pci_init pci_access ; + if not cleanup then + f pci_access else let result = - try f pci_access - with exn -> - B.pci_cleanup pci_access; - raise exn + try f pci_access with exn -> B.pci_cleanup pci_access ; raise exn in - B.pci_cleanup pci_access; - result + B.pci_cleanup pci_access ; result let get_devices pci_access = - B.pci_scan_bus pci_access; + B.pci_scan_bus pci_access ; let devs = Pci_access.devices pci_access in (* Be sure to fill all the fields that can be accessed from a Pci_dev.t *) - let fill_flags = T.Fill_flag.([ - fill_ident; fill_irq; fill_bases; fill_rom_base; fill_sizes; fill_class; - fill_caps; fill_ext_caps; fill_phys_slot; fill_module_alias; ]) in + let fill_flags = + T.Fill_flag. + [ + fill_ident + ; fill_irq + ; fill_bases + ; fill_rom_base + ; fill_sizes + ; fill_class + ; fill_caps + ; fill_ext_caps + ; fill_phys_slot + ; fill_module_alias + ] + in let flags = crush_flags id fill_flags in - List.map (fun d -> let (_: int) = B.pci_fill_info d flags in Pci_dev.make d) devs + List.map + (fun d -> + let (_ : int) = B.pci_fill_info d flags in + Pci_dev.make d) + devs diff --git a/lib/pci.mli b/lib/pci.mli index 89eff84..d6957f2 100644 --- a/lib/pci.mli +++ b/lib/pci.mli @@ -11,20 +11,20 @@ module Pci_dev : sig type t = { - domain : int; - bus : int; - dev : int; - func : int; - vendor_id : int; - device_id : int; - device_class : int; - irq : int; - base_addr : nativeint list; - size : nativeint list; - rom_base_addr : nativeint; - rom_size : nativeint; - phy_slot : string option; - subsystem_id : (int * int) option; + domain: int + ; bus: int + ; dev: int + ; func: int + ; vendor_id: int + ; device_id: int + ; device_class: int + ; irq: int + ; base_addr: nativeint list + ; size: nativeint list + ; rom_base_addr: nativeint + ; rom_size: nativeint + ; phy_slot: string option + ; subsystem_id: (int * int) option } end @@ -54,13 +54,15 @@ val lookup_subsystem_vendor_name : Pci_access.t -> int -> string option (** [lookup_subsystem_vendor_name a id] is like {!lookup_class_name} but returns the name of the PCI vendor with ID [id]. *) -val lookup_subsystem_device_name : Pci_access.t -> int -> int -> int -> int -> string option +val lookup_subsystem_device_name : + Pci_access.t -> int -> int -> int -> int -> string option (** [lookup_subsystem_device_name a v_id d_id sv_id sd_id] is like {!lookup_class_name} but returns the name of the PCI subsystem of a device with ID [d_id] made by vendor with ID [v_id] whose subvendor and subdevice IDs are [sv_id] and [sd_id] respectively. *) -val with_access : ?cleanup:bool -> ?from_dump:string -> (Pci_access.t -> 'a) -> 'a +val with_access : + ?cleanup:bool -> ?from_dump:string -> (Pci_access.t -> 'a) -> 'a (** [with_access ~cleanup f] wraps the [libpci] calls to [pci_alloc], [pci_init] and [pci_cleanup] and constructs [(access:Pci_access.t)] and returns [f access]. If [cleanup] is [true] (default), [pci_cleanup] is diff --git a/lib_test/dune b/lib_test/dune index 8987968..aabfe1f 100644 --- a/lib_test/dune +++ b/lib_test/dune @@ -1,5 +1,4 @@ (test - (name test_pci) - (deps dump.data) - (libraries pci ounit2) -) + (name test_pci) + (deps dump.data) + (libraries pci ounit2)) diff --git a/lib_test/test_pci.ml b/lib_test/test_pci.ml index 0b6b512..094c4df 100644 --- a/lib_test/test_pci.ml +++ b/lib_test/test_pci.ml @@ -9,8 +9,11 @@ let with_dump = let resident_pages () = let with_channel c f = - try let r = f c in close_in c; r - with exn -> close_in_noerr c; raise exn in + try + let r = f c in + close_in c ; r + with exn -> close_in_noerr c ; raise exn + in let statm = with_channel (open_in "/proc/self/statm") input_line in Scanf.sscanf statm "%d %d %d %d %d %d %d" (fun _ res _ _ _ _ _ -> res) @@ -18,54 +21,70 @@ let resident_pages () = (* End helper functions *) let smoke_test () = - with_dump (fun a -> let (_: Pci_dev.t list) = get_devices a in ()) + with_dump (fun a -> + let (_ : Pci_dev.t list) = get_devices a in + ()) let test_with_access_cleanup () = (* Get overhead for calling the fuction and the measuremnt functions *) - let _ = Gc.compact (); resident_pages () in - for i = 1 to 6000 do with_dump ~cleanup:true (fun _ -> ()) done; - let mem = Gc.compact (); resident_pages () in + let _ = Gc.compact () ; resident_pages () in + for i = 1 to 6000 do + with_dump ~cleanup:true (fun _ -> ()) + done ; + let mem = Gc.compact () ; resident_pages () in (* The incremental cost of calling with_access should be 0 *) - for i = 1 to 1000 do with_dump ~cleanup:true (fun _ -> ()) done; - let mem' = Gc.compact (); resident_pages () in - assert_equal ~printer:(Printf.sprintf "VmRSS = %d pages") mem mem'; + for i = 1 to 1000 do + with_dump ~cleanup:true (fun _ -> ()) + done ; + let mem' = Gc.compact () ; resident_pages () in + assert_equal ~printer:(Printf.sprintf "VmRSS = %d pages") mem mem' ; (* Also check we don't leak when raising an exception *) for i = 1 to 1000 do try with_dump ~cleanup:true (fun _ -> failwith "") with Failure _ -> () - done; - let mem'' = Gc.compact (); resident_pages () in - assert_equal ~printer:(Printf.sprintf "VmRSS = %d pages") mem mem'; + done ; + let mem'' = Gc.compact () ; resident_pages () in + assert_equal ~printer:(Printf.sprintf "VmRSS = %d pages") mem mem' ; (* Checking for a difference with cleanup=false as a negative test *) - for i = 1 to 1000 do with_dump ~cleanup:false (fun _ -> ()) done; - let mem''' = Gc.compact (); resident_pages () in + for i = 1 to 1000 do + with_dump ~cleanup:false (fun _ -> ()) + done ; + let mem''' = Gc.compact () ; resident_pages () in assert_raises (OUnitTest.OUnit_failure "not equal") (fun () -> - assert_equal mem'' mem''') + assert_equal mem'' mem''') let test_lookup_functions () = (* Subset of `lspci -mnnv` on my system - Class: Bridge [0680] - Vendor: Intel Corporation [8086] - Device: 82371AB/EB/MB PIIX4 ACPI [7113] - SVendor: Red Hat, Inc [1af4] - SDevice: Qemu virtual machine [1100] *) + Class: Bridge [0680] + Vendor: Intel Corporation [8086] + Device: 82371AB/EB/MB PIIX4 ACPI [7113] + SVendor: Red Hat, Inc [1af4] + SDevice: Qemu virtual machine [1100] *) let test_lookup = assert_equal ~printer:(fun x -> x) in let default v = match v with Some v -> v | None -> "" in with_dump (fun acc -> - test_lookup "Bridge" @@ (lookup_class_name acc 0x0680 |> default); - test_lookup "Intel Corporation" @@ (lookup_vendor_name acc 0x8086 |> default); - test_lookup "82371AB/EB/MB PIIX4 ACPI" @@ (lookup_device_name acc 0x8086 0x7113 |> default); - test_lookup "Red Hat, Inc." @@ (lookup_subsystem_vendor_name acc 0x1af4 |> default); - test_lookup "Qemu virtual machine" @@ (lookup_subsystem_device_name acc 0x8086 0x7113 0x1af4 0x1100 |> default); - test_lookup "VGA compatible controller" @@ (lookup_class_name acc 0x0300 |> default); - test_lookup "VGA controller" @@ (lookup_progif_name acc 0x0300 0x00 |> default); - ) + test_lookup "Bridge" @@ (lookup_class_name acc 0x0680 |> default) ; + test_lookup "Intel Corporation" + @@ (lookup_vendor_name acc 0x8086 |> default) ; + test_lookup "82371AB/EB/MB PIIX4 ACPI" + @@ (lookup_device_name acc 0x8086 0x7113 |> default) ; + test_lookup "Red Hat, Inc." + @@ (lookup_subsystem_vendor_name acc 0x1af4 |> default) ; + test_lookup "Qemu virtual machine" + @@ (lookup_subsystem_device_name acc 0x8086 0x7113 0x1af4 0x1100 + |> default + ) ; + test_lookup "VGA compatible controller" + @@ (lookup_class_name acc 0x0300 |> default) ; + test_lookup "VGA controller" + @@ (lookup_progif_name acc 0x0300 0x00 |> default)) let _ = - let suite = "pci" >::: - [ - "smoke_test" >:: smoke_test; - "test_with_access_cleanup" >:: test_with_access_cleanup; - "test_lookup_functions" >:: test_lookup_functions; - ] + let suite = + "pci" + >::: [ + "smoke_test" >:: smoke_test + ; "test_with_access_cleanup" >:: test_with_access_cleanup + ; "test_lookup_functions" >:: test_lookup_functions + ] in OUnit2.run_test_tt_main @@ ounit2_of_ounit1 suite diff --git a/stubgen/dune b/stubgen/dune index 906a005..26184a2 100644 --- a/stubgen/dune +++ b/stubgen/dune @@ -1,22 +1,18 @@ (executables - (names ffi_stubgen ffi_types_stubgen) - (libraries - pci_bindings - ctypes.stubs - ctypes - ) -) + (names ffi_stubgen ffi_types_stubgen) + (libraries pci_bindings ctypes.stubs ctypes)) (rule - (targets ffi_ml_types_stubgen.c) - (deps ./ffi_types_stubgen.exe) - (action (with-stdout-to %{targets} (bash "./%{deps}"))) -) + (targets ffi_ml_types_stubgen.c) + (deps ./ffi_types_stubgen.exe) + (action + (with-stdout-to + %{targets} + (bash "./%{deps}")))) (rule - (targets ffi_ml_types_stubgen.exe) - (deps ./ffi_ml_types_stubgen.c) - (action (bash "\ -%{cc} %{deps} -I `dirname %{lib:ctypes:ctypes_cstubs_internals.h}` \ - -I %{ocaml_where} -o %{targets}")) -) + (targets ffi_ml_types_stubgen.exe) + (deps ./ffi_ml_types_stubgen.c) + (action + (bash + "%{cc} %{deps} -I `dirname %{lib:ctypes:ctypes_cstubs_internals.h}` -I %{ocaml_where} -o %{targets}"))) diff --git a/stubgen/ffi_stubgen.ml b/stubgen/ffi_stubgen.ml index 6e71cc0..7ee40ac 100644 --- a/stubgen/ffi_stubgen.ml +++ b/stubgen/ffi_stubgen.ml @@ -1,16 +1,21 @@ let _ = let prefix = "libpci_stub" in - let generate_ml, generate_c = ref false, ref false in - Arg.(parse [ ("-ml", Set generate_ml, "Generate ML"); - ("-c", Set generate_c, "Generate C") ]) + let generate_ml, generate_c = (ref false, ref false) in + Arg.( + parse + [ + ("-ml", Set generate_ml, "Generate ML") + ; ("-c", Set generate_c, "Generate C") + ]) (fun _ -> failwith "unexpected anonymous argument") - "stubgen [-ml|-c]"; - match !generate_ml, !generate_c with - | false, false - | true, true -> - failwith "Exactly one of -ml and -c must be specified" + "stubgen [-ml|-c]" ; + match (!generate_ml, !generate_c) with + | false, false | true, true -> + failwith "Exactly one of -ml and -c must be specified" | true, false -> - Cstubs.write_ml Format.std_formatter ~prefix (module Pci_bindings.Ffi_bindings.Bindings) + Cstubs.write_ml Format.std_formatter ~prefix + (module Pci_bindings.Ffi_bindings.Bindings) | false, true -> - print_endline "#include "; - Cstubs.write_c Format.std_formatter ~prefix (module Pci_bindings.Ffi_bindings.Bindings) + print_endline "#include " ; + Cstubs.write_c Format.std_formatter ~prefix + (module Pci_bindings.Ffi_bindings.Bindings) diff --git a/stubgen/ffi_types_stubgen.ml b/stubgen/ffi_types_stubgen.ml index 3cd8246..85fc18b 100644 --- a/stubgen/ffi_types_stubgen.ml +++ b/stubgen/ffi_types_stubgen.ml @@ -1,3 +1,4 @@ let () = - print_endline "#include "; - Cstubs.Types.write_c Format.std_formatter (module Pci_bindings.Ffi_bindings.Types) + print_endline "#include " ; + Cstubs.Types.write_c Format.std_formatter + (module Pci_bindings.Ffi_bindings.Types)