diff options
Diffstat (limited to 'lisc/tools')
| -rw-r--r-- | lisc/tools/abi.ml | 247 |
1 files changed, 145 insertions, 102 deletions
diff --git a/lisc/tools/abi.ml b/lisc/tools/abi.ml index a5ad250..814bc79 100644 --- a/lisc/tools/abi.ml +++ b/lisc/tools/abi.ml @@ -19,7 +19,8 @@ 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 +type testb = TB: 'a bty * 'a -> testb +type testa = TA: 'a aty * 'a -> testa let btysize: type a. a bty -> int = function @@ -36,6 +37,14 @@ let styempty: type a. a sty -> bool = function | Field _ -> false | Empty -> true +let rec stysize: type a. a sty -> int = function + | Field (b, s) -> (btyalign b) + (stysize s) + | Empty -> 0 + +let rec styalign: type a. a sty -> int = function + | Field (b, s) -> max (btyalign b) (styalign s) + | Empty -> 1 + (* Generate types and test vectors. *) module Gen = struct @@ -111,7 +120,7 @@ module Gen = struct let test () = let AA ty = a () in let t = testv ty in - T (ty, t) + TA (ty, t) let tests () = let rec f n = @@ -124,8 +133,8 @@ 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 + val caller: out_channel -> testa -> testa list -> unit + val callee: out_channel -> testa -> testa list -> unit end (* Code generation for C *) @@ -170,7 +179,7 @@ module OutC = struct | Float, f -> fprintf oc "%ff" f | Double, f -> fprintf oc "%f" f - let init oc name (T (ty, t)) = + let init oc name (TA (ty, t)) = let inits s = let rec f: type a. a sty * a -> unit = function | Field (b, s), (tb, ts) -> @@ -208,7 +217,7 @@ module OutC = struct ] let typedef oc name = function - | T (Struct ts, _) -> + | TA (Struct ts, _) -> ctypelong oc name (Struct ts); fprintf oc ";\n"; | _ -> () @@ -220,8 +229,8 @@ module OutC = struct base oc t; fprintf oc ")\n\t\tfail(%S);\n" name; in function - | T (Base b, tb) -> chkbase name (b, tb) - | T (Struct s, ts) -> + | TA (Base b, tb) -> chkbase name (b, tb) + | TA (Struct s, ts) -> let rec f: type a. int -> a sty * a -> unit = fun i -> function | Field (b, s), (tb, ts) -> @@ -232,11 +241,11 @@ module OutC = struct let argname i = "arg" ^ string_of_int (i+1) - let proto oc (T (tret, _)) args = + let proto oc (TA (tret, _)) args = ctype oc "ret" tret; fprintf oc " f("; let narg = List.length args in - List.iteri (fun i (T (targ, _)) -> + List.iteri (fun i (TA (targ, _)) -> ctype oc (argname i) targ; fprintf oc " %s" (argname i); if i <> narg-1 then @@ -259,7 +268,7 @@ module OutC = struct init oc (argname i) arg; ) args; fprintf oc "\t"; - let T (tret, _) = ret in + let TA (tret, _) = ret in ctype oc "ret" tret; fprintf oc " ret;\n\n"; fprintf oc "\tret = f("; @@ -296,96 +305,21 @@ end module OutIL = struct open Printf - let ctypelong 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; - | Struct s -> - fprintf oc "struct %s { " name; - cs 1 s; - fprintf oc "}"; - () - - let ctype: type a. out_channel -> string -> a aty -> unit = - fun oc name -> function - | Struct _ -> fprintf oc "struct %s" name - | t -> ctypelong oc "" t - - let init oc name (T (ty, t)) = - let inits s = - let rec f: type a. a sty * a -> unit = function - | Field (b, s), (tb, ts) -> - base oc (b, tb); - fprintf oc ", "; - f (s, ts) - | Empty, () -> () in - fprintf oc "{ "; - f s; - fprintf oc "}"; in - ctype oc name ty; - fprintf oc " %s = " name; - begin match (ty, t) with - | Base b, tb -> base oc (b, tb) - | Struct s, ts -> inits (s, ts) - end; - fprintf oc ";\n"; - () - - let comment oc s = fprintf oc "# %s\n" s - let check oc name = - let chkbase: type a. string -> a bty * a -> unit = - fun name t -> - fprintf oc "\tif (%s != " name; - base oc t; - fprintf oc ")\n\t\tfail(%S);\n" name; in - function - | T (Base b, tb) -> chkbase name (b, tb) - | T (Struct s, ts) -> - let rec f: type a. int -> a sty * a -> unit = - fun i -> function - | Field (b, s), (tb, ts) -> - chkbase (Printf.sprintf "%s.f%d" name i) (b, tb); - f (i+1) (s, ts); - | Empty, () -> () in - f 1 (s, ts) - - let tmp = + let tmp, lbl = let next = ref 0 in - fun () -> - incr next; - "%t" ^ (string_of_int !next) - - (* NEW NEW NEW *) - - let base: type a. out_channel -> a bty * a -> unit = - fun oc -> function - | Char, i -> fprintf oc "%d" i - | Short, i -> fprintf oc "%d" i - | Int, i -> fprintf oc "%d" i - | Long, i -> fprintf oc "%d" i - | Float, f -> fprintf oc "s_%f" f - | Double, f -> fprintf oc "d_%f" f - - let extension = ".ssa" + (fun () -> incr next; "%t" ^ (string_of_int !next)), + (fun () -> incr next; "@l" ^ (string_of_int !next)) - let argname i = "arg" ^ string_of_int (i+1) + let bvalue: type a. a bty * a -> string = function + | Char, i -> sprintf "%d" i + | Short, i -> sprintf "%d" i + | Int, i -> sprintf "%d" i + | Long, i -> sprintf "%d" i + | Float, f -> sprintf "s_%f" f + | Double, f -> sprintf "d_%f" f let btype: type a. a bty -> string = function | Char -> "w" @@ -395,9 +329,71 @@ module OutIL = struct | Float -> "s" | Double -> "d" + let extension = ".ssa" + + let argname i = "arg" ^ string_of_int (i+1) + + let siter oc base s g = + let rec f: type a. int -> int -> a sty * a -> unit = + fun id off -> function + | Field (b, s), (tb, ts) -> + let al = btyalign b in + let off = + let x = off mod al in + if x <> 0 then off + al - x else off in + let addr = tmp () in + fprintf oc "\t%s =l add %d, %s\n" addr off base; + g id addr (TB (b, tb)); + f (id + 1) (off + btysize b) (s, ts); + | Empty, () -> () in + f 0 0 s + + let init oc = function + | TA (Base b, tb) -> bvalue (b, tb) + | TA (Struct s, ts) -> + let base = tmp () in + fprintf oc "\t%s =l alloc%d %d\n" + base (styalign s) (stysize s); + siter oc base (s, ts) + begin fun _ addr (TB (b, tb)) -> + fprintf oc "\tstore%s %s, %s\n" + (btype b) (bvalue (b, tb)) addr; + end; + base + + let check oc id name = + let bcheck = fun id name (b, tb) -> + let tcmp = tmp () in + let nxtl = lbl () in + fprintf oc "\t%s =w ceq%s %s, %s\n" + tcmp (btype b) name (bvalue (b, tb)); + fprintf oc "\tstorew %d, %%failcode\n" id; + fprintf oc "\tjnz %s, %s, @fail\n" tcmp nxtl; + fprintf oc "%s\n" nxtl; in + function + | TA (Base Char, i) -> + let tval = tmp () in + fprintf oc "\t%s =w extsb %s\n" tval name; + bcheck id tval (Int, i) + | TA (Base Short, i) -> + let tval = tmp () in + fprintf oc "\t%s =w extsh %s\n" tval name; + bcheck id tval (Int, i) + | TA (Base b, tb) -> + bcheck id name (b, tb) + | TA (Struct s, ts) -> + siter oc name (s, ts) + begin fun id' addr (TB (b, tb)) -> + let tval = tmp () in + fprintf oc "\t%s =%s load %s\n" + tval (btype b) addr; + bcheck (100*id + id'+1) tval (b, tb); + end; + () + let ttype name = function - | T (Base b, _) -> btype b - | T (Struct _, _) -> ":" ^ name + | TA (Base b, _) -> btype b + | TA (Struct _, _) -> ":" ^ name let typedef oc name = let rec f: type a. a sty -> unit = function @@ -408,12 +404,51 @@ module OutIL = struct f s; | Empty -> () in function - | T (Struct ts, _) -> + | TA (Struct ts, _) -> fprintf oc "type :%s = { " name; f ts; fprintf oc " }\n"; | _ -> () + let postlude oc = List.iter (fprintf oc "%s\n") + [ "@fail" + ; "# failure code" + ; "\t%fcode =w loadw %failcode" + ; "\t%f0 =w call $printf(l $failstr, w %fcode)" + ; "\t%f1 =w call $abort()" + ; "\tret 0" + ; "}" + ; "" + ; "data $failstr = { b \"fail on check %d\\n\", b 0 }" + ] + + let caller oc ret args = + let narg = List.length args in + List.iteri (fun i arg -> + typedef oc (argname i) arg; + ) args; + typedef oc "ret" ret; + fprintf oc "\nfunction w $main() {\n"; + fprintf oc "@start\n"; + fprintf oc "\t%%failcode =l alloc4 4\n"; + let targs = List.mapi (fun i arg -> + comment oc ("define argument " ^ (string_of_int (i+1))); + (ttype (argname i) arg, init oc arg) + ) args in + comment oc "call test function"; + fprintf oc "\t%%ret =%s call $f(" (ttype "ret" ret); + List.iteri (fun i (ty, tmp) -> + fprintf oc "%s %s" ty tmp; + if i <> narg-1 then + fprintf oc ", "; + ) targs; + fprintf oc ")\n"; + comment oc "check the return value"; + check oc 0 "%ret" ret; + fprintf oc "\tret 0\n"; + postlude oc; + () + let callee oc ret args = let narg = List.length args in List.iteri (fun i arg -> @@ -428,8 +463,16 @@ module OutIL = struct fprintf oc ", "; ) args; fprintf oc ") {\n"; - - fprintf oc "}\n"; + fprintf oc "@start\n"; + fprintf oc "\t%%failcode =l alloc4 4\n"; + List.iteri (fun i arg -> + comment oc ("checking argument " ^ (string_of_int (i+1))); + check oc (i+1) ("%" ^ argname i) arg; + ) args; + comment oc "define the return value"; + let rettmp = init oc ret in + fprintf oc "\tret %s\n" rettmp; + postlude oc; () end @@ -441,6 +484,6 @@ let _ = let targs = Gen.tests () in let oc = stdout in O.comment oc (Printf.sprintf "seed %d" seed); - (* O.caller oc tret targs; *) + O.caller oc tret targs; O.callee oc tret targs; () |