Allow the automatic list_head adjustment to be overridden,

when pointers go from one type of structure to another type.

diff --git a/extract/codegen/kerneldb_to_parser.ml b/extract/codegen/kerneldb_to_parser.ml
index f94de2f..2a46b68 100644 (file)
--- a/extract/codegen/kerneldb_to_parser.ml
+++ b/extract/codegen/kerneldb_to_parser.ml
@@ -36,22 +36,35 @@ type struct_t = {
 }
 and field_t = {
   mandatory_field : bool;  (* Is this field mandatory? *)
+  list_head_adjustment : bool; (* Only applies if the field points to a
+                               * struct list_head: If true, then we do the
+                               * list_head adjustment, so the field points
+                               * to the start of the structure.  If false,
+                               * leave the pointer intact.  The list_head
+                               * adjustment only works if the list_head
+                               * is in the same type of structure.
+                               *)
 }
 
+let ordinary_field = { mandatory_field = true; list_head_adjustment = true; }
+
+(*----------------------------------------------------------------------
+ * This controls what structures & fields we will parse out.
+ *----------------------------------------------------------------------*)
 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 };
+      "state",       ordinary_field;
+      "prio",        ordinary_field;
+      "normal_prio", ordinary_field;
+      "static_prio", ordinary_field;
+      "tasks'prev",  ordinary_field;
+      "tasks'next",  ordinary_field;
+      "mm",          ordinary_field;
+      "active_mm",   ordinary_field;
+      "comm",        ordinary_field;
+      "pid",         ordinary_field;
     ]
   };
 (*
@@ -63,17 +76,21 @@ let structs = [
   "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 };
+      "dev_list'prev", { mandatory_field = false; list_head_adjustment = true };
+      "dev_list'next", { mandatory_field = false; list_head_adjustment = true };
+      "next",          { mandatory_field = false; list_head_adjustment = true };
+      "name",          ordinary_field;
+      "dev_addr",      ordinary_field;
     ]
   };
   "net", {
     opener = "struct net {"; closer = "};"; mandatory_struct = false;
     fields = [
-      "dev_base_head'next", { mandatory_field = true };
+      "dev_base_head'next",
+        (* Don't do list_head adjustment on this field, because it points
+        * to a net_device struct.
+        *)
+        { mandatory_field = true; list_head_adjustment = false };
     ]
   };
 ]
@@ -585,16 +602,16 @@ Example (from toplevel of virt-mem source tree):
 
        (* Now get a type for each structure field. *)
        List.filter_map (
-         fun (field_name, { mandatory_field = mandatory }) ->
+         fun (field_name, ft) ->
            try
              let field_name = struct_name ^ "_" ^ field_name in
              let typ = Hashtbl.find hash field_name in
-             Some (field_name, (typ, mandatory))
+             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 mandatory then failwith msg else prerr_endline msg;
+             if ft.mandatory_field then failwith msg else prerr_endline msg;
              None
        ) struct_fields in
       (struct_name, kernels, field_types)
@@ -687,17 +704,17 @@ Example (from toplevel of virt-mem source tree):
        let struct_type, struct_sig =
          let fields = List.map (
            function
-           | (name, (`Int, true)) ->
+           | (name, (`Int, { mandatory_field = true })) ->
                <:ctyp< $lid:name$ : int64 >>
-           | (name, (`Int, false)) ->
+           | (name, (`Int, { mandatory_field = false })) ->
                <:ctyp< $lid:name$ : int64 option >>
-           | (name, (`Ptr _, true)) ->
+           | (name, (`Ptr _, { mandatory_field = true })) ->
                <:ctyp< $lid:name$ : Virt_mem_mmap.addr >>
-           | (name, (`Ptr _, false)) ->
+           | (name, (`Ptr _, { mandatory_field = false })) ->
                <:ctyp< $lid:name$ : Virt_mem_mmap.addr option >>
-           | (name, (`Str _, true)) ->
+           | (name, (`Str _, { mandatory_field = true })) ->
                <:ctyp< $lid:name$ : string >>
-           | (name, (`Str _, false)) ->
+           | (name, (`Str _, { mandatory_field = false })) ->
                <:ctyp< $lid:name$ : string option >>
          ) field_types in
          let fields = concat_record_fields _loc fields in
@@ -803,21 +820,22 @@ Example (from toplevel of virt-mem source tree):
              let assignments =
                List.map (
                  fun (field_name, typ) ->
-                   let (_, mandatory) =
+                   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 with
-                   | (`Ptr "list_head", offset, size), true ->
+                   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 ->
+                   | (`Ptr "list_head", offset, size), false, true ->
                        sprintf "%s = Some (Int64.sub %s %dL)"
                          field_name field_name offset
-                   | _, true ->
+                   | _, true, _ ->
                        sprintf "%s = %s" field_name field_name
-                   | _, false ->
+                   | _, false, _ ->
                        sprintf "%s = Some %s" field_name field_name
                ) fields in
              let assignments_not_present =