X-Git-Url: http://git.annexia.org/?p=virt-mem.git;a=blobdiff_plain;f=extract%2Fcodegen%2Fkerneldb_to_parser.ml;h=f94de2f72b3457324fc004a91ef79b945ce53ed1;hp=1d56126b84fa964a5b585c0daa4fcc1f71aba373;hb=e49f9de0ae3883b7dc1f3905972f98a44417bf8f;hpb=90a2bfed23e0850d749f76897fa4c4daed2fa0b2 diff --git a/extract/codegen/kerneldb_to_parser.ml b/extract/codegen/kerneldb_to_parser.ml index 1d56126..f94de2f 100644 --- a/extract/codegen/kerneldb_to_parser.ml +++ b/extract/codegen/kerneldb_to_parser.ml @@ -28,22 +28,54 @@ and fields we try to parse. *) -let what = [ - "task_struct", ( - "struct task_struct {", "};", true, - [ "state"; "prio"; "normal_prio"; "static_prio"; - "tasks'prev"; "tasks'next"; "mm"; "active_mm"; "comm"; "pid" ] - ); +type struct_t = { + opener : string; (* String in pa_hole file which starts this struct. *) + closer : string; (* String in pa_hole file which ends this struct. *) + mandatory_struct : bool; (* Is this struct mandatory? *) + fields : (string * field_t) list; (* List of interesting fields. *) +} +and field_t = { + mandatory_field : bool; (* Is this field mandatory? *) +} + +let structs = [ + "task_struct", { + opener = "struct task_struct {"; closer = "};"; mandatory_struct = true; + fields = [ + "state", { mandatory_field = true }; + "prio", { mandatory_field = true }; + "normal_prio", { mandatory_field = true }; + "static_prio", { mandatory_field = true }; + "tasks'prev", { mandatory_field = true }; + "tasks'next", { mandatory_field = true }; + "mm", { mandatory_field = true }; + "active_mm", { mandatory_field = true }; + "comm", { mandatory_field = true }; + "pid", { mandatory_field = true }; + ] + }; (* "mm_struct", ( "struct mm_struct {", "};", true, [ ] ); *) - "net_device", ( - "struct net_device {", "};", true, - [ "name"; "dev_addr" ] - ); + "net_device", { + opener = "struct net_device {"; closer = "};"; mandatory_struct = true; + fields = [ + "dev_list'prev", { mandatory_field = false }; + "dev_list'next", { mandatory_field = false }; + "next", { mandatory_field = false }; + "name", { mandatory_field = true }; + "dev_addr", { mandatory_field = true }; + ] + }; + "net", { + opener = "struct net {"; closer = "};"; mandatory_struct = false; + fields = [ + "dev_base_head'next", { mandatory_field = true }; + ] + }; ] let debug = false @@ -58,6 +90,56 @@ open Printf let (//) = Filename.concat +(* Couple of handy camlp4 construction functions which do some + * things that ought to be easy/obvious but aren't. + * + * 'concat_str_items' concatenates a list of str_item together into + * one big str_item. + * + * 'concat_record_fields' concatenates a list of records fields into + * a record. The list must have at least one element. + * + * 'build_record' builds a record out of record fields. + * + * 'build_tuple_from_exprs' builds an arbitrary length tuple from + * a list of expressions of length >= 2. + * + * Thanks to bluestorm on #ocaml for getting these working. + *) +let concat_str_items _loc items = + match items with + | [] -> <:str_item< >> + | x :: xs -> + List.fold_left (fun xs x -> <:str_item< $xs$ $x$ >>) x xs + +let concat_sig_items _loc items = + match items with + | [] -> <:sig_item< >> + | x :: xs -> + List.fold_left (fun xs x -> <:sig_item< $xs$ $x$ >>) x xs + +let concat_record_fields _loc fields = + match fields with + | [] -> assert false + | f :: fs -> + List.fold_left (fun fs f -> <:ctyp< $fs$ ; $f$ >>) f fs + +let concat_record_bindings _loc rbs = + match rbs with + | [] -> assert false + | rb :: rbs -> + List.fold_left (fun rbs rb -> <:rec_binding< $rbs$ ; $rb$ >>) rb rbs + +let build_record _loc rbs = + Ast.ExRec (_loc, rbs, Ast.ExNil _loc) + +let build_tuple_from_exprs _loc exprs = + match exprs with + | [] | [_] -> assert false + | x :: xs -> + Ast.ExTup (_loc, + List.fold_left (fun xs x -> Ast.ExCom (_loc, x, xs)) x xs) + let () = let args = Array.to_list Sys.argv in @@ -146,16 +228,20 @@ Example (from toplevel of virt-mem source tree): (basename, version, arch) ) infos in + let nr_kernels = List.length infos in + (* For quick access to the opener strings, build a hash. *) let openers = Hashtbl.create 13 in List.iter ( - fun (name, (opener, closer, _, _)) -> + fun (name, { opener = opener; closer = closer }) -> Hashtbl.add openers opener (closer, name) - ) what; + ) structs; (* Now read the data files and parse out the structures of interest. *) - let datas = List.map ( - fun (basename, version, arch) -> + let kernels = List.mapi ( + fun i (basename, version, arch) -> + printf "Loading kernel data file %d/%d\r%!" (i+1) nr_kernels; + let file_exists name = try Unix.access name [Unix.F_OK]; true with Unix.Unix_error _ -> false @@ -222,10 +308,10 @@ Example (from toplevel of virt-mem source tree): (* Make sure we got all the mandatory structures. *) List.iter ( - fun (name, (_, _, mandatory, _)) -> + fun (name, { mandatory_struct = mandatory }) -> if mandatory && not (Hashtbl.mem bodies name) then failwith (sprintf "%s: structure %s not found in this kernel" basename name) - ) what; + ) structs; (basename, version, arch, bodies) ) infos in @@ -342,10 +428,10 @@ Example (from toplevel of virt-mem source tree): in - let datas = List.map ( + let kernels = List.map ( fun (basename, version, arch, bodies) -> let structures = List.filter_map ( - fun (struct_name, (_, _, _, wanted_fields)) -> + fun (struct_name, { fields = wanted_fields }) -> let body = try Some (Hashtbl.find bodies struct_name) with Not_found -> None in @@ -366,13 +452,13 @@ Example (from toplevel of virt-mem source tree): * the wanted_fields. *) let fields = List.filter ( - fun (name, _) -> List.mem name wanted_fields + fun (name, _) -> List.mem_assoc name wanted_fields ) fields in - (* Also check we have all the wanted fields. *) + (* Also check we have all the mandatory fields. *) List.iter ( - fun wanted_field -> - if not (List.mem_assoc wanted_field fields) then + fun (wanted_field, { mandatory_field = mandatory }) -> + if mandatory && not (List.mem_assoc wanted_field fields) then failwith (sprintf "%s: structure %s is missing required field %s" basename struct_name wanted_field) ) wanted_fields; @@ -382,10 +468,10 @@ Example (from toplevel of virt-mem source tree): struct_name ^ "_" ^ name, details) fields in Some (struct_name, (fields, total_size)) - ) what in + ) structs in (basename, version, arch, structures) - ) datas in + ) kernels in if debug then List.iter ( @@ -408,50 +494,109 @@ Example (from toplevel of virt-mem source tree): ) fields; printf " } /* %d bytes */\n\n" total_size; ) structures; - ) datas; + ) kernels; + + (* First output file is a simple list of kernels, to support the + * 'virt-mem --list-kernels' option. + *) + let () = + let _loc = Loc.ghost in + + let versions = List.map (fun (_, version, _, _) -> version) kernels in + + (* Sort them in reverse because we are going to generate the + * final list in reverse. + *) + let cmp a b = compare b a in + let versions = List.sort ~cmp versions in + + let xs = + List.fold_left (fun xs version -> <:expr< $str:version$ :: $xs$ >>) + <:expr< [] >> versions in + + let code = <:str_item< + let kernels = $xs$ + >> in + + let output_file = outputdir // "virt_mem_kernels.ml" in + printf "Writing list of kernels to %s ...\n%!" output_file; + Printers.OCaml.print_implem ~output_file code in (* We'll generate a code file for each structure type (eg. task_struct - * across all kernel versions), so rearrange 'datas' for that purpose. + * across all kernel versions), so rearrange 'kernels' for that purpose. * * XXX This loop is O(n^3), luckily n is small! *) let files = List.map ( fun (name, _) -> - name, - List.filter_map ( - fun (basename, version, arch, structures) -> - try Some (basename, version, arch, List.assoc name structures) - with Not_found -> None - ) datas - ) what in + let kernels = + List.filter_map ( + fun (basename, version, arch, structures) -> + try Some (basename, version, arch, List.assoc name structures) + with Not_found -> None + ) kernels in + + (* Sort the kernels, which makes the generated output more stable + * and makes patches more useful. + *) + let kernels = List.sort kernels in - let datas = () in ignore datas; (* garbage collect *) + name, kernels + ) structs in - (* Get just the field types. It's plausible that a field with the - * same name has a different type between kernel versions, so we must - * check that didn't happen. + let kernels = () in ignore kernels; (* garbage collect *) + + (* Get just the field types. + * + * It's plausible that a field with the same name has a different + * type between kernel versions, so we must check that didn't + * happen. + * + * This is complicated because of non-mandatory fields, which don't + * appear in every kernel version. *) let files = List.map ( fun (struct_name, kernels) -> let field_types = - match kernels with - | [] -> [] - | (_, _, _, (fields, _)) :: kernels -> - let field_types_of_fields fields = - List.sort ( - List.map ( - fun (field_name, (typ, _, _)) -> field_name, typ - ) fields - ) - in - let field_types = field_types_of_fields fields in - List.iter ( - fun (_, _, _, (fields, _)) -> - if field_types <> field_types_of_fields fields then - failwith (sprintf "%s: one of the structure fields changed type between kernel versions" struct_name) - ) kernels; - field_types in + (* Get the list of fields expected in this structure. *) + let { fields = struct_fields } = List.assoc struct_name structs in + + (* Get the list of fields that we found in each kernel version. *) + let found_fields = + List.flatten + (List.map (fun (_, _, _, (fields, _)) -> fields) kernels) in + + (* Determine a hash from each field name to the type. As we add + * fields, we might get a conflicting type (meaning the type + * changed between kernel versions). + *) + let hash = Hashtbl.create 13 in + + List.iter ( + fun (field_name, (typ, _, _)) -> + try + let field_type = Hashtbl.find hash field_name in + if typ <> field_type then + failwith (sprintf "%s.%s: structure field changed type between kernel versions" struct_name field_name); + with Not_found -> + Hashtbl.add hash field_name typ + ) found_fields; + + (* Now get a type for each structure field. *) + List.filter_map ( + fun (field_name, { mandatory_field = mandatory }) -> + try + let field_name = struct_name ^ "_" ^ field_name in + let typ = Hashtbl.find hash field_name in + Some (field_name, (typ, mandatory)) + with Not_found -> + let msg = + sprintf "%s.%s: this field was not found in any kernel version" + struct_name field_name in + if mandatory then failwith msg else prerr_endline msg; + None + ) struct_fields in (struct_name, kernels, field_types) ) files in @@ -496,7 +641,8 @@ Example (from toplevel of virt-mem source tree): !i in (basename, version, arch, total_size, j) ) kernels in - struct_name, kernels, field_types, List.rev !xs + let parsers = List.rev !xs in + struct_name, kernels, field_types, parsers ) files in (* How much did we save by sharing? *) @@ -509,6 +655,25 @@ Example (from toplevel of virt-mem source tree): (List.length parsers) ) files; + (* Extend the parsers fields by adding on any optional fields which + * are not actually present in the specific kernel. + *) + let files = + List.map ( + fun (struct_name, kernels, field_types, parsers) -> + let parsers = List.map ( + fun (i, (endian, fields)) -> + let fields_not_present = + List.filter_map ( + fun (field_name, _) -> + if List.mem_assoc field_name fields then None + else Some field_name + ) field_types in + (i, (endian, fields, fields_not_present)) + ) parsers in + (struct_name, kernels, field_types, parsers) + ) files in + (* Let's generate some code! *) let files = List.map ( @@ -522,24 +687,71 @@ Example (from toplevel of virt-mem source tree): let struct_type, struct_sig = let fields = List.map ( function - | (name, `Int) -> + | (name, (`Int, true)) -> <:ctyp< $lid:name$ : int64 >> - | (name, `Ptr _) -> + | (name, (`Int, false)) -> + <:ctyp< $lid:name$ : int64 option >> + | (name, (`Ptr _, true)) -> <:ctyp< $lid:name$ : Virt_mem_mmap.addr >> - | (name, `Str _) -> + | (name, (`Ptr _, false)) -> + <:ctyp< $lid:name$ : Virt_mem_mmap.addr option >> + | (name, (`Str _, true)) -> <:ctyp< $lid:name$ : string >> + | (name, (`Str _, false)) -> + <:ctyp< $lid:name$ : string option >> ) field_types in - let f, fs = match fields with - | [] -> failwith (sprintf "%s: structure has no fields" struct_name) - | f :: fs -> f, fs in - let fields = List.fold_left ( - fun fs f -> <:ctyp< $fs$ ; $f$ >> - ) f fs in - + let fields = concat_record_fields _loc fields in let struct_type = <:str_item< type t = { $fields$ } >> in let struct_sig = <:sig_item< type t = { $fields$ } >> in struct_type, struct_sig in + (* Create a "field signature" which describes certain aspects + * of the fields which vary between kernel versions. + *) + let fieldsig_type, fieldsigs = + let fieldsig_type = + let fields = List.map ( + fun (name, _) -> + let fsname = "__fs_" ^ name in + <:ctyp< $lid:fsname$ : Virt_mem_types.fieldsig >> + ) field_types in + let fields = concat_record_fields _loc fields in + <:str_item< type fs_t = { $fields$ } >> in + + let fieldsigs = List.map ( + fun (i, (_, fields, fields_not_present)) -> + let make_fieldsig field_name available offset = + let available = + if available then <:expr< true >> else <:expr< false >> in + let fsname = "__fs_" ^ field_name in + <:rec_binding< + $lid:fsname$ = + { Virt_mem_types.field_available = $available$; + field_offset = $`int:offset$ } + >> + in + let fields = List.map ( + fun (field_name, (_, offset, _)) -> + make_fieldsig field_name true offset + ) fields in + let fields_not_present = List.map ( + fun field_name -> + make_fieldsig field_name false (-1) + ) fields_not_present in + + let fieldsigs = fields @ fields_not_present in + let fsname = sprintf "fieldsig_%d" i in + let fieldsigs = concat_record_bindings _loc fieldsigs in + let fieldsigs = build_record _loc fieldsigs in + <:str_item< + let $lid:fsname$ = $fieldsigs$ + >> + ) parsers in + + let fieldsigs = concat_str_items _loc fieldsigs in + + fieldsig_type, fieldsigs in + (* The shared parser functions. * * We could include bitmatch statements directly in here, but @@ -555,18 +767,14 @@ Example (from toplevel of virt-mem source tree): let fnname = sprintf "parser_%d" i in <:str_item< let $lid:fnname$ bits = $str:fnname$ - >> + >> ) parsers in - let parser_stmts = - match parser_stmts with - | [] -> <:str_item< >> - | p :: ps -> - List.fold_left (fun ps p -> <:str_item< $ps$ $p$ >>) p ps in + let parser_stmts = concat_str_items _loc parser_stmts in (* What gets substituted for "parser_NN" ... *) let parser_subs = List.map ( - fun (i, (endian, fields)) -> + fun (i, (endian, fields, fields_not_present)) -> let fnname = sprintf "parser_%d" i in let endian = match endian with @@ -579,7 +787,7 @@ Example (from toplevel of virt-mem source tree): *) let cmp (_, (_, o1, _)) (_, (_, o2, _)) = compare o1 o2 in let fields = List.sort ~cmp fields in - String.concat ";\n " ( + String.concat ";\n " ( List.map ( function | (field_name, (`Int, offset, size)) @@ -593,22 +801,42 @@ Example (from toplevel of virt-mem source tree): ) fields ) in let assignments = - String.concat ";\n " ( - List.map ( - function - | (field_name, (`Ptr "list_head", offset, size)) -> - sprintf "%s = Int64.sub %s %dL" field_name field_name offset - | (field_name, _) -> + List.map ( + fun (field_name, typ) -> + let (_, mandatory) = + try List.assoc field_name field_types + with Not_found -> + failwith (sprintf "%s: not found in field_types" + field_name) in + match typ, mandatory with + | (`Ptr "list_head", offset, size), true -> + sprintf "%s = Int64.sub %s %dL" + field_name field_name offset + | (`Ptr "list_head", offset, size), false -> + sprintf "%s = Some (Int64.sub %s %dL)" + field_name field_name offset + | _, true -> sprintf "%s = %s" field_name field_name - ) fields - ) in + | _, false -> + sprintf "%s = Some %s" field_name field_name + ) fields in + let assignments_not_present = + List.map ( + fun field_name -> sprintf "%s = None" field_name + ) fields_not_present in + + let assignments = + String.concat ";\n " + (assignments @ assignments_not_present) in let sub = - sprintf "\ + sprintf " bitmatch bits with - | { %s } -> { %s } - | { _ } -> raise (ParseError (%S, %S, \"failed to match kernel structure\"))" - patterns assignments struct_name fnname in + | { %s } -> + { %s } + | { _ } -> + raise (Virt_mem_types.ParseError (struct_name, %S, match_err))" + patterns assignments fnname in fnname, sub ) parsers in @@ -620,9 +848,10 @@ Example (from toplevel of virt-mem source tree): let stmts = List.fold_left ( fun stmts (_, version, arch, total_size, i) -> let parserfn = sprintf "parser_%d" i in + let fsname = sprintf "fieldsig_%d" i in <:str_item< $stmts$ - let v = ($lid:parserfn$, $`int:total_size$) + let v = ($lid:parserfn$, $`int:total_size$, $lid:fsname$) let map = StringMap.add $str:version$ v map >> ) <:str_item< let map = StringMap.empty >> kernels in @@ -632,42 +861,72 @@ Example (from toplevel of virt-mem source tree): $stmts$ >> in + (* Accessors for the field signatures. *) + let fsaccess, fsaccess_sig = + let fields = List.map ( + fun (field_name, _) -> + let fsname = "__fs_" ^ field_name in + <:str_item< + let $lid:"field_signature_of_"^field_name$ version = + let _, _, fs = StringMap.find version map in + fs.$lid:fsname$ + >> + ) field_types in + + let fsaccess = concat_str_items _loc fields in + + let fields = List.map ( + fun (field_name, _) -> + <:sig_item< + val $lid:"field_signature_of_"^field_name$ : kernel_version -> + Virt_mem_types.fieldsig + >> + ) field_types in + + let fsaccess_sig = concat_sig_items _loc fields in + + fsaccess, fsaccess_sig in + (* Code (.ml file). *) let code = <:str_item< - let warning = "This code is automatically generated from the kernel database by kerneldb-to-parser program. Any edits you make will be lost." let zero = 0 - exception ParseError of string * string * string;; + let struct_name = $str:struct_name$ + let match_err = "failed to match kernel structure" ;; $struct_type$ + $fieldsig_type$ + $fieldsigs$ $parser_stmts$ $version_map$ type kernel_version = string let $lid:struct_name^"_known"$ version = StringMap.mem version map let $lid:struct_name^"_size"$ version = - let _, size = StringMap.find version map in + let _, size, _ = StringMap.find version map in size let $lid:struct_name^"_of_bits"$ version bits = - let parsefn, _ = StringMap.find version map in + let parsefn, _, _ = StringMap.find version map in parsefn bits let $lid:"get_"^struct_name$ version mem addr = - let parsefn, size = StringMap.find version map in + let parsefn, size, _ = StringMap.find version map in let bytes = Virt_mem_mmap.get_bytes mem addr size in let bits = Bitstring.bitstring_of_string bytes in - parsefn bits + parsefn bits ;; + $fsaccess$ >> in (* Interface (.mli file). *) let interface = <:sig_item< - exception ParseError of string * string * string;; $struct_sig$ + val struct_name : string type kernel_version = string val $lid:struct_name^"_known"$ : kernel_version -> bool val $lid:struct_name^"_size"$ : kernel_version -> int val $lid:struct_name^"_of_bits"$ : kernel_version -> Bitstring.bitstring -> t val $lid:"get_"^struct_name$ : kernel_version -> - ('a, 'b, [`HasMapping]) Virt_mem_mmap.t -> Virt_mem_mmap.addr -> t + ('a, 'b, [`HasMapping]) Virt_mem_mmap.t -> Virt_mem_mmap.addr -> t;; + $fsaccess_sig$ >> in (struct_name, code, interface, parser_subs) @@ -694,6 +953,17 @@ Example (from toplevel of virt-mem source tree): let ichan = open_in new_output_file in let ochan = open_out output_file in + output_string ochan "\ +(* WARNING: This file and the corresponding mli (interface) are + * automatically generated by the extract/codegen/kerneldb_to_parser.ml + * program. + * + * Any edits you make to this file will be lost. + * + * To update this file from the latest kernel database, it is recommended + * that you do 'make update-kernel-structs'. + *)\n\n"; + let rec loop () = let line = input_line ichan in let line =