Code generation continued.

diff --git a/extract/codegen/kerneldb_to_parser.ml b/extract/codegen/kerneldb_to_parser.ml
index 61fc8b0..e7b4142 100644 (file)
--- 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