qbe

commit f0a91ffe5ec42e99d28a89e44162cd70021aa8bb
parent 5f45999036960c88994d0318285ad63ca7ab4e7f
Author: Quentin Carbonneaux <quentin.carbonneaux@yale.edu>
Date:   Sat, 19 Mar 2016 22:51:53 -0400

start C dumping

Diffstat:
M
lisc/tools/abi.ml
 | 
110
++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-----

1 file changed, 104 insertions(+), 6 deletions(-)
diff --git a/lisc/tools/abi.ml b/lisc/tools/abi.ml
@@ -1,7 +1,7 @@
 (* fuzzer *)
 
 type _ bty =
-  | Char: int bty
+  | Char: char bty
   | Short: int bty
   | Int: int bty
   | Long: int bty
@@ -19,6 +19,7 @@ type _ aty =
 type anyb = AB: _ bty -> anyb (* kinda boring... *)
 type anys = AS: _ sty -> anys
 type anya = AA: _ aty -> anya
+type test = T: 'a aty * 'a -> test
 
 
 let btysize: type a. a bty -> int = function
@@ -31,6 +32,10 @@ let btysize: type a. a bty -> int = function
 
 let btyalign = btysize
 
+let styempty: type a. a sty -> bool = function
+  | Field _ -> false
+  | Empty -> true
+
 
 (* Generate types and test vectors. *)
 module Gen = struct
@@ -62,7 +67,7 @@ module Gen = struct
     let tb: type a. a bty -> a = function (* eh, dry... *)
       | Float  -> float ()
       | Double -> float ()
-      | Char   -> int (btysize Char)
+      | Char   -> Char.chr (R.int 255)
       | Short  -> int (btysize Short)
       | Int    -> int (btysize Int)
       | Long   -> int (btysize Long) in
@@ -82,8 +87,8 @@ module Gen = struct
     | 4 -> AB Float
     | _ -> AB Double
 
-  let binn = 10   (* default parameters for binomial law of s *)
-  and binp = 0.5
+  let binn = 8   (* default parameters for binomial law of s *)
+  and binp = 0.8
 
   let rec s ?(n=binn) ?(pp=binp) () = (* binomial law *)
     if n = 0 || R.float 1.0 > pp then AS Empty else
@@ -91,19 +96,112 @@ module Gen = struct
     let AS st = s ~n:(n-1) () in
     AS (Field (bt, st))
 
-  let a ?(n=binn) ?(pp=binp) ?(ps=0.2) () =
+  let a ?(n=binn) ?(pp=binp) ?(ps=0.8) () =
     if R.float 1.0 > ps then
       let AB bt = b () in
       AA (Base bt)
     else
+      let AB bt = b () in
       let AS st = s ~n ~pp () in
-      AA (Struct st)
+      AA (Struct (Field (bt, st)))
 
 end
 
+module type OUT = sig
+  val extension: string
+  val comment: out_channel -> string -> unit
+  val caller: out_channel -> test -> test list -> unit
+  val callee: out_channel -> test -> test list -> unit
+end
 
 (* Code generation for C *)
 module OutC = struct
   open Printf
 
+  let ctype oc name =
+    let cb: type a. a bty -> unit = function
+      | Char   -> fprintf oc "char"
+      | Short  -> fprintf oc "short"
+      | Int    -> fprintf oc "int"
+      | Long   -> fprintf oc "long"
+      | Float  -> fprintf oc "float"
+      | Double -> fprintf oc "double" in
+    let rec cs: type a. int -> a sty -> unit =
+      fun i -> function
+      | Field (b, s) ->
+        cb b;
+        fprintf oc " f%d; " i;
+        cs (i+1) s;
+      | Empty -> () in
+    function
+    | Base b ->
+      cb b;
+      fprintf oc " %s" name;
+    | Struct s ->
+      fprintf oc "struct %s { " name;
+      cs 1 s;
+      fprintf oc "} %s" name;
+      ()
+
+  let init oc name (T (ty, t)) =
+    let initb: type a. a bty * a -> unit = function
+      | Char, c   -> fprintf oc "%C" c
+      | Short, i  -> fprintf oc "%d" i
+      | Int, i    -> fprintf oc "%d" i
+      | Long, i   -> fprintf oc "%d" i
+      | Float, f  -> fprintf oc "%ff" f
+      | Double, f -> fprintf oc "%f" f in
+    let inits s =
+      let rec f: type a. a sty * a -> unit = function
+        | Field (b, s), (tb, ts) ->
+          initb (b, tb);
+          fprintf oc ", ";
+          f (s, ts)
+        | Empty, () -> () in
+      fprintf oc "{ ";
+      f s;
+      fprintf oc "}"; in
+    ctype oc name ty;
+    fprintf oc " = ";
+    begin match (ty, t) with
+    | Base b, tb -> initb (b, tb)
+    | Struct s, ts -> inits (s, ts)
+    end;
+    fprintf oc ";\n";
+    ()
+
+  let extension = ".c"
+
+  let comment oc s =
+    fprintf oc "/* %s */\n" s
+
+  let prelude oc = List.iter (fprintf oc "%s\n")
+    [ "#include <stdio.h>"
+    ; "#include <stdlib.h>"
+    ; ""
+    ; "static void"
+    ; "fail(int ret, int chk)"
+    ; "{"
+    ; "\tfprintf(stderr, \"fail: %s check number %d\\n\""
+    ; "\t\tret ? \"return\" : \"argument\", chk);"
+    ; "\tabort();"
+    ; "}"
+    ; ""
+    ]
+
+  let caller oc ret args =
+    prelude oc;
+    fprintf oc "int\nmain()\n{";
+    fprintf oc "\t";
+    init oc "ret" ret;
+    fprintf oc "}\n";
+    ()
+
 end
+
+
+let _ =
+  let _seed = Gen.init None in
+  let AA ty = Gen.a () in
+  let t = Gen.test ty in
+  OutC.caller stdout (T (ty, t)) []