Follower code now works

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

diff --git a/extract/codegen/code_generation.ml b/extract/codegen/code_generation.ml
index 7b0262b..c5e735f 100644 (file)
--- a/extract/codegen/code_generation.ml
+++ b/extract/codegen/code_generation.ml
@@ -126,9 +126,21 @@ let generate_types xs =
          if fields <> [] then (
            let fields = List.map (
              fun (name, t) ->
-               let t = ocaml_type_of_field_type t in
-               <:ctyp< $lid:sf_name^"_"^name$ : $t$ >>
+               match t with
+               | PP.FListHeadPointer _ ->
+                   (* A list head turns into three fields, the pointer,
+                    * the offset within current struct, and the adjustment
+                    * (offset within destination struct).
+                    *)
+                   let t = ocaml_type_of_field_type t in
+                   [ <:ctyp< $lid:sf_name^"_"^name$ : $t$ >>;
+                     <:ctyp< $lid:sf_name^"_"^name^"_offset"$ : int >>;
+                     <:ctyp< $lid:sf_name^"_"^name^"_adjustment"$ : int >> ]
+               | _ ->
+                   let t = ocaml_type_of_field_type t in
+                   [ <:ctyp< $lid:sf_name^"_"^name$ : $t$ >> ]
            ) fields in
+           let fields = List.concat fields in
            let fields = concat_record_fields fields in
 
            <:str_item<
@@ -316,15 +328,17 @@ let generate_parsers xs =
                  List.find (fun { PP.field_name = name } -> field_name = name)
                    structure.PP.struct_fields in
 
-               (* Generate assignment code, if necessary we can adjust
-                * the list_head.
+               (* Generate assignment code.  List_heads are treated
+                * specially because they have an implicit adjustment.
                 *)
                match field_type with
                | PP.FListHeadPointer None ->
-                   sprintf "%s_%s = (if %s <> 0L then Int64.sub %s %dL else %s)"
-                     sf.SC.sf_name field_name
-                     field_name
-                     field_name offset field_name
+                   sprintf "%s_%s = %s;
+          %s_%s_offset = %d;
+          %s_%s_adjustment = %d"
+                     sf.SC.sf_name field_name field_name
+                     sf.SC.sf_name field_name offset
+                     sf.SC.sf_name field_name offset
 
                | PP.FListHeadPointer (Some (other_struct_name,
                                             other_field_name)) ->
@@ -332,16 +346,14 @@ let generate_parsers xs =
                     * know the offset until runtime, so we have to call
                     * offset_of_<struct>_<field> to find it.
                     *)
-                   sprintf "%s_%s = (
-                      if %s <> 0L then (
-                        let offset = offset_of_%s_%s kernel_version in
-                        let offset = Int64.of_int offset in
-                        Int64.sub %s offset
-                      ) else %s
-                    )"
+                   sprintf "%s_%s = %s;
+          %s_%s_offset = %d;
+          %s_%s_adjustment = offset_of_%s_%s kernel_version"
                      sf.SC.sf_name field_name field_name
-                     other_struct_name other_field_name
-                     field_name field_name
+                     sf.SC.sf_name field_name offset (* in this struct *)
+                     sf.SC.sf_name field_name        (* ... & in other struct*)
+                       other_struct_name other_field_name
+
                | _ ->
                    sprintf "%s_%s = %s" sf.SC.sf_name field_name field_name
            ) sf.SC.sf_fields in
@@ -421,16 +433,44 @@ let generate_followers xs =
                | PP.FListHeadPointer (Some (struct_name, _)) -> struct_name
                | PP.FStructPointer struct_name -> struct_name
                | _ -> assert false in
-             tuple_generate_extract follower_tuple follower_name
-               <:patt< f >> <:expr< followers >>
-               <:expr<
-                 let map =
-                   f load followers map shape.$lid:sf_name^"_"^name$ in $body$
-               >>
+
+             match typ with
+             | PP.FListHeadPointer _ ->
+                 tuple_generate_extract follower_tuple follower_name
+                 <:patt< f >> <:expr< followers >>
+                 <:expr<
+                   (* For list head pointers, add the address of the base
+                    * of this virtual structure to the map, then adjust
+                    * the pointer.
+                    *)
+                   let offset = shape.$lid:sf_name^"_"^name^"_offset"$
+                   and adj = shape.$lid:sf_name^"_"^name^"_adjustment"$ in
+                   let offset = Int64.of_int offset
+                   and adj = Int64.of_int adj in
+                   (* 'addr' is base of the virtual struct *)
+                   let addr = Int64.sub (Int64.add addr offset) adj in
+                   let map = AddrMap.add addr ($str:follower_name$, 0) map in
+                   let out_addr =
+                     Int64.sub shape.$lid:sf_name^"_"^name$ adj in
+                   let map =
+                     f load followers map out_addr in
+                   $body$
+                 >>
+
+             | PP.FStructPointer _ ->
+                 tuple_generate_extract follower_tuple follower_name
+                 <:patt< f >> <:expr< followers >>
+                 <:expr<
+                   let map =
+                     f load followers map shape.$lid:sf_name^"_"^name$ in
+                   $body$
+                 >>
+
+             | _ -> assert false
          ) fields <:expr< map >> in
 
          <:str_item<
-           let $lid:sf_name^"_follower"$ load followers map shape =
+           let $lid:sf_name^"_follower"$ load followers map addr shape =
              $body$
          >>
       ) sflist
@@ -454,7 +494,7 @@ let generate_followers xs =
            let map = AddrMap.add addr (struct_name, total_size) map in
            let bits = load struct_name addr total_size in
            let shape, _ = parserfn kernel_version bits in
-           followerfn load followers map shape
+           followerfn load followers map addr shape
          )
          else map
       >> in
@@ -612,7 +652,9 @@ let output_interf ~output_file types offsets parsers followers =
 
   let sigs =
     concat_sig_items [ prologue; types; offsets; parsers; followers ] in
-  Printers.OCaml.print_interf ~output_file sigs
+  Printers.OCaml.print_interf ~output_file sigs;
+
+  ignore (Sys.command (sprintf "wc -l %s" (Filename.quote output_file)))
 
 (* Finally generate the output files. *)
 let re_subst = Pcre.regexp "^(.*)\"(\\w+_parser_\\d+)\"(.*)$"
@@ -621,6 +663,7 @@ let output_implem ~output_file types offsets parsers parser_subs followers =
   (* Some standard code that appears at the top of the implementation file. *)
   let prologue =
     <:str_item<
+      open Printf ;;
       module StringMap = Map.Make (String) ;;
       module AddrMap = Map.Make (Int64) ;;
       type kernel_version = string ;;
@@ -681,4 +724,6 @@ supported Linux distribution, see this page about adding support:
   close_out ochan;
   close_in ichan;
 
-  Unix.unlink new_output_file
+  Unix.unlink new_output_file;
+
+  ignore (Sys.command (sprintf "wc -l %s" (Filename.quote output_file)))