X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;f=extract%2Fcodegen%2Fcode_generation.ml;h=d45134996c17125f5b0003b1abfce0265d5f07ab;hb=fea04ba6838a7fb1f7f6df9ea5b9603603205f3d;hp=c5e735f1438320a37205bd5863383eaf9ee9e83e;hpb=246caaf2b9558153bbcc85adf9a6e0d58de3399b;p=virt-mem.git diff --git a/extract/codegen/code_generation.ml b/extract/codegen/code_generation.ml index c5e735f..d451349 100644 --- a/extract/codegen/code_generation.ml +++ b/extract/codegen/code_generation.ml @@ -26,7 +26,7 @@ open ExtString open Printf module PP = Pahole_parser -module SC = Struct_classify +module MM = Minimizer let rec uniq ?(cmp = Pervasives.compare) = function [] -> [] @@ -82,15 +82,27 @@ let concat_exprs exprs = let concat_record_fields fields = match fields with - | [] -> assert false - | f :: fs -> - List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs + | [] -> assert false + | f :: fs -> + List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs let concat_record_bindings rbs = match rbs with - | [] -> assert false - | rb :: rbs -> - List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs + | [] -> assert false + | rb :: rbs -> + List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs + +let concat_bindings bs = + match bs with + | [] -> assert false + | b :: bs -> + List.fold_left (fun bs b -> <:binding< $bs$ and $b$ >>) b bs + +let concat_sum_types ts = + match ts with + | [] -> assert false + | t :: ts -> + List.fold_left (fun ts t -> <:ctyp< $ts$ | $t$ >>) t ts let build_record rbs = Ast.ExRec (_loc, rbs, Ast.ExNil _loc) @@ -109,74 +121,90 @@ let build_tuple_from_patts patts = Ast.PaTup (_loc, List.fold_left (fun xs x -> Ast.PaCom (_loc, x, xs)) x xs) +(* Helper functions to store things in a fixed-length tuple very efficiently. + * Note that the tuple length must be >= 2. + *) +type tuple = string list + +let tuple_create fields : tuple = fields + +(* Generates 'let _, _, resultpatt, _ = tupleexpr in body'. *) +let tuple_generate_extract fields field resultpatt tupleexpr body = + let patts = List.map ( + fun name -> if name = field then resultpatt else <:patt< _ >> + ) fields in + let result = build_tuple_from_patts patts in + <:expr< let $result$ = $tupleexpr$ in $body$ >> + +(* Generates '(fieldexpr1, fieldexpr2, ...)'. *) +let tuple_generate_construct fieldexprs = + build_tuple_from_exprs fieldexprs + type code = Ast.str_item * Ast.sig_item let ocaml_type_of_field_type = function - | PP.FInteger -> <:ctyp< int64 >> - | PP.FString _ -> <:ctyp< string >> - | PP.FStructPointer _ | PP.FVoidPointer - | PP.FAnonListHeadPointer | PP.FListHeadPointer _ -> + | PP.FInteger, true -> <:ctyp< int64 >> + | PP.FInteger, false -> <:ctyp< int64 option >> + | PP.FString _, true -> <:ctyp< string >> + | PP.FString _, false -> <:ctyp< string option >> + | PP.FStructPointer _, true | PP.FVoidPointer, true + | PP.FAnonListHeadPointer, true | PP.FListHeadPointer _, true -> <:ctyp< Virt_mem_mmap.addr >> + | PP.FStructPointer _, false | PP.FVoidPointer, false + | PP.FAnonListHeadPointer, false | PP.FListHeadPointer _, false -> + <:ctyp< Virt_mem_mmap.addr option >> let generate_types xs = - let strs = List.map ( - fun (struct_name, sflist, cflist) -> - let sflist = List.map ( - fun { SC.sf_name = sf_name; sf_fields = fields } -> - if fields <> [] then ( - let fields = List.map ( - fun (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< - type $lid:sf_name$ = { $fields$ } - >> - ) else - <:str_item< type $lid:sf_name$ = unit >> - ) sflist in - let sflist = concat_str_items sflist in - - let cflist = List.map ( - fun { SC.cf_name = cf_name; cf_fields = fields } -> - if fields <> [] then ( - let fields = List.map ( - fun (name, t) -> - let t = ocaml_type_of_field_type t in - <:ctyp< $lid:cf_name^"_"^name$ : $t$ >> - ) fields in - let fields = concat_record_fields fields in - - <:str_item< - type $lid:cf_name$ = { $fields$ } - >> - ) else - <:str_item< type $lid:cf_name$ = unit >> - ) cflist in - let cflist = concat_str_items cflist in + let types = List.map ( + fun (struct_name, all_fields) -> + let fields = List.map ( + fun (name, (typ, always_available)) -> + match typ 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 (typ, always_available) in + [ <:ctyp< $lid:struct_name^"_"^name$ : $t$ >>; + <:ctyp< $lid:struct_name^"_"^name^"_offset"$ : int >>; + <:ctyp< $lid:struct_name^"_"^name^"_adjustment"$ : int >> ] + | _ -> + let t = ocaml_type_of_field_type (typ, always_available) in + [ <:ctyp< $lid:struct_name^"_"^name$ : $t$ >> ] + ) all_fields in + let fields = List.concat fields in + let fields = concat_record_fields fields in <:str_item< - type ('a, 'b) $lid:struct_name$ = 'a * 'b ;; - $sflist$ - $cflist$ + type $lid:struct_name$ = { $fields$ } + >>, + <:sig_item< + type $lid:struct_name$ = { $fields$ } >> ) xs in - concat_str_items strs, <:sig_item< >> + (* Generate a sum-type which can use to store any type of kernel + * structure, ie. Task_struct | Net_device | ... + *) + let types = types @ [ + let constrs = + List.map ( + fun (struct_name, _) -> + let struct_name_uc = String.capitalize struct_name in + <:ctyp< $uid:struct_name_uc$ of $lid:struct_name$ >> + ) xs in + let constrs = concat_sum_types constrs in + <:str_item< + type kernel_struct = $constrs$ + >>, + <:sig_item< + type kernel_struct = $constrs$ + >> + ] in + + let strs, sigs = List.split types in + concat_str_items strs, concat_sig_items sigs let generate_offsets xs = (* Only need to generate the offset_of_* functions for fields @@ -190,7 +218,9 @@ let generate_offsets xs = List.filter_map ( function | (_, - PP.FListHeadPointer ((Some (struct_name, field_name)) as f)) -> + (PP.FListHeadPointer + ((Some (struct_name, field_name)) as f), + _)) -> f | _ -> None @@ -252,10 +282,10 @@ let generate_offsets xs = let generate_parsers xs = let strs = List.map ( - fun (struct_name, palist) -> + fun (struct_name, (all_fields, palist)) -> let palist = List.map ( - fun { SC.pa_name = pa_name } -> + fun { MM.pa_name = pa_name } -> <:str_item< let $lid:pa_name$ kernel_version bits = $str:pa_name$ >> @@ -276,12 +306,10 @@ let generate_parsers xs = *) let subs = Hashtbl.create 13 in List.iter ( - fun (struct_name, palist) -> + fun (struct_name, (all_fields, palist)) -> List.iter ( - fun ({ SC.pa_name = pa_name; - pa_endian = endian; pa_structure = structure; - pa_shape_field_struct = sf; - pa_content_field_struct = cf }) -> + fun ({ MM.pa_name = pa_name; + pa_endian = endian; pa_structure = structure }) -> (* Generate the code to match this structure. *) let endian = match endian with @@ -319,73 +347,109 @@ let generate_parsers xs = ) structure.PP.struct_fields ) in - let shape_assignments = + let assignments = List.map ( - fun (field_name, field_type) -> - - (* Go and look up the field offset in the correct kernel. *) - let { PP.field_offset = offset } = - List.find (fun { PP.field_name = name } -> field_name = name) - structure.PP.struct_fields in - - (* Generate assignment code. List_heads are treated - * specially because they have an implicit adjustment. - *) - match field_type with - | PP.FListHeadPointer None -> - sprintf "%s_%s = %s; + fun (field_name, (field_type, always_available)) -> + if always_available then ( + (* Go and look up the field offset in the correct kernel. *) + let { PP.field_offset = offset } = + List.find (fun { PP.field_name = name } -> + field_name = name) + structure.PP.struct_fields in + + (* Generate assignment code. List_heads are treated + * specially because they have an implicit adjustment. + *) + match field_type with + | PP.FListHeadPointer None -> + 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)) -> - (* A reference to a field in another structure. We don't - * know the offset until runtime, so we have to call - * offset_of__ to find it. + struct_name field_name field_name + struct_name field_name offset + struct_name field_name offset + + | PP.FListHeadPointer (Some (other_struct_name, + other_field_name)) -> + (* A reference to a field in another structure. We don't + * know the offset until runtime, so we have to call + * offset_of__ to find it. + *) + sprintf "%s_%s = %s; + %s_%s_offset = %d; + %s_%s_adjustment = offset_of_%s_%s kernel_version" + struct_name field_name field_name + struct_name field_name offset (* in this struct *) + struct_name field_name (* ... & in other struct*) + other_struct_name other_field_name + + | _ -> + sprintf "%s_%s = %s" struct_name field_name field_name + ) else ( + (* Field is optional. Is it available in this kernel + * version? If so, get its offset, else throw Not_found. + *) + try + let { PP.field_offset = offset } = + List.find (fun { PP.field_name = name } -> + field_name = name) + structure.PP.struct_fields in + + (* Generate assignment code. List_heads are treated + * specially because they have an implicit adjustment. *) - sprintf "%s_%s = %s; + match field_type with + | PP.FListHeadPointer None -> + sprintf "%s_%s = Some %s; + %s_%s_offset = %d; + %s_%s_adjustment = %d" + struct_name field_name field_name + struct_name field_name offset + struct_name field_name offset + + | PP.FListHeadPointer (Some (other_struct_name, + other_field_name)) -> + (* A reference to a field in another structure. We + * don't know the offset until runtime, so we have + * to call offset_of__ to find it. + *) + sprintf "%s_%s = Some %s; %s_%s_offset = %d; %s_%s_adjustment = offset_of_%s_%s kernel_version" - sf.SC.sf_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 - - let shape_assignments = - if shape_assignments = [] then "()" - else - "{ " ^ String.concat ";\n " shape_assignments ^ " }" in - - let content_assignments = - List.map ( - fun (field_name, _) -> - sprintf "%s_%s = %s" cf.SC.cf_name field_name field_name - ) cf.SC.cf_fields in - - let content_assignments = - if content_assignments = [] then "()" - else - "{ " ^ String.concat ";\n " content_assignments ^ " }" in + struct_name field_name field_name + struct_name field_name offset(*in this struct *) + struct_name field_name (*... & in other struct*) + other_struct_name other_field_name + + | _ -> + sprintf "%s_%s = Some %s" + struct_name field_name field_name + with + Not_found -> + (* Field is not available in this kernel version. *) + match field_type with + | PP.FListHeadPointer _ -> + sprintf "%s_%s = None; + %s_%s_offset = -1; + %s_%s_adjustment = -1" + struct_name field_name + struct_name field_name + struct_name field_name + | _ -> + sprintf "%s_%s = None" struct_name field_name + ) + ) all_fields in + + let assignments = String.concat ";\n " assignments in let code = sprintf " bitmatch bits with | { %s } -> - let s = - %s in - let c = - %s in - (s, c) + { %s } | { _ } -> - raise (Virt_mem_types.ParseError (%S, %S, match_err))" - patterns shape_assignments content_assignments + raise (ParseError (%S, %S, match_err))" + patterns assignments struct_name pa_name in Hashtbl.add subs pa_name code @@ -394,241 +458,174 @@ let generate_parsers xs = (strs, <:sig_item< >>), subs -(* Helper functions to store things in a fixed-length tuple very efficiently. - * Note that the tuple length must be >= 2. - *) -type tuple = string list +let generate_version_maps xs = + (* size_of_ kernel_version *) + let strs = List.map ( + fun (struct_name, (kernels, _)) -> + let map = + List.fold_right ( + fun ({ PP.kernel_version = version }, + { PP.struct_total_size = size }) map -> + <:expr< + StringMap.add $str:version$ $`int:size$ $map$ + >> + ) kernels <:expr< StringMap.empty >> in -let tuple_create fields : tuple = fields + <:str_item< + let $lid:"size_of_"^struct_name$ = + let map = $map$ in + fun kernel_version -> + try StringMap.find kernel_version map + with Not_found -> + unknown_kernel_version kernel_version $str:struct_name$ + >> + ) xs in -(* Generates 'let _, _, resultpatt, _ = tupleexpr in body'. *) -let tuple_generate_extract fields field resultpatt tupleexpr body = - let patts = List.map ( - fun name -> if name = field then resultpatt else <:patt< _ >> - ) fields in - let result = build_tuple_from_patts patts in - <:expr< let $result$ = $tupleexpr$ in $body$ >> + (* parser_of_ kernel_version *) + let strs = strs @ List.map ( + fun (struct_name, (kernels, pahash)) -> + let map = + List.fold_right ( + fun ({ PP.kernel_version = version }, _) map -> + let { MM.pa_name = pa_name } = Hashtbl.find pahash version in + <:expr< + StringMap.add $str:version$ $lid:pa_name$ $map$ + >> + ) kernels <:expr< StringMap.empty >> in -(* Generates '(fieldexpr1, fieldexpr2, ...)'. *) -let tuple_generate_construct fieldexprs = - build_tuple_from_exprs fieldexprs - -type follower_t = - | Missing of string | Follower of string | KernelVersion of string + <:str_item< + let $lid:"parser_of_"^struct_name$ = + let map = $map$ in + fun kernel_version -> + try StringMap.find kernel_version map + with Not_found -> + unknown_kernel_version kernel_version $str:struct_name$ + >> + ) xs in -let generate_followers xs = - (* Tuple of follower functions, just a list of struct_names. *) - let follower_tuple = tuple_create (List.map fst xs) in + concat_str_items strs, <:sig_item< >> - (* A shape-follow function for every structure/shape. *) - let strs = List.map ( - fun (struct_name, (_, sflist, _, _)) -> - List.map ( - fun { SC.sf_name = sf_name; sf_fields = fields } -> - let body = List.fold_right ( - fun (name, typ) body -> - let follower_name = - match typ with - | PP.FListHeadPointer None -> struct_name - | PP.FListHeadPointer (Some (struct_name, _)) -> struct_name - | PP.FStructPointer struct_name -> struct_name - | _ -> assert false in +let generate_followers names xs = + (* A follower function for every structure. *) + let bindings = List.map ( + fun (struct_name, all_fields) -> + let followers = List.fold_right ( + fun (name, (typ, always_available)) rest -> + let is_shape_field = + match typ with + | PP.FListHeadPointer None -> true + | PP.FListHeadPointer (Some (struct_name, _)) + | PP.FStructPointer struct_name + when List.mem struct_name names -> true + | _ -> false in + if not is_shape_field then rest + else ( + let dest_struct_name = + match typ with + | PP.FListHeadPointer None -> struct_name + | PP.FListHeadPointer (Some (struct_name, _)) -> struct_name + | PP.FStructPointer struct_name -> struct_name + | _ -> assert false in + let body = match typ with | PP.FListHeadPointer _ -> - tuple_generate_extract follower_tuple follower_name - <:patt< f >> <:expr< followers >> - <:expr< + <: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 = data.$lid:struct_name^"_"^name^"_offset"$ + 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 - let map = AddrMap.add addr ($str:follower_name$, 0) map in - let out_addr = - Int64.sub shape.$lid:sf_name^"_"^name$ 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 = + 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 = - f load followers map out_addr in - $body$ + $lid:dest_struct_name^"_follower"$ + kernel_version load map dest_addr in + map >> | PP.FStructPointer _ -> - tuple_generate_extract follower_tuple follower_name - <:patt< f >> <:expr< followers >> - <:expr< + <:expr< let map = - f load followers map shape.$lid:sf_name^"_"^name$ in - $body$ + $lid:dest_struct_name^"_follower"$ + kernel_version load map dest_addr in + map >> - | _ -> assert false - ) fields <:expr< map >> in + | _ -> assert false in - <:str_item< - let $lid:sf_name^"_follower"$ load followers map addr shape = - $body$ - >> - ) sflist - ) xs in - let strs = List.concat strs in - - (* A follower function for every kernel version / structure. When this - * function is called starting at some known root, it will load every - * reachable kernel structure. - *) - let strs = - let common = - (* Share as much common code as possible to minimize generated - * code size and benefit i-cache. - *) - <:str_item< - let kv_follower kernel_version struct_name total_size - parserfn followerfn - load followers map addr = - if addr <> 0L && not (AddrMap.mem addr map) then ( - 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 addr shape - ) - else map - >> in - - let fs = - List.map ( - fun (struct_name, (kernels, _, sfhash, pahash)) -> - List.map ( - fun ({ PP.kernel_version = version; kv_i = kv_i }, - { PP.struct_total_size = total_size }) -> - let { SC.pa_name = pa_name } = Hashtbl.find pahash version in - let { SC.sf_name = sf_name } = Hashtbl.find sfhash version in - - let fname = sprintf "%s_kv%d_follower" struct_name kv_i in - - <:str_item< - let $lid:fname$ = - kv_follower - $str:version$ $str:struct_name$ $`int:total_size$ - $lid:pa_name$ $lid:sf_name^"_follower"$ - >> - ) kernels - ) xs in - - let strs = strs @ [ common ] @ List.concat fs in - strs in - - (* A map from kernel versions to follower functions. - * - * For each struct, we have a list of kernel versions which contain - * that struct. Some kernels are missing a particular struct, so - * that is turned into a ParseError exception. - *) - let strs = - let nr_kernels = - List.fold_left max 0 - (List.map (fun (_, (kernels, _, _, _)) -> List.length kernels) xs) in - let nr_structs = List.length xs in - let array = Array.make_matrix nr_kernels (nr_structs+1) (Missing "") in - List.iteri ( - fun si (struct_name, _) -> - for i = 0 to nr_kernels - 1 do - array.(i).(si+1) <- Missing struct_name - done - ) xs; - List.iteri ( - fun si (struct_name, (kernels, _, _, _)) -> - List.iter ( - fun ({ PP.kernel_version = version; kv_i = kv_i }, _) -> - array.(kv_i).(0) <- KernelVersion version; - array.(kv_i).(si+1) <- - Follower (sprintf "%s_kv%d_follower" struct_name kv_i) - ) kernels - ) xs; - - let array = Array.map ( - fun row -> - match Array.to_list row with - | [] | (Missing _|Follower _) :: _ -> assert false - | KernelVersion kernel_version :: followers -> kernel_version, followers - ) array in - - let map = List.fold_left ( - fun map (kernel_version, followers) -> - let followers = List.map ( - function - | Follower fname -> - <:expr< $lid:fname$ >> - - (* no follower for this kernel/struct combination *) - | Missing struct_name -> + if always_available then <:expr< - fun _ _ _ _ -> - raise ( - Virt_mem_types.ParseError ( - $str:struct_name$, "follower_map", struct_missing_err - ) - ) + let dest_addr = data.$lid:struct_name^"_"^name$ in + let map = $body$ in + $rest$ >> - | KernelVersion _ -> assert false - ) followers in - let followers = tuple_generate_construct followers in - - <:expr< StringMap.add $str:kernel_version$ $followers$ $map$ >> - ) <:expr< StringMap.empty >> (Array.to_list array) in - - let str = - <:str_item< - let follower_map = $map$ - >> in - strs @ [ str ] in - - (* Finally a publicly exposed follower function. *) - let strs = - let fs = - List.map ( - fun (struct_name, (kernels, _, _, _)) -> - let fname = sprintf "%s_follower" struct_name in - - let body = - tuple_generate_extract follower_tuple struct_name - <:patt< f >> <:expr< followers >> + else <:expr< - f load followers AddrMap.empty addr - >> in - - <:str_item< - let $lid:fname$ kernel_version load addr = - let followers = - try StringMap.find kernel_version follower_map - with Not_found -> - unknown_kernel_version kernel_version $str:struct_name$ in - $body$ - >> - ) xs in - - strs @ fs in - - let sigs = - List.map ( - fun (struct_name, _) -> - <:sig_item< - val $lid:struct_name^"_follower"$ : - kernel_version -> - (string -> Virt_mem_mmap.addr -> int -> Bitstring.bitstring) -> - Virt_mem_mmap.addr -> - (string * int) AddrMap.t - >> - ) xs in + let map = + match data.$lid:struct_name^"_"^name$ with + | None -> map + | Some dest_addr -> $body$ in + $rest$ + >> + ) + ) all_fields <:expr< map >> in + + let struct_name_uc = String.capitalize struct_name in + + <:binding< + $lid:struct_name^"_follower"$ kernel_version load map 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 + let bits = load $str:struct_name$ addr total_size in + let data = parser_ kernel_version bits in + let map = AddrMap.add + addr ($str:struct_name$, + Some (total_size, bits, $uid:struct_name_uc$ data)) + map in + $followers$ + ) + else map + >> + ) xs in + let bindings = concat_bindings bindings in + let strs = <:str_item< let rec $bindings$ >> in + + (* Function signatures for the interface. *) + let sigs = List.map ( + fun (struct_name, _) -> + <:sig_item< + val $lid:struct_name^"_follower"$ : + kernel_version -> load_fn -> addrmap -> Virt_mem_mmap.addr -> + addrmap + >> + ) xs in + let sigs = concat_sig_items sigs in - concat_str_items strs, concat_sig_items sigs + strs, sigs -let output_interf ~output_file types offsets parsers followers = - (* Some standard code that appears at the top of the interface file. *) +let output_interf ~output_file types offsets parsers version_maps followers = + (* Some standard code that appears at the top and bottom + * of the interface file. + *) let prologue = <:sig_item< module AddrMap : sig @@ -647,11 +644,28 @@ let output_interf ~output_file types offsets parsers 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; 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))) @@ -659,31 +673,48 @@ let output_interf ~output_file types offsets parsers followers = (* Finally generate the output files. *) let re_subst = Pcre.regexp "^(.*)\"(\\w+_parser_\\d+)\"(.*)$" -let output_implem ~output_file types offsets parsers parser_subs followers = - (* Some standard code that appears at the top of the implementation file. *) +let output_implem ~output_file types offsets parsers parser_subs + version_maps followers = + (* 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 struct_missing_err = "struct does not exist in this kernel version" ;; + let match_err = "failed to match kernel structure" let unknown_kernel_version version struct_name = - invalid_arg (Printf.sprintf "%s: unknown kernel version or + invalid_arg (sprintf "%s: unknown kernel version or 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; 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