X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=extract%2Fcodegen%2Fcode_generation.ml;h=b465e4ba2c593a4dad663125b11ed3aa91a87bc6;hb=HEAD;hp=41254d8bc24e719dee3a3820780b8e4c68747b1d;hpb=62b4fb5d778b12af1ed90c4f7934a34e10e1ba9d;p=virt-mem.git diff --git a/extract/codegen/code_generation.ml b/extract/codegen/code_generation.ml index 41254d8..b465e4b 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 @@ -531,30 +531,60 @@ let generate_followers names xs = 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 >> @@ -580,7 +610,9 @@ let generate_followers names xs = 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 @@ -603,13 +635,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 + bool -> kernel_version -> load_fn -> addrmap -> Virt_mem_mmap.addr -> + addrmap >> ) xs in let sigs = concat_sig_items sigs in @@ -617,7 +644,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 +665,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 +696,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 +714,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) + + 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