| { %s } ->
{ %s }
| { _ } ->
- raise (Virt_mem_types.ParseError (%S, %S, match_err))"
+ raise (ParseError (%S, %S, match_err))"
patterns assignments
struct_name pa_name in
match typ with
| PP.FListHeadPointer _ ->
<:expr<
- (* For list head pointers, add the address of the base
+ if debug then
+ eprintf "%s_follower: %s: list_head pointing at a %s\n"
+ $str:struct_name$ $str:name$ $str:dest_struct_name$;
+
+ (* For list head pointers, add the address of the base
* of this virtual structure to the map, then adjust
* the pointer.
*)
let offset = data.$lid:struct_name^"_"^name^"_offset"$
and adj = data.$lid:struct_name^"_"^name^"_adjustment"$ in
+
+ if debug then
+ eprintf "%s_follower: %s: offset=%d adjustment=%d\n"
+ $str:struct_name$ $str:name$ offset adj;
+
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
+
+ if debug then
+ eprintf "%s_follower: %s: dest_addr=%Lx\n"
+ $str:struct_name$ $str:name$ dest_addr;
+
let map =
$lid:dest_struct_name^"_follower"$
- kernel_version load map dest_addr in
+ debug kernel_version load map dest_addr in
map
>>
| PP.FStructPointer _ ->
<:expr<
+ if debug then
+ eprintf "%s_follower: %s: is a struct pointer pointing to a %s; dest_addr=%Lx\n"
+ $str:struct_name$ $str:name$
+ $str:dest_struct_name$ dest_addr;
+
let map =
$lid:dest_struct_name^"_follower"$
- kernel_version load map dest_addr in
+ debug kernel_version load map dest_addr in
map
>>
let struct_name_uc = String.capitalize struct_name in
<:binding<
- $lid:struct_name^"_follower"$ kernel_version load map addr =
+ $lid:struct_name^"_follower"$ debug kernel_version load map addr =
+ if debug then
+ eprintf "%s_follower: addr = %Lx\n" $str:struct_name$ addr;
if addr <> 0L && not (AddrMap.mem addr map) then (
let parser_ = $lid:"parser_of_"^struct_name$ kernel_version in
let total_size = $lid:"size_of_"^struct_name$ kernel_version in
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
+ bool -> kernel_version -> load_fn -> addrmap -> Virt_mem_mmap.addr ->
+ addrmap
>>
) xs in
let sigs = concat_sig_items sigs in
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
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)))
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
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)
+
+ type kernel_version = string
+ type load_fn = string -> Virt_mem_mmap.addr -> int -> Bitstring.bitstring
- let zero = 0 ;;
+ 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
git.annexia.org / virt-mem.git / blobdiff