X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=extract%2Fcodegen%2Fcode_generation.ml;h=d45134996c17125f5b0003b1abfce0265d5f07ab;hb=fea04ba6838a7fb1f7f6df9ea5b9603603205f3d;hp=41254d8bc24e719dee3a3820780b8e4c68747b1d;hpb=62b4fb5d778b12af1ed90c4f7934a34e10e1ba9d;p=virt-mem.git

diff --git a/extract/codegen/code_generation.ml b/extract/codegen/code_generation.ml
index 41254d8..d451349 100644
--- 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