+let generate_version_maps xs =
+ (* size_of_<struct> kernel_version *)
+ let strs = List.map (
+ fun (struct_name, (kernels, _)) ->
+ let map =
+ List.fold_right (
+ fun ({ PP.kernel_version = version },
+ { PP.struct_total_size = size }) map ->
+ <:expr<
+ StringMap.add $str:version$ $`int:size$ $map$
+ >>
+ ) kernels <:expr< StringMap.empty >> in
+
+ <:str_item<
+ let $lid:"size_of_"^struct_name$ =
+ let map = $map$ in
+ fun kernel_version ->
+ try StringMap.find kernel_version map
+ with Not_found ->
+ unknown_kernel_version kernel_version $str:struct_name$
+ >>
+ ) xs in
+
+ (* parser_of_<struct> kernel_version *)
+ let strs = strs @ List.map (
+ fun (struct_name, (kernels, pahash)) ->
+ let map =
+ List.fold_right (
+ fun ({ PP.kernel_version = version }, _) map ->
+ let { MM.pa_name = pa_name } = Hashtbl.find pahash version in
+ <:expr<
+ StringMap.add $str:version$ $lid:pa_name$ $map$
+ >>
+ ) kernels <:expr< StringMap.empty >> in
+
+ <:str_item<
+ let $lid:"parser_of_"^struct_name$ =
+ let map = $map$ in
+ fun kernel_version ->
+ try StringMap.find kernel_version map
+ with Not_found ->
+ unknown_kernel_version kernel_version $str:struct_name$
+ >>
+ ) xs in
+
+ concat_str_items strs, <:sig_item< >>
+
+let generate_followers names xs =
+ (* A follower function for every structure. *)
+ let bindings = List.map (
+ fun (struct_name, all_fields) ->
+ let followers = List.fold_right (
+ fun (name, (typ, always_available)) rest ->
+ let is_shape_field =
+ match typ with
+ | PP.FListHeadPointer None -> true
+ | PP.FListHeadPointer (Some (struct_name, _))
+ | PP.FStructPointer struct_name
+ when List.mem struct_name names -> true
+ | _ -> false in
+ if not is_shape_field then rest
+ else (
+ let dest_struct_name =
+ match typ with
+ | PP.FListHeadPointer None -> struct_name
+ | PP.FListHeadPointer (Some (struct_name, _)) -> struct_name
+ | PP.FStructPointer struct_name -> struct_name
+ | _ -> assert false in
+
+ let body =
+ match typ with
+ | PP.FListHeadPointer _ ->
+ <:expr<
+ if debug then
+ eprintf "%s_follower: %s: list_head pointing at a %s\n"
+ $str:struct_name$ $str:name$ $str:dest_struct_name$;
+
+ (* For list head pointers, add the address of the base
+ * of this virtual structure to the map, then adjust
+ * the pointer.
+ *)
+ let offset = data.$lid:struct_name^"_"^name^"_offset"$
+ and adj = data.$lid:struct_name^"_"^name^"_adjustment"$ in
+
+ if debug then
+ eprintf "%s_follower: %s: offset=%d adjustment=%d\n"
+ $str:struct_name$ $str:name$ offset adj;
+
+ let offset = Int64.of_int offset
+ and adj = Int64.of_int adj in
+
+ (* 'addr' is base of the virtual struct, but when
+ * adding it to the map make sure we don't splat
+ * the real structure (can happen if offset=adj).
+ *)
+ let map =
+ if offset <> adj then (
+ let addr = Int64.sub (Int64.add addr offset) adj in
+ AddrMap.add addr ($str:dest_struct_name$, None) map
+ ) else map in
+
+ (* 'dest_addr' is the destination address of
+ * this pointer. It needs the usual list_head
+ * adjustment applied.
+ *)
+ let dest_addr = Int64.sub dest_addr adj in
+
+ if debug then
+ eprintf "%s_follower: %s: dest_addr=%Lx\n"
+ $str:struct_name$ $str:name$ dest_addr;
+
+ let map =
+ $lid:dest_struct_name^"_follower"$
+ debug kernel_version load map dest_addr in
+ map
+ >>
+
+ | PP.FStructPointer _ ->
+ <:expr<
+ if debug then
+ eprintf "%s_follower: %s: is a struct pointer pointing to a %s; dest_addr=%Lx\n"
+ $str:struct_name$ $str:name$
+ $str:dest_struct_name$ dest_addr;
+
+ let map =
+ $lid:dest_struct_name^"_follower"$
+ debug kernel_version load map dest_addr in
+ map
+ >>
+
+ | _ -> assert false in
+
+ if always_available then
+ <:expr<
+ let dest_addr = data.$lid:struct_name^"_"^name$ in
+ let map = $body$ in
+ $rest$
+ >>
+ else
+ <:expr<
+ let map =
+ match data.$lid:struct_name^"_"^name$ with
+ | None -> map
+ | Some dest_addr -> $body$ in
+ $rest$
+ >>
+ )
+ ) all_fields <:expr< map >> in
+
+ let struct_name_uc = String.capitalize struct_name in
+
+ <:binding<
+ $lid:struct_name^"_follower"$ debug kernel_version load map addr =
+ if debug then
+ eprintf "%s_follower: addr = %Lx\n" $str:struct_name$ addr;
+ if addr <> 0L && not (AddrMap.mem addr map) then (
+ let parser_ = $lid:"parser_of_"^struct_name$ kernel_version in
+ let total_size = $lid:"size_of_"^struct_name$ kernel_version in
+ let bits = load $str:struct_name$ addr total_size in
+ let data = parser_ kernel_version bits in
+ let map = AddrMap.add
+ addr ($str:struct_name$,
+ Some (total_size, bits, $uid:struct_name_uc$ data))
+ map in
+ $followers$
+ )
+ else map
+ >>
+ ) xs in
+ let bindings = concat_bindings bindings in
+ let strs = <:str_item< let rec $bindings$ >> in
+
+ (* Function signatures for the interface. *)
+ let sigs = List.map (
+ fun (struct_name, _) ->
+ <:sig_item<
+ val $lid:struct_name^"_follower"$ :
+ bool -> kernel_version -> load_fn -> addrmap -> Virt_mem_mmap.addr ->
+ addrmap
+ >>
+ ) xs in
+ let sigs = concat_sig_items sigs in
+
+ strs, sigs
+
+let output_interf ~output_file types offsets parsers version_maps followers =
+ (* Some standard code that appears at the top and bottom
+ * of the interface file.
+ *)
+ let prologue =
+ <:sig_item<
+ module AddrMap : sig
+ type key = Virt_mem_mmap.addr
+ type 'a t = 'a Map.Make(Int64).t
+ val empty : 'a t
+ val is_empty : 'a t -> bool
+ val add : key -> 'a -> 'a t -> 'a t
+ val find : key -> 'a t -> 'a
+ val remove : key -> 'a t -> 'a t
+ val mem : key -> 'a t -> bool
+ val iter : (key -> 'a -> unit) -> 'a t -> unit
+ val map : ('a -> 'b) -> 'a t -> 'b t
+ val mapi : (key -> 'a -> 'b) -> 'a t -> 'b t
+ val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+ val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+ val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+ end ;;
+ exception ParseError of string * string * string ;;
+
+ type kernel_version = string
+
+ type load_fn =
+ string -> Virt_mem_mmap.addr -> int -> Bitstring.bitstring
+ >>
+ and addrmap =
+ <:sig_item<
+ type addrmap =
+ (string * (int * Bitstring.bitstring * kernel_struct) option)
+ AddrMap.t
+ >> in
+
+ let sigs =
+ concat_sig_items [ prologue;
+ types;
+ addrmap;
+ offsets;
+ parsers;
+ version_maps;
+ followers ] in
+ Printers.OCaml.print_interf ~output_file sigs;
+
+ ignore (Sys.command (sprintf "wc -l %s" (Filename.quote output_file)))