diff --git a/regression/Makefile b/regression/Makefile index af76ba98c..aa3113c79 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -8,9 +8,9 @@ check: $(TESTS) $(TESTS): %: %.expr @echo $@ -# @$(RC) $< && cat $@.input | ./$@ > $@.log && diff $@.log orig/$@.log + $(RC) $< && cat $@.input | ./$@ 2> /dev/null > $@.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 $< 2> /dev/null > $@.log && diff $@.log orig/$@.log clean: $(RM) test*.log *.s *~ $(TESTS) diff --git a/src/Language.ml b/src/Language.ml index 941fca3e8..1916e48dd 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -120,7 +120,7 @@ module Builtin = | ".length" -> (st, i, o, (Value.of_int (match List.hd args with Value.Sexp (_, a) | Value.Array a -> Array.length a | Value.String s -> Bytes.length s))::vs) | ".array" -> (st, i, o, (Value.of_array @@ Array.of_list args)::vs) | ".stringval" -> let [a] = args in (st, i, o, (Value.of_string @@ Value.string_val a)::vs) - | "_gc_init" -> (st, i, o, vs) + | "__gc_init" -> (st, i, o, vs) | "raw" -> let [a] = args in (st, i, o, a :: vs) end diff --git a/src/SM.ml b/src/SM.ml index a83c65e89..72e43b401 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -82,9 +82,17 @@ let print_stack memo s = List.iter (fun v -> Printf.eprintf "%s " @@ show(value) v) s; Printf.eprintf "\n%!" +let show_insn = show insn + let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = function | [] -> conf -| insn :: prg' -> +| insn :: prg' -> + (* + Printf.eprintf "eval\n"; + Printf.eprintf " insn=%s\n" (show_insn insn); + Printf.eprintf " stack=%s\n" (show(list) (show(value)) stack); + Printf.eprintf "end\n"; + *) (match insn with | 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', glob, loc, i, o) prg' | CONST n -> eval env (cstack, (Value.of_int n)::stack, glob, loc, i, o) prg' @@ -201,7 +209,6 @@ 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 *) let run p i = - (* print_prg p; *) let module M = Map.Make (String) in let rec make_env (m, s) = function | [] -> (m, s) @@ -219,7 +226,7 @@ let run p i = let (st, i, o, r) = Language.Builtin.eval (State.I, i, o, []) (List.map Obj.magic @@ List.rev args) f in (cstack, (match r with [r] -> (Obj.magic r)::stack | _ -> Value.Empty :: stack), glob, loc, i, o) end - ([], [Value.Closure ([], "main", [||])], (List.fold_left (fun s (name, value) -> State.bind name value s) glob (Builtin.bindings ())), {locals=[||]; args=[||]; closure=[||]}, i, []) + ([], [], (List.fold_left (fun s (name, value) -> State.bind name value s) glob (Builtin.bindings ())), {locals=[||]; args=[||]; closure=[||]}, i, []) p in o @@ -335,7 +342,13 @@ object (self : 'self) | State.I -> State.G (Builtin.names, List.fold_left - (fun s (name, value) -> State.bind name (Value.Fun name) s) + (fun s (name, value) -> + let name' = + match name.[0] with + | '.' -> name + | _ -> "L" ^ name + in + State.bind name (Value.Fun name') s) State.undefined (Builtin.bindings ())) | _ -> @@ -639,20 +652,7 @@ let compile p = | Expr.Return None -> env, false, [CONST 0; RET] | Expr.Leave -> env, false, [] - - | Expr.Case (e, [p, s]) -> - let lexp , env = env#get_label in - let ldrop, env = env#get_label in - let env, fe , se = compile_expr lexp env e in - let env, ldrop' , pcode = pattern env ldrop p in - let env = env#push_scope in - let env, bindcode = bindings env p in - let env, ldrop'', scode = compile_expr ldrop env s in - let env = env#pop_scope in - if ldrop' || ldrop'' - then env, true , se @ (if fe then [LABEL lexp] else []) @ [DUP] @ pcode @ bindcode @ scode @ [JMP l; LABEL ldrop; DROP] - else env, false, se @ (if fe then [LABEL lexp] else []) @ [DUP] @ pcode @ bindcode @ scode - + | Expr.Case (e, brs) -> let n = List.length brs - 1 in let lexp, env = env#get_label in @@ -700,6 +700,6 @@ let compile p = let env = new env in let lend, env = env#get_label in let env, flag, code = compile_expr lend env p in - let env, prg = compile_fundefs [[BEGIN ("main", 0, env#nlocals, [])] @(if flag then code @ [LABEL lend] else code) @ [END]] env in + let env, prg = compile_fundefs [[LABEL "main"; BEGIN ("main", 0, env#nlocals, [])] @(if flag then code @ [LABEL lend] else code) @ [END]] env in let prg = List.flatten prg in prg diff --git a/src/X86.ml b/src/X86.ml index dbefb19bc..4c6a7f5fe 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -126,10 +126,7 @@ 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 call env n = - let f = "foo" in - Printf.eprintf "Stack in call: %s\n%!" env#show_stack; - invalid_arg "CALL not yet supported.\n"; + let call env f n = let f = match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f in @@ -167,7 +164,7 @@ let compile env code = | STRING s -> let s, env = env#string s in let l, env = env#allocate in - let env, call = call env (* TODO!!! ".string" *) 1 in + let env, call = call env ".string" 1 in (env, Mov (M ("$" ^ s), l) :: call) | LDA x -> @@ -196,7 +193,7 @@ let compile env code = ) | STA -> - call env (* TODO! ".sta" *) 3 + call env ".sta" 3 | STI -> let v, x, env' = env#pop2 in @@ -305,14 +302,21 @@ let compile env code = | BEGIN (f, nargs, nlocals, closure) -> env#assert_empty_stack; - let env = env#enter f nlocals in - let size = Printf.sprintf "$%d" (word_size * (nlocals + if closure = [] then 0 else 1)) in - env, [Push ebp; Mov (esp, ebp); Binop ("-", M size, esp); + 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 size, ecx); + 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) -> @@ -329,21 +333,23 @@ let compile env code = 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) - *) ] | RET -> let x, env = env#pop in env, [Mov (x, eax); Jmp env#epilogue] - | CALL (f, n) -> call env n + | CALL (f, n) -> call env f n + + | CALLC n -> + invalid_arg "CALLC not supported yet" | SEXP (t, n) -> let s, env = env#allocate in - let env, code = call env (* TODO! ".sexp" *) (n+1) in + let env, code = call env ".sexp" (n+1) in env, [Mov (L env#hash t, s)] @ code | DROP -> @@ -361,25 +367,25 @@ let compile env code = | TAG (t, n) -> let s1, env = env#allocate in let s2, env = env#allocate in - let env, code = call env (* TODO! ".tag" *) 3 in + let env, code = call env ".tag" 3 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 (* TODO! ".array_patt" *) 2 in + let env, code = call env ".array_patt" 2 in env, [Mov (L n, s)] @ code - | PATT StrCmp -> call env (* TODO!!! ".string_patt" *) 2 + | PATT StrCmp -> call env ".string_patt" 2 | PATT patt -> - call env (* TODO!!! + call env (match patt with | Boxed -> ".boxed_patt" | UnBoxed -> ".unboxed_patt" | Array -> ".array_tag_patt" | String -> ".string_tag_patt" | Sexp -> ".sexp_tag_patt" - ) *)1 + ) 1 | i -> invalid_arg (Printf.sprintf "invalid SM insn: %s\n" (GT.show(insn) i)) @@ -507,7 +513,7 @@ class env = (* registers a variable in the environment *) method variable x = match x with - | Value.Global name -> {< globals = S.add name globals >} + | Value.Global name -> {< globals = S.add ("global_" ^ name) globals >} | _ -> self (* registers a string constant *) @@ -526,10 +532,8 @@ class env = (* gets a number of stack positions allocated *) method allocated = stack_slots - - (* + method allocated_size = Printf.sprintf "LS%s_SIZE" fname - *) (* enters a function *) method enter f nlocals = @@ -550,10 +554,8 @@ class env = (* returns a label for the epilogue *) method epilogue = Printf.sprintf "L%s_epilogue" fname - (* (* returns a name for local size meta-symbol *) method lsize = Printf.sprintf "L%s_SIZE" fname - *) (* returns a list of live registers *) method live_registers depth = @@ -582,7 +584,6 @@ let genasm prog = | _ -> decorate prog in let sm = SM.compile expr in - Printf.eprintf "SM:\n"; print_prg sm; let env, code = compile (new env) sm in let gc_start, gc_end = "__gc_data_start", "__gc_data_end" in let data = [Meta "\t.data";