virt-ps working again.

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

diff --git a/extract/codegen/code_generation.ml b/extract/codegen/code_generation.ml
index 41254d8..d451349 100644 (file)
--- a/extract/codegen/code_generation.ml
+++ b/extract/codegen/code_generation.ml
@@ -448,7 +448,7 @@ let generate_parsers xs =
   | { %s } ->
       { %s }
   | { _ } ->
-      raise (Virt_mem_types.ParseError (%S, %S, match_err))"
+      raise (ParseError (%S, %S, match_err))"
              patterns assignments
              struct_name pa_name in
 
@@ -539,10 +539,21 @@ let generate_followers names xs =
                    and adj = data.$lid:struct_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
+
+                   (* 'addr' is base of the virtual struct, but when
+                    * adding it to the map make sure we don't splat
+                    * the real structure (can happen if offset=adj).
+                    *)
                    let map =
-                     AddrMap.add addr ($str:dest_struct_name$, None) map in
+                     if offset <> adj then (
+                       let addr = Int64.sub (Int64.add addr offset) adj in
+                       AddrMap.add addr ($str:dest_struct_name$, None) map
+                     ) else map in
+
+                   (* 'dest_addr' is the destination address of
+                    * this pointer.  It needs the usual list_head
+                    * adjustment applied.
+                    *)
                    let dest_addr = Int64.sub dest_addr adj in
                    let map =
                      $lid:dest_struct_name^"_follower"$
@@ -603,13 +614,8 @@ let generate_followers names xs =
     fun (struct_name, _) ->
       <:sig_item<
         val $lid:struct_name^"_follower"$ :
-         kernel_version ->
-         (string -> Virt_mem_mmap.addr -> int -> Bitstring.bitstring) ->
-         (string * (int * Bitstring.bitstring * kernel_struct) option)
-            AddrMap.t ->
-         Virt_mem_mmap.addr ->
-         (string * (int * Bitstring.bitstring * kernel_struct) option)
-            AddrMap.t
+         kernel_version -> load_fn -> addrmap -> Virt_mem_mmap.addr ->
+         addrmap
       >>
   ) xs in
   let sigs = concat_sig_items sigs in
@@ -617,7 +623,9 @@ let generate_followers names xs =
   strs, sigs
 
 let output_interf ~output_file types offsets parsers version_maps followers =
-  (* Some standard code that appears at the top of the interface file. *)
+  (* Some standard code that appears at the top and bottom
+   * of the interface file.
+   *)
   let prologue =
     <:sig_item<
       module AddrMap : sig
@@ -636,12 +644,28 @@ let output_interf ~output_file types offsets parsers version_maps followers =
        val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
        val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
       end ;;
-      type kernel_version = string ;;
+      exception ParseError of string * string * string ;;
+
+      type kernel_version = string
+
+      type load_fn =
+         string -> Virt_mem_mmap.addr -> int -> Bitstring.bitstring
+    >>
+  and addrmap =
+    <:sig_item<
+      type addrmap =
+         (string * (int * Bitstring.bitstring * kernel_struct) option)
+           AddrMap.t
     >> in
 
   let sigs =
-    concat_sig_items [ prologue; types; offsets; parsers;
-                      version_maps; followers ] in
+    concat_sig_items [ prologue;
+                      types;
+                      addrmap;
+                      offsets;
+                      parsers;
+                      version_maps;
+                      followers ] in
   Printers.OCaml.print_interf ~output_file sigs;
 
   ignore (Sys.command (sprintf "wc -l %s" (Filename.quote output_file)))
@@ -651,15 +675,17 @@ let re_subst = Pcre.regexp "^(.*)\"(\\w+_parser_\\d+)\"(.*)$"
 
 let output_implem ~output_file types offsets parsers parser_subs
     version_maps followers =
-  (* Some standard code that appears at the top of the implementation file. *)
+  (* Some standard code that appears at the top and bottom
+   * of the implementation file.
+   *)
   let prologue =
     <:str_item<
       open Printf ;;
       module StringMap = Map.Make (String) ;;
       module AddrMap = Map.Make (Int64) ;;
-      type kernel_version = string ;;
+      exception ParseError of string * string * string ;;
 
-      let match_err = "failed to match kernel structure" ;;
+      let match_err = "failed to match kernel structure"
 
       let unknown_kernel_version version struct_name =
        invalid_arg (sprintf "%s: unknown kernel version or
@@ -667,14 +693,28 @@ struct %s is not supported in this kernel.
 Try a newer version of virt-mem, or if the guest is not from a
 supported Linux distribution, see this page about adding support:
   http://et.redhat.com/~rjones/virt-mem/faq.html\n"
-                      version struct_name) ;;
+                      version struct_name)
 
-      let zero = 0 ;;
+      type kernel_version = string
+      type load_fn = string -> Virt_mem_mmap.addr -> int -> Bitstring.bitstring
+
+      let zero = 0
+    >>
+  and addrmap =
+    <:str_item<
+      type addrmap =
+         (string * (int * Bitstring.bitstring * kernel_struct) option)
+           AddrMap.t
     >> in
 
   let strs =
-    concat_str_items [ prologue; types; offsets; parsers;
-                      version_maps; followers ] in
+    concat_str_items [ prologue;
+                      types;
+                      addrmap;
+                      offsets;
+                      parsers;
+                      version_maps;
+                      followers ] in
 
   (* Write the new implementation to .ml.new file. *)
   let new_output_file = output_file ^ ".new" in