diff --git a/regression/Makefile b/regression/Makefile index 16fdefec9..31e136a99 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -7,7 +7,7 @@ RC=../src/rc.opt check: $(TESTS) $(TESTS): %: %.expr - #@$(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log + @$(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log diff --git a/runtime/runtime.c b/runtime/runtime.c index c24283f99..b3a1ab1fd 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -1,6 +1,307 @@ /* Runtime library */ # include +# include +# include +# include +# include +# include + +# define STRING_TAG 0x00000000 +# define ARRAYU_TAG 0x01000000 +# define ARRAYB_TAG 0x02000000 + +# define LEN(x) (x & 0x00FFFFFF) +# define TAG(x) (x & 0xFF000000) + +# define TO_DATA(x) ((data*)((char*)(x)-sizeof(int))) + +typedef struct { + int tag; + char contents[0]; +} data; + +extern int Blength (void *p) { + data *a = TO_DATA(p); + return LEN(a->tag); +} + +extern void* Belem (void *p, int i) { + data *a = TO_DATA(p); + + if (TAG(a->tag) == STRING_TAG) return (void*)(int)(a->contents[i]); + + return (void*) ((int*) a->contents)[i]; +} + +extern void* Bstring (void *p) { + int n = strlen (p); + data *r = (data*) malloc (n + 1 + sizeof (int)); + + r->tag = n; + strncpy (r->contents, p, n + 1); + + return r->contents; +} + +extern void* Barray (int n, ...) { + va_list args; + int i; + data *r = (data*) malloc (sizeof(int) * (n+1)); + + r->tag = ARRAYB_TAG | n; //(boxed ? ARRAYB_TAG : ARRAYU_TAG) | size; + + va_start(args, n); + + for (i=0; icontents)[i] = ai; + } + + va_end(args); + + return r->contents; +} + +extern void Bsta (int n, int v, void *s, ...) { + va_list args; + int i, k; + data *a; + + va_start(args, s); + + for (i=0; itag) == STRING_TAG)((char*) s)[k] = (char) v; + else ((int*) s)[k] = v; +} + +/* +extern void* Lstrdup (void *p) { + data *s = TO_DATA(p); + data *r = (data*) malloc (s->tag + sizeof(int) + 1); + r->tag = s->tag; + strncpy (r->contents, s->contents, s->tag + 1); + return r->contents; +} + +extern int Lstrget (void *p, int i) { + data *s = TO_DATA(p); + return s->contents[i]; +} + +extern void* Lstrset (void *p, int i, int c) { + data *s = TO_DATA(p); + s->contents[i] = c; + return s; +} + +extern void* Lstrcat (void *p1, void *p2) { + data *s1 = TO_DATA(p1), *s2 = TO_DATA(p2); + data *r = (data*) malloc (s1->tag + s2->tag + sizeof (int) + 1); + r->tag = s1->tag + s2->tag; + strncpy (r->contents, s1->contents, s1->tag); + strncpy (&(r->contents)[s1->tag], s2->contents, s2->tag+1); + return r->contents; +} + +extern void* Lstrmake (int n, int c) { + data *r = (data*) malloc (n + sizeof (int) + 1); + int i; + r->tag = n; + for (i=0; icontents[i] = c; + r->contents[n] = 0; + return r->contents; +} + +extern void* Lstrsub (void *p, int i, int l) { + data *s = TO_DATA(p); + data *r = (data*) malloc (l + sizeof (int) + 1); + r->tag = l; + strncpy (r->contents, &(s->contents[i]), l); + r->contents[l] = 0; + return r->contents; +} + +extern int Lstrcmp (void *p1, void *p2) { + int i; + data *s1 = TO_DATA(p1), *s2 = TO_DATA(p2); + int b = s1->tag < s2->tag ? s1->tag : s2->tag; + for (i=0; i < b; i++) { + if (s1->contents[i] < s2->contents[i]) return -1; + if (s2->contents[i] < s1->contents[i]) return 1; + } + if (s1->tag < s2->tag) return -1; + if (s1->tag > s2->tag) return 1; + return 0; +} + +extern int Larrlen (void *p) { + data *a = TO_DATA(p); + return a->tag & 0x00FFFFFF; +} + +extern int L0arrElem (int i, void *p) { + data *a = TO_DATA(p); + return ((int*) a->contents)[i]; +} + +extern void* L0sta (void *s, int n, ...) { + data *a = TO_DATA(s); + va_list args; + int i, k, v; + data *p = a; + + va_start(args, n); + + for (i=0; icontents)[k]; + } + + k = va_arg(args, int); + v = va_arg(args, int); + + ((int*) p->contents)[k] = v; + + va_end(args); + + return p; +} + +extern void* L0makeArray (int boxed, int size, ...) { + va_list args; + int i; + data *r = (data*) malloc (sizeof(int)*(size+1)); + + r->tag = (boxed ? ARRAYB_TAG : ARRAYU_TAG) | size; + + va_start(args, size); + + for (i=0; icontents)[i] = ai; + } + + va_end(args); + + return r->contents; +} + +extern void* L0makeSexp (int tag, int size, ...) { + va_list args; + int i; + data *r = (data*) malloc (sizeof(int)*(size+1)); + + r->tag = ((tag+3) << 24) | size; + + va_start(args, size); + + for (i=0; icontents)[i] = ai; + } + + va_end(args); + + return r->contents; +} + +extern int Ltag (void *p) { + data *s = TO_DATA(p); + int t = ((s->tag & 0xFF000000) >> 24) - 3; + return t; +} + +extern int Ltagcmp (int t1, int t2) { + return t1 == t2; +} + +extern void* Larrmake (int size, int val) { + data *a = (data*) malloc (sizeof(int)*(size+1)); + int i; + + a->tag = ARRAYU_TAG | size; + + for (i=0; icontents)[i] = val; + + return a->contents; +} + +extern void* LArrmake (int size, void *val) { + data *a = (data*) malloc (sizeof(int)*(size+1)); + int i; + + a->tag = ARRAYB_TAG | size; + + for (i=0; icontents)[i] = val; + + return a->contents; +} + +extern int Lread () { + int result; + + printf ("> "); + fflush (stdout); + scanf ("%d", &result); + + return result; +} + +extern int Lwrite (int n) { + printf ("%d\n", n); + fflush (stdout); + + return 0; +} + +extern int Lprintf (char *format, ...) { + va_list args; + int n = Lstrlen ((void*)format); + + va_start (args, format); + + vprintf (format, args); + + va_end (args); + + return 0; +} + +extern void* Lfread (char *fname) { + data *result; + int size; + FILE * file; + int n = Lstrlen ((void*)fname); + + file = fopen (fname, "rb"); + + fseek (file, 0, SEEK_END); + size = ftell (file); + rewind (file); + + result = (data*) malloc (size+sizeof(int)+1); + result->tag = size; + + fread (result->contents, sizeof(char), size, file); + fclose (file); + + result->contents[size] = 0; + + return result->contents; +} + +// New one +*/ /* Lread is an implementation of the "read" construct */ extern int Lread () { @@ -20,3 +321,4 @@ extern int Lwrite (int n) { return 0; } + diff --git a/src/Language.ml b/src/Language.ml index d58acef54..82b9be6e3 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -71,19 +71,19 @@ module State = (* Builtins *) module Builtin = struct - + let eval (st, i, o, _) args = function | "read" -> (match i with z::i' -> (st, i', o, Some (Value.of_int z)) | _ -> failwith "Unexpected end of input") | "write" -> (st, i, o @ [Value.to_int @@ List.hd args], None) - | "$elem" -> let [b; j] = args in + | ".elem" -> let [b; j] = args in (st, i, o, let i = Value.to_int j in Some (match b with | Value.String s -> Value.of_int @@ Char.code s.[i] | Value.Array a -> List.nth a i ) ) - | "$length" -> (st, i, o, Some (Value.of_int (match List.hd args with Value.Array a -> List.length a | Value.String s -> String.length s))) - | "$array" -> (st, i, o, Some (Value.of_array args)) + | ".length" -> (st, i, o, Some (Value.of_int (match List.hd args with Value.Array a -> List.length a | Value.String s -> String.length s))) + | ".array" -> (st, i, o, Some (Value.of_array args)) | "isArray" -> let [a] = args in (st, i, o, Some (Value.of_int @@ match a with Value.Array _ -> 1 | _ -> 0)) | "isString" -> let [a] = args in (st, i, o, Some (Value.of_int @@ match a with Value.String _ -> 1 | _ -> 0)) @@ -158,7 +158,7 @@ module Expr = | Var x -> (st, i, o, Some (State.eval st x)) | Array xs -> let (st, i, o, vs) = eval_list env conf xs in - env#definition env "$array" vs (st, i, o, None) + env#definition env ".array" vs (st, i, o, None) | Sexp (t, xs) -> let (st, i, o, vs) = eval_list env conf xs in (st, i, o, Some (Value.Sexp (t, vs))) @@ -168,10 +168,10 @@ module Expr = (st, i, o, Some (Value.of_int @@ to_func op (Value.to_int x) (Value.to_int y))) | Elem (b, i) -> let (st, i, o, args) = eval_list env conf [b; i] in - env#definition env "$elem" args (st, i, o, None) + env#definition env ".elem" args (st, i, o, None) | Length e -> let (st, i, o, Some v) = eval env conf e in - env#definition env "$length" [v] (st, i, o, None) + env#definition env ".length" [v] (st, i, o, None) | Call (f, args) -> let (st, i, o, args) = eval_list env conf args in env#definition env f args (st, i, o, None) @@ -244,7 +244,6 @@ module Stmt = Takes an environment, a configuration and a statement, and returns another configuration. The environment is the same as for expressions *) - let update st x v is = let rec update a v = function | [] -> v diff --git a/src/SM.ml b/src/SM.ml index 5ff3c519d..699403191 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -74,7 +74,7 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function Takes a program, an input stream, and returns an output stream this program calculates *) let run p i = - (* print_prg p; *) + (*print_prg p; *) let module M = Map.Make (String) in let rec make_map m = function | [] -> m @@ -119,9 +119,9 @@ let compile (defs, p) = | Expr.String s -> [STRING s] | Expr.Binop (op, x, y) -> expr x @ expr y @ [BINOP op] | Expr.Call (f, args) -> call f args false - | Expr.Array xs -> List.flatten (List.map expr xs) @ [CALL ("$array", List.length xs, false)] - | Expr.Elem (a, i) -> expr a @ expr i @ [CALL ("$elem", 2, false)] - | Expr.Length e -> expr e @ [CALL ("$length", 1, false)] + | Expr.Array xs -> List.flatten (List.map expr xs) @ [CALL (".array", List.length xs, false)] + | Expr.Elem (a, i) -> expr a @ expr i @ [CALL (".elem", 2, false)] + | Expr.Length e -> expr e @ [CALL (".length", 1, false)] in let rec compile_stmt l env = function | Stmt.Assign (x, [], e) -> env, false, expr e @ [ST x] diff --git a/src/X86.ml b/src/X86.ml index c6b270ab6..14e22a5c9 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -102,6 +102,35 @@ let compile env code = in let rec compile' env scode = let on_stack = function S _ -> true | _ -> false in + let call env f n p = + let f = + match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f + in + let pushr, popr = + List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n) + in + let env, code = + if n = 0 + then env, pushr @ [Call f] @ (List.rev popr) + else + let rec push_args env acc = function + | 0 -> env, acc + | n -> let x, env = env#pop in + push_args env ((Push x)::acc) (n-1) + in + let env, pushs = push_args env [] n in + let pushs = + match f with + | "Barray" -> List.rev @@ (Push (L n)) :: pushs + | "Bsta" -> + let x::v::is = List.rev pushs in + is @ [x; v] @ [Push (L (n-2))] + | _ -> List.rev pushs + in + env, pushr @ pushs @ [Call f; Binop ("+", L (n*4), esp)] @ (List.rev popr) + in + (if p then env, code else let y, env = env#allocate in env, code @ [Mov (eax, y)]) + in match scode with | [] -> env, [] | instr :: scode' -> @@ -110,6 +139,13 @@ let compile env code = | CONST n -> let s, env' = env#allocate in (env', [Mov (L n, s)]) + + | STRING s -> + let s, env = env#string s in + let l, env = env#allocate in + let env, call = call env ".string" 1 false in + (env, Mov (M ("$" ^ s), l) :: call) + | LD x -> let s, env' = (env#global x)#allocate in env', @@ -117,7 +153,15 @@ let compile env code = | S _ | M _ -> [Mov (env'#loc x, eax); Mov (eax, s)] | _ -> [Mov (env'#loc x, s)] ) - | STA (x, n) -> failwith "" + | STA (x, n) -> + let s, env = (env#global x)#allocate in + let push = + match s with + | S _ | M _ -> [Mov (env#loc x, eax); Mov (eax, s)] + | _ -> [Mov (env#loc x, s)] + in + let env, code = call env ".sta" (n+2) true in + env, push @ code | ST x -> let s, env' = (env#global x)#pop in env', @@ -206,23 +250,7 @@ let compile env code = then let x, env = env#pop in env, [Mov (x, eax); Jmp env#epilogue] else env, [Jmp env#epilogue] - | CALL (f, n, p) -> - let pushr, popr = - List.split @@ List.map (fun r -> (Push r, Pop r)) env#live_registers - in - let env, code = - if n = 0 - then env, pushr @ [Call f] @ (List.rev popr) - else - let rec push_args env acc = function - | 0 -> env, acc - | n -> let x, env = env#pop in - push_args env ((Push x)::acc) (n-1) - in - let env, pushs = push_args env [] n in - env, pushr @ (List.rev pushs) @ [Call f; Binop ("+", L (n*4), esp)] @ (List.rev popr) - in - (if p then env, code else let y, env = env#allocate in env, code @ [Mov (eax, y)]) + | CALL (f, n, p) -> call env f n p in let env'', code'' = compile' env' scode' in env'', code' @ code'' @@ -232,12 +260,17 @@ let compile env code = (* A set of strings *) module S = Set.Make (String) +(* A map indexed by strings *) +module M = Map.Make (String) + (* Environment implementation *) let make_assoc l = List.combine l (List.init (List.length l) (fun x -> x)) class env = object (self) val globals = S.empty (* a set of global variables *) + val stringm = M.empty (* a string map *) + val scount = 0 (* string count *) val stack_slots = 0 (* maximal number of stack positions *) val stack = [] (* symbolic stack *) val args = [] (* function arguments *) @@ -276,9 +309,20 @@ class env = (* registers a global variable in the environment *) method global x = {< globals = S.add ("global_" ^ x) globals >} + (* registers a string constant *) + method string x = + try M.find x stringm, self + with Not_found -> + let y = Printf.sprintf "string_%d" scount in + let m = M.add x y stringm in + y, {< scount = scount + 1; stringm = m>} + (* gets all global variables *) method globals = S.elements globals + (* gets all string definitions *) + method strings = M.bindings stringm + (* gets a number of stack positions allocated *) method allocated = stack_slots @@ -293,8 +337,13 @@ class env = method lsize = Printf.sprintf "L%s_SIZE" fname (* returns a list of live registers *) - method live_registers = - List.filter (function R _ -> true | _ -> false) stack + method live_registers depth = + let rec inner d acc = function + | [] -> acc + | (R _ as r)::tl -> inner (d+1) (if d >= depth then (r::acc) else acc) tl + | _::tl -> inner (d+1) acc tl + in + inner 0 [] stack end @@ -308,7 +357,8 @@ let genasm (ds, stmt) = (new env) ((LABEL "main") :: (BEGIN ("main", [], [])) :: SM.compile (ds, stmt)) in - let data = Meta "\t.data" :: (List.map (fun s -> Meta (s ^ ":\t.int\t0")) env#globals) in + let data = Meta "\t.data" :: (List.map (fun s -> Meta (Printf.sprintf "%s:\t.int\t0" s )) env#globals) @ + (List.map (fun (s, v) -> Meta (Printf.sprintf "%s:\t.string\t\"%s\"" v s)) env#strings) in let asm = Buffer.create 1024 in List.iter (fun i -> Buffer.add_string asm (Printf.sprintf "%s\n" @@ show i))