+ let field_name = struct_name ^ "_" ^ field_name in
+ let typ = Hashtbl.find hash field_name in
+ Some (field_name, (typ, ft))
+ with Not_found ->
+ let msg =
+ sprintf "%s.%s: this field was not found in any kernel version"
+ struct_name field_name in
+ if ft.mandatory_field then failwith msg else prerr_endline msg;
+ None
+ ) struct_fields in
+ (struct_name, kernels, field_types)
+ ) files in
+
+ (* To minimize generated code size, we want to fold together all
+ * structures where the particulars (eg. offsets, sizes, endianness)
+ * of the fields we care about are the same -- eg. between kernel
+ * versions which are very similar.
+ *)
+ let endian_of_architecture arch =
+ if String.starts_with arch "i386" ||
+ String.starts_with arch "i486" ||
+ String.starts_with arch "i586" ||
+ String.starts_with arch "i686" ||
+ String.starts_with arch "x86_64" ||
+ String.starts_with arch "x86-64" then
+ Bitstring.LittleEndian
+ else if String.starts_with arch "ia64" then
+ Bitstring.LittleEndian (* XXX usually? *)
+ else if String.starts_with arch "ppc" then
+ Bitstring.BigEndian
+ else if String.starts_with arch "sparc" then
+ Bitstring.BigEndian
+ else
+ failwith (sprintf "endian_of_architecture: cannot parse %S" arch)
+ in
+
+ let files =
+ List.map (
+ fun (struct_name, kernels, field_types) ->
+ let hash = Hashtbl.create 13 in
+ let i = ref 0 in
+ let xs = ref [] in
+ let kernels =
+ List.map (
+ fun (basename, version, arch, (fields, total_size)) ->
+ let key = endian_of_architecture arch, fields in
+ let j =
+ try Hashtbl.find hash key
+ with Not_found ->
+ incr i;
+ xs := (!i, key) :: !xs; Hashtbl.add hash key !i;
+ !i in
+ (basename, version, arch, total_size, j)
+ ) kernels in
+ let parsers = List.rev !xs in
+ struct_name, kernels, field_types, parsers
+ ) files in
+
+ (* How much did we save by sharing? *)
+ if debug then
+ List.iter (
+ fun (struct_name, kernels, _, parsers) ->
+ printf "struct %s:\n" struct_name;
+ printf " number of kernel versions: %d\n" (List.length kernels);
+ printf " number of parser functions needed after sharing: %d\n"
+ (List.length parsers)
+ ) files;
+
+ (* Extend the parsers fields by adding on any optional fields which
+ * are not actually present in the specific kernel.
+ *)
+ let files =
+ List.map (
+ fun (struct_name, kernels, field_types, parsers) ->
+ let parsers = List.map (
+ fun (i, (endian, fields)) ->
+ let fields_not_present =
+ List.filter_map (
+ fun (field_name, _) ->
+ if List.mem_assoc field_name fields then None
+ else Some field_name
+ ) field_types in
+ (i, (endian, fields, fields_not_present))
+ ) parsers in
+ (struct_name, kernels, field_types, parsers)
+ ) files in
+
+ (* Let's generate some code! *)
+ let files =
+ List.map (
+ fun (struct_name, kernels, field_types, parsers) ->
+ (* Dummy location required - there are no real locations for
+ * output files.
+ *)
+ let _loc = Loc.ghost in
+
+ (* The structure type. *)
+ let struct_type, struct_sig =
+ let fields = List.map (
+ function
+ | (name, (`Int, { mandatory_field = true })) ->
+ <:ctyp< $lid:name$ : int64 >>
+ | (name, (`Int, { mandatory_field = false })) ->
+ <:ctyp< $lid:name$ : int64 option >>
+ | (name, ((`VoidPtr|`Ptr _), { mandatory_field = true })) ->
+ <:ctyp< $lid:name$ : Virt_mem_mmap.addr >>
+ | (name, ((`VoidPtr|`Ptr _), { mandatory_field = false })) ->
+ <:ctyp< $lid:name$ : Virt_mem_mmap.addr option >>
+ | (name, (`Str _, { mandatory_field = true })) ->
+ <:ctyp< $lid:name$ : string >>
+ | (name, (`Str _, { mandatory_field = false })) ->
+ <:ctyp< $lid:name$ : string option >>
+ ) field_types in
+ let fields = concat_record_fields _loc fields in
+ let struct_type = <:str_item< type t = { $fields$ } >> in
+ let struct_sig = <:sig_item< type t = { $fields$ } >> in
+ struct_type, struct_sig in
+
+ (* Create a "field signature" which describes certain aspects
+ * of the fields which vary between kernel versions.
+ *)
+ let fieldsig_type, fieldsigs =
+ let fieldsig_type =
+ let fields = List.map (
+ fun (name, _) ->
+ let fsname = "__fs_" ^ name in
+ <:ctyp< $lid:fsname$ : Virt_mem_types.fieldsig >>
+ ) field_types in
+ let fields = concat_record_fields _loc fields in
+ <:str_item< type fs_t = { $fields$ } >> in
+
+ let fieldsigs = List.map (
+ fun (i, (_, fields, fields_not_present)) ->
+ let make_fieldsig field_name available offset =
+ let available =
+ if available then <:expr< true >> else <:expr< false >> in
+ let fsname = "__fs_" ^ field_name in
+ <:rec_binding<
+ $lid:fsname$ =
+ { Virt_mem_types.field_available = $available$;
+ field_offset = $`int:offset$ }
+ >>
+ in
+ let fields = List.map (
+ fun (field_name, (_, offset, _)) ->
+ make_fieldsig field_name true offset
+ ) fields in
+ let fields_not_present = List.map (
+ fun field_name ->
+ make_fieldsig field_name false (-1)
+ ) fields_not_present in
+
+ let fieldsigs = fields @ fields_not_present in
+ let fsname = sprintf "fieldsig_%d" i in
+ let fieldsigs = concat_record_bindings _loc fieldsigs in
+ let fieldsigs = build_record _loc fieldsigs in
+ <:str_item<
+ let $lid:fsname$ = $fieldsigs$
+ >>
+ ) parsers in
+
+ let fieldsigs = concat_str_items _loc fieldsigs in
+
+ fieldsig_type, fieldsigs in
+
+ (* The shared parser functions.
+ *
+ * We could include bitmatch statements directly in here, but
+ * what happens is that the macros get expanded here, resulting
+ * in (even more) unreadable generated code. So instead just
+ * do a textual substitution later by post-processing the
+ * generated files. Not type-safe, but we can't have
+ * everything.
+ *)
+ let parser_stmts, parser_subs =
+ let parser_stmts = List.map (
+ fun (i, _) ->
+ let fnname = sprintf "parser_%d" i in
+ <:str_item<
+ let $lid:fnname$ bits = $str:fnname$
+ >>
+ ) parsers in
+
+ let parser_stmts = concat_str_items _loc parser_stmts in
+
+ (* What gets substituted for "parser_NN" ... *)
+ let parser_subs = List.map (
+ fun (i, (endian, fields, fields_not_present)) ->
+ let fnname = sprintf "parser_%d" i in
+ let endian =
+ match endian with
+ | Bitstring.LittleEndian -> "littleendian"
+ | Bitstring.BigEndian -> "bigendian"
+ | _ -> assert false in
+ let patterns =
+ (* Fields must be sorted by offset, otherwise bitmatch
+ * will complain.
+ *)
+ let cmp (_, (_, o1, _)) (_, (_, o2, _)) = compare o1 o2 in
+ let fields = List.sort ~cmp fields in
+ String.concat ";\n " (
+ List.map (
+ function
+ | (field_name, ((`Int|`Ptr _|`VoidPtr), offset, size)) ->
+ (* 'zero+' is a hack to force the type to int64. *)
+ sprintf "%s : zero+%d : offset(%d), %s"
+ field_name (size*8) (offset*8) endian
+ | (field_name, (`Str width, offset, size)) ->
+ sprintf "%s : %d : offset(%d), string"
+ field_name (width*8) (offset*8)
+ ) fields
+ ) in
+ let assignments =
+ List.map (
+ fun (field_name, typ) ->
+ let (_, { mandatory_field = mandatory;
+ list_head_adjustment = list_head_adjustment }) =
+ try List.assoc field_name field_types
+ with Not_found ->
+ failwith (sprintf "%s: not found in field_types"
+ field_name) in
+ match typ, mandatory, list_head_adjustment with
+ | (`Ptr "list_head", offset, size), true, true ->
+ sprintf "%s = Int64.sub %s %dL"
+ field_name field_name offset
+ | (`Ptr "list_head", offset, size), false, true ->
+ sprintf "%s = Some (Int64.sub %s %dL)"
+ field_name field_name offset
+ | _, true, _ ->
+ sprintf "%s = %s" field_name field_name
+ | _, false, _ ->
+ sprintf "%s = Some %s" field_name field_name
+ ) fields in
+ let assignments_not_present =
+ List.map (
+ fun field_name -> sprintf "%s = None" field_name
+ ) fields_not_present in
+
+ let assignments =
+ String.concat ";\n "
+ (assignments @ assignments_not_present) in
+
+ let sub =
+ sprintf "
+ bitmatch bits with
+ | { %s } ->
+ { %s }
+ | { _ } ->
+ raise (Virt_mem_types.ParseError (struct_name, %S, match_err))"
+ patterns assignments fnname in
+
+ fnname, sub
+ ) parsers in
+
+ parser_stmts, parser_subs in
+
+ (* Define a map from kernel versions to parsing functions. *)
+ let version_map =
+ let stmts = List.fold_left (
+ fun stmts (_, version, arch, total_size, i) ->
+ let parserfn = sprintf "parser_%d" i in
+ let fsname = sprintf "fieldsig_%d" i in
+ <:str_item<
+ $stmts$
+ let v = ($lid:parserfn$, $`int:total_size$, $lid:fsname$)
+ let map = StringMap.add $str:version$ v map
+ >>
+ ) <:str_item< let map = StringMap.empty >> kernels in
+
+ <:str_item<
+ module StringMap = Map.Make (String) ;;
+ $stmts$
+ >> in
+
+ (* Accessors for the field signatures. *)
+ let fsaccess, fsaccess_sig =
+ let fields = List.map (
+ fun (field_name, _) ->
+ let fsname = "__fs_" ^ field_name in
+ <:str_item<
+ let $lid:"field_signature_of_"^field_name$ version =
+ let _, _, fs = StringMap.find version map in
+ fs.$lid:fsname$
+ >>
+ ) field_types in
+
+ let fsaccess = concat_str_items _loc fields in
+
+ let fields = List.map (
+ fun (field_name, _) ->
+ <:sig_item<
+ val $lid:"field_signature_of_"^field_name$ : kernel_version ->
+ Virt_mem_types.fieldsig
+ >>
+ ) field_types in
+
+ let fsaccess_sig = concat_sig_items _loc fields in
+
+ fsaccess, fsaccess_sig in
+
+ (* Code (.ml file). *)
+ let code = <:str_item<
+ let zero = 0
+ let struct_name = $str:struct_name$
+ let match_err = "failed to match kernel structure" ;;
+ $struct_type$
+ $fieldsig_type$
+ $fieldsigs$
+ $parser_stmts$
+ $version_map$
+
+ type kernel_version = string
+ let $lid:struct_name^"_known"$ version = StringMap.mem version map
+ let $lid:struct_name^"_size"$ version =
+ let _, size, _ = StringMap.find version map in
+ size
+ let $lid:struct_name^"_of_bits"$ version bits =
+ let parsefn, _, _ = StringMap.find version map in
+ parsefn bits
+ let $lid:"get_"^struct_name$ version mem addr =
+ let parsefn, size, _ = StringMap.find version map in
+ let bytes = Virt_mem_mmap.get_bytes mem addr size in
+ let bits = Bitstring.bitstring_of_string bytes in
+ parsefn bits ;;
+ $fsaccess$
+ >> in
+
+ (* Interface (.mli file). *)
+ let interface = <:sig_item<
+ $struct_sig$
+
+ val struct_name : string
+ type kernel_version = string
+ val $lid:struct_name^"_known"$ : kernel_version -> bool
+ val $lid:struct_name^"_size"$ : kernel_version -> int
+ val $lid:struct_name^"_of_bits"$ :
+ kernel_version -> Bitstring.bitstring -> t
+ val $lid:"get_"^struct_name$ : kernel_version ->
+ ('a, 'b, [`HasMapping]) Virt_mem_mmap.t -> Virt_mem_mmap.addr -> t;;
+ $fsaccess_sig$
+ >> in
+
+ (struct_name, code, interface, parser_subs)
+ ) files in
+
+ (* Finally generate the output files. *)
+ let re_subst = Pcre.regexp "^(.*)\"(parser_\\d+)\"(.*)$" in
+
+ List.iter (
+ fun (struct_name, code, interface, parser_subs) ->
+ (* Interface (.mli file). *)
+ let output_file = outputdir // "kernel_" ^ struct_name ^ ".mli" in
+ printf "Writing %s interface to %s ...\n%!" struct_name output_file;
+ Printers.OCaml.print_interf ~output_file interface;
+
+ (* Implementation (.ml file). *)
+ let output_file = outputdir // "kernel_" ^ struct_name ^ ".ml" in
+ printf "Writing %s implementation to %s ...\n%!" struct_name output_file;
+
+ let new_output_file = output_file ^ ".new" in
+ Printers.OCaml.print_implem ~output_file:new_output_file code;
+
+ (* Substitute the parser bodies in the output file. *)
+ let ichan = open_in new_output_file in
+ let ochan = open_out output_file in
+
+ output_string ochan "\
+(* WARNING: This file and the corresponding mli (interface) are
+ * automatically generated by the extract/codegen/kerneldb_to_parser.ml
+ * program.
+ *
+ * Any edits you make to this file will be lost.
+ *
+ * To update this file from the latest kernel database, it is recommended
+ * that you do 'make update-kernel-structs'.
+ *)\n\n";
+
+ let rec loop () =
+ let line = input_line ichan in
+ let line =
+ if Pcre.pmatch ~rex:re_subst line then (
+ let subs = Pcre.exec ~rex:re_subst line in
+ let start = Pcre.get_substring subs 1 in
+ let template = Pcre.get_substring subs 2 in
+ let rest = Pcre.get_substring subs 3 in
+ let sub = List.assoc template parser_subs in
+ start ^ sub ^ rest
+ ) else line in
+ output_string ochan line; output_char ochan '\n';
+ loop ()
+ in
+ (try loop () with End_of_file -> ());
+
+ close_out ochan;
+ close_in ichan;
+
+ Unix.unlink new_output_file
+ ) files
+*)