Cross-references in list_head fields working.

[virt-mem.git] / extract / codegen / code_generation.ml

diff --git a/extract/codegen/code_generation.ml b/extract/codegen/code_generation.ml
index 37bffc2..b462af2 100644 (file)
--- a/extract/codegen/code_generation.ml
+++ b/extract/codegen/code_generation.ml
@@ -28,6 +28,19 @@ open Printf
 module PP = Pahole_parser
 module SC = Struct_classify
 
+let rec uniq ?(cmp = Pervasives.compare) = function
+    [] -> []
+  | [x] -> [x]
+  | x :: y :: xs when cmp x y = 0 ->
+      uniq (x :: xs)
+  | x :: y :: xs ->
+      x :: uniq (y :: xs)
+
+let sort_uniq ?cmp xs =
+  let xs = List.sort ?cmp xs in
+  let xs = uniq ?cmp xs in
+  xs
+
 (* We don't care about locations when generating code, so it's
  * useful to just have a single global _loc.
  *)
@@ -83,6 +96,8 @@ let build_tuple_from_exprs exprs =
       Ast.ExTup (_loc,
                 List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs)
 
+type code = Ast.str_item * Ast.sig_item
+
 let ocaml_type_of_field_type = function
   | PP.FInteger -> <:ctyp< int64 >>
   | PP.FString _ -> <:ctyp< string >>
@@ -149,6 +164,82 @@ let generate_types xs =
 
   concat_str_items strs, concat_sig_items sigs
 
+let generate_offsets xs =
+  (* Only need to generate the offset_of_* functions for fields
+   * which are cross-referenced from another field.  Which
+   * ones are those?
+   *)
+  let fields =
+    List.concat (
+      List.map (
+       fun (_, (_, all_fields)) ->
+         List.filter_map (
+           function
+           | (_,
+              PP.FListHeadPointer ((Some (struct_name, field_name)) as f)) ->
+               f
+           | _ ->
+               None
+         ) all_fields
+      ) xs
+    ) in
+
+  let fields = sort_uniq fields in
+
+  let strs =
+    List.map (
+      fun (struct_name, field_name) ->
+       let kernels, _ =
+         try List.assoc struct_name xs
+         with Not_found ->
+           failwith (
+             sprintf "generate_offsets: structure %s not found. This is probably a list_head-related bug."
+               struct_name
+           ) in
+       (* Find the offset of this field in each kernel version. *)
+       let offsets =
+         List.filter_map (
+           fun ({ PP.kernel_version = version },
+                { PP.struct_fields = fields }) ->
+             try
+               let field =
+                 List.find (fun { PP.field_name = name } -> field_name = name)
+                   fields in
+               let offset = field.PP.field_offset in
+               Some (version, offset)
+             with Not_found -> None
+         ) kernels in
+
+       if offsets = [] then
+         failwith (
+           sprintf "generate_offsets: field %s.%s not found in any kernel. This is probably a list_head-related bug."
+             struct_name field_name
+         );
+
+       (* Generate a map of kernel version to offset. *)
+       let map = List.fold_left (
+         fun map (version, offset) ->
+           <:expr< StringMap.add $str:version$ $`int:offset$ $map$ >>
+       ) <:expr< StringMap.empty >> offsets in
+
+       let code =
+         <:str_item<
+           let $lid:"offset_of_"^struct_name^"_"^field_name$ =
+             let map = $map$ in
+             fun kernel_version -> StringMap.find kernel_version map
+         >> in
+       code
+    ) fields in
+
+  let strs = concat_str_items strs in
+  let strs =
+    <:str_item<
+      module StringMap = Map.Make (String) ;;
+      $strs$
+    >> in
+
+  strs, <:sig_item< >>
+
 let generate_parsers xs =
   let strs =
     List.map (
@@ -156,7 +247,9 @@ let generate_parsers xs =
        let palist =
          List.map (
            fun { SC.pa_name = pa_name } ->
-             <:str_item< let $lid:pa_name$ bits = $str:pa_name$ >>
+             <:str_item<
+               let $lid:pa_name$ kernel_version bits = $str:pa_name$
+             >>
          ) palist in
        concat_str_items palist
     ) xs in
@@ -234,11 +327,20 @@ let generate_parsers xs =
                    sprintf "%s_%s = Int64.sub %s %dL"
                      sf.SC.sf_name field_name field_name offset
 
-               | PP.FListHeadPointer (Some (other_struct_name, other_field_name)) ->
-                   let other_offset = 666 in
-                   sprintf "%s_%s = Int64.sub %s %dL"
-                     sf.SC.sf_name field_name field_name other_offset
-
+               | PP.FListHeadPointer (Some (other_struct_name,
+                                            other_field_name)) ->
+                   (* A reference to a field in another structure.  We don't
+                    * know the offset until runtime, so we have to call
+                    * offset_of_<struct>_<field> to find it.
+                    *)
+                   sprintf "%s_%s = (
+                      let offset = offset_of_%s_%s kernel_version in
+                      let offset = Int64.of_int offset in
+                      Int64.sub %s offset
+                    )"
+                     sf.SC.sf_name field_name
+                     other_struct_name other_field_name
+                     field_name
                | _ ->
                    sprintf "%s_%s = %s" sf.SC.sf_name field_name field_name
            ) sf.SC.sf_fields in
@@ -274,19 +376,19 @@ let generate_parsers xs =
       ) palist;
   ) xs;
 
-  strs, <:sig_item< >>, subs
+  (strs, <:sig_item< >>), subs
 
-let output_interf ~output_file types parsers =
-  let sigs = concat_sig_items [ types; parsers ] in
+let output_interf ~output_file types offsets parsers =
+  let sigs = concat_sig_items [ types; offsets; parsers ] in
   Printers.OCaml.print_interf ~output_file sigs
 
 (* Finally generate the output files. *)
 let re_subst = Pcre.regexp "^(.*)\"(\\w+_parser_\\d+)\"(.*)$"
 
-let output_implem ~output_file types parsers parser_subs =
+let output_implem ~output_file types offsets parsers parser_subs =
   let new_output_file = output_file ^ ".new" in
 
-  let strs = concat_str_items [ types; parsers ] in
+  let strs = concat_str_items [ types; offsets; parsers ] in
   Printers.OCaml.print_implem ~output_file:new_output_file strs;
 
   (* Substitute the parser bodies in the output file. *)