From: Richard W.M. Jones <"Richard W.M. Jones "> Date: Wed, 6 Aug 2008 15:30:36 +0000 (+0100) Subject: Code generation continued. X-Git-Url: http://git.annexia.org/?a=commitdiff_plain;h=7bd9a4fd2fef8beee44fc8982c90aee2643876dd;p=virt-mem.git Code generation continued. --- diff --git a/extract/codegen/kerneldb_to_parser.ml b/extract/codegen/kerneldb_to_parser.ml index 61fc8b0..e7b4142 100644 --- a/extract/codegen/kerneldb_to_parser.ml +++ b/extract/codegen/kerneldb_to_parser.ml @@ -352,6 +352,13 @@ Example (from toplevel of virt-mem source tree): let body = List.tl body in (* Don't care about opener line. *) let fields = parse basename body in + (* Compute total size of the structure. *) + let total_size = + let fields = List.map ( + fun (_, (_, offset, size)) -> offset + size + ) fields in + List.fold_left max 0 fields in + (* That got us all the fields, but we only care about * the wanted_fields. *) @@ -366,7 +373,7 @@ Example (from toplevel of virt-mem source tree): failwith (sprintf "%s: structure %s is missing required field %s" basename name wanted_field) ) wanted_fields; - Some (name, fields) + Some (name, (fields, total_size)) ) what in (basename, version, arch, structures) @@ -377,7 +384,7 @@ Example (from toplevel of virt-mem source tree): fun (basename, version, arch, structures) -> printf "%s (version: %s, arch: %s):\n" basename version arch; List.iter ( - fun (struct_name, fields) -> + fun (struct_name, (fields, total_size)) -> printf " struct %s {\n" struct_name; List.iter ( fun (field_name, (typ, offset, size)) -> @@ -391,7 +398,7 @@ Example (from toplevel of virt-mem source tree): ); printf " /* offset = %d, size = %d */\n" offset size ) fields; - printf " }\n\n"; + printf " } /* %d bytes */\n\n" total_size; ) structures; ) datas; @@ -422,7 +429,7 @@ Example (from toplevel of virt-mem source tree): let field_types = match kernels with | [] -> [] - | (_, _, _, fields) :: kernels -> + | (_, _, _, (fields, _)) :: kernels -> let field_types_of_fields fields = List.sort ( List.map ( @@ -432,7 +439,7 @@ Example (from toplevel of virt-mem source tree): in let field_types = field_types_of_fields fields in List.iter ( - fun (_, _, _, fields) -> + 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; @@ -471,7 +478,7 @@ Example (from toplevel of virt-mem source tree): let xs = ref [] in let kernels = List.map ( - fun (basename, version, arch, fields) -> + fun (basename, version, arch, (fields, total_size)) -> let key = endian_of_architecture arch, fields in let j = try Hashtbl.find hash key @@ -479,7 +486,7 @@ Example (from toplevel of virt-mem source tree): incr i; xs := (!i, key) :: !xs; Hashtbl.add hash key !i; !i in - (basename, version, arch, j) + (basename, version, arch, total_size, j) ) kernels in struct_name, kernels, field_types, List.rev !xs ) files in @@ -510,7 +517,7 @@ Example (from toplevel of virt-mem source tree): | (name, `Int) -> <:ctyp< $lid:name$ : int >> | (name, `Ptr struct_name) -> - <:ctyp< $lid:name$ : (*`$str:struct_name$*) int64 >> + <:ctyp< $lid:name$ : [`$lid:struct_name$] int64 >> | (name, `Str _) -> <:ctyp< $lid:name$ : string >> ) field_types in @@ -525,12 +532,87 @@ Example (from toplevel of virt-mem source tree): let struct_sig = <:sig_item< type t = { $fields$ } >> in struct_type, struct_sig in + (* The shared parser functions. + * We could include bitmatch statements directly in here, but + * what happens is that the macros get expanded here, resulting + * in unreadable generated code. So instead just do a textual + * substitution later by post-processing the generated files. + * Not type-safe, but we can't have everything. + *) + let parser_stmts, parser_subs = + let parser_stmts = List.map ( + fun (i, _) -> + 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 + + (* What gets substituted for "parser_NN" ... *) + let parser_subs = List.map ( + fun (i, (endian, fields)) -> + let fnname = sprintf "parser_%d" i in + let patterns = "" and assignments = "" in (* XXX *) + let sub = + sprintf "bitmatch bits with + | { %s } -> { %s } + | { _ } -> raise (ParseError (%S, %S, \"failed to match kernel structure\"))" + patterns assignments struct_name fnname in + fnname, sub + ) parsers in + + parser_stmts, parser_subs in + + (* Define a map from kernel versions to parsing functions. *) + let version_map = + let stmts = List.fold_left ( + fun stmts (_, version, arch, total_size, i) -> + let parserfn = sprintf "parser_%d" i in + <:str_item< + $stmts$ + let v = ($lid:parserfn$, $`int:total_size$) + let map = StringMap.add $str:version$ v map + >> + ) <:str_item< let map = StringMap.empty >> kernels in + + <:str_item< + module StringMap = Map.Make (String) + $stmts$ + >> 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." + exception ParseError of string ;; $struct_type$ + $parser_stmts$ + $version_map$ + + type kernel_version = string + let known version = StringMap.mem version map + let size version = + let _, size = StringMap.find version map in + size + let get version bits = + let parsefn, _ = StringMap.find version map in + parsefn bits >> in + (* Interface (.mli file). *) let interface = <:sig_item< + exception ParseError of string ;; $struct_sig$ + + type kernel_version = string + val known : kernel_version -> bool + val size : kernel_version -> int + val get : kernel_version -> Bitstring.bitstring -> t >> in (struct_name, code, interface) @@ -540,8 +622,10 @@ Example (from toplevel of virt-mem source tree): List.iter ( fun (struct_name, code, interface) -> let output_file = outputdir // "kernel_" ^ struct_name ^ ".ml" in + printf "Writing %s implementation to %s ...\n%!" struct_name output_file; Printers.OCaml.print_implem ~output_file code; let output_file = outputdir // "kernel_" ^ struct_name ^ ".mli" in + printf "Writing %s interface to %s ...\n%!" struct_name output_file; Printers.OCaml.print_interf ~output_file interface ) files