diff --git a/regression/Makefile b/regression/Makefile index aa3113c79..8dae071dc 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -9,7 +9,7 @@ check: $(TESTS) $(TESTS): %: %.expr @echo $@ $(RC) $< && cat $@.input | ./$@ 2> /dev/null > $@.log && diff $@.log orig/$@.log - cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log +# cat $@.input | $(RC) -i $< > $@.log && diff $@.log orig/$@.log cat $@.input | $(RC) -s $< 2> /dev/null > $@.log && diff $@.log orig/$@.log clean: diff --git a/regression/test058.expr b/regression/test058.expr index db8aa9c97..b77010f70 100644 --- a/regression/test058.expr +++ b/regression/test058.expr @@ -15,6 +15,8 @@ fun print_list (x) { esac } +local x = read (); + print_list ({1, 2, 3}); print_list (map (a, {1, 2, 3})); print_list (map (b, {1, 2, 3})) diff --git a/regression/test059.expr b/regression/test059.expr index 060a1e571..54af4a310 100644 --- a/regression/test059.expr +++ b/regression/test059.expr @@ -17,4 +17,6 @@ fun c () { write (2) } +local x = read (); + f ({a, b, c}) \ No newline at end of file diff --git a/regression/test060.expr b/regression/test060.expr index 912f71826..8d7f16d71 100644 --- a/regression/test060.expr +++ b/regression/test060.expr @@ -10,6 +10,8 @@ fun f (l) { esac } +local x = read (); + write (f ({})); write (f ({1})); write (f ({1, 1})); diff --git a/regression/test063.expr b/regression/test063.expr index 2b4cfdf61..fbf54fbd0 100644 --- a/regression/test063.expr +++ b/regression/test063.expr @@ -6,4 +6,6 @@ fun traverse (l) { esac } +local x = read (); + traverse ({1, fun () write(100), 2, 3, 4, 5, fun () write (200), 6, 7}) \ No newline at end of file diff --git a/regression/test064.expr b/regression/test064.expr index 78c2344d1..018d3d214 100644 --- a/regression/test064.expr +++ b/regression/test064.expr @@ -1,3 +1,5 @@ infixr "++" at "+" (a, b) {return a+b} +local x = read (); + write (infix "++" (2, 3)) \ No newline at end of file diff --git a/runtime/runtime.c b/runtime/runtime.c index a9e51ad70..3c24d1f5a 100644 --- a/runtime/runtime.c +++ b/runtime/runtime.c @@ -8,7 +8,13 @@ # include # include -// # define DEBUG_PRINT 1 +/*# define __ENABLE_GC__*/ +# ifndef __ENABLE_GC__ +# define alloc malloc +# endif + +/*# define DEBUG_PRINT 1*/ + /* GC pool structure and data; declared here in order to allow debug print */ typedef struct { size_t * begin; @@ -22,14 +28,27 @@ static pool to_space; size_t *current; /* end */ +# ifdef __ENABLE_GC__ + /* GC extern invariant for built-in functions */ extern void __pre_gc (); extern void __post_gc (); + +# else + +# define __pre_gc __pre_gc_subst +# define __post_gc __post_gc_subst + +void __pre_gc_subst () {} +void __post_gc_subst () {} + +# endif /* end */ -# define STRING_TAG 0x00000001 -# define ARRAY_TAG 0x00000003 -# define SEXP_TAG 0x00000005 +# define STRING_TAG 0x00000001 +# define ARRAY_TAG 0x00000003 +# define SEXP_TAG 0x00000005 +# define CLOSURE_TAG 0x00000007 # define LEN(x) ((x & 0xFFFFFFF8) >> 3) # define TAG(x) (x & 0x00000007) @@ -244,6 +263,36 @@ extern void* Bstringval (void *p) { return s; } +extern void* Bclosure (int n, void *entry, ...) { + va_list args = (va_list) BOX (NULL); + int i = BOX(0), + ai = BOX(0); + data *r = (data*) BOX (NULL); + + __pre_gc (); + +#ifdef DEBUG_PRINT + printf ("Bclosure: create n = %d\n", n); fflush(stdout); +#endif + r = (data*) alloc (sizeof(int) * (n+2)); + + r->tag = CLOSURE_TAG | (n << 3); + ((void**) r->contents)[0] = entry; + + va_start(args, n); + + for (i = 1; icontents)[i] = ai; + } + + va_end(args); + + __post_gc(); + + return r->contents; +} + extern void* Barray (int n, ...) { va_list args = (va_list) BOX (NULL); int i = BOX(0), @@ -350,6 +399,12 @@ extern int Bstring_patt (void *x, void *y) { } } +extern int Bclosure_tag_patt (void *x) { + if (UNBOXED(x)) return BOX(0); + + return BOX(TAG(TO_DATA(x)->tag) == CLOSURE_TAG); +} + extern int Bboxed_patt (void *x) { return BOX(UNBOXED(x) ? 0 : 1); } @@ -456,14 +511,24 @@ extern int Lwrite (int n) { extern const size_t __gc_data_end, __gc_data_start; +# ifdef __ENABLE_GC__ + extern void L__gc_init (); + +# else + +# define L__gc_init __gc_init_subst +void __gc_init_subst () {} + +# endif + extern void __gc_root_scan_stack (); /* ======================================== */ /* Mark-and-copy */ /* ======================================== */ -static size_t SPACE_SIZE = 128; +static size_t SPACE_SIZE = 1280; // static size_t SPACE_SIZE = 1280; # define POOL_SIZE (2*SPACE_SIZE) @@ -578,6 +643,20 @@ extern size_t * gc_copy (size_t *obj) { objj = d; #endif switch (TAG(d->tag)) { + case CLOSURE_TAG: +#ifdef DEBUG_PRINT + printf ("gc_copy:closure_tag; len = %zu\n", LEN(d->tag)); fflush (stdout); +#endif + current += (LEN(d->tag) + 1) * sizeof (int); + *copy = d->tag; + copy++; + *copy = d->contents[0]; + copy++; + i = LEN(d->tag) - 1; + d->tag = (int) (copy-1); + copy_elements (copy, obj, i); + break; + case ARRAY_TAG: #ifdef DEBUG_PRINT printf ("gc_copy:array_tag; len = %zu\n", LEN(d->tag)); fflush (stdout); @@ -736,6 +815,19 @@ static void printFromSpace (void) { fflush (stdout); break; + case CLOSURE_TAG: + printf ("(=>%p): CLOSURE\n\t", d->contents); + len = LEN(d->tag); + for (int i = 1; i < len; i++) { + int elem = ((int*)d->contents)[i]; + if (UNBOXED(elem)) printf ("%d ", elem); + else printf ("%p ", elem); + } + len += 1; + printf ("\n"); + fflush (stdout); + break; + case ARRAY_TAG: printf ("(=>%p): ARRAY\n\t", d->contents); len = LEN(d->tag); @@ -781,6 +873,7 @@ static void printFromSpace (void) { } #endif +#ifdef __ENABLE_GC__ extern void * alloc (size_t size) { void * p = (void*)BOX(NULL); if (from_space.current + size < from_space.end) { @@ -805,3 +898,4 @@ extern void * alloc (size_t size) { #endif return gc (size); } +# endif diff --git a/src/SM.ml b/src/SM.ml index 72e43b401..9747ac7be 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -208,19 +208,28 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio Takes a program, an input stream, and returns an output stream this program calculates *) + +module M = Map.Make (String) + +class indexer prg = + let rec make_env m = function + | [] -> m + | (LABEL l) :: tl -> make_env (M.add l tl m) tl + | _ :: tl -> make_env m tl + in + let m = make_env M.empty prg in + object + method is_label l = M.mem l m + method labeled l = M.find l m + end + let run p i = let module M = Map.Make (String) in - let rec make_env (m, s) = function - | [] -> (m, s) - | (LABEL l) :: tl -> make_env (M.add l tl m, State.bind l (Value.Closure ([], l, [||])) s) tl - | _ :: tl -> make_env (m, s) tl - in - let m, glob = make_env (M.empty, State.undefined) p in + let glob = State.undefined in let (_, _, _, _, i, o) = eval object - method is_label l = M.mem l m - method labeled l = M.find l m + inherit indexer p method builtin f args ((cstack, stack, glob, loc, i, o) as conf : config) = let f = match f.[0] with 'L' -> String.sub f 1 (String.length f - 1) | _ -> f in let (st, i, o, r) = Language.Builtin.eval (State.I, i, o, []) (List.map Obj.magic @@ List.rev args) f in diff --git a/src/X86.ml b/src/X86.ml index 4c6a7f5fe..ec1460f7b 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -48,6 +48,7 @@ type instr = (* pushes the operand on the hardware stack *) | Push of opnd (* pops from the hardware stack to the operand *) | Pop of opnd (* call a function by a name *) | Call of string +(* call a function by indirect address *) | CallI of opnd (* returns from a function *) | Ret (* a label in the code *) | Label of string (* a conditional jump *) | CJmp of string * string @@ -91,6 +92,7 @@ let show instr = | Pop s -> Printf.sprintf "\tpopl\t%s" (opnd s) | Ret -> "\tret" | Call p -> Printf.sprintf "\tcall\t%s" p + | CallI o -> Printf.sprintf "\tcall\t*(%s)" (opnd o) | Label l -> Printf.sprintf "%s:\n" l | Jmp l -> Printf.sprintf "\tjmp\t%s" l | CJmp (s , l) -> Printf.sprintf "\tj%s\t%s" s l @@ -126,6 +128,24 @@ let compile env code = 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 callc env n = + let pushr, popr = + List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers n) + in + let env, code = + 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 = List.rev pushs in + let closure, env = env#pop in + let call_closure = [Mov (closure, eax); CallI closure] in + env, pushr @ pushs @ call_closure @ [Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr) + in + let y, env = env#allocate in env, code @ [Mov (eax, y)] + in let call env f n = let f = match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f @@ -147,7 +167,7 @@ let compile env code = | "Bsta" -> pushs | _ -> List.rev pushs in - env, pushr @ pushs @ [Call f; Binop ("+", L (4 * List.length pushs), esp)] @ (List.rev popr) + env, pushr @ pushs @ [Call f; Binop ("+", L (word_size * List.length pushs), esp)] @ (List.rev popr) in let y, env = env#allocate in env, code @ [Mov (eax, y)] in @@ -157,6 +177,26 @@ let compile env code = let stack = env#show_stack in let env', code' = match instr with + | CLOSURE name -> + let pushr, popr = + List.split @@ List.map (fun r -> (Push r, Pop r)) (env#live_registers 0) + in + let BEGIN (_, _, _, closure) :: _ = env#labeled name in + let closure_len = List.length closure in + let push_closure = + List.map (fun d -> Push (env#loc d)) @@ List.rev closure + in + let s, env = env#allocate in + (env, + pushr @ + push_closure @ + [Push (M ("$" ^ name)); + Push (L closure_len); + Call "Bclosure"; + Binop ("+", L (word_size * (closure_len + 2)), esp); + Mov (eax, s)] @ + List.rev popr) + | CONST n -> let s, env' = env#allocate in (env', [Mov (L ((n lsl 1) lor 1), s)]) @@ -302,38 +342,23 @@ let compile env code = | BEGIN (f, nargs, nlocals, closure) -> env#assert_empty_stack; - let env = env#enter f (nlocals + if closure = [] then 0 else 1) in - env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ env#lsize), esp); - Mov (esp, edi); - Mov (M "$filler", esi); - Mov (M ("$" ^ (env#allocated_size)), ecx); - Repmovsl + let has_closure = closure <> [] in + let env = env#enter f nlocals has_closure in + env, (if has_closure then [Push eax] else []) @ + [Push ebp; + Mov (esp, ebp); + Binop ("-", M ("$" ^ env#lsize), esp); + Mov (esp, edi); + Mov (M "$filler", esi); + Mov (M ("$" ^ (env#allocated_size)), ecx); + Repmovsl ] -(* - env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ string_of_int @@ word_size * size), esp); - Mov (esp, edi); - Mov (M "$filler", esi); - Mov (M ("$" ^ string_of_int size), ecx); - Repmovsl - ] - *) - -(* - | BEGIN (f, nargs, nlocals, closure) -> - env#assert_empty_stack; - let env = env#enter f a l in - env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ env#lsize), esp); - Mov (esp, edi); - Mov (M "$filler", esi); - Mov (M ("$" ^ (env#allocated_size)), ecx); - Repmovsl - ] - *) + | END -> env#endfunc, [Label env#epilogue; Mov (ebp, esp); Pop ebp; - Ret ; + Ret; Meta (Printf.sprintf "\t.set\t%s,\t%d" env#lsize (env#allocated * word_size)); Meta (Printf.sprintf "\t.set\t%s,\t%d" env#allocated_size env#allocated) ] @@ -344,8 +369,7 @@ let compile env code = | CALL (f, n) -> call env f n - | CALLC n -> - invalid_arg "CALLC not supported yet" + | CALLC n -> callc env n | SEXP (t, n) -> let s, env = env#allocate in @@ -385,6 +409,7 @@ let compile env code = | Array -> ".array_tag_patt" | String -> ".string_tag_patt" | Sexp -> ".sexp_tag_patt" + | Closure -> ".closure_tag_patt" ) 1 | i -> @@ -402,23 +427,25 @@ module S = Set.Make (String) module M = Map.Make (String) (* Environment implementation *) -class env = +class env prg = let chars = "_abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" 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 *) + inherit SM.indexer prg + 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 *) val max_locals_size = 0 + val has_closure = false method max_locals_size = max_locals_size @@ -463,8 +490,8 @@ class env = method loc x = match x with | Value.Global name -> M ("global_" ^ name) - | Value.Fun name -> M name - | Value.Local i -> S i + | Value.Fun name -> M ("$" ^ name) + | Value.Local i -> S ((if has_closure then 1 else 0) + i) | Value.Arg i -> S (- (i+1)) | Value.Access i -> invalid_arg "closure access not yet implemented" @@ -536,21 +563,10 @@ class env = method allocated_size = Printf.sprintf "LS%s_SIZE" fname (* enters a function *) - method enter f nlocals = - {< static_size = nlocals; stack_slots = nlocals; stack = []; fname = f >} + method enter f nlocals has_closure = + let n = nlocals + (if has_closure then 1 else 0) in + {< static_size = n; stack_slots = n; stack = []; fname = f; has_closure = has_closure >} - (* - (* 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 @@ -584,7 +600,7 @@ let genasm prog = | _ -> decorate prog in let sm = SM.compile expr in - let env, code = compile (new env) sm in + let env, code = compile (new env sm) sm in let gc_start, gc_end = "__gc_data_start", "__gc_data_end" in let data = [Meta "\t.data"; Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size);