From e3882be985f3264a22f430c14beebc5a2c0c4802 Mon Sep 17 00:00:00 2001
From: "Richard W.M. Jones" <rjones@redhat.com>
Date: Thu, 1 Jan 1970 00:00:00 +0000
Subject: [PATCH] Allow fields in kernel structures to be marked optional.

---
 extract/codegen/kerneldb_to_parser.ml | 360 ++++++++++++++++++++++++++--------
 1 file changed, 282 insertions(+), 78 deletions(-)

diff --git a/extract/codegen/kerneldb_to_parser.ml b/extract/codegen/kerneldb_to_parser.ml
index a3bb9a1..d78c108 100644
--- a/extract/codegen/kerneldb_to_parser.ml
+++ b/extract/codegen/kerneldb_to_parser.ml
@@ -28,22 +28,48 @@
    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
@@ -58,6 +84,51 @@ open Printf
 
 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
 
@@ -151,9 +222,9 @@ Example (from toplevel of virt-mem source tree):
   (* 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 (
@@ -226,10 +297,10 @@ Example (from toplevel of virt-mem source tree):
 
       (* 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
@@ -349,7 +420,7 @@ Example (from toplevel of virt-mem source tree):
   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
@@ -370,13 +441,13 @@ Example (from toplevel of virt-mem source tree):
 	       * 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;
 
@@ -386,7 +457,7 @@ Example (from toplevel of virt-mem source tree):
 			    struct_name ^ "_" ^ name, details) fields in
 
 	      Some (struct_name, (fields, total_size))
-      ) what in
+      ) structs in
 
       (basename, version, arch, structures)
   ) kernels in
@@ -461,34 +532,60 @@ Example (from toplevel of virt-mem source tree):
 	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
 
@@ -547,6 +644,25 @@ Example (from toplevel of virt-mem source tree):
 	  (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 (
@@ -560,24 +676,70 @@ Example (from toplevel of virt-mem source tree):
 	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
@@ -593,18 +755,14 @@ Example (from toplevel of virt-mem source tree):
 	      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
@@ -631,15 +789,33 @@ Example (from toplevel of virt-mem source tree):
 		  ) 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 "
@@ -647,7 +823,7 @@ Example (from toplevel of virt-mem source tree):
   | { %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
@@ -660,9 +836,10 @@ Example (from toplevel of virt-mem source tree):
 	  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
@@ -672,34 +849,61 @@ Example (from toplevel of virt-mem source tree):
 	    $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
@@ -709,7 +913,8 @@ Example (from toplevel of virt-mem source tree):
 	  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)
@@ -745,8 +950,7 @@ Example (from toplevel of virt-mem source tree):
  *
  * 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
-- 
1.8.3.1