From 25b4a798329f7fa615bb345307f2b70c30666cb1 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Fri, 27 Apr 2018 01:27:10 +0300 Subject: [PATCH 01/32] Buildtins, arrays, string (no X86 yet), tests --- regression/orig/test035.log | 8 ++++++++ regression/orig/test036.log | 16 ++++++++++++++++ regression/test034.expr | 4 +--- regression/test035.expr | 21 +++++++++++++++++++++ regression/test035.input | 1 + regression/test036.expr | 21 +++++++++++++++++++++ regression/test036.input | 1 + src/Language.ml | 29 +++++++++++++---------------- src/SM.ml | 9 ++++----- src/X86.ml | 16 ++++++++-------- 10 files changed, 94 insertions(+), 32 deletions(-) create mode 100644 regression/orig/test035.log create mode 100644 regression/orig/test036.log create mode 100644 regression/test035.expr create mode 100644 regression/test035.input create mode 100644 regression/test036.expr create mode 100644 regression/test036.input diff --git a/regression/orig/test035.log b/regression/orig/test035.log new file mode 100644 index 000000000..439208742 --- /dev/null +++ b/regression/orig/test035.log @@ -0,0 +1,8 @@ +> 10 +20 +30 +40 +0 +1 +2 +3 diff --git a/regression/orig/test036.log b/regression/orig/test036.log new file mode 100644 index 000000000..35990fed4 --- /dev/null +++ b/regression/orig/test036.log @@ -0,0 +1,16 @@ +> 97 +98 +99 +100 +101 +102 +103 +104 +97 +97 +97 +97 +97 +97 +97 +97 diff --git a/regression/test034.expr b/regression/test034.expr index dd898077e..a31a87f19 100644 --- a/regression/test034.expr +++ b/regression/test034.expr @@ -14,6 +14,4 @@ for i:=0, i (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 - (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)) - | "strcat" -> let [x; y] = args in - (st, i, o, Some (Value.of_string @@ Value.to_string x ^ Value.to_string y)) - | "isArray" -> let [a] = args in - (st, i, o, Some (Value.of_int @@ match a with Array _ -> 1 | _ -> 0)) + | "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 + (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)) + | "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)) end diff --git a/src/SM.ml b/src/SM.ml index 6ebf68b6a..5ff3c519d 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -18,7 +18,6 @@ open Language (* returns from a function *) | RET of bool with show (* The type for the stack machine program *) - type prg = insn list let print_prg p = List.iter (fun i -> Printf.printf "%s\n" (show(insn) i)) p @@ -60,7 +59,7 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function then eval env ((prg', st)::cstack, stack, c) (env#labeled f) else eval env (env#builtin conf f n p) prg' | BEGIN (_, args, locals) -> let vs, stack' = split (List.length args) stack in - let state = List.combine args vs in + let state = List.combine args @@ List.rev vs in eval env (cstack, stack', (List.fold_left (fun s (x, v) -> State.update x v s) (State.enter st (args @ locals)) state, i, o)) prg' | END | RET _ -> (match cstack with | (prg', st')::cstack' -> eval env (cstack', stack, (State.leave st st', i, o)) prg' @@ -91,7 +90,7 @@ let run p i = method builtin (cstack, stack, (st, i, o)) f n p = let f = match f.[0] with 'L' -> String.sub f 1 (String.length f - 1) | _ -> f in let args, stack' = split n stack in - let (st, i, o, r) = Language.Builtin.eval (st, i, o, None) args f in + let (st, i, o, r) = Language.Builtin.eval (st, i, o, None) (List.rev args) f in let stack'' = if p then stack' else let Some r = r in r::stack' in Printf.printf "Builtin: %s\n"; (cstack, stack'', (st, i, o)) @@ -112,7 +111,7 @@ let run p i = let compile (defs, p) = let label s = "L" ^ s in let rec call f args p = - let args_code = List.concat @@ List.map expr (List.rev args) in + let args_code = List.concat @@ List.map expr args in args_code @ [CALL (label f, List.length args, p)] and expr = function | Expr.Var x -> [LD x] @@ -121,7 +120,7 @@ let compile (defs, p) = | 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 i @ expr a @ [CALL ("$elem", 2, 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 diff --git a/src/X86.ml b/src/X86.ml index 7b6dcb08b..c6b270ab6 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -220,7 +220,7 @@ let compile env code = push_args env ((Push x)::acc) (n-1) in let env, pushs = push_args env [] n in - env, pushr @ pushs @ [Call f; Binop ("+", L (n*4), esp)] @ (List.rev popr) + 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)]) in @@ -253,14 +253,14 @@ class env = (* allocates a fresh position on a symbolic stack *) method allocate = let x, n = - let rec allocate' = function - | [] -> ebx , 0 - | (S n)::_ -> S (n+1) , n+2 - | (R n)::_ when n < num_of_regs -> R (n+1) , stack_slots + let rec allocate' = function + | [] -> R 0 , 0 + | (S n)::_ -> S (n+1) , n+2 + | (R n)::_ when n < num_of_regs -> R (n+1) , stack_slots | (M _)::s -> allocate' s - | _ -> S 0 , 1 - in - allocate' stack + | _ -> let n = List.length locals in S n, n+1 + in + allocate' stack in x, {< stack_slots = max n stack_slots; stack = x::stack >} From f2cecd9bf108d10eab656dff98127bb971b697eb Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Mon, 30 Apr 2018 17:18:41 +0300 Subject: [PATCH 02/32] Arrays/strings in x86 --- regression/Makefile | 2 +- runtime/runtime.c | 302 ++++++++++++++++++++++++++++++++++++++++++++ src/Language.ml | 15 +-- src/SM.ml | 8 +- src/X86.ml | 92 +++++++++++--- 5 files changed, 385 insertions(+), 34 deletions(-) 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)) From 838aedbe372cb9522e7668622635de84c79b999e Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Mon, 30 Apr 2018 18:12:12 +0300 Subject: [PATCH 03/32] Added sorting test --- regression/orig/test037.log | 6 ++++++ regression/test037.expr | 26 ++++++++++++++++++++++++++ regression/test037.input | 1 + 3 files changed, 33 insertions(+) create mode 100644 regression/orig/test037.log create mode 100644 regression/test037.expr create mode 100644 regression/test037.input diff --git a/regression/orig/test037.log b/regression/orig/test037.log new file mode 100644 index 000000000..58b322cfb --- /dev/null +++ b/regression/orig/test037.log @@ -0,0 +1,6 @@ +> 5 +6 +7 +8 +9 +10 diff --git a/regression/test037.expr b/regression/test037.expr new file mode 100644 index 000000000..807233374 --- /dev/null +++ b/regression/test037.expr @@ -0,0 +1,26 @@ +fun sort (x) local i, j, y, n { + n := x.length; + + if n == 0 then return x fi; + + for i := 0, i Date: Tue, 1 May 2018 02:57:09 +0300 Subject: [PATCH 04/32] Pattern-matching parsing --- src/Driver.ml | 9 ++++++++- src/Language.ml | 40 +++++++++++++++++++++++++++++++++++++--- src/SM.ml | 6 +++++- 3 files changed, 50 insertions(+), 5 deletions(-) diff --git a/src/Driver.ml b/src/Driver.ml index 04818b39e..71d0e2df7 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -8,7 +8,14 @@ let parse infile = inherit Util.Lexers.decimal s inherit Util.Lexers.string s inherit Util.Lexers.char s - inherit Util.Lexers.ident ["skip"; "if"; "then"; "else"; "elif"; "fi"; "while"; "do"; "od"; "repeat"; "until"; "for"; "fun"; "local"; "return"; "length"] s + inherit Util.Lexers.ident ["skip"; + "if"; "then"; "else"; "elif"; "fi"; + "while"; "do"; "od"; + "repeat"; "until"; + "for"; + "fun"; "local"; "return"; + "length"; + "case"; "of"; "esac"; "when"] s inherit Util.Lexers.skip [ Matcher.Skip.whitespaces " \t\n"; Matcher.Skip.lineComment "--"; diff --git a/src/Language.ml b/src/Language.ml index 82b9be6e3..c53a3dfa5 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -25,6 +25,7 @@ module Value = | Array a -> a | _ -> failwith "array value expected" + let sexp s vs = Sexp (s, vs) let of_int n = Int n let of_string s = String s let of_array a = Array a @@ -226,16 +227,48 @@ module Expr = module Stmt = struct + (* Patterns in statements *) + module Pattern = + struct + + (* The type for patterns *) + @type t = + (* wildcard "-" *) | Wildcard + (* S-expression *) | Sexp of string * t list + (* identifier *) | Ident of string + (* constant *) | Const of int + (* string *) | String of string + (* array *) | Array of t list + (* arbitrary array *) | IsArray + (* arbitrary string *) | IsString + with show + + (* Pattern parser *) + ostap ( + parse: + %"_" {Wildcard} + | "`" t:IDENT ps:(-"(" !(Util.list)[parse] -")")? {Sexp (t, match ps with None -> [] | Some ps -> ps)} + | x:IDENT {Ident x} + | n:DECIMAL {Const n} + | s:STRING {String s} + | a:(-"[" !(Util.list)[parse] -"]") {Array a} + | "#" "[" "]" {IsArray} + | "#" {IsString} + ) + + end + (* The type for statements *) - type t = + @type t = (* assignment *) | Assign of string * Expr.t list * Expr.t (* composition *) | Seq of t * t (* empty statement *) | Skip (* conditional *) | If of Expr.t * t * t (* loop with a pre-condition *) | While of Expr.t * t (* loop with a post-condition *) | Repeat of t * Expr.t + (* pattern-matching *) | Case of Expr.t * (Pattern.t * Expr.t option * t) list (* return statement *) | Return of Expr.t option - (* call a procedure *) | Call of string * Expr.t list + (* call a procedure *) | Call of string * Expr.t list with show (* Statement evaluator @@ -299,7 +332,8 @@ module Stmt = Seq (i, While (c, Seq (b, s))) } | %"repeat" s:parse %"until" e:!(Expr.parse) {Repeat (s, e)} - | %"return" e:!(Expr.parse)? {Return e} + | %"return" e:!(Expr.parse)? {Return e} + | %"case" e:!(Expr.parse) %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) (-"when" !(Expr.parse))? parse)] %"esac" {Case (e, bs)} | x:IDENT s:(is:(-"[" !(Expr.parse) -"]")* ":=" e :!(Expr.parse) {Assign (x, is, e)} | "(" args:!(Util.list0)[Expr.parse] ")" {Call (x, args)} diff --git a/src/SM.ml b/src/SM.ml index 699403191..ed5dd3ae7 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -5,7 +5,8 @@ open Language @type insn = (* binary operator *) | BINOP of string (* put a constant on the stack *) | CONST of int -(* put a string on the stack *) | STRING of string +(* put a string on the stack *) | STRING of string +(* create an S-expression *) | SEXP of string * int (* load a variable to the stack *) | LD of string (* store a variable from the stack *) | ST of string (* store in an array *) | STA of string * int @@ -48,6 +49,8 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function | BINOP op -> let y::x::stack' = stack in eval env (cstack, (Value.of_int @@ Expr.to_func op (Value.to_int x) (Value.to_int y)) :: stack', c) prg' | CONST i -> eval env (cstack, (Value.of_int i)::stack, c) prg' | STRING s -> eval env (cstack, (Value.of_string s)::stack, c) prg' + | SEXP (s, n) -> let vs, stack' = split n stack in + eval env (cstack, (Value.sexp s @@ List.rev vs)::stack', c) prg' | LD x -> eval env (cstack, State.eval st x :: stack, c) prg' | ST x -> let z::stack' = stack in eval env (cstack, stack', (State.update x z st, i, o)) prg' | STA (x, n) -> let v::is, stack' = split (n+1) stack in @@ -120,6 +123,7 @@ let compile (defs, p) = | 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.Sexp (t, 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 From 0306d85962fc2b19d8a6c1bf362685a9fe482953 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Tue, 1 May 2018 03:37:29 +0300 Subject: [PATCH 05/32] Generalized state --- src/Language.ml | 33 +++++++++++++++++++++++++-------- 1 file changed, 25 insertions(+), 8 deletions(-) diff --git a/src/Language.ml b/src/Language.ml index c53a3dfa5..abc4eedbe 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -44,28 +44,45 @@ module State = struct (* State: global state, local state, scope variables *) - type t = {g : string -> Value.t; l : string -> Value.t; scope : string list} + type t = + | G of (string -> Value.t) + | L of string list * (string -> Value.t) * t + (* Undefined state *) + let undefined x = failwith (Printf.sprintf "Undefined variable: %s" x) + (* Empty state *) - let empty = - let e x = failwith (Printf.sprintf "Undefined variable: %s" x) in - {g = e; l = e; scope = []} + let empty = G undefined (* Update: non-destructively "modifies" the state s by binding the variable x to value v and returns the new state w.r.t. a scope *) let update x v s = let u x v s = fun y -> if x = y then v else s y in - if List.mem x s.scope then {s with l = u x v s.l} else {s with g = u x v s.g} + let rec inner = function + | G s -> G (u x v s) + | L (scope, s, enclosing) -> + if List.mem x scope then L (scope, u x v s, enclosing) else L (scope, s, inner enclosing) + in + inner s (* Evals a variable in a state w.r.t. a scope *) - let eval s x = (if List.mem x s.scope then s.l else s.g) x + let rec eval s x = + match s with + | G s -> s x + | L (scope, s, enclosing) -> if List.mem x scope then s x else eval enclosing x (* Creates a new scope, based on a given state *) - let enter st xs = {empty with g = st.g; scope = xs} + let enter st xs = + match st with + | G _ -> L (xs, undefined, st) + | L (_, _, e) -> L (xs, undefined, e) (* Drops a scope *) - let leave st st' = {st' with g = st.g} + let leave (L (_, _, e)) st' = + match st' with + | L (scope, s, _) -> L (scope, s, e) + | G _ -> e end From 958bf482a8485baaae8caee28d5c459afddbd09f Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Wed, 2 May 2018 22:36:27 +0300 Subject: [PATCH 06/32] Reach pattern-matching. --- regression/Makefile | 4 +- regression/orig/test038.log | 12 ++++++ regression/test038.expr | 24 +++++++++++ regression/test038.input | 1 + src/Language.ml | 85 +++++++++++++++++++++++++++++++------ src/SM.ml | 22 +++++++++- 6 files changed, 132 insertions(+), 16 deletions(-) create mode 100644 regression/orig/test038.log create mode 100644 regression/test038.expr create mode 100644 regression/test038.input diff --git a/regression/Makefile b/regression/Makefile index 31e136a99..0c712d8cf 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -7,9 +7,9 @@ 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 + #cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log clean: rm -f test*.log *.s *~ $(TESTS) diff --git a/regression/orig/test038.log b/regression/orig/test038.log new file mode 100644 index 000000000..9876f9a7e --- /dev/null +++ b/regression/orig/test038.log @@ -0,0 +1,12 @@ +> 1 +2 +3 +4 +1 +2 +3 +4 +3 +4 +1 +2 diff --git a/regression/test038.expr b/regression/test038.expr new file mode 100644 index 000000000..623017ecd --- /dev/null +++ b/regression/test038.expr @@ -0,0 +1,24 @@ +fun append (x, y) { + case x of + `nil -> return y + | `cons (h, t) -> return `cons (h, append (t, y)) + esac +} + +fun printList (x) { + case x of + `nil -> skip + | `cons (h, t) -> write (h); printList (t) + esac +} + +n := read (); + +x := `cons (1, `cons (2, `nil)); +y := `cons (3, `cons (4, `nil)); + +printList (x); +printList (y); +printList (append (x, y)); +printList (append (y, x)) + diff --git a/regression/test038.input b/regression/test038.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/test038.input @@ -0,0 +1 @@ +0 diff --git a/src/Language.ml b/src/Language.ml index abc4eedbe..910ea3bf7 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -73,17 +73,30 @@ module State = | L (scope, s, enclosing) -> if List.mem x scope then s x else eval enclosing x (* Creates a new scope, based on a given state *) - let enter st xs = + let rec enter st xs = match st with | G _ -> L (xs, undefined, st) - | L (_, _, e) -> L (xs, undefined, e) + | L (_, _, e) -> enter e xs (* Drops a scope *) - let leave (L (_, _, e)) st' = - match st' with - | L (scope, s, _) -> L (scope, s, e) - | G _ -> e + let leave st st' = + let rec get = function + | G _ as st -> st + | L (_, _, e) -> get e + in + let g = get st in + let rec recurse = function + | L (scope, s, e) -> L (scope, s, recurse e) + | G _ -> g + in + recurse st' + (* Push a new local scope *) + let push st s xs = L (xs, s, st) + + (* Drop a local scope *) + let drop (L (_, _, e)) = e + end (* Builtins *) @@ -258,7 +271,7 @@ module Stmt = (* array *) | Array of t list (* arbitrary array *) | IsArray (* arbitrary string *) | IsString - with show + with show, foldl (* Pattern parser *) ostap ( @@ -273,6 +286,10 @@ module Stmt = | "#" {IsString} ) + let vars p = + let module S = Set.Make (String) in + S.elements @@ transform(t) (object inherit [S.t] @t[foldl] method c_Ident s _ name = S.add name s end) S.empty p + end (* The type for statements *) @@ -285,8 +302,9 @@ module Stmt = (* loop with a post-condition *) | Repeat of t * Expr.t (* pattern-matching *) | Case of Expr.t * (Pattern.t * Expr.t option * t) list (* return statement *) | Return of Expr.t option - (* call a procedure *) | Call of string * Expr.t list with show - + (* call a procedure *) | Call of string * Expr.t list + (* leave a scope *) | Leave with show + (* Statement evaluator val eval : env -> config -> t -> config @@ -305,11 +323,12 @@ module Stmt = ) in State.update x (match is with [] -> v | _ -> update (State.eval st x) v is) st - + let rec eval env ((st, i, o, r) as conf) k stmt = let seq x = function Skip -> x | y -> Seq (x, y) in match stmt with - | Assign (x, is, e) -> + | Leave -> eval env (State.drop st, i, o, r) Skip k + | Assign (x, is, e) -> let (st, i, o, is) = Expr.eval_list env conf is in let (st, i, o, Some v) = Expr.eval env (st, i, o, None) e in eval env (update st x v is, i, o, None) Skip k @@ -324,7 +343,47 @@ module Stmt = | Repeat (s, e) -> eval env conf (seq (While (Expr.Binop ("==", e, Expr.Const 0), s)) k) s | Return e -> (match e with None -> (st, i, o, None) | Some e -> Expr.eval env conf e) | Call (f, args) -> eval env (Expr.eval env conf (Expr.Call (f, args))) k Skip - + | Case (e, bs) -> + let (_, _, _, Some v) as conf' = Expr.eval env conf e in + let rec branch ((st, i, o, _) as conf) = function + | [] -> failwith (Printf.sprintf "Pattern matching failed: no branch is selected while matching %s\n" (show(Value.t) v)) + | (patt, con, body)::tl -> + let rec match_patt patt v st = + let update x v = function + | None -> None + | Some s -> Some (fun y -> if y = x then v else s y) + in + match patt, v with + | Pattern.Ident x , v -> update x v st + | Pattern.Wildcard , _ -> st + | Pattern.Const n , Value.Int n' when n = n' -> st + | Pattern.String s , Value.String s' when s = s' -> st + | Pattern.Array p , Value.Array p' -> match_list p p' st + | Pattern.IsArray , Value.Array _ -> st + | Pattern.IsString , Value.String _ -> st + | Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' -> match_list ps vs st + | _ -> None + and match_list ps vs s = + match ps, vs with + | [], [] -> s + | p::ps, v::vs -> match_list ps vs (match_patt p v s) + | _ -> None + in + match match_patt patt v (Some State.undefined) with + | None -> branch conf tl + | Some st' -> + let st'' = State.push st st' (Pattern.vars patt) in + let (st''', i', o', Some c) = + match con with + | None -> (st'', i, o, Some (Value.of_int 1)) + | Some c -> Expr.eval env (st'', i, o, None) c + in + if Value.to_int c <> 0 + then eval env (st''', i', o', None) k (Seq (body, Leave)) + else branch (st''', i', o', None) tl + in + branch conf' bs + (* Statement parser *) ostap ( parse: @@ -350,7 +409,7 @@ module Stmt = } | %"repeat" s:parse %"until" e:!(Expr.parse) {Repeat (s, e)} | %"return" e:!(Expr.parse)? {Return e} - | %"case" e:!(Expr.parse) %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) (-"when" !(Expr.parse))? parse)] %"esac" {Case (e, bs)} + | %"case" e:!(Expr.parse) %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) (-"when" !(Expr.parse))? -"->" parse)] %"esac" {Case (e, bs)} | x:IDENT s:(is:(-"[" !(Expr.parse) -"]")* ":=" e :!(Expr.parse) {Assign (x, is, e)} | "(" args:!(Util.list0)[Expr.parse] ")" {Call (x, args)} diff --git a/src/SM.ml b/src/SM.ml index ed5dd3ae7..bb28a1992 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -16,7 +16,8 @@ open Language (* begins procedure definition *) | BEGIN of string * string list * string list (* end procedure definition *) | END (* calls a function/procedure *) | CALL of string * int * bool -(* returns from a function *) | RET of bool with show +(* returns from a function *) | RET of bool + | DROP | DUP | OVER with show (* The type for the stack machine program *) type prg = insn list @@ -116,6 +117,25 @@ let compile (defs, p) = let rec call f args p = let args_code = List.concat @@ List.map expr args in args_code @ [CALL (label f, List.length args, p)] + and pattern = function + | Stmt.Pattern.Wildcard -> [DROP; CONST 1] + | Stmt.Pattern.Const n -> [CONST n; BINOP "=="] + | Stmt.Pattern.String s -> [STRING s; CALL ("strcmp", 2, false)] + | Stmt.Pattern.Ident n -> [DROP; CONST 1] + | Stmt.Pattern.Array ps -> [DUP; + CALL ("isArray", 1, false); + OVER; + CALL (".length", 1, false); + CONST (List.length ps); + BINOP "=="; + BINOP "&&"; + ] + | Stmt.Pattern.IsArray -> [CALL ("isArray", 1, false)] + | Stmt.Pattern.IsString -> [CALL ("isString", 1, false)] + | Stmt.Pattern.Sexp (t, ps) -> [] + and patterns = function + | [] -> [] + | (e, p)::ps -> expr e @ pattern p @ [BINOP "&&"] @ patterns ps and expr = function | Expr.Var x -> [LD x] | Expr.Const n -> [CONST n] From 800d976b8e2b3124d93ae7af149b9dcefb770a18 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Fri, 4 May 2018 02:59:23 +0300 Subject: [PATCH 07/32] S-expressions and pattern matching --- regression/Makefile | 2 +- regression/orig/test039.log | 6 +++ regression/test038.expr | 1 - regression/test039.expr | 31 +++++++++++++ regression/test039.input | 1 + src/Language.ml | 90 ++++++++++++++----------------------- src/Makefile | 15 +++---- src/SM.ml | 90 ++++++++++++++++++++++++++++--------- 8 files changed, 148 insertions(+), 88 deletions(-) create mode 100644 regression/orig/test039.log create mode 100644 regression/test039.expr create mode 100644 regression/test039.input diff --git a/regression/Makefile b/regression/Makefile index 0c712d8cf..16fdefec9 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -9,7 +9,7 @@ check: $(TESTS) $(TESTS): %: %.expr #@$(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 + cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log clean: rm -f test*.log *.s *~ $(TESTS) diff --git a/regression/orig/test039.log b/regression/orig/test039.log new file mode 100644 index 000000000..c41010416 --- /dev/null +++ b/regression/orig/test039.log @@ -0,0 +1,6 @@ +> 1 +1 +1 +1 +0 +0 diff --git a/regression/test038.expr b/regression/test038.expr index 623017ecd..e13e88c87 100644 --- a/regression/test038.expr +++ b/regression/test038.expr @@ -21,4 +21,3 @@ printList (x); printList (y); printList (append (x, y)); printList (append (y, x)) - diff --git a/regression/test039.expr b/regression/test039.expr new file mode 100644 index 000000000..1eaff0a70 --- /dev/null +++ b/regression/test039.expr @@ -0,0 +1,31 @@ +fun insert (t, x) { + case t of + `leaf -> return `node (x, `leaf, `leaf) + | `node (y, l, r) -> if x > y + then return `node (y, insert (l, x), r) + else return `node (y, l, insert (r, x)) + fi + esac +} + +fun find (t, x) { + case t of + `leaf -> return 0 + | `node (y, l, r) -> if x == y then return 1 + elif x > y then return find (l, x) + else return find (r, x) + fi + esac +} + +n := read (); + +t := insert (insert (insert (insert (`leaf, 5), 4), 6), 3); + +write (find (t, 5)); +write (find (t, 4)); +write (find (t, 6)); +write (find (t, 3)); +write (find (t, 2)); +write (find (t, 1)) + diff --git a/regression/test039.input b/regression/test039.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/test039.input @@ -0,0 +1 @@ +0 diff --git a/src/Language.ml b/src/Language.ml index 910ea3bf7..845988477 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -50,7 +50,10 @@ module State = (* Undefined state *) let undefined x = failwith (Printf.sprintf "Undefined variable: %s" x) - + + (* Bind a variable to a value in a state *) + let bind x v s = fun y -> if x = y then v else s y + (* Empty state *) let empty = G undefined @@ -58,11 +61,10 @@ module State = to value v and returns the new state w.r.t. a scope *) let update x v s = - let u x v s = fun y -> if x = y then v else s y in let rec inner = function - | G s -> G (u x v s) + | G s -> G (bind x v s) | L (scope, s, enclosing) -> - if List.mem x scope then L (scope, u x v s, enclosing) else L (scope, s, inner enclosing) + if List.mem x scope then L (scope, bind x v s, enclosing) else L (scope, s, inner enclosing) in inner s @@ -109,8 +111,9 @@ module Builtin = | ".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 + | Value.String s -> Value.of_int @@ Char.code s.[i] + | Value.Array a -> List.nth a i + | Value.Sexp (_, 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))) @@ -266,11 +269,6 @@ module Stmt = (* wildcard "-" *) | Wildcard (* S-expression *) | Sexp of string * t list (* identifier *) | Ident of string - (* constant *) | Const of int - (* string *) | String of string - (* array *) | Array of t list - (* arbitrary array *) | IsArray - (* arbitrary string *) | IsString with show, foldl (* Pattern parser *) @@ -279,16 +277,10 @@ module Stmt = %"_" {Wildcard} | "`" t:IDENT ps:(-"(" !(Util.list)[parse] -")")? {Sexp (t, match ps with None -> [] | Some ps -> ps)} | x:IDENT {Ident x} - | n:DECIMAL {Const n} - | s:STRING {String s} - | a:(-"[" !(Util.list)[parse] -"]") {Array a} - | "#" "[" "]" {IsArray} - | "#" {IsString} ) let vars p = - let module S = Set.Make (String) in - S.elements @@ transform(t) (object inherit [S.t] @t[foldl] method c_Ident s _ name = S.add name s end) S.empty p + transform(t) (object inherit [string list] @t[foldl] method c_Ident s _ name = name::s end) [] p end @@ -300,7 +292,7 @@ module Stmt = (* conditional *) | If of Expr.t * t * t (* loop with a pre-condition *) | While of Expr.t * t (* loop with a post-condition *) | Repeat of t * Expr.t - (* pattern-matching *) | Case of Expr.t * (Pattern.t * Expr.t option * t) list + (* pattern-matching *) | Case of Expr.t * (Pattern.t * t) list (* return statement *) | Return of Expr.t option (* call a procedure *) | Call of string * Expr.t list (* leave a scope *) | Leave with show @@ -344,43 +336,29 @@ module Stmt = | Return e -> (match e with None -> (st, i, o, None) | Some e -> Expr.eval env conf e) | Call (f, args) -> eval env (Expr.eval env conf (Expr.Call (f, args))) k Skip | Case (e, bs) -> - let (_, _, _, Some v) as conf' = Expr.eval env conf e in - let rec branch ((st, i, o, _) as conf) = function - | [] -> failwith (Printf.sprintf "Pattern matching failed: no branch is selected while matching %s\n" (show(Value.t) v)) - | (patt, con, body)::tl -> - let rec match_patt patt v st = - let update x v = function - | None -> None - | Some s -> Some (fun y -> if y = x then v else s y) - in - match patt, v with - | Pattern.Ident x , v -> update x v st - | Pattern.Wildcard , _ -> st - | Pattern.Const n , Value.Int n' when n = n' -> st - | Pattern.String s , Value.String s' when s = s' -> st - | Pattern.Array p , Value.Array p' -> match_list p p' st - | Pattern.IsArray , Value.Array _ -> st - | Pattern.IsString , Value.String _ -> st - | Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' -> match_list ps vs st - | _ -> None - and match_list ps vs s = - match ps, vs with - | [], [] -> s - | p::ps, v::vs -> match_list ps vs (match_patt p v s) - | _ -> None - in - match match_patt patt v (Some State.undefined) with - | None -> branch conf tl - | Some st' -> - let st'' = State.push st st' (Pattern.vars patt) in - let (st''', i', o', Some c) = - match con with - | None -> (st'', i, o, Some (Value.of_int 1)) - | Some c -> Expr.eval env (st'', i, o, None) c + let (_, _, _, Some v) as conf' = Expr.eval env conf e in + let rec branch ((st, i, o, _) as conf) = function + | [] -> failwith (Printf.sprintf "Pattern matching failed: no branch is selected while matching %s\n" (show(Value.t) v)) + | (patt, body)::tl -> + let rec match_patt patt v st = + let update x v = function + | None -> None + | Some s -> Some (State.bind x v s) in - if Value.to_int c <> 0 - then eval env (st''', i', o', None) k (Seq (body, Leave)) - else branch (st''', i', o', None) tl + match patt, v with + | Pattern.Ident x , v -> update x v st + | Pattern.Wildcard , _ -> st + | Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' -> match_list ps vs st + | _ -> None + and match_list ps vs s = + match ps, vs with + | [], [] -> s + | p::ps, v::vs -> match_list ps vs (match_patt p v s) + | _ -> None + in + match match_patt patt v (Some State.undefined) with + | None -> branch conf tl + | Some st' -> eval env (State.push st st' (Pattern.vars patt), i, o, None) k (Seq (body, Leave)) in branch conf' bs @@ -409,7 +387,7 @@ module Stmt = } | %"repeat" s:parse %"until" e:!(Expr.parse) {Repeat (s, e)} | %"return" e:!(Expr.parse)? {Return e} - | %"case" e:!(Expr.parse) %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) (-"when" !(Expr.parse))? -"->" parse)] %"esac" {Case (e, bs)} + | %"case" e:!(Expr.parse) %"of" bs:!(Util.listBy)[ostap ("|")][ostap (!(Pattern.parse) -"->" parse)] %"esac" {Case (e, bs)} | x:IDENT s:(is:(-"[" !(Expr.parse) -"]")* ":=" e :!(Expr.parse) {Assign (x, is, e)} | "(" args:!(Util.list0)[Expr.parse] ")" {Call (x, args)} diff --git a/src/Makefile b/src/Makefile index 8eb66bcfd..489cb2c69 100644 --- a/src/Makefile +++ b/src/Makefile @@ -1,12 +1,11 @@ TOPFILE = rc -OCAMLC = ocamlc -OCAMLOPT = ocamlopt -OCAMLDEP = ocamldep +OCAMLC = ocamlfind c +OCAMLOPT = ocamlfind opt +OCAMLDEP = ocamlfind dep SOURCES = Language.ml SM.ml X86.ml Driver.ml -LIBS = GT.cma unix.cma re.cma emacs/re_emacs.cma str/re_str.cma -CAMLP5 = -pp "camlp5o -I `ocamlfind -query GT.syntax` -I `ocamlfind -query ostap.syntax` pa_ostap.cmo pa_gt.cmo -L `ocamlfind -query GT.syntax`" +CAMLP5 = -syntax camlp5o -package ostap.syntax,GT.syntax.all PXFLAGS = $(CAMLP5) -BFLAGS = -rectypes -I `ocamlfind -query GT` -I `ocamlfind -query re` -I `ocamlfind -query ostap` +BFLAGS = -rectypes OFLAGS = $(BFLAGS) all: .depend $(TOPFILE).opt @@ -15,10 +14,10 @@ all: .depend $(TOPFILE).opt $(OCAMLDEP) $(PXFLAGS) *.ml > .depend $(TOPFILE).opt: $(SOURCES:.ml=.cmx) - $(OCAMLOPT) -o $(TOPFILE).opt $(OFLAGS) $(LIBS:.cma=.cmxa) ostap.cmx $(SOURCES:.ml=.cmx) + $(OCAMLOPT) -o $(TOPFILE).opt $(OFLAGS) $(LIBS:.cma=.cmxa) -linkpkg -package ostap $(SOURCES:.ml=.cmx) $(TOPFILE).byte: $(SOURCES:.ml=.cmo) - $(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) ostap.cma $(SOURCES:.ml=.cmo) + $(OCAMLC) -o $(TOPFILE).byte $(BFLAGS) $(LIBS) -linkpkg -package ostap $(SOURCES:.ml=.cmo) clean: rm -Rf *.cmi *.cmo *.cmx *.annot *.o *.opt *.byte *~ .depend diff --git a/src/SM.ml b/src/SM.ml index bb28a1992..39a421007 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -17,7 +17,13 @@ open Language (* end procedure definition *) | END (* calls a function/procedure *) | CALL of string * int * bool (* returns from a function *) | RET of bool - | DROP | DUP | OVER with show +(* drops the top element off *) | DROP +(* duplicates the top element *) | DUP +(* swaps two top elements *) | SWAP +(* checks the tag of S-expression *) | TAG of string +(* enters a scope *) | ENTER of string list +(* leaves a scope *) | LEAVE +with show (* The type for the stack machine program *) type prg = insn list @@ -69,6 +75,17 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function | (prg', st')::cstack' -> eval env (cstack', stack, (State.leave st st', i, o)) prg' | [] -> conf ) + | DROP -> eval env (cstack, List.tl stack, c) prg' + | DUP -> eval env (cstack, List.hd stack :: stack, c) prg' + | SWAP -> let x::y::stack' = stack in + eval env (cstack, y::x::stack', c) prg' + | TAG t -> let x::stack' = stack in + eval env (cstack, (Value.of_int @@ match x with Value.Sexp (t', _) when t' = t -> 1 | _ -> 0) :: stack', c) prg' + + | ENTER xs -> let vs, stack' = split (List.length xs) stack in + eval env (cstack, stack', (State.push st (List.fold_left (fun s (x, v) -> State.bind x v s) State.undefined (List.combine xs vs)) xs, i, o)) prg' + + | LEAVE -> eval env (cstack, stack, (State.drop st, i, o)) prg' ) (* Top-level evaluation @@ -78,7 +95,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 @@ -117,25 +134,29 @@ let compile (defs, p) = let rec call f args p = let args_code = List.concat @@ List.map expr args in args_code @ [CALL (label f, List.length args, p)] - and pattern = function - | Stmt.Pattern.Wildcard -> [DROP; CONST 1] - | Stmt.Pattern.Const n -> [CONST n; BINOP "=="] - | Stmt.Pattern.String s -> [STRING s; CALL ("strcmp", 2, false)] - | Stmt.Pattern.Ident n -> [DROP; CONST 1] - | Stmt.Pattern.Array ps -> [DUP; - CALL ("isArray", 1, false); - OVER; - CALL (".length", 1, false); - CONST (List.length ps); - BINOP "=="; - BINOP "&&"; - ] - | Stmt.Pattern.IsArray -> [CALL ("isArray", 1, false)] - | Stmt.Pattern.IsString -> [CALL ("isString", 1, false)] - | Stmt.Pattern.Sexp (t, ps) -> [] - and patterns = function - | [] -> [] - | (e, p)::ps -> expr e @ pattern p @ [BINOP "&&"] @ patterns ps + and pattern lfalse = function + | Stmt.Pattern.Wildcard -> false, [DROP] + | Stmt.Pattern.Ident n -> false, [DROP] + | Stmt.Pattern.Sexp (t, ps) -> + true, + [DUP; TAG t; CJMP ("z", lfalse)] @ + (List.concat @@ + List.mapi + (fun i p -> + [DUP; CONST i; CALL (".elem", 2, false)] @ + snd @@ pattern lfalse p + ) + ps + ) + and bindings p = + let rec inner = function + | Stmt.Pattern.Ident n -> [SWAP] + | Stmt.Pattern.Wildcard -> [DROP] + | Stmt.Pattern.Sexp (_, ps) -> + (List.flatten @@ List.mapi (fun i p -> [DUP; CONST i; CALL (".elem", 2, false)] @ inner p) ps) @ + [DROP] + in + inner p @ [ENTER (Stmt.Pattern.vars p)] and expr = function | Expr.Var x -> [LD x] | Expr.Const n -> [CONST n] @@ -143,7 +164,7 @@ let compile (defs, p) = | 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.Sexp (t, xs) -> List.flatten (List.map expr xs) @ [CALL (".array", List.length xs, false)] + | Expr.Sexp (t, xs) -> List.flatten (List.map expr xs) @ [SEXP (t, List.length xs)] | Expr.Elem (a, i) -> expr a @ expr i @ [CALL (".elem", 2, false)] | Expr.Length e -> expr e @ [CALL (".length", 1, false)] in @@ -175,6 +196,31 @@ let compile (defs, p) = | Stmt.Call (f, args) -> env, false, call f args true | Stmt.Return e -> env, false, (match e with Some e -> expr e | None -> []) @ [RET (e <> None)] + + | Stmt.Leave -> env, false, [LEAVE] + + | Stmt.Case (e, [p, s]) -> + let pflag, pcode = pattern l p in + let env, sflag, scode = compile_stmt l env (Stmt.Seq (s, Stmt.Leave)) in + env, pflag || sflag, expr e @ pcode @ bindings p @ scode + + | Stmt.Case (e, brs) -> + let n = List.length brs - 1 in + let env, _, _, code = + List.fold_left + (fun (env, lab, i, code) (p, s) -> + let (lfalse, env), jmp = + if i = n + then (l, env), [] + else env#get_label, [JMP l] + in + let _, pcode = pattern lfalse p in + let env, _, scode = compile_stmt l env (Stmt.Seq (s, Stmt.Leave)) in + (env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l]) @ pcode @ bindings p @ scode @ jmp) :: code) + ) + (env, None, 0, []) brs + in + env, true, expr e @ List.flatten @@ List.rev code in let compile_def env (name, (args, locals, stmt)) = let lend, env = env#get_label in From 0dd8ae8a7aad0231b291a2365ad7a24bf85fbc40 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Sun, 6 May 2018 21:38:36 +0300 Subject: [PATCH 08/32] Sync --- src/SM.ml | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/SM.ml b/src/SM.ml index 39a421007..f78582dc5 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -95,7 +95,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 @@ -153,7 +153,14 @@ let compile (defs, p) = | Stmt.Pattern.Ident n -> [SWAP] | Stmt.Pattern.Wildcard -> [DROP] | Stmt.Pattern.Sexp (_, ps) -> - (List.flatten @@ List.mapi (fun i p -> [DUP; CONST i; CALL (".elem", 2, false)] @ inner p) ps) @ + (List.flatten @@ + List.mapi + (fun i p -> + [DUP; CONST i; CALL (".elem", 2, false)] @ + inner p + ) + ps + ) @ [DROP] in inner p @ [ENTER (Stmt.Pattern.vars p)] From 2ba7a95f86c46549838f8d3f39a6ad4fb1935062 Mon Sep 17 00:00:00 2001 From: danyaberezun Date: Mon, 12 Nov 2018 16:15:48 +0300 Subject: [PATCH 09/32] merge --- src/SM.ml | 84 ++++++++++++++++++++++++++++++------------------------ src/X86.ml | 27 ++++++++++++------ 2 files changed, 66 insertions(+), 45 deletions(-) diff --git a/src/SM.ml b/src/SM.ml index f78582dc5..1100a74ba 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -95,7 +95,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 @@ -134,36 +134,44 @@ let compile (defs, p) = let rec call f args p = let args_code = List.concat @@ List.map expr args in args_code @ [CALL (label f, List.length args, p)] - and pattern lfalse = function - | Stmt.Pattern.Wildcard -> false, [DROP] - | Stmt.Pattern.Ident n -> false, [DROP] - | Stmt.Pattern.Sexp (t, ps) -> - true, - [DUP; TAG t; CJMP ("z", lfalse)] @ - (List.concat @@ - List.mapi - (fun i p -> - [DUP; CONST i; CALL (".elem", 2, false)] @ - snd @@ pattern lfalse p - ) - ps - ) + and pattern env lfalse = function + | Stmt.Pattern.Wildcard -> env, false, [DROP] + | Stmt.Pattern.Ident n -> env, false, [DROP] + | Stmt.Pattern.Sexp (t, ps) -> + let ltag , env = env#get_label in + let ldrop, env = env#get_label in + let tag = [DUP; TAG t; CJMP ("nz", ltag); LABEL ldrop; DROP; JMP lfalse; LABEL ltag] in + let _, env, code = + List.fold_left + (fun (i, env, code) p -> + let env, _, pcode = pattern env ldrop p in + i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code + ) + (0, env, []) + ps + in + env, true, tag @ List.flatten (List.rev code) @ [DROP] and bindings p = - let rec inner = function - | Stmt.Pattern.Ident n -> [SWAP] - | Stmt.Pattern.Wildcard -> [DROP] - | Stmt.Pattern.Sexp (_, ps) -> - (List.flatten @@ - List.mapi - (fun i p -> - [DUP; CONST i; CALL (".elem", 2, false)] @ - inner p - ) - ps - ) @ - [DROP] + let bindings = + transform(Stmt.Pattern.t) + (object inherit [int list, (string * int list) list] @Stmt.Pattern.t + method c_Wildcard path _ = [] + method c_Ident path _ s = [s, path] + method c_Sexp path x _ ps = List.concat @@ List.mapi (fun i p -> x.GT.f (path @ [i]) p) ps + end) + [] + p in - inner p @ [ENTER (Stmt.Pattern.vars p)] + List.concat + (List.map + (fun (name, path) -> + [DUP] @ + List.concat (List.map (fun i -> [CONST i; CALL (".elem", 2, false)]) path) @ + [SWAP] + ) + (List.rev bindings) + ) @ + [DROP; ENTER (List.map fst bindings)] and expr = function | Expr.Var x -> [LD x] | Expr.Const n -> [CONST n] @@ -207,12 +215,14 @@ let compile (defs, p) = | Stmt.Leave -> env, false, [LEAVE] | Stmt.Case (e, [p, s]) -> - let pflag, pcode = pattern l p in - let env, sflag, scode = compile_stmt l env (Stmt.Seq (s, Stmt.Leave)) in - env, pflag || sflag, expr e @ pcode @ bindings p @ scode + let ldrop, env = env#get_label in + let env, _, pcode = pattern env ldrop p in + let env, _, scode = compile_stmt ldrop env (Stmt.Seq (s, Stmt.Leave)) in + env, true, expr e @ [DUP] @ pcode @ bindings p @ scode @ [JMP l; LABEL ldrop; DROP] | Stmt.Case (e, brs) -> - let n = List.length brs - 1 in + let n = List.length brs - 1 in + let ldrop, env = env#get_label in let env, _, _, code = List.fold_left (fun (env, lab, i, code) (p, s) -> @@ -221,13 +231,13 @@ let compile (defs, p) = then (l, env), [] else env#get_label, [JMP l] in - let _, pcode = pattern lfalse p in - let env, _, scode = compile_stmt l env (Stmt.Seq (s, Stmt.Leave)) in - (env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l]) @ pcode @ bindings p @ scode @ jmp) :: code) + let env, _, pcode = pattern env lfalse p in + let env, _, scode = compile_stmt ldrop env (Stmt.Seq (s, Stmt.Leave)) in + (env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l; DUP]) @ pcode @ bindings p @ scode @ jmp) :: code) ) (env, None, 0, []) brs in - env, true, expr e @ List.flatten @@ List.rev code + env, true, expr e @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l; LABEL ldrop; DROP] in let compile_def env (name, (args, locals, stmt)) = let lend, env = env#get_label in diff --git a/src/X86.ml b/src/X86.ml index 14e22a5c9..023c0ea6a 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -251,6 +251,18 @@ let compile env code = else env, [Jmp env#epilogue] | CALL (f, n, p) -> call env f n p +(* + | SEXP (t, n) -> + | DROP -> snd env#pop, [] + | DUP -> let x = env#peek in + let s, env = env#allocate in + env, [Mov (x, s)] + | SWAP -> let x, y = env#peek2 in + env, [Push x; Push y; Pop x; Pop y] + + | TAG t + | ENTER xs + | LEAVE *) in let env'', code'' = compile' env' scode' in env'', code' @ code'' @@ -286,14 +298,13 @@ class env = (* allocates a fresh position on a symbolic stack *) method allocate = let x, n = - let rec allocate' = function - | [] -> R 0 , 0 - | (S n)::_ -> S (n+1) , n+2 - | (R n)::_ when n < num_of_regs -> R (n+1) , stack_slots - | (M _)::s -> allocate' s - | _ -> let n = List.length locals in S n, n+1 - in - allocate' stack + let rec allocate' = function + | [] -> ebx , 0 + | (S n)::_ -> S (n+1) , n+2 + | (R n)::_ when n < num_of_regs -> R (n+1) , stack_slots + | _ -> S stack_slots, stack_slots+1 + in + allocate' stack in x, {< stack_slots = max n stack_slots; stack = x::stack >} From 9f8391607d48875fe8877319b74330c985abbf1b Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Wed, 16 May 2018 09:24:40 +0300 Subject: [PATCH 10/32] Intermediate; pattern matching in x86 --- regression/Makefile | 2 +- regression/test038.expr | 23 ---- regression/test039.expr | 31 ----- runtime/runtime.c | 273 +++++++++------------------------------- src/Language.ml | 2 +- src/SM.ml | 6 +- src/X86.ml | 150 +++++++++++++++++----- 7 files changed, 184 insertions(+), 303 deletions(-) delete mode 100644 regression/test038.expr delete mode 100644 regression/test039.expr 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/regression/test038.expr b/regression/test038.expr deleted file mode 100644 index e13e88c87..000000000 --- a/regression/test038.expr +++ /dev/null @@ -1,23 +0,0 @@ -fun append (x, y) { - case x of - `nil -> return y - | `cons (h, t) -> return `cons (h, append (t, y)) - esac -} - -fun printList (x) { - case x of - `nil -> skip - | `cons (h, t) -> write (h); printList (t) - esac -} - -n := read (); - -x := `cons (1, `cons (2, `nil)); -y := `cons (3, `cons (4, `nil)); - -printList (x); -printList (y); -printList (append (x, y)); -printList (append (y, x)) diff --git a/regression/test039.expr b/regression/test039.expr deleted file mode 100644 index 1eaff0a70..000000000 --- a/regression/test039.expr +++ /dev/null @@ -1,31 +0,0 @@ -fun insert (t, x) { - case t of - `leaf -> return `node (x, `leaf, `leaf) - | `node (y, l, r) -> if x > y - then return `node (y, insert (l, x), r) - else return `node (y, l, insert (r, x)) - fi - esac -} - -fun find (t, x) { - case t of - `leaf -> return 0 - | `node (y, l, r) -> if x == y then return 1 - elif x > y then return find (l, x) - else return find (r, x) - fi - esac -} - -n := read (); - -t := insert (insert (insert (insert (`leaf, 5), 4), 6), 3); - -write (find (t, 5)); -write (find (t, 4)); -write (find (t, 6)); -write (find (t, 3)); -write (find (t, 2)); -write (find (t, 1)) - diff --git a/runtime/runtime.c b/runtime/runtime.c index b3a1ab1fd..6e0bfe294 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -8,19 +8,25 @@ # include # define STRING_TAG 0x00000000 -# define ARRAYU_TAG 0x01000000 -# define ARRAYB_TAG 0x02000000 +# define ARRAY_TAG 0x01000000 +# define SEXP_TAG 0x02000000 # define LEN(x) (x & 0x00FFFFFF) # define TAG(x) (x & 0xFF000000) # define TO_DATA(x) ((data*)((char*)(x)-sizeof(int))) +# define TO_SEXP(x) ((sexp*)((char*)(x)-2*sizeof(int))) typedef struct { int tag; char contents[0]; } data; +typedef struct { + int tag; + data contents; +} sexp; + extern int Blength (void *p) { data *a = TO_DATA(p); return LEN(a->tag); @@ -30,7 +36,9 @@ extern void* Belem (void *p, int i) { data *a = TO_DATA(p); if (TAG(a->tag) == STRING_TAG) return (void*)(int)(a->contents[i]); - + + //printf ("elem %d = %p\n", i, (void*) ((int*) a->contents)[i]); + return (void*) ((int*) a->contents)[i]; } @@ -49,7 +57,7 @@ extern void* Barray (int n, ...) { int i; data *r = (data*) malloc (sizeof(int) * (n+1)); - r->tag = ARRAYB_TAG | n; //(boxed ? ARRAYB_TAG : ARRAYU_TAG) | size; + r->tag = ARRAY_TAG | n; va_start(args, n); @@ -63,6 +71,36 @@ extern void* Barray (int n, ...) { return r->contents; } +extern void* Bsexp (int n, ...) { + va_list args; + int i; + sexp *r = (sexp*) malloc (sizeof(int) * (n+2)); + data *d = &(r->contents); + + d->tag = SEXP_TAG | (n-1); + + va_start(args, n); + + for (i=0; icontents)[i] = ai; + } + + r->tag = va_arg(args, int); + va_end(args); + + //printf ("tag %d\n", r->tag); + //printf ("returning %p\n", d->contents); + + return d->contents; +} + +extern int Btag (void *d, int t) { + data *r = TO_DATA(d); + return TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t; +} + extern void Bsta (int n, int v, void *s, ...) { va_list args; int i, k; @@ -82,227 +120,30 @@ extern void Bsta (int n, int v, void *s, ...) { 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); +void Lprintf (char *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_start (args, s); + vprintf (s, args); va_end (args); - - return 0; } -extern void* Lfread (char *fname) { - data *result; - int size; - FILE * file; - int n = Lstrlen ((void*)fname); +void Lfprintf (FILE *f, char *s, ...) { + va_list args; - 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; + va_start (args, s); + vfprintf (f, s, args); + va_end (args); } -// New one -*/ +FILE* Lfopen (char *f, char *m) { + return fopen (f, m); +} +void Lfclose (FILE *f) { + fclose (f); +} + /* Lread is an implementation of the "read" construct */ extern int Lread () { int result; diff --git a/src/Language.ml b/src/Language.ml index 845988477..b3bf9c7d6 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -231,7 +231,7 @@ module Expr = !(Ostap.Util.expr (fun x -> x) (Array.map (fun (a, s) -> a, - List.map (fun s -> ostap(- $(s)), (fun x y -> Binop (s, x, y))) s + List.map (fun s -> ostap(- $(s)), (fun x y -> Binop (s, x, y))) s ) [| `Lefta, ["!!"]; diff --git a/src/SM.ml b/src/SM.ml index 1100a74ba..715ea09ae 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -222,7 +222,7 @@ let compile (defs, p) = | Stmt.Case (e, brs) -> let n = List.length brs - 1 in - let ldrop, env = env#get_label in + (*let ldrop, env = env#get_label in*) let env, _, _, code = List.fold_left (fun (env, lab, i, code) (p, s) -> @@ -232,12 +232,12 @@ let compile (defs, p) = else env#get_label, [JMP l] in let env, _, pcode = pattern env lfalse p in - let env, _, scode = compile_stmt ldrop env (Stmt.Seq (s, Stmt.Leave)) in + let env, _, scode = compile_stmt l(*ldrop*) env (Stmt.Seq (s, Stmt.Leave)) in (env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l; DUP]) @ pcode @ bindings p @ scode @ jmp) :: code) ) (env, None, 0, []) brs in - env, true, expr e @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l; LABEL ldrop; DROP] + env, true, expr e @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l] (*; LABEL ldrop; DROP]*) in let compile_def env (name, (args, locals, stmt)) = let lend, env = env#get_label in diff --git a/src/X86.ml b/src/X86.ml index 023c0ea6a..7157d6e56 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -1,3 +1,5 @@ +open GT + (* X86 codegeneration interface *) (* The registers: *) @@ -7,14 +9,15 @@ let regs = [|"%ebx"; "%ecx"; "%esi"; "%edi"; "%eax"; "%edx"; "%ebp"; "%esp"|] let num_of_regs = Array.length regs - 5 (* We need to know the word size to calculate offsets correctly *) -let word_size = 4 +let word_size = 4;; (* We need to distinguish the following operand types: *) -type opnd = +@type opnd = | R of int (* hard register *) | S of int (* a position on the hardware stack *) | M of string (* a named memory location *) | L of int (* an immediate operand *) +with show (* For convenience we define the following synonyms for the registers: *) let ebx = R 0 @@ -91,6 +94,8 @@ open SM of x86 instructions *) let compile env code = + SM.print_prg code; + flush stdout; let suffix = function | "<" -> "l" | "<=" -> "le" @@ -102,6 +107,7 @@ let compile env code = in let rec compile' env scode = let on_stack = function S _ -> true | _ -> false in + let mov x s = if on_stack x && on_stack s then [Mov (x, eax); Mov (eax, s)] else [Mov (x, s)] in let call env f n p = let f = match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f @@ -121,19 +127,21 @@ let compile env code = let env, pushs = push_args env [] n in let pushs = match f with - | "Barray" -> List.rev @@ (Push (L n)) :: pushs + | "Barray" -> List.rev @@ (Push (L n)) :: pushs + | "Bsexp" -> List.rev @@ (Push (L n)) :: pushs | "Bsta" -> - let x::v::is = List.rev pushs in - is @ [x; v] @ [Push (L (n-2))] + 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) + env, pushr @ pushs @ [Call f; Binop ("+", L (4 * List.length pushs), 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' -> + let stack = env#show_stack in let env', code' = match instr with | CONST n -> @@ -152,7 +160,8 @@ let compile env code = (match s with | S _ | M _ -> [Mov (env'#loc x, eax); Mov (eax, s)] | _ -> [Mov (env'#loc x, s)] - ) + ) + | STA (x, n) -> let s, env = (env#global x)#allocate in let push = @@ -162,6 +171,7 @@ let compile env code = 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', @@ -169,6 +179,7 @@ let compile env code = | S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)] | _ -> [Mov (s, env'#loc x)] ) + | BINOP op -> let x, y, env' = env#pop2 in env'#push y, @@ -227,11 +238,13 @@ let compile env code = then [Mov (x, eax); Binop (op, eax, y)] else [Binop (op, x, y)] ) - | LABEL s -> env, [Label s] - | JMP l -> env, [Jmp l] + | LABEL s -> (if env#is_barrier then (env#drop_barrier)#retrieve_stack s else env), [Label s] + + | JMP l -> (env#set_stack l)#set_barrier, [Jmp l] + | CJMP (s, l) -> let x, env = env#pop in - env, [Binop ("cmp", L 0, x); CJmp (s, l)] + env#set_stack l, [Binop ("cmp", L 0, x); CJmp (s, l)] | BEGIN (f, a, l) -> let env = env#enter f a l in @@ -251,49 +264,104 @@ let compile env code = else env, [Jmp env#epilogue] | CALL (f, n, p) -> call env f n p -(* + | SEXP (t, n) -> + let s, env = env#allocate in + let env, code = call env ".sexp" (n+1) false in + env, [Mov (L env#hash t, s)] @ code + | DROP -> snd env#pop, [] - | DUP -> let x = env#peek in - let s, env = env#allocate in - env, [Mov (x, s)] - | SWAP -> let x, y = env#peek2 in - env, [Push x; Push y; Pop x; Pop y] - - | TAG t - | ENTER xs - | LEAVE *) + + | DUP -> + let x = env#peek in + let s, env = env#allocate in + env, mov x s + + | SWAP -> + let x, y = env#peek2 in + env, [Push x; Push y; Pop x; Pop y] + + | TAG t -> + let s, env = env#allocate in + let env, code = call env ".tag" 2 false in + env, [Mov (L env#hash t, s)] @ code + + | ENTER xs -> + let env, code = + List.fold_left + (fun (env, code) v -> + let s, env = env#pop in + env, (mov s @@ env#loc v) :: code + ) + (env#scope @@ List.rev xs, []) xs + in + env, List.flatten @@ List.rev code + + | LEAVE -> env#unscope, [] in let env'', code'' = compile' env' scode' in - env'', code' @ code'' + env'', [Meta (Printf.sprintf "# %s / % s" (GT.show(SM.insn) instr) stack)] @ code' @ code'' in compile' env code (* A set of strings *) -module S = Set.Make (String) +module S = Set.Make (String) (* A map indexed by strings *) -module M = Map.Make (String) +module M = Map.Make (String) (* Environment implementation *) -let make_assoc l = List.combine l (List.init (List.length l) (fun x -> x)) - class env = + let chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNJPQRSTUVWXYZ" in + let make_assoc l i = List.combine l (List.init (List.length l) (fun x -> x + i)) in + let rec assoc x = function [] -> raise Not_found | l :: ls -> try List.assoc x l with Not_found -> assoc x ls in 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 static_size = 0 (* static data size *) val stack = [] (* symbolic stack *) val args = [] (* function arguments *) val locals = [] (* function local variables *) val fname = "" (* function name *) + val stackmap = M.empty (* labels to stack map *) + val barrier = false (* barrier condition *) + method show_stack = + GT.show(list) (GT.show(opnd)) stack + + method print_locals = + Printf.printf "LOCALS: size = %d\n" static_size; + List.iter + (fun l -> + Printf.printf "("; + List.iter (fun (a, i) -> Printf.printf "%s=%d " a i) l; + Printf.printf ")\n" + ) locals; + Printf.printf "END LOCALS\n" + + (* check barrier condition *) + method is_barrier = barrier + + (* set barrier *) + method set_barrier = {< barrier = true >} + + (* drop barrier *) + method drop_barrier = {< barrier = false >} + + (* associates a stack to a label *) + method set_stack l = Printf.printf "Setting stack for %s\n" l; {< stackmap = M.add l stack stackmap >} + + (* retrieves a stack for a label *) + method retrieve_stack l = Printf.printf "Retrieving stack for %s\n" l; + try {< stack = M.find l stackmap >} with Not_found -> self + (* gets a name for a global variable *) method loc x = try S (- (List.assoc x args) - 1) with Not_found -> - try S (List.assoc x locals) with Not_found -> M ("global_" ^ x) + try S (assoc x locals) with Not_found -> M ("global_" ^ x) (* allocates a fresh position on a symbolic stack *) method allocate = @@ -302,7 +370,7 @@ class env = | [] -> ebx , 0 | (S n)::_ -> S (n+1) , n+2 | (R n)::_ when n < num_of_regs -> R (n+1) , stack_slots - | _ -> S stack_slots, stack_slots+1 + | _ -> S static_size, static_size+1 in allocate' stack in @@ -317,6 +385,20 @@ class env = (* pops two operands from the symbolic stack *) method pop2 = let x::y::stack' = stack in x, y, {< stack = stack' >} + (* peeks the top of the stack (the stack does not change) *) + method peek = List.hd stack + + (* peeks two topmost values from the stack (the stack itself does not change) *) + method peek2 = let x::y::_ = stack in x, y + + (* tag hash: gets a hash for a string tag *) + method hash tag = + let h = ref 0 in + for i = 0 to min (String.length tag - 1) 4 do + h := (!h lsl 6) lor (String.index chars tag.[i]) + done; + !h + (* registers a global variable in the environment *) method global x = {< globals = S.add ("global_" ^ x) globals >} @@ -339,8 +421,20 @@ class env = (* enters a function *) method enter f a l = - {< stack_slots = List.length l; stack = []; locals = make_assoc l; args = make_assoc a; fname = f >} + let n = List.length l in + {< static_size = n; stack_slots = n; stack = []; locals = [make_assoc l 0]; args = make_assoc a 0; fname = f >} + (* enters a scope *) + method scope vars = + let n = List.length vars in + let static_size' = n + static_size in + {< stack_slots = max stack_slots static_size'; static_size = static_size'; locals = (make_assoc vars static_size) :: locals >} + + (* leaves a scope *) + method unscope = + let n = List.length (List.hd locals) in + {< static_size = static_size - n; locals = List.tl locals >} + (* returns a label for the epilogue *) method epilogue = Printf.sprintf "L%s_epilogue" fname From bbe403de268421fa258e72e6dda9007fd1aab78d Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Wed, 16 May 2018 16:50:36 +0300 Subject: [PATCH 11/32] Pattern matching in X86 --- regression/orig/test040.log | 4 ++++ regression/orig/test041.log | 2 ++ regression/orig/test042.log | 10 ++++++++++ regression/orig/test043.log | 3 +++ regression/orig/test044.log | 6 ++++++ regression/test038.expr | 23 +++++++++++++++++++++++ regression/test039.expr | 31 +++++++++++++++++++++++++++++++ regression/test040.expr | 15 +++++++++++++++ regression/test040.input | 1 + regression/test041.expr | 11 +++++++++++ regression/test041.input | 1 + regression/test042.expr | 17 +++++++++++++++++ regression/test042.input | 1 + regression/test043.expr | 12 ++++++++++++ regression/test043.input | 1 + regression/test044.expr | 37 +++++++++++++++++++++++++++++++++++++ regression/test044.input | 1 + src/X86.ml | 6 +++--- 18 files changed, 179 insertions(+), 3 deletions(-) create mode 100644 regression/orig/test040.log create mode 100644 regression/orig/test041.log create mode 100644 regression/orig/test042.log create mode 100644 regression/orig/test043.log create mode 100644 regression/orig/test044.log create mode 100644 regression/test038.expr create mode 100644 regression/test039.expr create mode 100644 regression/test040.expr create mode 100644 regression/test040.input create mode 100644 regression/test041.expr create mode 100644 regression/test041.input create mode 100644 regression/test042.expr create mode 100644 regression/test042.input create mode 100644 regression/test043.expr create mode 100644 regression/test043.input create mode 100644 regression/test044.expr create mode 100644 regression/test044.input diff --git a/regression/orig/test040.log b/regression/orig/test040.log new file mode 100644 index 000000000..90e44a83b --- /dev/null +++ b/regression/orig/test040.log @@ -0,0 +1,4 @@ +> 1 +2 +3 +4 diff --git a/regression/orig/test041.log b/regression/orig/test041.log new file mode 100644 index 000000000..99e508a22 --- /dev/null +++ b/regression/orig/test041.log @@ -0,0 +1,2 @@ +> 600 +1800 diff --git a/regression/orig/test042.log b/regression/orig/test042.log new file mode 100644 index 000000000..ef20969cc --- /dev/null +++ b/regression/orig/test042.log @@ -0,0 +1,10 @@ +> 0 +1 +2 +3 +4 +4 +4 +4 +4 +4 diff --git a/regression/orig/test043.log b/regression/orig/test043.log new file mode 100644 index 000000000..c3c21fc91 --- /dev/null +++ b/regression/orig/test043.log @@ -0,0 +1,3 @@ +> 0 +100 +300 diff --git a/regression/orig/test044.log b/regression/orig/test044.log new file mode 100644 index 000000000..3484555d5 --- /dev/null +++ b/regression/orig/test044.log @@ -0,0 +1,6 @@ +> 1 +2 +3 +100 +200 +300 diff --git a/regression/test038.expr b/regression/test038.expr new file mode 100644 index 000000000..e13e88c87 --- /dev/null +++ b/regression/test038.expr @@ -0,0 +1,23 @@ +fun append (x, y) { + case x of + `nil -> return y + | `cons (h, t) -> return `cons (h, append (t, y)) + esac +} + +fun printList (x) { + case x of + `nil -> skip + | `cons (h, t) -> write (h); printList (t) + esac +} + +n := read (); + +x := `cons (1, `cons (2, `nil)); +y := `cons (3, `cons (4, `nil)); + +printList (x); +printList (y); +printList (append (x, y)); +printList (append (y, x)) diff --git a/regression/test039.expr b/regression/test039.expr new file mode 100644 index 000000000..1eaff0a70 --- /dev/null +++ b/regression/test039.expr @@ -0,0 +1,31 @@ +fun insert (t, x) { + case t of + `leaf -> return `node (x, `leaf, `leaf) + | `node (y, l, r) -> if x > y + then return `node (y, insert (l, x), r) + else return `node (y, l, insert (r, x)) + fi + esac +} + +fun find (t, x) { + case t of + `leaf -> return 0 + | `node (y, l, r) -> if x == y then return 1 + elif x > y then return find (l, x) + else return find (r, x) + fi + esac +} + +n := read (); + +t := insert (insert (insert (insert (`leaf, 5), 4), 6), 3); + +write (find (t, 5)); +write (find (t, 4)); +write (find (t, 6)); +write (find (t, 3)); +write (find (t, 2)); +write (find (t, 1)) + diff --git a/regression/test040.expr b/regression/test040.expr new file mode 100644 index 000000000..766857331 --- /dev/null +++ b/regression/test040.expr @@ -0,0 +1,15 @@ +fun f (x) { + case x of + `a -> write (1) + | `b -> write (2) + | `c -> write (3) + | _ -> write (4) + esac +} + +x := read (); + +f (`a); +f (`b); +f (`c); +f (`d) \ No newline at end of file diff --git a/regression/test040.input b/regression/test040.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/test040.input @@ -0,0 +1 @@ +0 diff --git a/regression/test041.expr b/regression/test041.expr new file mode 100644 index 000000000..36d947f35 --- /dev/null +++ b/regression/test041.expr @@ -0,0 +1,11 @@ +fun f (a) { + case a of + `a (x, y, z) -> write (x + y + z) + | `b (x, y, z) -> write (x + y + z) + esac +} + +x := read (); + +f (`a (100, 200, 300)); +f (`b (500, 600, 700)) \ No newline at end of file diff --git a/regression/test041.input b/regression/test041.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/test041.input @@ -0,0 +1 @@ +0 diff --git a/regression/test042.expr b/regression/test042.expr new file mode 100644 index 000000000..1029c9eb9 --- /dev/null +++ b/regression/test042.expr @@ -0,0 +1,17 @@ +fun f (x) { + case x of + `nil -> write (0) + | `cons (_, `nil) -> write (1) + | `cons (_, `cons (_, `nil)) -> write (2) + | `cons (_, `cons (_, `cons (_, `nil))) -> write (3) + | _ -> write (4) + esac +} + +x := read (); +y := `nil; + +for i := 0, i < 10, i := i + 1 do + f (y); + y := `cons (i, y) +od \ No newline at end of file diff --git a/regression/test042.input b/regression/test042.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/test042.input @@ -0,0 +1 @@ +0 diff --git a/regression/test043.expr b/regression/test043.expr new file mode 100644 index 000000000..88bab7941 --- /dev/null +++ b/regression/test043.expr @@ -0,0 +1,12 @@ +fun sum (x) { + case x of + `nil -> return 0 + | `cons (x, tl) -> return x + sum (tl) + esac +} + +x := read (); + +write (sum (`nil)); +write (sum (`cons (100, `nil))); +write (sum (`cons (100, `cons (200, `nil)))) \ No newline at end of file diff --git a/regression/test043.input b/regression/test043.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/test043.input @@ -0,0 +1 @@ +0 diff --git a/regression/test044.expr b/regression/test044.expr new file mode 100644 index 000000000..78bc10dfd --- /dev/null +++ b/regression/test044.expr @@ -0,0 +1,37 @@ +fun zip (x) { + case x of `pair (x, y) -> + case x of + `nil -> return `nil + | `cons (x, xs) -> case y of + `nil -> return `nil + | `cons (y, ys) -> return `cons (`pair (x, y), zip (`pair (xs, ys))) + esac + esac + esac +} + +fun unzip (x) { + case x of + `nil -> return `pair (`nil, `nil) + | `cons (`pair (x, y), tl) -> + case unzip (tl) of + `pair (xs, ys) -> return `pair (`cons (x, xs), `cons (y, ys)) + esac + esac +} + +fun printList (l) { + case l of + `nil -> skip + | `cons (x, xs) -> write (x); printList (xs) + esac +} + +z := read (); + +x := `cons (1, `cons (2, `cons (3, `nil))); +y := `cons (100, `cons (200, `cons (300, `nil))); + +case unzip (zip (`pair (x, y))) of + `pair (x, y) -> printList (x); printList (y) +esac \ No newline at end of file diff --git a/regression/test044.input b/regression/test044.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/test044.input @@ -0,0 +1 @@ +0 diff --git a/src/X86.ml b/src/X86.ml index 7157d6e56..9dd20f23e 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -94,7 +94,7 @@ open SM of x86 instructions *) let compile env code = - SM.print_prg code; + (*SM.print_prg code;*) flush stdout; let suffix = function | "<" -> "l" @@ -351,10 +351,10 @@ class env = method drop_barrier = {< barrier = false >} (* associates a stack to a label *) - method set_stack l = Printf.printf "Setting stack for %s\n" l; {< stackmap = M.add l stack stackmap >} + method set_stack l = (*Printf.printf "Setting stack for %s\n" l;*) {< stackmap = M.add l stack stackmap >} (* retrieves a stack for a label *) - method retrieve_stack l = Printf.printf "Retrieving stack for %s\n" l; + method retrieve_stack l = (*Printf.printf "Retrieving stack for %s\n" l;*) try {< stack = M.find l stackmap >} with Not_found -> self (* gets a name for a global variable *) From bc07277f581890afc3d741d9e191bf7e94bff760 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Fri, 25 May 2018 09:53:10 +0300 Subject: [PATCH 12/32] Pre-HW12 --- runtime/runtime.c | 16 +++++++++++++++- src/Language.ml | 10 ++++++++-- 2 files changed, 23 insertions(+), 3 deletions(-) diff --git a/runtime/runtime.c b/runtime/runtime.c index 6e0bfe294..133b72c7b 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -124,10 +124,24 @@ void Lprintf (char *s, ...) { va_list args; va_start (args, s); - vprintf (s, args); + vprintf (s, args); // vprintf (char *, va_list) <-> printf (char *, ...) va_end (args); } +void* Lstrcat (void *a, void *b) { + data *da = TO_DATA(a); + data *db = TO_DATA(b); + + data *d = (data *) malloc (sizeof(int) + LEN(da->tag) + LEN(db->tag) + 1); + + d->tag = LEN(da->tag) + LEN(db->tag); + + strcpy (d->contents, da->contents); + strcat (d->contents, db->contents); + + return d->contents; +} + void Lfprintf (FILE *f, char *s, ...) { va_list args; diff --git a/src/Language.ml b/src/Language.ml index b3bf9c7d6..0318ba7be 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -231,13 +231,19 @@ module Expr = !(Ostap.Util.expr (fun x -> x) (Array.map (fun (a, s) -> a, - List.map (fun s -> ostap(- $(s)), (fun x y -> Binop (s, x, y))) s + List.map (fun s -> ostap(- $(s)), + (fun x y -> + match s with + "++" -> Call ("strcat", [x; y]) + | _ -> Binop (s, x, y) + ) + ) s ) [| `Lefta, ["!!"]; `Lefta, ["&&"]; `Nona , ["=="; "!="; "<="; "<"; ">="; ">"]; - `Lefta, ["+" ; "-"]; + `Lefta, ["++"; "+" ; "-"]; `Lefta, ["*" ; "/"; "%"]; |] ) From b00925f6e93f0ded10b6c0ca5c600dee390064b8 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Mon, 28 May 2018 18:44:38 +0300 Subject: [PATCH 13/32] Switched to the new GT --- src/Language.ml | 4 ++-- src/SM.ml | 11 ++++++----- 2 files changed, 8 insertions(+), 7 deletions(-) diff --git a/src/Language.ml b/src/Language.ml index 0318ba7be..cb9f0eadf 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -285,8 +285,8 @@ module Stmt = | x:IDENT {Ident x} ) - let vars p = - transform(t) (object inherit [string list] @t[foldl] method c_Ident s _ name = name::s end) [] p + let vars p = fix0 (fun f -> + transform(t) (object inherit [string list, _] @t[foldl] f method c_Ident s name = name::s end)) [] p end diff --git a/src/SM.ml b/src/SM.ml index 715ea09ae..345659d11 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -153,12 +153,13 @@ let compile (defs, p) = env, true, tag @ List.flatten (List.rev code) @ [DROP] and bindings p = let bindings = + fix0 (fun fself -> transform(Stmt.Pattern.t) - (object inherit [int list, (string * int list) list] @Stmt.Pattern.t - method c_Wildcard path _ = [] - method c_Ident path _ s = [s, path] - method c_Sexp path x _ ps = List.concat @@ List.mapi (fun i p -> x.GT.f (path @ [i]) p) ps - end) + (object inherit [int list, (string * int list) list, _] @Stmt.Pattern.t + method c_Wildcard path = [] + method c_Ident path s = [s, path] + method c_Sexp path x ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps + end)) [] p in From 302ef5dca165e988a92fa56d73c70fb26aa100a3 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Tue, 23 Oct 2018 14:29:30 +0300 Subject: [PATCH 14/32] Fixed ref in X86.ml --- src/X86.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/X86.ml b/src/X86.ml index 9dd20f23e..e54463571 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -393,7 +393,7 @@ class env = (* tag hash: gets a hash for a string tag *) method hash tag = - let h = ref 0 in + let h = Pervasives.ref 0 in for i = 0 to min (String.length tag - 1) 4 do h := (!h lsl 6) lor (String.index chars tag.[i]) done; From 577d0e2d128c015d91cf7240e7a713e720e3300d Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Tue, 23 Oct 2018 23:18:00 +0300 Subject: [PATCH 15/32] Arithmetics+corrections (expressions only) --- regression/expressions/Makefile | 6 +-- regression/test034.expr | 17 -------- runtime/runtime.c | 18 +++++---- src/Language.ml | 2 +- src/SM.ml | 2 +- src/X86.ml | 72 +++++++++++++++++++++++++-------- 6 files changed, 72 insertions(+), 45 deletions(-) delete mode 100644 regression/test034.expr diff --git a/regression/expressions/Makefile b/regression/expressions/Makefile index fe0e5468b..0ffefb2f6 100644 --- a/regression/expressions/Makefile +++ b/regression/expressions/Makefile @@ -7,9 +7,9 @@ RC = ../../src/rc.opt check: $(TESTS) $(TESTS): %: %.expr - @RC_RUNTIME=../../runtime $(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 + RC_RUNTIME=../../runtime $(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 clean: rm -f *.log *.s *~ $(TESTS) diff --git a/regression/test034.expr b/regression/test034.expr deleted file mode 100644 index a31a87f19..000000000 --- a/regression/test034.expr +++ /dev/null @@ -1,17 +0,0 @@ -fun printString (x) { - for i:=0, i> 1; +} + +extern void Lprintf (char *s, ...) { va_list args; va_start (args, s); @@ -128,7 +132,7 @@ void Lprintf (char *s, ...) { va_end (args); } -void* Lstrcat (void *a, void *b) { +extern void* Lstrcat (void *a, void *b) { data *da = TO_DATA(a); data *db = TO_DATA(b); @@ -142,7 +146,7 @@ void* Lstrcat (void *a, void *b) { return d->contents; } -void Lfprintf (FILE *f, char *s, ...) { +extern void Lfprintf (FILE *f, char *s, ...) { va_list args; va_start (args, s); @@ -150,11 +154,11 @@ void Lfprintf (FILE *f, char *s, ...) { va_end (args); } -FILE* Lfopen (char *f, char *m) { +extern FILE* Lfopen (char *f, char *m) { return fopen (f, m); } -void Lfclose (FILE *f) { +extern void Lfclose (FILE *f) { fclose (f); } @@ -166,12 +170,12 @@ extern int Lread () { fflush (stdout); scanf ("%d", &result); - return result; + return (result << 1) | 0x0001; } /* Lwrite is an implementation of the "write" construct */ extern int Lwrite (int n) { - printf ("%d\n", n); + printf ("%d\n", n >> 1); fflush (stdout); return 0; diff --git a/src/Language.ml b/src/Language.ml index cb9f0eadf..c9c84aaf8 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -138,7 +138,7 @@ module Expr = (* variable *) | Var of string (* binary operator *) | Binop of string * t * t (* element extraction *) | Elem of t * t - (* length *) | Length of t + (* length *) | Length of t (* function call *) | Call of string * t list with show (* Available binary operators: diff --git a/src/SM.ml b/src/SM.ml index 345659d11..11894b921 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -113,7 +113,7 @@ let run p i = let args, stack' = split n stack in let (st, i, o, r) = Language.Builtin.eval (st, i, o, None) (List.rev args) f in let stack'' = if p then stack' else let Some r = r in r::stack' in - Printf.printf "Builtin: %s\n"; + (*Printf.printf "Builtin:\n";*) (cstack, stack'', (st, i, o)) end ) diff --git a/src/X86.ml b/src/X86.ml index e54463571..24b019271 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -47,7 +47,12 @@ type instr = (* a conditional jump *) | CJmp of string * string (* a non-conditional jump *) | Jmp of string (* directive *) | Meta of string - + +(* arithmetic correction: decrement *) | Dec of opnd +(* arithmetic correction: or 0x0001 *) | Or1 of opnd +(* arithmetic correction: shl 1 *) | Sal1 of opnd +(* arithmetic correction: shr 1 *) | Sar1 of opnd + (* Instruction printer *) let show instr = let binop = function @@ -82,7 +87,11 @@ let show instr = | Jmp l -> Printf.sprintf "\tjmp\t%s" l | CJmp (s , l) -> Printf.sprintf "\tj%s\t%s" s l | Meta s -> Printf.sprintf "%s\n" s - + | Dec s -> Printf.sprintf "\tdecl\t%s" (opnd s) + | Or1 s -> Printf.sprintf "\torl\t$0x0001,\t%s" (opnd s) + | Sal1 s -> Printf.sprintf "\tsall\t%s" (opnd s) + | Sar1 s -> Printf.sprintf "\tsarl\t%s" (opnd s) + (* Opening stack machine to use instructions without fully qualified names *) open SM @@ -146,7 +155,7 @@ let compile env code = match instr with | CONST n -> let s, env' = env#allocate in - (env', [Mov (L n, s)]) + (env', [Mov (L ((n lsl 1) lor 1), s)]) | STRING s -> let s, env = env#string s in @@ -184,11 +193,27 @@ let compile env code = let x, y, env' = env#pop2 in env'#push y, (match op with - | "/" | "%" -> + | "/" -> [Mov (y, eax); + Sar1 eax; Cltd; + (* x := x >> 1 ?? *) + Sar1 x; (*!!!*) IDiv x; - Mov ((match op with "/" -> eax | _ -> edx), y) + Sal1 eax; + Or1 eax; + Mov (eax, y) + ] + | "%" -> + [Mov (y, eax); + Sar1 eax; + Cltd; + (* x := x >> 1 ?? *) + Sar1 x; (*!!!*) + IDiv x; + Sal1 edx; + Or1 edx; + Mov (edx, y) ] | "<" | "<=" | "==" | "!=" | ">=" | ">" -> (match x with @@ -197,25 +222,31 @@ let compile env code = Mov (x, edx); Binop ("cmp", edx, y); Set (suffix op, "%al"); + Sal1 eax; + Or1 eax; Mov (eax, y) ] | _ -> [Binop ("^" , eax, eax); Binop ("cmp", x, y); Set (suffix op, "%al"); + Sal1 eax; + Or1 eax; Mov (eax, y) ] ) | "*" -> - if on_stack x && on_stack y - then [Mov (y, eax); Binop (op, x, eax); Mov (eax, y)] - else [Binop (op, x, y)] + if on_stack y + then [Dec y; Mov (x, eax); Sar1 eax; Binop (op, y, eax); Or1 eax; Mov (eax, y)] + else [Dec y; Mov (x, eax); Sar1 eax; Binop (op, eax, y); Or1 y] | "&&" -> - [Mov (x, eax); + [Dec x; (*!!!*) + Mov (x, eax); Binop (op, x, eax); Mov (L 0, eax); Set ("ne", "%al"); - + + Dec y; (*!!!*) Mov (y, edx); Binop (op, y, edx); Mov (L 0, edx); @@ -223,20 +254,29 @@ let compile env code = Binop (op, edx, eax); Set ("ne", "%al"); - + Sal1 eax; + Or1 eax; Mov (eax, y) ] | "!!" -> [Mov (y, eax); + Sar1 eax; + Sar1 x; (*!!!*) Binop (op, x, eax); Mov (L 0, eax); Set ("ne", "%al"); + Sal1 eax; + Or1 eax; Mov (eax, y) ] - | _ -> + | "+" -> if on_stack x && on_stack y - then [Mov (x, eax); Binop (op, eax, y)] - else [Binop (op, x, y)] + then [Mov (x, eax); Dec eax; Binop ("+", eax, y)] + else [Binop (op, x, y); Dec y] + | "-" -> + if on_stack x && on_stack y + then [Mov (x, eax); Binop (op, eax, y); Or1 y] + else [Binop (op, x, y); Or1 y] ) | LABEL s -> (if env#is_barrier then (env#drop_barrier)#retrieve_stack s else env), [Label s] @@ -244,7 +284,7 @@ let compile env code = | CJMP (s, l) -> let x, env = env#pop in - env#set_stack l, [Binop ("cmp", L 0, x); CJmp (s, l)] + env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, l)] | BEGIN (f, a, l) -> let env = env#enter f a l in @@ -456,7 +496,7 @@ class env = the stack code, then generates x86 assember code, then prints the assembler file *) let genasm (ds, stmt) = - let stmt = Language.Stmt.Seq (stmt, Language.Stmt.Return (Some (Language.Expr.Const 0))) in + let stmt = Language.Stmt.Seq (stmt, Language.Stmt.Return (Some (Language.Expr.Call ("raw", [Language.Expr.Const 0])))) in let env, code = compile (new env) From 212d759037bc35da493a5d2394f85c3427adafa4 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Thu, 25 Oct 2018 03:15:24 +0300 Subject: [PATCH 16/32] Arithmetic corrections --- regression/Makefile | 4 ++-- regression/expressions/Makefile | 6 +++--- runtime/runtime.c | 26 ++++++++++++++++---------- 3 files changed, 21 insertions(+), 15 deletions(-) diff --git a/regression/Makefile b/regression/Makefile index 31e136a99..0fc4b3f96 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -8,8 +8,8 @@ check: $(TESTS) $(TESTS): %: %.expr @$(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 + @cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log + @cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log clean: rm -f test*.log *.s *~ $(TESTS) diff --git a/regression/expressions/Makefile b/regression/expressions/Makefile index 0ffefb2f6..fe0e5468b 100644 --- a/regression/expressions/Makefile +++ b/regression/expressions/Makefile @@ -7,9 +7,9 @@ RC = ../../src/rc.opt check: $(TESTS) $(TESTS): %: %.expr - RC_RUNTIME=../../runtime $(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 + @RC_RUNTIME=../../runtime $(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 clean: rm -f *.log *.s *~ $(TESTS) diff --git a/runtime/runtime.c b/runtime/runtime.c index 67b0fd7ee..8fb1e1b49 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -17,6 +17,9 @@ # define TO_DATA(x) ((data*)((char*)(x)-sizeof(int))) # define TO_SEXP(x) ((sexp*)((char*)(x)-2*sizeof(int))) +# define UNBOX(x) (((int) (x)) >> 1) +# define BOX(x) ((((int) (x)) << 1) | 0x0001) + typedef struct { int tag; char contents[0]; @@ -29,15 +32,18 @@ typedef struct { extern int Blength (void *p) { data *a = TO_DATA(p); - return LEN(a->tag); + return BOX(LEN(a->tag)); } extern void* Belem (void *p, int i) { data *a = TO_DATA(p); + i = UNBOX(i); + + /* printf ("elem %d = %p\n", i, (void*) ((int*) a->contents)[i]); */ - if (TAG(a->tag) == STRING_TAG) return (void*)(int)(a->contents[i]); - - //printf ("elem %d = %p\n", i, (void*) ((int*) a->contents)[i]); + if (TAG(a->tag) == STRING_TAG) { + return (void*) BOX(a->contents[i]); + } return (void*) ((int*) a->contents)[i]; } @@ -98,7 +104,7 @@ extern void* Bsexp (int n, ...) { extern int Btag (void *d, int t) { data *r = TO_DATA(d); - return TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t; + return ((TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t) << 1) | 1; } extern void Bsta (int n, int v, void *s, ...) { @@ -109,14 +115,14 @@ extern void Bsta (int n, int v, void *s, ...) { va_start(args, s); for (i=0; itag) == STRING_TAG)((char*) s)[k] = (char) v; + if (TAG(a->tag) == STRING_TAG)((char*) s)[k] = (char) (v >> 1); else ((int*) s)[k] = v; } @@ -170,12 +176,12 @@ extern int Lread () { fflush (stdout); scanf ("%d", &result); - return (result << 1) | 0x0001; + return BOX(result); } /* Lwrite is an implementation of the "write" construct */ extern int Lwrite (int n) { - printf ("%d\n", n >> 1); + printf ("%d\n", UNBOX(n)); fflush (stdout); return 0; From 1f564dbc5e201a2357822d7cda5b2b56e404c096 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Wed, 31 Oct 2018 20:10:50 +0300 Subject: [PATCH 17/32] StringVal as a builtin .string --- runtime/runtime.c | 129 +++++++++++++++++++++++++++++++++++++++++++--- src/Driver.ml | 1 + src/Language.ml | 55 +++++++++++++------- src/SM.ml | 1 + 4 files changed, 160 insertions(+), 26 deletions(-) diff --git a/runtime/runtime.c b/runtime/runtime.c index 8fb1e1b49..c766c4465 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -6,6 +6,7 @@ # include # include # include +# include # define STRING_TAG 0x00000000 # define ARRAY_TAG 0x01000000 @@ -17,8 +18,9 @@ # define TO_DATA(x) ((data*)((char*)(x)-sizeof(int))) # define TO_SEXP(x) ((sexp*)((char*)(x)-2*sizeof(int))) -# define UNBOX(x) (((int) (x)) >> 1) -# define BOX(x) ((((int) (x)) << 1) | 0x0001) +# define UNBOXED(x) (((int) (x)) & 0x0001) +# define UNBOX(x) (((int) (x)) >> 1) +# define BOX(x) ((((int) (x)) << 1) | 0x0001) typedef struct { int tag; @@ -35,6 +37,104 @@ extern int Blength (void *p) { return BOX(LEN(a->tag)); } +char* de_hash (int n) { + static char *chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNJPQRSTUVWXYZ"; + static char buf[6]; + char *p = &buf[5]; + + /*printf ("tag: %d\n", n);*/ + + *p-- = 0; + + while (n != 0) { + /*printf ("char: %c\n", chars [n & 0x003F]);*/ + *p-- = chars [n & 0x003F]; + n = n >> 6; + } + + return ++p; +} + +typedef struct { + char *contents; + int ptr; + int len; +} StringBuf; + +static StringBuf stringBuf; + +# define STRINGBUF_INIT 128 + +static void createStringBuf () { + stringBuf.contents = (char*) malloc (STRINGBUF_INIT); + stringBuf.ptr = 0; + stringBuf.len = STRINGBUF_INIT; +} + +static void deleteStringBuf () { + free (stringBuf.contents); +} + +static void extendStringBuf () { + int len = stringBuf.len << 1; + + stringBuf.contents = (char*) realloc (stringBuf.contents, len); + stringBuf.len = len; +} + +static void printStringBuf (char *fmt, ...) { + va_list args; + int written, rest; + char *buf = &stringBuf.contents[stringBuf.ptr]; + + again: + va_start (args, fmt); + rest = stringBuf.len - stringBuf.ptr; + written = vsnprintf (buf, rest, fmt, args); + + if (written >= rest) { + extendStringBuf (); + goto again; + } + + stringBuf.ptr += written; +} + +static void printValue (void *p) { + if (UNBOXED(p)) printStringBuf ("%d", UNBOX(p)); + else { + data *a = TO_DATA(p); + + switch (TAG(a->tag)) { + case STRING_TAG: + printStringBuf ("\"%s\"", a->contents); + break; + + case ARRAY_TAG: + printStringBuf ("["); + for (int i = 0; i < LEN(a->tag); i++) { + printValue ((void*)((int*) a->contents)[i]); + if (i != LEN(a->tag) - 1) printStringBuf (", "); + } + printStringBuf ("]"); + break; + + case SEXP_TAG: + printStringBuf ("`%s", de_hash (TO_SEXP(p)->tag)); + printStringBuf (" ("); + for (int i = 0; i < LEN(a->tag); i++) { + printValue ((void*)((int*) a->contents)[i]); + if (i != LEN(a->tag) - 1) printStringBuf (", "); + } + printStringBuf (")"); + break; + + default: + printStringBuf ("*** invalid tag: %x ***", TAG(a->tag)); + } + } +} + extern void* Belem (void *p, int i) { data *a = TO_DATA(p); i = UNBOX(i); @@ -58,6 +158,19 @@ extern void* Bstring (void *p) { return r->contents; } +extern void* Bstringval (void *p) { + void *s; + + createStringBuf (); + printValue (p); + + s = Bstring (stringBuf.contents); + + deleteStringBuf (); + + return s; +} + extern void* Barray (int n, ...) { va_list args; int i; @@ -104,7 +217,7 @@ extern void* Bsexp (int n, ...) { extern int Btag (void *d, int t) { data *r = TO_DATA(d); - return ((TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t) << 1) | 1; + return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t); } extern void Bsta (int n, int v, void *s, ...) { @@ -122,20 +235,20 @@ extern void Bsta (int n, int v, void *s, ...) { k = UNBOX(va_arg(args, int)); a = TO_DATA(s); - if (TAG(a->tag) == STRING_TAG)((char*) s)[k] = (char) (v >> 1); + if (TAG(a->tag) == STRING_TAG)((char*) s)[k] = (char) UNBOX(v); else ((int*) s)[k] = v; } extern int Lraw (int x) { - return x >> 1; + return UNBOX(x); } extern void Lprintf (char *s, ...) { va_list args; va_start (args, s); - vprintf (s, args); // vprintf (char *, va_list) <-> printf (char *, ...) - va_end (args); + vprintf (s, args); // vprintf (char *, va_list) <-> printf (char *, ...) + va_end (args); } extern void* Lstrcat (void *a, void *b) { @@ -157,7 +270,7 @@ extern void Lfprintf (FILE *f, char *s, ...) { va_start (args, s); vfprintf (f, s, args); - va_end (args); + va_end (args); } extern FILE* Lfopen (char *f, char *m) { diff --git a/src/Driver.ml b/src/Driver.ml index 71d0e2df7..773d96daa 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -15,6 +15,7 @@ let parse infile = "for"; "fun"; "local"; "return"; "length"; + "string"; "case"; "of"; "esac"; "when"] s inherit Util.Lexers.skip [ Matcher.Skip.whitespaces " \t\n"; diff --git a/src/Language.ml b/src/Language.ml index c9c84aaf8..a0547f7b6 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -36,7 +36,21 @@ module Value = let update_string s i x = String.init (String.length s) (fun j -> if j = i then x else s.[j]) let update_array a i x = List.init (List.length a) (fun j -> if j = i then x else List.nth a j) - + + let string_val v = + let buf = Buffer.create 128 in + let append s = Buffer.add_string buf s in + let rec inner = function + | Int n -> append (string_of_int n) + | String s -> append "\""; append s; append "\"" + | Array a -> let n = List.length a in + append "["; List.iteri (fun i a -> (if i < n-1 then append ", "); inner a) a; append "]" + | Sexp (t, a) -> let n = List.length a in + append "`"; append t; append " ("; List.iteri (fun i a -> (if i < n-1 then append ", "); inner a) a; append ")" + in + inner v; + Buffer.contents buf + end (* States *) @@ -116,10 +130,11 @@ module Builtin = | Value.Sexp (_, 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)) - | "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)) + | ".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)) + | ".stringval" -> let [a] = args in (st, i, o, Some (Value.of_string @@ Value.string_val a)) + | "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)) end @@ -131,15 +146,16 @@ module Expr = notation, it came from GT. *) @type t = - (* integer constant *) | Const of int - (* array *) | Array of t list - (* string *) | String of string - (* S-expressions *) | Sexp of string * t list - (* variable *) | Var of string - (* binary operator *) | Binop of string * t * t - (* element extraction *) | Elem of t * t - (* length *) | Length of t - (* function call *) | Call of string * t list with show + (* integer constant *) | Const of int + (* array *) | Array of t list + (* string *) | String of string + (* S-expressions *) | Sexp of string * t list + (* variable *) | Var of string + (* binary operator *) | Binop of string * t * t + (* element extraction *) | Elem of t * t + (* length *) | Length of t + (* string conversion *) | StringVal of t + (* function call *) | Call of string * t list with show (* Available binary operators: !! --- disjunction @@ -187,8 +203,11 @@ module Expr = let rec eval env ((st, i, o, r) as conf) expr = match expr with - | Const n -> (st, i, o, Some (Value.of_int n)) - | String s -> (st, i, o, Some (Value.of_string s)) + | Const n -> (st, i, o, Some (Value.of_int n)) + | String s -> (st, i, o, Some (Value.of_string s)) + | StringVal s -> + let (st, i, o, Some s) = eval env conf s in + (st, i, o, Some (Value.of_string @@ Value.string_val s)) | Var x -> (st, i, o, Some (State.eval st x)) | Array xs -> let (st, i, o, vs) = eval_list env conf xs in @@ -248,8 +267,8 @@ module Expr = |] ) primary); - primary: b:base is:(-"[" i:parse -"]" {`Elem i} | "." %"length" {`Len}) * - {List.fold_left (fun b -> function `Elem i -> Elem (b, i) | `Len -> Length b) b is}; + primary: b:base is:(-"[" i:parse -"]" {`Elem i} | -"." (%"length" {`Len} | %"string" {`Str})) * + {List.fold_left (fun b -> function `Elem i -> Elem (b, i) | `Len -> Length b | `Str -> StringVal b) b is}; base: n:DECIMAL {Const n} | s:STRING {String (String.sub s 1 (String.length s - 2))} diff --git a/src/SM.ml b/src/SM.ml index 11894b921..62c394a35 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -183,6 +183,7 @@ let compile (defs, p) = | Expr.Sexp (t, xs) -> List.flatten (List.map expr xs) @ [SEXP (t, List.length xs)] | Expr.Elem (a, i) -> expr a @ expr i @ [CALL (".elem", 2, false)] | Expr.Length e -> expr e @ [CALL (".length", 1, false)] + | Expr.StringVal e -> expr e @ [CALL (".stringval", 1, false)] in let rec compile_stmt l env = function | Stmt.Assign (x, [], e) -> env, false, expr e @ [ST x] From 9bc99679124a3ea74eb9b8ffb75b73b7acfbebdf Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Wed, 31 Oct 2018 21:48:44 +0300 Subject: [PATCH 18/32] Added test for .string --- regression/orig/test045.log | 43 +++++++++++++++++++++++++++++++++++++ regression/test045.expr | 12 +++++++++++ regression/test045.input | 1 + runtime/runtime.c | 12 ++++++----- src/Language.ml | 4 ++-- 5 files changed, 65 insertions(+), 7 deletions(-) create mode 100644 regression/orig/test045.log create mode 100644 regression/test045.expr create mode 100644 regression/test045.input diff --git a/regression/orig/test045.log b/regression/orig/test045.log new file mode 100644 index 000000000..5a4da1720 --- /dev/null +++ b/regression/orig/test045.log @@ -0,0 +1,43 @@ +> 49 +34 +97 +98 +99 +34 +91 +93 +91 +49 +44 +32 +50 +44 +32 +51 +93 +96 +99 +111 +110 +115 +32 +40 +49 +44 +32 +96 +99 +111 +110 +115 +32 +40 +50 +44 +32 +96 +110 +105 +108 +41 +41 diff --git a/regression/test045.expr b/regression/test045.expr new file mode 100644 index 000000000..246780277 --- /dev/null +++ b/regression/test045.expr @@ -0,0 +1,12 @@ +fun printString (s) local i { + for i := 0, i < s.length, i := i + 1 do + write (s[i]) + od +} + +x := read (); +printString (1.string); +printString ("abc".string); +printString ([].string); +printString ([1, 2, 3].string); +printString (`cons (1, `cons (2, `nil)).string) \ No newline at end of file diff --git a/regression/test045.input b/regression/test045.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/test045.input @@ -0,0 +1 @@ +0 diff --git a/runtime/runtime.c b/runtime/runtime.c index c766c4465..c4677c97f 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -121,12 +121,14 @@ static void printValue (void *p) { case SEXP_TAG: printStringBuf ("`%s", de_hash (TO_SEXP(p)->tag)); - printStringBuf (" ("); - for (int i = 0; i < LEN(a->tag); i++) { - printValue ((void*)((int*) a->contents)[i]); - if (i != LEN(a->tag) - 1) printStringBuf (", "); + if (LEN(a->tag)) { + printStringBuf (" ("); + for (int i = 0; i < LEN(a->tag); i++) { + printValue ((void*)((int*) a->contents)[i]); + if (i != LEN(a->tag) - 1) printStringBuf (", "); + } + printStringBuf (")"); } - printStringBuf (")"); break; default: diff --git a/src/Language.ml b/src/Language.ml index a0547f7b6..b48a77cad 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -44,9 +44,9 @@ module Value = | Int n -> append (string_of_int n) | String s -> append "\""; append s; append "\"" | Array a -> let n = List.length a in - append "["; List.iteri (fun i a -> (if i < n-1 then append ", "); inner a) a; append "]" + append "["; List.iteri (fun i a -> (if i > 0 then append ", "); inner a) a; append "]" | Sexp (t, a) -> let n = List.length a in - append "`"; append t; append " ("; List.iteri (fun i a -> (if i < n-1 then append ", "); inner a) a; append ")" + append "`"; append t; (if n > 0 then (append " ("; List.iteri (fun i a -> (if i > 0 then append ", "); inner a) a; append ")")) in inner v; Buffer.contents buf From 66de3dd1f9bee3766d8da7f6d9961e066ee0f760 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Thu, 1 Nov 2018 15:08:13 +0300 Subject: [PATCH 19/32] Added missing file --- regression/test034.expr | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 regression/test034.expr diff --git a/regression/test034.expr b/regression/test034.expr new file mode 100644 index 000000000..0a624a069 --- /dev/null +++ b/regression/test034.expr @@ -0,0 +1,17 @@ +fun printString (x) { + for i:=0, i Date: Thu, 1 Nov 2018 15:12:45 +0300 Subject: [PATCH 20/32] Added x86only --- regression/test.sh | 1 + regression/x86only/Makefile | 13 +++++++++++++ regression/x86only/orig/test001.log | 12 ++++++++++++ regression/x86only/test001.expr | 19 +++++++++++++++++++ regression/x86only/test001.input | 1 + 5 files changed, 46 insertions(+) create mode 100644 regression/x86only/Makefile create mode 100644 regression/x86only/orig/test001.log create mode 100644 regression/x86only/test001.expr create mode 100644 regression/x86only/test001.input diff --git a/regression/test.sh b/regression/test.sh index 61dca4a12..5cdc61484 100755 --- a/regression/test.sh +++ b/regression/test.sh @@ -1,3 +1,4 @@ make check pushd expressions && make check && popd pushd deep-expressions && make check && popd +pushd x86only && make check && popd diff --git a/regression/x86only/Makefile b/regression/x86only/Makefile new file mode 100644 index 000000000..d78ca38c1 --- /dev/null +++ b/regression/x86only/Makefile @@ -0,0 +1,13 @@ +TESTS=$(basename $(wildcard test*.expr)) + +RC=../../src/rc.opt + +.PHONY: check $(TESTS) + +check: $(TESTS) + +$(TESTS): %: %.expr + @RC_RUNTIME=../../runtime $(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log + +clean: + rm -f test*.log *.s *~ $(TESTS) diff --git a/regression/x86only/orig/test001.log b/regression/x86only/orig/test001.log new file mode 100644 index 000000000..b89fb7132 --- /dev/null +++ b/regression/x86only/orig/test001.log @@ -0,0 +1,12 @@ +`Empty +`Node (0, `Empty, `Empty) +`Node (0, `Empty, `Node (1, `Empty, `Empty)) +`Node (0, `Empty, `Node (1, `Empty, `Node (2, `Empty, `Empty))) +`Node (0, `Empty, `Node (1, `Empty, `Node (2, `Empty, `Node (3, `Empty, `Empty)))) +`Node (0, `Empty, `Node (1, `Empty, `Node (2, `Empty, `Node (3, `Empty, `Node (4, `Empty, `Empty))))) +`Node (0, `Empty, `Node (1, `Empty, `Node (2, `Empty, `Node (3, `Empty, `Node (4, `Empty, `Node (5, `Empty, `Empty)))))) +`Node (0, `Empty, `Node (1, `Empty, `Node (2, `Empty, `Node (3, `Empty, `Node (4, `Empty, `Node (5, `Empty, `Node (6, `Empty, `Empty))))))) +`Node (0, `Empty, `Node (1, `Empty, `Node (2, `Empty, `Node (3, `Empty, `Node (4, `Empty, `Node (5, `Empty, `Node (6, `Empty, `Node (7, `Empty, `Empty)))))))) +`Node (0, `Empty, `Node (1, `Empty, `Node (2, `Empty, `Node (3, `Empty, `Node (4, `Empty, `Node (5, `Empty, `Node (6, `Empty, `Node (7, `Empty, `Node (8, `Empty, `Empty))))))))) +`Node (0, `Empty, `Node (1, `Empty, `Node (2, `Empty, `Node (3, `Empty, `Node (4, `Empty, `Node (5, `Empty, `Node (6, `Empty, `Node (7, `Empty, `Node (8, `Empty, `Node (9, `Empty, `Empty)))))))))) +`Node (0, `Empty, `Node (1, `Empty, `Node (2, `Empty, `Node (3, `Empty, `Node (4, `Empty, `Node (5, `Empty, `Node (6, `Empty, `Node (7, `Empty, `Node (8, `Empty, `Node (9, `Empty, `Node (10, `Empty, `Empty))))))))))) diff --git a/regression/x86only/test001.expr b/regression/x86only/test001.expr new file mode 100644 index 000000000..486bef831 --- /dev/null +++ b/regression/x86only/test001.expr @@ -0,0 +1,19 @@ +fun insert (tree, value) { + case tree of + `Empty -> return `Node (value, `Empty, `Empty) + | `Node (x, left, right) -> + if x > value + then return `Node (x, insert (left, value), right) + else return `Node (x, left, insert (right, value)) + fi + esac +} + +tree := `Empty; + +for i := 0, i <= 10, i := i+1 do + printf ("%s\n", tree.string); + tree := insert (tree, i) +od; + +printf ("%s\n", tree.string) diff --git a/regression/x86only/test001.input b/regression/x86only/test001.input new file mode 100644 index 000000000..8b1378917 --- /dev/null +++ b/regression/x86only/test001.input @@ -0,0 +1 @@ + From d7ca482b25fb578c19387687e890eb4ded385243 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Sun, 4 Nov 2018 12:54:26 +0300 Subject: [PATCH 21/32] Sync --- src/Language.ml | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/src/Language.ml b/src/Language.ml index b48a77cad..ef947a5aa 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -246,15 +246,15 @@ module Expr = DECIMAL --- a decimal constant [0-9]+ as a string *) ostap ( - parse: + parse: !(Ostap.Util.expr (fun x -> x) (Array.map (fun (a, s) -> a, List.map (fun s -> ostap(- $(s)), (fun x y -> - match s with - "++" -> Call ("strcat", [x; y]) - | _ -> Binop (s, x, y) + match s with + | "++" -> Call ("strcat", [x; y]) + | _ -> Binop (s, x, y) ) ) s ) @@ -266,17 +266,17 @@ module Expr = `Lefta, ["*" ; "/"; "%"]; |] ) - primary); + primary); primary: b:base is:(-"[" i:parse -"]" {`Elem i} | -"." (%"length" {`Len} | %"string" {`Str})) * - {List.fold_left (fun b -> function `Elem i -> Elem (b, i) | `Len -> Length b | `Str -> StringVal b) b is}; + {List.fold_left (fun b -> function `Elem i -> Elem (b, i) | `Len -> Length b | `Str -> StringVal b) b is}; base: - n:DECIMAL {Const n} + n:DECIMAL {Const n} | s:STRING {String (String.sub s 1 (String.length s - 2))} | c:CHAR {Const (Char.code c)} | "[" es:!(Util.list0)[parse] "]" {Array es} | "`" t:IDENT args:(-"(" !(Util.list)[parse] -")")? {Sexp (t, match args with None -> [] | Some args -> args)} | x:IDENT s:("(" args:!(Util.list0)[parse] ")" {Call (x, args)} | empty {Var x}) {s} - | -"(" parse -")" + | -"(" parse -")" ) end From 00e808a92168774e548552cac5d7be5a40a623e7 Mon Sep 17 00:00:00 2001 From: danyabeerzun Date: Tue, 6 Nov 2018 14:25:28 +0300 Subject: [PATCH 22/32] Fixed ugly bug in runtime (.string) --- runtime/runtime.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/runtime/runtime.c b/runtime/runtime.c index c4677c97f..ecb6b3328 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -85,10 +85,11 @@ static void extendStringBuf () { static void printStringBuf (char *fmt, ...) { va_list args; int written, rest; - char *buf = &stringBuf.contents[stringBuf.ptr]; + char *buf; again: va_start (args, fmt); + buf = &stringBuf.contents[stringBuf.ptr]; rest = stringBuf.len - stringBuf.ptr; written = vsnprintf (buf, rest, fmt, args); From 12c90391b90a76a331e4ba0da73f99352a5ca8b6 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Mon, 5 Nov 2018 18:21:41 +0300 Subject: [PATCH 23/32] 'as' pattern --- regression/Makefile | 6 ++-- regression/orig/test046.log | 6 ++++ regression/test046.expr | 21 ++++++++++++++ regression/test046.input | 1 + src/Driver.ml | 3 +- src/Language.ml | 24 +++++++++++++--- src/SM.ml | 56 ++++++++++++++++++++++--------------- src/X86.ml | 3 +- 8 files changed, 89 insertions(+), 31 deletions(-) create mode 100644 regression/orig/test046.log create mode 100644 regression/test046.expr create mode 100644 regression/test046.input diff --git a/regression/Makefile b/regression/Makefile index 0fc4b3f96..7d1cce545 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -7,9 +7,9 @@ RC=../src/rc.opt check: $(TESTS) $(TESTS): %: %.expr - @$(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 + $(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 clean: rm -f test*.log *.s *~ $(TESTS) diff --git a/regression/orig/test046.log b/regression/orig/test046.log new file mode 100644 index 000000000..5c1aac067 --- /dev/null +++ b/regression/orig/test046.log @@ -0,0 +1,6 @@ +> 3 +3 +3 +1 +2 +3 diff --git a/regression/test046.expr b/regression/test046.expr new file mode 100644 index 000000000..a3922863f --- /dev/null +++ b/regression/test046.expr @@ -0,0 +1,21 @@ +n := read (); + +case 3 of + a -> write (a) +| _ -> write (0) +esac; + +case 3 of + a -> write (a) +esac; + +case 3 of + a@_ -> write (a) +esac; + +case `a (1, 2, 3) of + `b -> write (1) +| a@`a (_, _, _) -> case a of + `a (x, y, z) -> write (x); write (y); write (z) + esac +esac \ No newline at end of file diff --git a/regression/test046.input b/regression/test046.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/test046.input @@ -0,0 +1 @@ +0 diff --git a/src/Driver.ml b/src/Driver.ml index 773d96daa..2239a6693 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -16,7 +16,8 @@ let parse infile = "fun"; "local"; "return"; "length"; "string"; - "case"; "of"; "esac"; "when"] s + "case"; "of"; "esac"; "when"; + "boxed"; "unboxed"; "string"; "sexp"; "array"] s inherit Util.Lexers.skip [ Matcher.Skip.whitespaces " \t\n"; Matcher.Skip.lineComment "--"; diff --git a/src/Language.ml b/src/Language.ml index ef947a5aa..52bcc6d68 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -293,7 +293,15 @@ module Stmt = @type t = (* wildcard "-" *) | Wildcard (* S-expression *) | Sexp of string * t list - (* identifier *) | Ident of string + (* array *) | Array of t list + (* identifier *) | Named of string * t + (* ground integer *) | Const of int + (* ground string *) | String of string + (* boxed value *) | Boxed + (* unboxed value *) | UnBoxed + (* any string value *) | StringTag + (* any sexp value *) | SexpTag + (* any array value *) | ArrayTag with show, foldl (* Pattern parser *) @@ -301,11 +309,19 @@ module Stmt = parse: %"_" {Wildcard} | "`" t:IDENT ps:(-"(" !(Util.list)[parse] -")")? {Sexp (t, match ps with None -> [] | Some ps -> ps)} - | x:IDENT {Ident x} + | "[" ps:(!(Util.list0)[parse]) "]" {Array ps} + | x:IDENT y:(-"@" parse)? {match y with None -> Named (x, Wildcard) | Some y -> Named (x, y)} + | c:DECIMAL {Const c} + | s:STRING {String s} + | "#" %"boxed" {Boxed} + | "#" %"unboxed" {UnBoxed} + | "#" %"string" {StringTag} + | "#" %"sexp" {SexpTag} + | "#" %"array" {ArrayTag} ) let vars p = fix0 (fun f -> - transform(t) (object inherit [string list, _] @t[foldl] f method c_Ident s name = name::s end)) [] p + transform(t) (object inherit [string list, _] @t[foldl] f method c_Named s name p = name :: f s p end)) [] p end @@ -371,7 +387,7 @@ module Stmt = | Some s -> Some (State.bind x v s) in match patt, v with - | Pattern.Ident x , v -> update x v st + | Pattern.Named (x, p), v -> update x v (match_patt p v st ) | Pattern.Wildcard , _ -> st | Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' -> match_list ps vs st | _ -> None diff --git a/src/SM.ml b/src/SM.ml index 62c394a35..67bb418e7 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -136,7 +136,7 @@ let compile (defs, p) = args_code @ [CALL (label f, List.length args, p)] and pattern env lfalse = function | Stmt.Pattern.Wildcard -> env, false, [DROP] - | Stmt.Pattern.Ident n -> env, false, [DROP] + | Stmt.Pattern.Named (_, p) -> pattern env lfalse p | Stmt.Pattern.Sexp (t, ps) -> let ltag , env = env#get_label in let ldrop, env = env#get_label in @@ -157,8 +157,16 @@ let compile (defs, p) = transform(Stmt.Pattern.t) (object inherit [int list, (string * int list) list, _] @Stmt.Pattern.t method c_Wildcard path = [] - method c_Ident path s = [s, path] + method c_Named path s p = [s, path] @ fself path p method c_Sexp path x ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps + method c_UnBoxed = invalid_arg "" + method c_StringTag = invalid_arg "" + method c_String = invalid_arg "" + method c_SexpTag = invalid_arg "" + method c_Const = invalid_arg "" + method c_Boxed = invalid_arg "" + method c_ArrayTag = invalid_arg "" + method c_Array = invalid_arg "" end)) [] p @@ -216,30 +224,34 @@ let compile (defs, p) = | Stmt.Leave -> env, false, [LEAVE] - | Stmt.Case (e, [p, s]) -> - let ldrop, env = env#get_label in - let env, _, pcode = pattern env ldrop p in - let env, _, scode = compile_stmt ldrop env (Stmt.Seq (s, Stmt.Leave)) in - env, true, expr e @ [DUP] @ pcode @ bindings p @ scode @ [JMP l; LABEL ldrop; DROP] + | Stmt.Case (e, [p, s]) -> + let ldrop, env = env#get_label in + let env, ldrop' , pcode = pattern env ldrop p in + let env, ldrop'', scode = compile_stmt ldrop env (Stmt.Seq (s, Stmt.Leave)) in + if ldrop' || ldrop'' + then env, true , expr e @ [DUP] @ pcode @ bindings p @ scode @ [JMP l; LABEL ldrop; DROP] + else env, false, expr e @ [DUP] @ pcode @ bindings p @ scode - | Stmt.Case (e, brs) -> - let n = List.length brs - 1 in - (*let ldrop, env = env#get_label in*) - let env, _, _, code = + | Stmt.Case (e, brs) -> + let n = List.length brs - 1 in + let env, _, _, code, _ = List.fold_left - (fun (env, lab, i, code) (p, s) -> - let (lfalse, env), jmp = - if i = n - then (l, env), [] - else env#get_label, [JMP l] - in - let env, _, pcode = pattern env lfalse p in - let env, _, scode = compile_stmt l(*ldrop*) env (Stmt.Seq (s, Stmt.Leave)) in - (env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l; DUP]) @ pcode @ bindings p @ scode @ jmp) :: code) + (fun ((env, lab, i, code, continue) as acc) (p, s) -> + if continue + then + let (lfalse, env), jmp = + if i = n + then (l, env), [] + else env#get_label, [JMP l] + in + let env, lfalse', pcode = pattern env lfalse p in + let env, l' , scode = compile_stmt l env (Stmt.Seq (s, Stmt.Leave)) in + (env, Some lfalse, i+1, ((match lab with None -> [] | Some l -> [LABEL l; DUP]) @ pcode @ bindings p @ scode @ jmp) :: code, lfalse') + else acc ) - (env, None, 0, []) brs + (env, None, 0, [], true) brs in - env, true, expr e @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l] (*; LABEL ldrop; DROP]*) + env, true, expr e @ [DUP] @ (List.flatten @@ List.rev code) @ [JMP l] in let compile_def env (name, (args, locals, stmt)) = let lend, env = env#get_label in diff --git a/src/X86.ml b/src/X86.ml index 24b019271..70b89c476 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -310,7 +310,8 @@ let compile env code = let env, code = call env ".sexp" (n+1) false in env, [Mov (L env#hash t, s)] @ code - | DROP -> snd env#pop, [] + | DROP -> + snd env#pop, [] | DUP -> let x = env#peek in From 9569598775dd5f817123f22098718918b41995fa Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Mon, 5 Nov 2018 20:17:11 +0300 Subject: [PATCH 24/32] Fixed bug in sexp arity --- regression/orig/test046.log | 1 + regression/test046.expr | 11 ++++++++- runtime/runtime.c | 4 ++-- src/Language.ml | 2 +- src/SM.ml | 46 ++++++++++++++++++------------------- src/X86.ml | 9 ++++---- 6 files changed, 42 insertions(+), 31 deletions(-) diff --git a/regression/orig/test046.log b/regression/orig/test046.log index 5c1aac067..dae76f132 100644 --- a/regression/orig/test046.log +++ b/regression/orig/test046.log @@ -4,3 +4,4 @@ 1 2 3 +5 diff --git a/regression/test046.expr b/regression/test046.expr index a3922863f..b8fad763b 100644 --- a/regression/test046.expr +++ b/regression/test046.expr @@ -14,8 +14,17 @@ case 3 of esac; case `a (1, 2, 3) of - `b -> write (1) + `a -> write (1) | a@`a (_, _, _) -> case a of `a (x, y, z) -> write (x); write (y); write (z) esac +esac; + +case `a (1, 2, 3, 4, 5) of + `a -> write (0) +| `a (_) -> write (1) +| `a (_, _) -> write (2) +| `a (_, _, _) -> write (3) +| `a (_, _, _, _) -> write (4) +| `a (_, _, _, _, _) -> write (5) esac \ No newline at end of file diff --git a/runtime/runtime.c b/runtime/runtime.c index ecb6b3328..a44eea4e3 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -218,9 +218,9 @@ extern void* Bsexp (int n, ...) { return d->contents; } -extern int Btag (void *d, int t) { +extern int Btag (void *d, int t, int n) { data *r = TO_DATA(d); - return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t); + return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t && LEN(r->tag) == n); } extern void Bsta (int n, int v, void *s, ...) { diff --git a/src/Language.ml b/src/Language.ml index 52bcc6d68..ce346c4c1 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -130,7 +130,7 @@ module Builtin = | Value.Sexp (_, 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))) + | ".length" -> (st, i, o, Some (Value.of_int (match List.hd args with Value.Sexp (_, a) | Value.Array a -> List.length a | Value.String s -> String.length s))) | ".array" -> (st, i, o, Some (Value.of_array args)) | ".stringval" -> let [a] = args in (st, i, o, Some (Value.of_string @@ Value.string_val a)) | "isArray" -> let [a] = args in (st, i, o, Some (Value.of_int @@ match a with Value.Array _ -> 1 | _ -> 0)) diff --git a/src/SM.ml b/src/SM.ml index 67bb418e7..39f701fac 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -3,26 +3,26 @@ open Language (* The type for the stack machine instructions *) @type insn = -(* binary operator *) | BINOP of string -(* put a constant on the stack *) | CONST of int -(* put a string on the stack *) | STRING of string -(* create an S-expression *) | SEXP of string * int -(* load a variable to the stack *) | LD of string -(* store a variable from the stack *) | ST of string -(* store in an array *) | STA of string * int -(* a label *) | LABEL of string -(* unconditional jump *) | JMP of string -(* conditional jump *) | CJMP of string * string -(* begins procedure definition *) | BEGIN of string * string list * string list -(* end procedure definition *) | END -(* calls a function/procedure *) | CALL of string * int * bool -(* returns from a function *) | RET of bool -(* drops the top element off *) | DROP -(* duplicates the top element *) | DUP -(* swaps two top elements *) | SWAP -(* checks the tag of S-expression *) | TAG of string -(* enters a scope *) | ENTER of string list -(* leaves a scope *) | LEAVE +(* binary operator *) | BINOP of string +(* put a constant on the stack *) | CONST of int +(* put a string on the stack *) | STRING of string +(* create an S-expression *) | SEXP of string * int +(* load a variable to the stack *) | LD of string +(* store a variable from the stack *) | ST of string +(* store in an array *) | STA of string * int +(* a label *) | LABEL of string +(* unconditional jump *) | JMP of string +(* conditional jump *) | CJMP of string * string +(* begins procedure definition *) | BEGIN of string * string list * string list +(* end procedure definition *) | END +(* calls a function/procedure *) | CALL of string * int * bool +(* returns from a function *) | RET of bool +(* drops the top element off *) | DROP +(* duplicates the top element *) | DUP +(* swaps two top elements *) | SWAP +(* checks the tag and arity of S-expression *) | TAG of string * int +(* enters a scope *) | ENTER of string list +(* leaves a scope *) | LEAVE with show (* The type for the stack machine program *) @@ -79,8 +79,8 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function | DUP -> eval env (cstack, List.hd stack :: stack, c) prg' | SWAP -> let x::y::stack' = stack in eval env (cstack, y::x::stack', c) prg' - | TAG t -> let x::stack' = stack in - eval env (cstack, (Value.of_int @@ match x with Value.Sexp (t', _) when t' = t -> 1 | _ -> 0) :: stack', c) prg' + | TAG (t, n) -> let x::stack' = stack in + eval env (cstack, (Value.of_int @@ match x with Value.Sexp (t', a) when t' = t && List.length a = n -> 1 | _ -> 0) :: stack', c) prg' | ENTER xs -> let vs, stack' = split (List.length xs) stack in eval env (cstack, stack', (State.push st (List.fold_left (fun s (x, v) -> State.bind x v s) State.undefined (List.combine xs vs)) xs, i, o)) prg' @@ -140,7 +140,7 @@ let compile (defs, p) = | Stmt.Pattern.Sexp (t, ps) -> let ltag , env = env#get_label in let ldrop, env = env#get_label in - let tag = [DUP; TAG t; CJMP ("nz", ltag); LABEL ldrop; DROP; JMP lfalse; LABEL ltag] in + let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", ltag); LABEL ldrop; DROP; JMP lfalse; LABEL ltag] in let _, env, code = List.fold_left (fun (i, env, code) p -> diff --git a/src/X86.ml b/src/X86.ml index 70b89c476..b51ccad38 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -322,10 +322,11 @@ let compile env code = let x, y = env#peek2 in env, [Push x; Push y; Pop x; Pop y] - | TAG t -> - let s, env = env#allocate in - let env, code = call env ".tag" 2 false in - env, [Mov (L env#hash t, s)] @ code + | TAG (t, n) -> + let s1, env = env#allocate in + let s2, env = env#allocate in + let env, code = call env ".tag" 3 false in + env, [Mov (L env#hash t, s1); Mov (L n, s2)] @ code | ENTER xs -> let env, code = From 155ad46ec289fa31060d427e3268feba31fc6783 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Tue, 6 Nov 2018 00:21:38 +0300 Subject: [PATCH 25/32] Extended pattern-matching --- regression/Makefile | 6 +-- regression/orig/test046.log | 6 +++ regression/orig/test047.log | 17 +++++++ regression/test046.expr | 10 +++- regression/test047.expr | 72 +++++++++++++++++++++++++++++ regression/test047.input | 1 + runtime/runtime.c | 47 ++++++++++++++++++- src/Language.ml | 27 +++++++---- src/SM.ml | 91 +++++++++++++++++++++++++------------ src/X86.ml | 21 ++++++++- 10 files changed, 253 insertions(+), 45 deletions(-) create mode 100644 regression/orig/test047.log create mode 100644 regression/test047.expr create mode 100644 regression/test047.input diff --git a/regression/Makefile b/regression/Makefile index 7d1cce545..0fc4b3f96 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -7,9 +7,9 @@ RC=../src/rc.opt check: $(TESTS) $(TESTS): %: %.expr - $(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 + @$(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 clean: rm -f test*.log *.s *~ $(TESTS) diff --git a/regression/orig/test046.log b/regression/orig/test046.log index dae76f132..f33ba2d92 100644 --- a/regression/orig/test046.log +++ b/regression/orig/test046.log @@ -5,3 +5,9 @@ 2 3 5 +5 +1 +2 +3 +4 +5 diff --git a/regression/orig/test047.log b/regression/orig/test047.log new file mode 100644 index 000000000..b98c3e4e7 --- /dev/null +++ b/regression/orig/test047.log @@ -0,0 +1,17 @@ +> 1 +1 +1 +1 +1 +2 +3 +100 +3 +2 +1 +6 +5 +4 +3 +2 +1 diff --git a/regression/test046.expr b/regression/test046.expr index b8fad763b..9a0a8d106 100644 --- a/regression/test046.expr +++ b/regression/test046.expr @@ -27,4 +27,12 @@ case `a (1, 2, 3, 4, 5) of | `a (_, _, _) -> write (3) | `a (_, _, _, _) -> write (4) | `a (_, _, _, _, _) -> write (5) -esac \ No newline at end of file +esac; + +write (`a (1, 2, 3, 4, 5).length); + +write (`a (1, 2, 3, 4, 5)[0]); +write (`a (1, 2, 3, 4, 5)[1]); +write (`a (1, 2, 3, 4, 5)[2]); +write (`a (1, 2, 3, 4, 5)[3]); +write (`a (1, 2, 3, 4, 5)[4]) diff --git a/regression/test047.expr b/regression/test047.expr new file mode 100644 index 000000000..37516ac0b --- /dev/null +++ b/regression/test047.expr @@ -0,0 +1,72 @@ +fun collect_ints_acc (v, tail) local i { + case v of + a@#unboxed -> return `cons (a, tail) + | #string -> return tail + | _ -> + for i := 0, i < v.length, i := i + 1 do + tail := collect_ints_acc (v[i], tail) + od; + return tail + esac +} + +fun collect_ints (v) { + return collect_ints_acc (v, `nil) +} + +fun print_list (l) { + case l of + `nil -> skip + | `cons (n, t) -> write (n); print_list (t) + esac +} + +n := read (); + +case 1 of + 5 -> write (5) +| 4 -> write (4) +| 3 -> write (3) +| 2 -> write (2) +| 1 -> write (1) +| 0 -> write (0) +esac; + +case 1 of + a@5 -> write (a) +| a@4 -> write (a) +| a@3 -> write (a) +| a@2 -> write (a) +| a@1 -> write (a) +| a@0 -> write (a) +esac; + +case `a (1, 2, 3) of + `a (1, 3, 5) -> write (0) +| `a (3, 4, 5) -> write (0) +| `a (1, 2, 3) -> write (1) +| `a (6, 7, 8) -> write (0) +esac; + +case "abc" of + "def" -> write (0) +| "ab" -> write (0) +| "abc" -> write (1) +| "" -> write (0) +esac; + +case [1, 2, 3] of + [] -> write (0) +| [a, b] -> write (0) +| [a, b, c] -> write (a); write (b); write (c) +| [_, _, _] -> write (0) +esac; + +case [1, 2, 3] of + [] -> write (0) +| [a, b] -> write (0) +| [_, _, _] -> write (100) +| [a, b, c] -> write (a); write (b); write (c) +esac; + +print_list (collect_ints ([1, 2, 3, [4, 5, 6, `cons (1, 2, 3)]])) diff --git a/regression/test047.input b/regression/test047.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/test047.input @@ -0,0 +1 @@ +0 diff --git a/runtime/runtime.c b/runtime/runtime.c index a44eea4e3..c4a110dad 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -222,7 +222,52 @@ extern int Btag (void *d, int t, int n) { data *r = TO_DATA(d); return BOX(TAG(r->tag) == SEXP_TAG && TO_SEXP(d)->tag == t && LEN(r->tag) == n); } - + +extern int Barray_patt (void *d, int n) { + if (UNBOXED(d)) return BOX(0); + else { + data *r = TO_DATA(d); + return BOX(TAG(r->tag) == ARRAY_TAG && LEN(r->tag) == n); + } +} + +extern int Bstring_patt (void *x, void *y) { + if (UNBOXED(x)) return BOX(0); + else { + data *rx = TO_DATA(x), *ry = TO_DATA(y); + + if (TAG(rx->tag) != STRING_TAG) return BOX(0); + + return BOX(strcmp (rx->contents, ry->contents) == 0 ? 1 : 0); + } +} + +extern int Bboxed_patt (void *x) { + return BOX(UNBOXED(x) ? 0 : 1); +} + +extern int Bunboxed_patt (void *x) { + return BOX(UNBOXED(x) ? 1 : 0); +} + +extern int Barray_tag_patt (void *x) { + if (UNBOXED(x)) return BOX(0); + + return BOX(TAG(TO_DATA(x)->tag) == ARRAY_TAG); +} + +extern int Bstring_tag_patt (void *x) { + if (UNBOXED(x)) return BOX(0); + + return BOX(TAG(TO_DATA(x)->tag) == STRING_TAG); +} + +extern int Bsexp_tag_patt (void *x) { + if (UNBOXED(x)) return BOX(0); + + return BOX(TAG(TO_DATA(x)->tag) == SEXP_TAG); +} + extern void Bsta (int n, int v, void *s, ...) { va_list args; int i, k; diff --git a/src/Language.ml b/src/Language.ml index ce346c4c1..33a0fd4ed 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -132,10 +132,8 @@ module Builtin = ) | ".length" -> (st, i, o, Some (Value.of_int (match List.hd args with Value.Sexp (_, a) | Value.Array a -> List.length a | Value.String s -> String.length s))) | ".array" -> (st, i, o, Some (Value.of_array args)) - | ".stringval" -> let [a] = args in (st, i, o, Some (Value.of_string @@ Value.string_val a)) - | "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)) - + | ".stringval" -> let [a] = args in (st, i, o, Some (Value.of_string @@ Value.string_val a)) + end (* Simple expressions: syntax and semantics *) @@ -312,7 +310,8 @@ module Stmt = | "[" ps:(!(Util.list0)[parse]) "]" {Array ps} | x:IDENT y:(-"@" parse)? {match y with None -> Named (x, Wildcard) | Some y -> Named (x, y)} | c:DECIMAL {Const c} - | s:STRING {String s} + | s:STRING {String (String.sub s 1 (String.length s - 2))} + | c:CHAR {Const (Char.code c)} | "#" %"boxed" {Boxed} | "#" %"unboxed" {UnBoxed} | "#" %"string" {StringTag} @@ -387,10 +386,20 @@ module Stmt = | Some s -> Some (State.bind x v s) in match patt, v with - | Pattern.Named (x, p), v -> update x v (match_patt p v st ) - | Pattern.Wildcard , _ -> st - | Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' -> match_list ps vs st - | _ -> None + | Pattern.Named (x, p), v -> update x v (match_patt p v st ) + | Pattern.Wildcard , _ -> st + | Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' && List.length ps = List.length vs -> match_list ps vs st + | Pattern.Array ps , Value.Array vs when List.length ps = List.length vs -> match_list ps vs st + | Pattern.Const n , Value.Int n' when n = n' -> st + | Pattern.String s , Value.String s' when s = s' -> st + | Pattern.Boxed , Value.String _ + | Pattern.Boxed , Value.Array _ + | Pattern.UnBoxed , Value.Int _ + | Pattern.Boxed , Value.Sexp (_, _) + | Pattern.StringTag , Value.String _ + | Pattern.ArrayTag , Value.Array _ + | Pattern.SexpTag , Value.Sexp (_, _) -> st + | _ -> None and match_list ps vs s = match ps, vs with | [], [] -> s diff --git a/src/SM.ml b/src/SM.ml index 39f701fac..118548281 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -1,6 +1,9 @@ open GT open Language - + +(* The type for patters *) +@type patt = StrCmp | String | Array | Sexp | Boxed | UnBoxed with show + (* The type for the stack machine instructions *) @type insn = (* binary operator *) | BINOP of string @@ -21,6 +24,8 @@ open Language (* duplicates the top element *) | DUP (* swaps two top elements *) | SWAP (* checks the tag and arity of S-expression *) | TAG of string * int +(* checks the tag and size of array *) | ARRAY of int +(* checks various patterns *) | PATT of patt (* enters a scope *) | ENTER of string list (* leaves a scope *) | LEAVE with show @@ -28,7 +33,7 @@ with show (* The type for the stack machine program *) type prg = insn list -let print_prg p = List.iter (fun i -> Printf.printf "%s\n" (show(insn) i)) p +let print_prg p = List.iter (fun i -> Printf.printf "%s\n\!" (show(insn) i)) p (* The type for the stack machine configuration: control stack, stack and configuration from statement interpreter @@ -81,10 +86,22 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function eval env (cstack, y::x::stack', c) prg' | TAG (t, n) -> let x::stack' = stack in eval env (cstack, (Value.of_int @@ match x with Value.Sexp (t', a) when t' = t && List.length a = n -> 1 | _ -> 0) :: stack', c) prg' - + | ARRAY n -> let x::stack' = stack in + eval env (cstack, (Value.of_int @@ match x with Value.Array a when List.length a = n -> 1 | _ -> 0) :: stack', c) prg' + | PATT StrCmp -> let x::y::stack' = stack in + eval env (cstack, (Value.of_int @@ match x, y with (Value.String xs, Value.String ys) when xs = ys -> 1 | _ -> 0) :: stack', c) prg' + | PATT Array -> let x::stack' = stack in + eval env (cstack, (Value.of_int @@ match x with Value.Array _ -> 1 | _ -> 0) :: stack', c) prg' + | PATT String -> let x::stack' = stack in + eval env (cstack, (Value.of_int @@ match x with Value.String _ -> 1 | _ -> 0) :: stack', c) prg' + | PATT Sexp -> let x::stack' = stack in + eval env (cstack, (Value.of_int @@ match x with Value.Sexp _ -> 1 | _ -> 0) :: stack', c) prg' + | PATT Boxed -> let x::stack' = stack in + eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 0 | _ -> 1) :: stack', c) prg' + | PATT UnBoxed -> let x::stack' = stack in + eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 1 | _ -> 0) :: stack', c) prg' | ENTER xs -> let vs, stack' = split (List.length xs) stack in eval env (cstack, stack', (State.push st (List.fold_left (fun s (x, v) -> State.bind x v s) State.undefined (List.combine xs vs)) xs, i, o)) prg' - | LEAVE -> eval env (cstack, stack, (State.drop st, i, o)) prg' ) @@ -95,7 +112,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 @@ -137,36 +154,52 @@ let compile (defs, p) = and pattern env lfalse = function | Stmt.Pattern.Wildcard -> env, false, [DROP] | Stmt.Pattern.Named (_, p) -> pattern env lfalse p - | Stmt.Pattern.Sexp (t, ps) -> - let ltag , env = env#get_label in + | Stmt.Pattern.Const c -> env, true, [CONST c; BINOP "=="; CJMP ("z", lfalse)] + | Stmt.Pattern.String s -> env, true, [STRING s; PATT StrCmp; CJMP ("z", lfalse)] + | Stmt.Pattern.ArrayTag -> env, true, [PATT Array; CJMP ("z", lfalse)] + | Stmt.Pattern.StringTag -> env, true, [PATT String; CJMP ("z", lfalse)] + | Stmt.Pattern.SexpTag -> env, true, [PATT Sexp; CJMP ("z", lfalse)] + | Stmt.Pattern.UnBoxed -> env, true, [PATT UnBoxed; CJMP ("z", lfalse)] + | Stmt.Pattern.Boxed -> env, true, [PATT Boxed; CJMP ("z", lfalse)] + | Stmt.Pattern.Array ps -> + let lhead, env = env#get_label in let ldrop, env = env#get_label in - let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", ltag); LABEL ldrop; DROP; JMP lfalse; LABEL ltag] in - let _, env, code = - List.fold_left - (fun (i, env, code) p -> - let env, _, pcode = pattern env ldrop p in - i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code - ) - (0, env, []) - ps - in - env, true, tag @ List.flatten (List.rev code) @ [DROP] + let tag = [DUP; ARRAY (List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in + let code, env = pattern_list lhead ldrop env ps in + env, true, tag @ code @ [DROP] + | Stmt.Pattern.Sexp (t, ps) -> + let lhead, env = env#get_label in + let ldrop, env = env#get_label in + let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in + let code, env = pattern_list lhead ldrop env ps in + env, true, tag @ code @ [DROP] + and pattern_list lhead ldrop env ps = + let _, env, code = + List.fold_left + (fun (i, env, code) p -> + let env, _, pcode = pattern env ldrop p in + i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code + ) + (0, env, []) + ps + in + List.flatten (List.rev code), env and bindings p = let bindings = fix0 (fun fself -> transform(Stmt.Pattern.t) (object inherit [int list, (string * int list) list, _] @Stmt.Pattern.t - method c_Wildcard path = [] - method c_Named path s p = [s, path] @ fself path p - method c_Sexp path x ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps - method c_UnBoxed = invalid_arg "" - method c_StringTag = invalid_arg "" - method c_String = invalid_arg "" - method c_SexpTag = invalid_arg "" - method c_Const = invalid_arg "" - method c_Boxed = invalid_arg "" - method c_ArrayTag = invalid_arg "" - method c_Array = invalid_arg "" + method c_Wildcard path = [] + method c_Named path s p = [s, path] @ fself path p + method c_Sexp path x ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps + method c_UnBoxed _ = [] + method c_StringTag _ = [] + method c_String _ _ = [] + method c_SexpTag _ = [] + method c_Const _ _ = [] + method c_Boxed _ = [] + method c_ArrayTag _ = [] + method c_Array path ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps end)) [] p diff --git a/src/X86.ml b/src/X86.ml index b51ccad38..27f6833d4 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -326,8 +326,25 @@ let compile env code = let s1, env = env#allocate in let s2, env = env#allocate in let env, code = call env ".tag" 3 false in - env, [Mov (L env#hash t, s1); Mov (L n, s2)] @ code - + env, [Mov (L env#hash t, s1); Mov (L n, s2)] @ code + + | ARRAY n -> + let s, env = env#allocate in + let env, code = call env ".array_patt" 2 false in + env, [Mov (L n, s)] @ code + + | PATT StrCmp -> call env ".string_patt" 2 false + + | PATT patt -> + call env + (match patt with + | Boxed -> ".boxed_patt" + | UnBoxed -> ".unboxed_patt" + | Array -> ".array_tag_patt" + | String -> ".string_tag_patt" + | Sexp -> ".sexp_tag_patt" + ) 1 false + | ENTER xs -> let env, code = List.fold_left From 5bfc0a08ec9a16fc315de228a22f9815ae1ee4ce Mon Sep 17 00:00:00 2001 From: danyaberezun Date: Mon, 12 Nov 2018 16:28:21 +0300 Subject: [PATCH 26/32] merge --- regression/Makefile | 6 +++--- regression/orig/test046.log | 9 +-------- regression/test046.expr | 21 ++------------------- src/Language.ml | 21 +++++---------------- src/SM.ml | 35 +++++++++++------------------------ 5 files changed, 22 insertions(+), 70 deletions(-) diff --git a/regression/Makefile b/regression/Makefile index 0fc4b3f96..7d1cce545 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -7,9 +7,9 @@ RC=../src/rc.opt check: $(TESTS) $(TESTS): %: %.expr - @$(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 + $(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 clean: rm -f test*.log *.s *~ $(TESTS) diff --git a/regression/orig/test046.log b/regression/orig/test046.log index f33ba2d92..bdb9ab676 100644 --- a/regression/orig/test046.log +++ b/regression/orig/test046.log @@ -3,11 +3,4 @@ 3 1 2 -3 -5 -5 -1 -2 -3 -4 -5 +3 \ No newline at end of file diff --git a/regression/test046.expr b/regression/test046.expr index 9a0a8d106..c670c95d4 100644 --- a/regression/test046.expr +++ b/regression/test046.expr @@ -14,25 +14,8 @@ case 3 of esac; case `a (1, 2, 3) of - `a -> write (1) + `b -> write (1) | a@`a (_, _, _) -> case a of `a (x, y, z) -> write (x); write (y); write (z) esac -esac; - -case `a (1, 2, 3, 4, 5) of - `a -> write (0) -| `a (_) -> write (1) -| `a (_, _) -> write (2) -| `a (_, _, _) -> write (3) -| `a (_, _, _, _) -> write (4) -| `a (_, _, _, _, _) -> write (5) -esac; - -write (`a (1, 2, 3, 4, 5).length); - -write (`a (1, 2, 3, 4, 5)[0]); -write (`a (1, 2, 3, 4, 5)[1]); -write (`a (1, 2, 3, 4, 5)[2]); -write (`a (1, 2, 3, 4, 5)[3]); -write (`a (1, 2, 3, 4, 5)[4]) +esac diff --git a/src/Language.ml b/src/Language.ml index 33a0fd4ed..10a7a366a 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -310,8 +310,7 @@ module Stmt = | "[" ps:(!(Util.list0)[parse]) "]" {Array ps} | x:IDENT y:(-"@" parse)? {match y with None -> Named (x, Wildcard) | Some y -> Named (x, y)} | c:DECIMAL {Const c} - | s:STRING {String (String.sub s 1 (String.length s - 2))} - | c:CHAR {Const (Char.code c)} + | s:STRING {String s} | "#" %"boxed" {Boxed} | "#" %"unboxed" {UnBoxed} | "#" %"string" {StringTag} @@ -386,20 +385,10 @@ module Stmt = | Some s -> Some (State.bind x v s) in match patt, v with - | Pattern.Named (x, p), v -> update x v (match_patt p v st ) - | Pattern.Wildcard , _ -> st - | Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' && List.length ps = List.length vs -> match_list ps vs st - | Pattern.Array ps , Value.Array vs when List.length ps = List.length vs -> match_list ps vs st - | Pattern.Const n , Value.Int n' when n = n' -> st - | Pattern.String s , Value.String s' when s = s' -> st - | Pattern.Boxed , Value.String _ - | Pattern.Boxed , Value.Array _ - | Pattern.UnBoxed , Value.Int _ - | Pattern.Boxed , Value.Sexp (_, _) - | Pattern.StringTag , Value.String _ - | Pattern.ArrayTag , Value.Array _ - | Pattern.SexpTag , Value.Sexp (_, _) -> st - | _ -> None + | Pattern.Named (x, p), v -> update x v (match_patt p v st ) + | Pattern.Wildcard , _ -> st + | Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' -> match_list ps vs st + | _ -> None and match_list ps vs s = match ps, vs with | [], [] -> s diff --git a/src/SM.ml b/src/SM.ml index 118548281..0845e3886 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -154,19 +154,6 @@ let compile (defs, p) = and pattern env lfalse = function | Stmt.Pattern.Wildcard -> env, false, [DROP] | Stmt.Pattern.Named (_, p) -> pattern env lfalse p - | Stmt.Pattern.Const c -> env, true, [CONST c; BINOP "=="; CJMP ("z", lfalse)] - | Stmt.Pattern.String s -> env, true, [STRING s; PATT StrCmp; CJMP ("z", lfalse)] - | Stmt.Pattern.ArrayTag -> env, true, [PATT Array; CJMP ("z", lfalse)] - | Stmt.Pattern.StringTag -> env, true, [PATT String; CJMP ("z", lfalse)] - | Stmt.Pattern.SexpTag -> env, true, [PATT Sexp; CJMP ("z", lfalse)] - | Stmt.Pattern.UnBoxed -> env, true, [PATT UnBoxed; CJMP ("z", lfalse)] - | Stmt.Pattern.Boxed -> env, true, [PATT Boxed; CJMP ("z", lfalse)] - | Stmt.Pattern.Array ps -> - let lhead, env = env#get_label in - let ldrop, env = env#get_label in - let tag = [DUP; ARRAY (List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in - let code, env = pattern_list lhead ldrop env ps in - env, true, tag @ code @ [DROP] | Stmt.Pattern.Sexp (t, ps) -> let lhead, env = env#get_label in let ldrop, env = env#get_label in @@ -189,17 +176,17 @@ let compile (defs, p) = fix0 (fun fself -> transform(Stmt.Pattern.t) (object inherit [int list, (string * int list) list, _] @Stmt.Pattern.t - method c_Wildcard path = [] - method c_Named path s p = [s, path] @ fself path p - method c_Sexp path x ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps - method c_UnBoxed _ = [] - method c_StringTag _ = [] - method c_String _ _ = [] - method c_SexpTag _ = [] - method c_Const _ _ = [] - method c_Boxed _ = [] - method c_ArrayTag _ = [] - method c_Array path ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps + method c_Wildcard path = [] + method c_Named path s p = [s, path] @ fself path p + method c_Sexp path x ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps + method c_UnBoxed = invalid_arg "" + method c_StringTag = invalid_arg "" + method c_String = invalid_arg "" + method c_SexpTag = invalid_arg "" + method c_Const = invalid_arg "" + method c_Boxed = invalid_arg "" + method c_ArrayTag = invalid_arg "" + method c_Array = invalid_arg "" end)) [] p From c9bfede950196ca34151ed6f184f1f9194da1f22 Mon Sep 17 00:00:00 2001 From: danyaberezun Date: Mon, 12 Nov 2018 16:32:24 +0300 Subject: [PATCH 27/32] merge --- regression/orig/test046.log | 3 ++- regression/test046.expr | 13 ++++++++++-- src/SM.ml | 41 ++++++++++--------------------------- src/X86.ml | 20 +----------------- 4 files changed, 25 insertions(+), 52 deletions(-) diff --git a/regression/orig/test046.log b/regression/orig/test046.log index bdb9ab676..dae76f132 100644 --- a/regression/orig/test046.log +++ b/regression/orig/test046.log @@ -3,4 +3,5 @@ 3 1 2 -3 \ No newline at end of file +3 +5 diff --git a/regression/test046.expr b/regression/test046.expr index c670c95d4..b8fad763b 100644 --- a/regression/test046.expr +++ b/regression/test046.expr @@ -14,8 +14,17 @@ case 3 of esac; case `a (1, 2, 3) of - `b -> write (1) + `a -> write (1) | a@`a (_, _, _) -> case a of `a (x, y, z) -> write (x); write (y); write (z) esac -esac +esac; + +case `a (1, 2, 3, 4, 5) of + `a -> write (0) +| `a (_) -> write (1) +| `a (_, _) -> write (2) +| `a (_, _, _) -> write (3) +| `a (_, _, _, _) -> write (4) +| `a (_, _, _, _, _) -> write (5) +esac \ No newline at end of file diff --git a/src/SM.ml b/src/SM.ml index 0845e3886..32e1fca7e 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -24,8 +24,6 @@ open Language (* duplicates the top element *) | DUP (* swaps two top elements *) | SWAP (* checks the tag and arity of S-expression *) | TAG of string * int -(* checks the tag and size of array *) | ARRAY of int -(* checks various patterns *) | PATT of patt (* enters a scope *) | ENTER of string list (* leaves a scope *) | LEAVE with show @@ -86,20 +84,6 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function eval env (cstack, y::x::stack', c) prg' | TAG (t, n) -> let x::stack' = stack in eval env (cstack, (Value.of_int @@ match x with Value.Sexp (t', a) when t' = t && List.length a = n -> 1 | _ -> 0) :: stack', c) prg' - | ARRAY n -> let x::stack' = stack in - eval env (cstack, (Value.of_int @@ match x with Value.Array a when List.length a = n -> 1 | _ -> 0) :: stack', c) prg' - | PATT StrCmp -> let x::y::stack' = stack in - eval env (cstack, (Value.of_int @@ match x, y with (Value.String xs, Value.String ys) when xs = ys -> 1 | _ -> 0) :: stack', c) prg' - | PATT Array -> let x::stack' = stack in - eval env (cstack, (Value.of_int @@ match x with Value.Array _ -> 1 | _ -> 0) :: stack', c) prg' - | PATT String -> let x::stack' = stack in - eval env (cstack, (Value.of_int @@ match x with Value.String _ -> 1 | _ -> 0) :: stack', c) prg' - | PATT Sexp -> let x::stack' = stack in - eval env (cstack, (Value.of_int @@ match x with Value.Sexp _ -> 1 | _ -> 0) :: stack', c) prg' - | PATT Boxed -> let x::stack' = stack in - eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 0 | _ -> 1) :: stack', c) prg' - | PATT UnBoxed -> let x::stack' = stack in - eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 1 | _ -> 0) :: stack', c) prg' | ENTER xs -> let vs, stack' = split (List.length xs) stack in eval env (cstack, stack', (State.push st (List.fold_left (fun s (x, v) -> State.bind x v s) State.undefined (List.combine xs vs)) xs, i, o)) prg' | LEAVE -> eval env (cstack, stack, (State.drop st, i, o)) prg' @@ -157,20 +141,17 @@ let compile (defs, p) = | Stmt.Pattern.Sexp (t, ps) -> let lhead, env = env#get_label in let ldrop, env = env#get_label in - let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in - let code, env = pattern_list lhead ldrop env ps in - env, true, tag @ code @ [DROP] - and pattern_list lhead ldrop env ps = - let _, env, code = - List.fold_left - (fun (i, env, code) p -> - let env, _, pcode = pattern env ldrop p in - i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code - ) - (0, env, []) - ps - in - List.flatten (List.rev code), env + let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", ltag); LABEL ldrop; DROP; JMP lfalse; LABEL ltag] in + let _, env, code = + List.fold_left + (fun (i, env, code) p -> + let env, _, pcode = pattern env ldrop p in + i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code + ) + (0, env, []) + ps + in + env, true, tag @ List.flatten (List.rev code) @ [DROP] and bindings p = let bindings = fix0 (fun fself -> diff --git a/src/X86.ml b/src/X86.ml index 27f6833d4..176ab218c 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -326,25 +326,7 @@ let compile env code = let s1, env = env#allocate in let s2, env = env#allocate in let env, code = call env ".tag" 3 false in - env, [Mov (L env#hash t, s1); Mov (L n, s2)] @ code - - | ARRAY n -> - let s, env = env#allocate in - let env, code = call env ".array_patt" 2 false in - env, [Mov (L n, s)] @ code - - | PATT StrCmp -> call env ".string_patt" 2 false - - | PATT patt -> - call env - (match patt with - | Boxed -> ".boxed_patt" - | UnBoxed -> ".unboxed_patt" - | Array -> ".array_tag_patt" - | String -> ".string_tag_patt" - | Sexp -> ".sexp_tag_patt" - ) 1 false - + env, [Mov (L env#hash t, s1); Mov (L n, s2)] @ code | ENTER xs -> let env, code = List.fold_left From 4d54809acb6b11bd4acd71a1b3ac2176e90ea458 Mon Sep 17 00:00:00 2001 From: danyaberezun Date: Mon, 12 Nov 2018 16:33:44 +0300 Subject: [PATCH 28/32] merge --- regression/Makefile | 6 +-- regression/orig/test046.log | 6 +++ regression/test046.expr | 10 ++++- src/Language.ml | 21 +++++++--- src/SM.ml | 76 ++++++++++++++++++++++++++----------- src/X86.ml | 19 +++++++++- 6 files changed, 106 insertions(+), 32 deletions(-) diff --git a/regression/Makefile b/regression/Makefile index 7d1cce545..0fc4b3f96 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -7,9 +7,9 @@ RC=../src/rc.opt check: $(TESTS) $(TESTS): %: %.expr - $(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 + @$(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 clean: rm -f test*.log *.s *~ $(TESTS) diff --git a/regression/orig/test046.log b/regression/orig/test046.log index dae76f132..f33ba2d92 100644 --- a/regression/orig/test046.log +++ b/regression/orig/test046.log @@ -5,3 +5,9 @@ 2 3 5 +5 +1 +2 +3 +4 +5 diff --git a/regression/test046.expr b/regression/test046.expr index b8fad763b..9a0a8d106 100644 --- a/regression/test046.expr +++ b/regression/test046.expr @@ -27,4 +27,12 @@ case `a (1, 2, 3, 4, 5) of | `a (_, _, _) -> write (3) | `a (_, _, _, _) -> write (4) | `a (_, _, _, _, _) -> write (5) -esac \ No newline at end of file +esac; + +write (`a (1, 2, 3, 4, 5).length); + +write (`a (1, 2, 3, 4, 5)[0]); +write (`a (1, 2, 3, 4, 5)[1]); +write (`a (1, 2, 3, 4, 5)[2]); +write (`a (1, 2, 3, 4, 5)[3]); +write (`a (1, 2, 3, 4, 5)[4]) diff --git a/src/Language.ml b/src/Language.ml index 10a7a366a..33a0fd4ed 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -310,7 +310,8 @@ module Stmt = | "[" ps:(!(Util.list0)[parse]) "]" {Array ps} | x:IDENT y:(-"@" parse)? {match y with None -> Named (x, Wildcard) | Some y -> Named (x, y)} | c:DECIMAL {Const c} - | s:STRING {String s} + | s:STRING {String (String.sub s 1 (String.length s - 2))} + | c:CHAR {Const (Char.code c)} | "#" %"boxed" {Boxed} | "#" %"unboxed" {UnBoxed} | "#" %"string" {StringTag} @@ -385,10 +386,20 @@ module Stmt = | Some s -> Some (State.bind x v s) in match patt, v with - | Pattern.Named (x, p), v -> update x v (match_patt p v st ) - | Pattern.Wildcard , _ -> st - | Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' -> match_list ps vs st - | _ -> None + | Pattern.Named (x, p), v -> update x v (match_patt p v st ) + | Pattern.Wildcard , _ -> st + | Pattern.Sexp (t, ps), Value.Sexp (t', vs) when t = t' && List.length ps = List.length vs -> match_list ps vs st + | Pattern.Array ps , Value.Array vs when List.length ps = List.length vs -> match_list ps vs st + | Pattern.Const n , Value.Int n' when n = n' -> st + | Pattern.String s , Value.String s' when s = s' -> st + | Pattern.Boxed , Value.String _ + | Pattern.Boxed , Value.Array _ + | Pattern.UnBoxed , Value.Int _ + | Pattern.Boxed , Value.Sexp (_, _) + | Pattern.StringTag , Value.String _ + | Pattern.ArrayTag , Value.Array _ + | Pattern.SexpTag , Value.Sexp (_, _) -> st + | _ -> None and match_list ps vs s = match ps, vs with | [], [] -> s diff --git a/src/SM.ml b/src/SM.ml index 32e1fca7e..118548281 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -24,6 +24,8 @@ open Language (* duplicates the top element *) | DUP (* swaps two top elements *) | SWAP (* checks the tag and arity of S-expression *) | TAG of string * int +(* checks the tag and size of array *) | ARRAY of int +(* checks various patterns *) | PATT of patt (* enters a scope *) | ENTER of string list (* leaves a scope *) | LEAVE with show @@ -84,6 +86,20 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function eval env (cstack, y::x::stack', c) prg' | TAG (t, n) -> let x::stack' = stack in eval env (cstack, (Value.of_int @@ match x with Value.Sexp (t', a) when t' = t && List.length a = n -> 1 | _ -> 0) :: stack', c) prg' + | ARRAY n -> let x::stack' = stack in + eval env (cstack, (Value.of_int @@ match x with Value.Array a when List.length a = n -> 1 | _ -> 0) :: stack', c) prg' + | PATT StrCmp -> let x::y::stack' = stack in + eval env (cstack, (Value.of_int @@ match x, y with (Value.String xs, Value.String ys) when xs = ys -> 1 | _ -> 0) :: stack', c) prg' + | PATT Array -> let x::stack' = stack in + eval env (cstack, (Value.of_int @@ match x with Value.Array _ -> 1 | _ -> 0) :: stack', c) prg' + | PATT String -> let x::stack' = stack in + eval env (cstack, (Value.of_int @@ match x with Value.String _ -> 1 | _ -> 0) :: stack', c) prg' + | PATT Sexp -> let x::stack' = stack in + eval env (cstack, (Value.of_int @@ match x with Value.Sexp _ -> 1 | _ -> 0) :: stack', c) prg' + | PATT Boxed -> let x::stack' = stack in + eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 0 | _ -> 1) :: stack', c) prg' + | PATT UnBoxed -> let x::stack' = stack in + eval env (cstack, (Value.of_int @@ match x with Value.Int _ -> 1 | _ -> 0) :: stack', c) prg' | ENTER xs -> let vs, stack' = split (List.length xs) stack in eval env (cstack, stack', (State.push st (List.fold_left (fun s (x, v) -> State.bind x v s) State.undefined (List.combine xs vs)) xs, i, o)) prg' | LEAVE -> eval env (cstack, stack, (State.drop st, i, o)) prg' @@ -138,36 +154,52 @@ let compile (defs, p) = and pattern env lfalse = function | Stmt.Pattern.Wildcard -> env, false, [DROP] | Stmt.Pattern.Named (_, p) -> pattern env lfalse p + | Stmt.Pattern.Const c -> env, true, [CONST c; BINOP "=="; CJMP ("z", lfalse)] + | Stmt.Pattern.String s -> env, true, [STRING s; PATT StrCmp; CJMP ("z", lfalse)] + | Stmt.Pattern.ArrayTag -> env, true, [PATT Array; CJMP ("z", lfalse)] + | Stmt.Pattern.StringTag -> env, true, [PATT String; CJMP ("z", lfalse)] + | Stmt.Pattern.SexpTag -> env, true, [PATT Sexp; CJMP ("z", lfalse)] + | Stmt.Pattern.UnBoxed -> env, true, [PATT UnBoxed; CJMP ("z", lfalse)] + | Stmt.Pattern.Boxed -> env, true, [PATT Boxed; CJMP ("z", lfalse)] + | Stmt.Pattern.Array ps -> + let lhead, env = env#get_label in + let ldrop, env = env#get_label in + let tag = [DUP; ARRAY (List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in + let code, env = pattern_list lhead ldrop env ps in + env, true, tag @ code @ [DROP] | Stmt.Pattern.Sexp (t, ps) -> let lhead, env = env#get_label in let ldrop, env = env#get_label in - let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", ltag); LABEL ldrop; DROP; JMP lfalse; LABEL ltag] in - let _, env, code = - List.fold_left - (fun (i, env, code) p -> - let env, _, pcode = pattern env ldrop p in - i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code - ) - (0, env, []) - ps - in - env, true, tag @ List.flatten (List.rev code) @ [DROP] + let tag = [DUP; TAG (t, List.length ps); CJMP ("nz", lhead); LABEL ldrop; DROP; JMP lfalse; LABEL lhead] in + let code, env = pattern_list lhead ldrop env ps in + env, true, tag @ code @ [DROP] + and pattern_list lhead ldrop env ps = + let _, env, code = + List.fold_left + (fun (i, env, code) p -> + let env, _, pcode = pattern env ldrop p in + i+1, env, ([DUP; CONST i; CALL (".elem", 2, false)] @ pcode) :: code + ) + (0, env, []) + ps + in + List.flatten (List.rev code), env and bindings p = let bindings = fix0 (fun fself -> transform(Stmt.Pattern.t) (object inherit [int list, (string * int list) list, _] @Stmt.Pattern.t - method c_Wildcard path = [] - method c_Named path s p = [s, path] @ fself path p - method c_Sexp path x ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps - method c_UnBoxed = invalid_arg "" - method c_StringTag = invalid_arg "" - method c_String = invalid_arg "" - method c_SexpTag = invalid_arg "" - method c_Const = invalid_arg "" - method c_Boxed = invalid_arg "" - method c_ArrayTag = invalid_arg "" - method c_Array = invalid_arg "" + method c_Wildcard path = [] + method c_Named path s p = [s, path] @ fself path p + method c_Sexp path x ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps + method c_UnBoxed _ = [] + method c_StringTag _ = [] + method c_String _ _ = [] + method c_SexpTag _ = [] + method c_Const _ _ = [] + method c_Boxed _ = [] + method c_ArrayTag _ = [] + method c_Array path ps = List.concat @@ List.mapi (fun i p -> fself (path @ [i]) p) ps end)) [] p diff --git a/src/X86.ml b/src/X86.ml index 176ab218c..dd69089f7 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -326,7 +326,24 @@ let compile env code = let s1, env = env#allocate in let s2, env = env#allocate in let env, code = call env ".tag" 3 false in - env, [Mov (L env#hash t, s1); Mov (L n, s2)] @ code + env, [Mov (L env#hash t, s1); Mov (L n, s2)] @ code + + | ARRAY n -> + let s, env = env#allocate in + let env, code = call env ".array_patt" 2 false in + env, [Mov (L n, s)] @ code + + | PATT StrCmp -> call env ".string_patt" 2 false + + | PATT patt -> + call env + (match patt with + | Boxed -> ".boxed_patt" + | UnBoxed -> ".unboxed_patt" + | Array -> ".array_tag_patt" + | String -> ".string_tag_patt" + | Sexp -> ".sexp_tag_patt" + ) 1 false | ENTER xs -> let env, code = List.fold_left From 75a09f45e8cbfac900e5ce3d85a59e1402163b7f Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Tue, 6 Nov 2018 14:03:55 +0300 Subject: [PATCH 29/32] Added test to x86only --- regression/x86only/orig/test002.log | 9 +++++ regression/x86only/test002.expr | 63 +++++++++++++++++++++++++++++ regression/x86only/test002.input | 1 + 3 files changed, 73 insertions(+) create mode 100644 regression/x86only/orig/test002.log create mode 100644 regression/x86only/test002.expr create mode 100644 regression/x86only/test002.input diff --git a/regression/x86only/orig/test002.log b/regression/x86only/orig/test002.log new file mode 100644 index 000000000..047d48e6c --- /dev/null +++ b/regression/x86only/orig/test002.log @@ -0,0 +1,9 @@ +1 +1 +1 +1 +1 +2 +3 +100 +`cons (3, `cons (2, `cons (1, `cons (6, `cons (5, `cons (4, `cons (3, `cons (2, `cons (1, `nil))))))))) diff --git a/regression/x86only/test002.expr b/regression/x86only/test002.expr new file mode 100644 index 000000000..37616d334 --- /dev/null +++ b/regression/x86only/test002.expr @@ -0,0 +1,63 @@ +fun collect_ints_acc (v, tail) local i { + case v of + a@#unboxed -> return `cons (a, tail) + | #string -> return tail + | _ -> + for i := 0, i < v.length, i := i + 1 do + tail := collect_ints_acc (v[i], tail) + od; + return tail + esac +} + +fun collect_ints (v) { + return collect_ints_acc (v, `nil) +} + +case 1 of + 5 -> write (5) +| 4 -> write (4) +| 3 -> write (3) +| 2 -> write (2) +| 1 -> write (1) +| 0 -> write (0) +esac; + +case 1 of + a@5 -> write (a) +| a@4 -> write (a) +| a@3 -> write (a) +| a@2 -> write (a) +| a@1 -> write (a) +| a@0 -> write (a) +esac; + +case `a (1, 2, 3) of + `a (1, 3, 5) -> write (0) +| `a (3, 4, 5) -> write (0) +| `a (1, 2, 3) -> write (1) +| `a (6, 7, 8) -> write (0) +esac; + +case "abc" of + "def" -> write (0) +| "ab" -> write (0) +| "abc" -> write (1) +| "" -> write (0) +esac; + +case [1, 2, 3] of + [] -> write (0) +| [a, b] -> write (0) +| [a, b, c] -> write (a); write (b); write (c) +| [_, _, _] -> write (0) +esac; + +case [1, 2, 3] of + [] -> write (0) +| [a, b] -> write (0) +| [_, _, _] -> write (100) +| [a, b, c] -> write (a); write (b); write (c) +esac; + +printf ("%s\n", collect_ints ([1, 2, 3, [4, 5, 6, `cons (1, 2, 3)]]).string) diff --git a/regression/x86only/test002.input b/regression/x86only/test002.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/x86only/test002.input @@ -0,0 +1 @@ +0 From 3e95c3b8f51a87e801198e871b100d1366004bb1 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Tue, 6 Nov 2018 17:10:35 +0300 Subject: [PATCH 30/32] Some extra tests --- regression/orig/test048.log | 3 +++ regression/orig/test049.log | 3 +++ regression/test048.expr | 9 +++++++++ regression/test048.input | 1 + regression/test049.expr | 19 +++++++++++++++++++ regression/test049.input | 1 + 6 files changed, 36 insertions(+) create mode 100644 regression/orig/test048.log create mode 100644 regression/orig/test049.log create mode 100644 regression/test048.expr create mode 100644 regression/test048.input create mode 100644 regression/test049.expr create mode 100644 regression/test049.input diff --git a/regression/orig/test048.log b/regression/orig/test048.log new file mode 100644 index 000000000..9536400a4 --- /dev/null +++ b/regression/orig/test048.log @@ -0,0 +1,3 @@ +> 7 +7 +28 diff --git a/regression/orig/test049.log b/regression/orig/test049.log new file mode 100644 index 000000000..20b1d6a07 --- /dev/null +++ b/regression/orig/test049.log @@ -0,0 +1,3 @@ +> 55 +310 +310 diff --git a/regression/test048.expr b/regression/test048.expr new file mode 100644 index 000000000..d84d9bc8b --- /dev/null +++ b/regression/test048.expr @@ -0,0 +1,9 @@ +fun test (n, m) local i, s { + write (n); + write (m); + return n +} + +n := read (); +y := 1 + (2 + (3 + (4 + (5 + (6 + test (7, 7)))))); +write (y) \ No newline at end of file diff --git a/regression/test048.input b/regression/test048.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/test048.input @@ -0,0 +1 @@ +0 diff --git a/regression/test049.expr b/regression/test049.expr new file mode 100644 index 000000000..f3e6d32a6 --- /dev/null +++ b/regression/test049.expr @@ -0,0 +1,19 @@ +fun test (n, m) local i, s { + s := 0; + for i := 0, i <= n, i := i + 1 do + s := s + i; + if s > m then return s fi + od; + + return s +} + +n := read (); +y := ((((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))))) + ((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))))) + (((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))))) + ((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + test(10, 100))))))))); + +t := test(10, 100); +y2 := ((((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))))) + ((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))))) + (((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))))) + ((((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))))) + (((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1)))) + ((((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + 1))) + (((1 + 1) + (1 + 1)) + ((1 + 1) + (1 + t)))))))); + +write (t); +write (y2); +write (y) \ No newline at end of file diff --git a/regression/test049.input b/regression/test049.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/test049.input @@ -0,0 +1 @@ +0 From 7f01e91b057304ab48a614a86a183fddc696f738 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Wed, 7 Nov 2018 15:05:01 +0300 Subject: [PATCH 31/32] Fixed README --- README.md | 2 +- regression/x86only/test001.expr | 2 +- regression/x86only/test002.expr | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index 552617ec3..1163d4b01 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ Prerequisites: ocaml [http://ocaml.org], opam [http://opam.ocaml.org]. Building: -* `opam pin add GT https://github.com/dboulytchev/GT.git` +* `opam pin add GT https://github.com/kakasu/GT.git#ppx` * `opam pin add ostap https://github.com/dboulytchev/ostap.git` * `opam install ostap` * `opam install GT` diff --git a/regression/x86only/test001.expr b/regression/x86only/test001.expr index 486bef831..50c3333a7 100644 --- a/regression/x86only/test001.expr +++ b/regression/x86only/test001.expr @@ -1,6 +1,6 @@ fun insert (tree, value) { case tree of - `Empty -> return `Node (value, `Empty, `Empty) + `Empty -> return `Node (value, `Empty, `Empty) | `Node (x, left, right) -> if x > value then return `Node (x, insert (left, value), right) diff --git a/regression/x86only/test002.expr b/regression/x86only/test002.expr index 37616d334..cbfcab27b 100644 --- a/regression/x86only/test002.expr +++ b/regression/x86only/test002.expr @@ -1,7 +1,7 @@ fun collect_ints_acc (v, tail) local i { case v of a@#unboxed -> return `cons (a, tail) - | #string -> return tail + | #string -> return tail | _ -> for i := 0, i < v.length, i := i + 1 do tail := collect_ints_acc (v[i], tail) From a181c2d287f3d795d0d4de1cdff5275aa3eda5d7 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Wed, 7 Nov 2018 15:05:36 +0300 Subject: [PATCH 32/32] Fixed README yet again --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 1163d4b01..2f6632dab 100644 --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ Prerequisites: ocaml [http://ocaml.org], opam [http://opam.ocaml.org]. Building: -* `opam pin add GT https://github.com/kakasu/GT.git#ppx` +* `opam pin add GT https://github.com/kakadu/GT.git#ppx` * `opam pin add ostap https://github.com/dboulytchev/ostap.git` * `opam install ostap` * `opam install GT`