summaryrefslogtreecommitdiff
path: root/lisc/tools
diff options
context:
space:
mode:
Diffstat (limited to 'lisc/tools')
-rw-r--r--lisc/tools/abi.ml247
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;
()
generated by cgit v1.2.3 (git 2.25.1) at 2026-01-16 02:54:07 +0000