and fields we try to parse.
*)
-let what = [
- "task_struct", (
- "struct task_struct {", "};", true,
- [ "state"; "prio"; "normal_prio"; "static_prio";
- "tasks'prev"; "tasks'next"; "mm"; "active_mm"; "comm"; "pid" ]
- );
+type struct_t = {
+ opener : string; (* String in pa_hole file which starts this struct. *)
+ closer : string; (* String in pa_hole file which ends this struct. *)
+ mandatory_struct : bool; (* Is this struct mandatory? *)
+ fields : (string * field_t) list; (* List of interesting fields. *)
+}
+and field_t = {
+ mandatory_field : bool; (* Is this field mandatory? *)
+}
+
+let structs = [
+ "task_struct", {
+ opener = "struct task_struct {"; closer = "};"; mandatory_struct = true;
+ fields = [
+ "state", { mandatory_field = true };
+ "prio", { mandatory_field = true };
+ "normal_prio", { mandatory_field = true };
+ "static_prio", { mandatory_field = true };
+ "tasks'prev", { mandatory_field = true };
+ "tasks'next", { mandatory_field = true };
+ "mm", { mandatory_field = true };
+ "active_mm", { mandatory_field = true };
+ "comm", { mandatory_field = true };
+ "pid", { mandatory_field = true };
+ ]
+ };
(*
"mm_struct", (
"struct mm_struct {", "};", true,
[ ]
);
*)
- "net_device", (
- "struct net_device {", "};", true,
- [ "name"; "dev_addr" ]
- );
+ "net_device", {
+ opener = "struct net_device {"; closer = "};"; mandatory_struct = true;
+ fields = [
+ "dev_list'prev", { mandatory_field = false };
+ "dev_list'next", { mandatory_field = false };
+ "next", { mandatory_field = false };
+ "name", { mandatory_field = true };
+ "dev_addr", { mandatory_field = true };
+ ]
+ }
]
let debug = false
let (//) = Filename.concat
+(* Couple of handy camlp4 construction functions which do some
+ * things that ought to be easy/obvious but aren't.
+ *
+ * 'concat_str_items' concatenates a list of str_item together into
+ * one big str_item.
+ *
+ * 'concat_record_fields' concatenates a list of records fields into
+ * a record. The list must have at least one element.
+ *
+ * 'build_tuple_from_exprs' builds an arbitrary length tuple from
+ * a list of expressions of length >= 2.
+ *
+ * Thanks to bluestorm on #ocaml for getting the last one working.
+ *)
+let concat_str_items _loc items =
+ match items with
+ | [] -> <:str_item< >>
+ | x :: xs ->
+ List.fold_left (fun xs x -> <:str_item< $xs$ $x$ >>) x xs
+
+let concat_sig_items _loc items =
+ match items with
+ | [] -> <:sig_item< >>
+ | x :: xs ->
+ List.fold_left (fun xs x -> <:sig_item< $xs$ $x$ >>) x xs
+
+let concat_record_fields _loc fields =
+ match fields with
+ | [] -> assert false
+ | f :: fs ->
+ List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs
+
+let concat_record_bindings _loc rbs =
+ match rbs with
+ | [] -> assert false
+ | rb :: rbs ->
+ List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs
+
+let build_tuple_from_exprs _loc exprs =
+ match exprs with
+ | [] | [_] -> assert false
+ | x :: xs ->
+ Ast.ExTup (_loc,
+ List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs)
+
let () =
let args = Array.to_list Sys.argv in
(* For quick access to the opener strings, build a hash. *)
let openers = Hashtbl.create 13 in
List.iter (
- fun (name, (opener, closer, _, _)) ->
+ fun (name, { opener = opener; closer = closer }) ->
Hashtbl.add openers opener (closer, name)
- ) what;
+ ) structs;
(* Now read the data files and parse out the structures of interest. *)
let kernels = List.mapi (
(* Make sure we got all the mandatory structures. *)
List.iter (
- fun (name, (_, _, mandatory, _)) ->
+ fun (name, { mandatory_struct = mandatory }) ->
if mandatory && not (Hashtbl.mem bodies name) then
failwith (sprintf "%s: structure %s not found in this kernel" basename name)
- ) what;
+ ) structs;
(basename, version, arch, bodies)
) infos in
let kernels = List.map (
fun (basename, version, arch, bodies) ->
let structures = List.filter_map (
- fun (struct_name, (_, _, _, wanted_fields)) ->
+ fun (struct_name, { fields = wanted_fields }) ->
let body =
try Some (Hashtbl.find bodies struct_name)
with Not_found -> None in
* the wanted_fields.
*)
let fields = List.filter (
- fun (name, _) -> List.mem name wanted_fields
+ fun (name, _) -> List.mem_assoc name wanted_fields
) fields in
- (* Also check we have all the wanted fields. *)
+ (* Also check we have all the mandatory fields. *)
List.iter (
- fun wanted_field ->
- if not (List.mem_assoc wanted_field fields) then
+ fun (wanted_field, { mandatory_field = mandatory }) ->
+ if mandatory && not (List.mem_assoc wanted_field fields) then
failwith (sprintf "%s: structure %s is missing required field %s" basename struct_name wanted_field)
) wanted_fields;
struct_name ^ "_" ^ name, details) fields in
Some (struct_name, (fields, total_size))
- ) what in
+ ) structs in
(basename, version, arch, structures)
) kernels in
let kernels = List.sort kernels in
name, kernels
- ) what in
+ ) structs in
let kernels = () in ignore kernels; (* garbage collect *)
- (* Get just the field types. It's plausible that a field with the
- * same name has a different type between kernel versions, so we must
- * check that didn't happen.
+ (* Get just the field types.
+ *
+ * It's plausible that a field with the same name has a different
+ * type between kernel versions, so we must check that didn't
+ * happen.
+ *
+ * This is complicated because of non-mandatory fields, which don't
+ * appear in every kernel version.
*)
let files = List.map (
fun (struct_name, kernels) ->
let field_types =
- match kernels with
- | [] -> []
- | (_, _, _, (fields, _)) :: kernels ->
- let field_types_of_fields fields =
- List.sort (
- List.map (
- fun (field_name, (typ, _, _)) -> field_name, typ
- ) fields
- )
- in
- let field_types = field_types_of_fields fields in
- List.iter (
- fun (_, _, _, (fields, _)) ->
- if field_types <> field_types_of_fields fields then
- failwith (sprintf "%s: one of the structure fields changed type between kernel versions" struct_name)
- ) kernels;
- field_types in
+ (* Get the list of fields expected in this structure. *)
+ let { fields = struct_fields } = List.assoc struct_name structs in
+
+ (* Get the list of fields that we found in each kernel version. *)
+ let found_fields =
+ List.flatten
+ (List.map (fun (_, _, _, (fields, _)) -> fields) kernels) in
+
+ (* Determine a hash from each field name to the type. As we add
+ * fields, we might get a conflicting type (meaning the type
+ * changed between kernel versions).
+ *)
+ let hash = Hashtbl.create 13 in
+
+ List.iter (
+ fun (field_name, (typ, _, _)) ->
+ try
+ let field_type = Hashtbl.find hash field_name in
+ if typ <> field_type then
+ failwith (sprintf "%s.%s: structure field changed type between kernel versions" struct_name field_name);
+ with Not_found ->
+ Hashtbl.add hash field_name typ
+ ) found_fields;
+
+ (* Now get a type for each structure field. *)
+ List.filter_map (
+ fun (field_name, { mandatory_field = mandatory }) ->
+ try
+ let field_name = struct_name ^ "_" ^ field_name in
+ let typ = Hashtbl.find hash field_name in
+ Some (field_name, (typ, mandatory))
+ with Not_found ->
+ let msg =
+ sprintf "%s.%s: this field was not found in any kernel version"
+ struct_name field_name in
+ if mandatory then failwith msg else prerr_endline msg;
+ None
+ ) struct_fields in
(struct_name, kernels, field_types)
) files in
(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 (
let struct_type, struct_sig =
let fields = List.map (
function
- | (name, `Int) ->
+ | (name, (`Int, true)) ->
<:ctyp< $lid:name$ : int64 >>
- | (name, `Ptr _) ->
+ | (name, (`Int, false)) ->
+ <:ctyp< $lid:name$ : int64 option >>
+ | (name, (`Ptr _, true)) ->
<:ctyp< $lid:name$ : Virt_mem_mmap.addr >>
- | (name, `Str _) ->
+ | (name, (`Ptr _, false)) ->
+ <:ctyp< $lid:name$ : Virt_mem_mmap.addr option >>
+ | (name, (`Str _, true)) ->
<:ctyp< $lid:name$ : string >>
+ | (name, (`Str _, false)) ->
+ <:ctyp< $lid:name$ : string option >>
) field_types in
- let f, fs = match fields with
- | [] -> failwith (sprintf "%s: structure has no fields" struct_name)
- | f :: fs -> f, fs in
- let fields = List.fold_left (
- fun fs f -> <:ctyp< $fs$ ; $f$ >>
- ) f fs 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
+ <:str_item<
+ let $lid:fsname$ = { () with $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
let fnname = sprintf "parser_%d" i in
<:str_item<
let $lid:fnname$ bits = $str:fnname$
- >>
+ >>
) parsers in
- let parser_stmts =
- match parser_stmts with
- | [] -> <:str_item< >>
- | p :: ps ->
- List.fold_left (fun ps p -> <:str_item< $ps$ $p$ >>) p ps 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)) ->
+ fun (i, (endian, fields, fields_not_present)) ->
let fnname = sprintf "parser_%d" i in
let endian =
match endian with
) fields
) in
let assignments =
- String.concat ";\n " (
- List.map (
- function
- | (field_name, (`Ptr "list_head", offset, size)) ->
- sprintf "%s = Int64.sub %s %dL" field_name field_name offset
- | (field_name, _) ->
+ List.map (
+ fun (field_name, typ) ->
+ let (_, mandatory) =
+ try List.assoc field_name field_types
+ with Not_found ->
+ failwith (sprintf "%s: not found in field_types"
+ field_name) in
+ match typ, mandatory with
+ | (`Ptr "list_head", offset, size), true ->
+ sprintf "%s = Int64.sub %s %dL"
+ field_name field_name offset
+ | (`Ptr "list_head", offset, size), false ->
+ sprintf "%s = Some (Int64.sub %s %dL)"
+ field_name field_name offset
+ | _, true ->
sprintf "%s = %s" field_name field_name
- ) fields
- ) in
+ | _, 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 "
| { %s } ->
{ %s }
| { _ } ->
- raise (ParseError (struct_name, %S, match_err))"
+ raise (Virt_mem_types.ParseError (struct_name, %S, match_err))"
patterns assignments fnname in
fnname, sub
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$)
+ 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
$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"
- exception ParseError of string * string * string;;
+ 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
+ let _, size, _ = StringMap.find version map in
size
let $lid:struct_name^"_of_bits"$ version bits =
- let parsefn, _ = StringMap.find version map in
+ 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 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
+ parsefn bits ;;
+ $fsaccess$
>> in
(* Interface (.mli file). *)
let interface = <:sig_item<
- exception ParseError of string * string * string;;
$struct_sig$
val struct_name : string
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
+ ('a, 'b, [`HasMapping]) Virt_mem_mmap.t -> Virt_mem_mmap.addr -> t;;
+ $fsaccess_sig$
>> in
(struct_name, code, interface, parser_subs)
*
* 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
git.annexia.org / virt-mem.git / commitdiff