Further code generation ** NOT WORKING **

[virt-mem.git] / extract / codegen / code_generation.ml

diff --git a/extract/codegen/code_generation.ml b/extract/codegen/code_generation.ml
new file mode 100644 (file)
index 0000000..2dba820
--- /dev/null
+++ b/extract/codegen/code_generation.ml
@@ -0,0 +1,158 @@
+(* Memory info command for virtual domains.
+   (C) Copyright 2008 Richard W.M. Jones, Red Hat Inc.
+   http://libvirt.org/
+
+   This program is free software; you can redistribute it and/or modify
+   it under the terms of the GNU General Public License as published by
+   the Free Software Foundation; either version 2 of the License, or
+   (at your option) any later version.
+
+   This program is distributed in the hope that it will be useful,
+   but WITHOUT ANY WARRANTY; without even the implied warranty of
+   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+   GNU General Public License for more details.
+
+   You should have received a copy of the GNU General Public License
+   along with this program; if not, write to the Free Software
+   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ *)
+
+open Camlp4.PreCast
+open Syntax
+(*open Ast*)
+
+open ExtList
+open ExtString
+open Printf
+
+module PP = Pahole_parser
+module SC = Struct_classify
+
+(* We don't care about locations when generating code, so it's
+ * useful to just have a single global _loc.
+ *)
+let _loc = Loc.ghost
+
+(* Some 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 items =
+  match items with
+  | [] -> <:str_item< >>
+  | x :: xs ->
+      List.fold_left (fun xs x -> <:str_item< $xs$ $x$ >>) x xs
+
+let concat_sig_items items =
+  match items with
+  | [] -> <:sig_item< >>
+  | x :: xs ->
+      List.fold_left (fun xs x -> <:sig_item< $xs$ $x$ >>) x xs
+
+let concat_record_fields fields =
+  match fields with
+    | [] -> 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
+
+let build_record rbs =
+  Ast.ExRec (_loc, rbs, Ast.ExNil _loc)
+
+let build_tuple_from_exprs 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 ocaml_type_of_field_type = function
+  | PP.FInteger -> <:ctyp< int64 >>
+  | PP.FString _ -> <:ctyp< string >>
+  | PP.FStructPointer _ | PP.FVoidPointer
+  | PP.FAnonListHeadPointer | PP.FListHeadPointer _ ->
+      <:ctyp< Virt_mem_mmap.addr >>
+
+let generate_types xs =
+  let strs = List.map (
+    fun (struct_name, sflist, cflist) ->
+      let sflist = List.map (
+       fun { SC.sf_name = name; sf_fields = fields } ->
+         if fields <> [] then (
+           let fields = List.map (
+             fun { PP.field_name = name; PP.field_type = t } ->
+               let t = ocaml_type_of_field_type t in
+               <:ctyp< $lid:name$ : $t$ >>
+           ) fields in
+           let fields = concat_record_fields fields in
+
+           <:str_item<
+             type $lid:name$ = { $fields$ }
+            >>
+         ) else
+           <:str_item< type $lid:name$ = unit >>
+      ) sflist in
+      let sflist = concat_str_items sflist in
+
+      let cflist = List.map (
+       fun { SC.cf_name = name; cf_fields = fields } ->
+         if fields <> [] then (
+           let fields = List.map (
+             fun { PP.field_name = name; PP.field_type = t } ->
+               let t = ocaml_type_of_field_type t in
+               <:ctyp< $lid:name$ : $t$ >>
+           ) fields in
+           let fields = concat_record_fields fields in
+
+           <:str_item<
+             type $lid:name$ = { $fields$ }
+            >>
+         ) else
+           <:str_item< type $lid:name$ = unit >>
+      ) cflist in
+      let cflist = concat_str_items cflist in
+
+      <:str_item<
+        type ('a, 'b) $lid:struct_name$ = {
+         $lid:struct_name^"_shape"$ : 'a;
+         $lid:struct_name^"_content"$ : 'b;
+       }
+       $sflist$
+       $cflist$
+      >>
+  ) xs in
+
+  let sigs =
+    List.map (
+      fun (struct_name, _, _) ->
+       <:sig_item<
+          type ('a, 'b) $lid:struct_name$
+       >>
+    ) xs in
+
+  concat_str_items strs, concat_sig_items sigs
+
+let output_interf ~output_file types =
+  let sigs = concat_sig_items [ types ] in
+  Printers.OCaml.print_interf ~output_file sigs
+
+let output_implem ~output_file types =
+  let strs = concat_str_items [ types ] in
+  Printers.OCaml.print_implem ~output_file strs