open Printf
module PP = Pahole_parser
-module SC = Struct_classify
+module MM = Minimizer
let rec uniq ?(cmp = Pervasives.compare) = function
[] -> []
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)
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
List.filter_map (
function
| (_,
- PP.FListHeadPointer ((Some (struct_name, field_name)) as f)) ->
+ (PP.FListHeadPointer
+ ((Some (struct_name, field_name)) as f),
+ _)) ->
f
| _ ->
None
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$
>>
*)
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
) 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_<struct>_<field> 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_<struct>_<field> 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_<struct>_<field> 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
(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_<struct> 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_<struct> 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
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)))
(* 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
git.annexia.org / virt-mem.git / blobdiff