X-Git-Url: http://git.annexia.org/?a=blobdiff_plain;ds=sidebyside;f=extract%2Fcodegen%2Fkerneldb_to_parser.ml;fp=extract%2Fcodegen%2Fkerneldb_to_parser.ml;h=e7b4142e8c520e1c552f4e97dfced12492caa970;hb=7bd9a4fd2fef8beee44fc8982c90aee2643876dd;hp=61fc8b0354775ce591241123e0186f0422207c07;hpb=4e08313e6d89ec75be5b7ff023fc365fe3a3dea6;p=virt-mem.git

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