From e529ba14720cee96cc2fc0751cb8dfe6b6cc0860 Mon Sep 17 00:00:00 2001 From: Dmitry Boulytchev Date: Mon, 14 Oct 2019 19:44:33 +0300 Subject: [PATCH] Added static call --- regression/Makefile | 2 +- regression/orig/test067.log | 1 + regression/test067.expr | 5 ++ regression/test067.input | 1 + src/Driver.ml | 2 +- src/Language.ml | 4 +- src/SM.ml | 62 +++++++++++++----- src/X86.ml | 127 +++++++++++++++++++++--------------- 8 files changed, 134 insertions(+), 70 deletions(-) create mode 100644 regression/orig/test067.log create mode 100644 regression/test067.expr create mode 100644 regression/test067.input diff --git a/regression/Makefile b/regression/Makefile index 40ae14613..af76ba98c 100644 --- a/regression/Makefile +++ b/regression/Makefile @@ -10,7 +10,7 @@ $(TESTS): %: %.expr @echo $@ # @$(RC) $< && cat $@.input | ./$@ > $@.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 + cat $@.input | $(RC) -s $< > $@.log && diff $@.log orig/$@.log clean: $(RM) test*.log *.s *~ $(TESTS) diff --git a/regression/orig/test067.log b/regression/orig/test067.log new file mode 100644 index 000000000..5037637a6 --- /dev/null +++ b/regression/orig/test067.log @@ -0,0 +1 @@ +> 12 diff --git a/regression/test067.expr b/regression/test067.expr new file mode 100644 index 000000000..132b043b9 --- /dev/null +++ b/regression/test067.expr @@ -0,0 +1,5 @@ +infixr "**" before "*" (f, g) { + return fun (x) {return f (g (x))} +} + +write ((fun (x) {return x+2} ** fun (x) {return x+3})(7)) \ No newline at end of file diff --git a/regression/test067.input b/regression/test067.input new file mode 100644 index 000000000..7ed6ff82d --- /dev/null +++ b/regression/test067.input @@ -0,0 +1 @@ +5 diff --git a/src/Driver.ml b/src/Driver.ml index bba88ef78..d9f26727d 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -43,7 +43,7 @@ let main = if to_compile then ( let basename = Filename.chop_suffix infile ".expr" in - (* ignore @@ X86.build prog basename *) (* TODO! *) () + ignore @@ X86.build prog basename ) else ( (* Printf.printf "Program:\n%s\n" (GT.show(Language.Expr.t) prog);*) diff --git a/src/Language.ml b/src/Language.ml index dd1e5c821..941fca3e8 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -102,7 +102,7 @@ module Value = module Builtin = struct - let list = ["read"; "write"; ".elem"; ".length"; ".array"; ".stringval"] + let list = ["read"; "write"; ".elem"; ".length"; ".array"; ".stringval"; "__gc_init"; "raw"] let bindings () = List.map (fun name -> name, Value.Builtin name) list let names = List.map (fun name -> name, false) list @@ -120,6 +120,8 @@ 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) + | "raw" -> let [a] = args in (st, i, o, a :: vs) end diff --git a/src/SM.ml b/src/SM.ml index 365c83305..a83c65e89 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -21,7 +21,8 @@ open Language (* begins procedure definition *) | BEGIN of string * int * int * Value.designation list (* end procedure definition *) | END (* create a closure *) | CLOSURE of string -(* calls a function/procedure *) | CALL of int +(* calls a closure *) | CALLC of int +(* calls a function/procedure *) | CALL of string * int (* returns from a function *) | RET (* drops the top element off *) | DROP (* duplicates the top element *) | DUP @@ -121,12 +122,33 @@ let rec eval env (((cstack, stack, glob, loc, i, o) as conf) : config) = functio | Value.Arg i -> loc.args.(i) | Value.Local i -> loc.locals.(i) | Value.Access i -> loc.closure.(i) - | _ -> invalid_arg "wrong value in CLOSURE") + | _ -> invalid_arg "wrong value in CLOSURE") dgs in eval env (cstack, (Value.Closure ([], name, closure)) :: stack, glob, loc, i, o) prg' - | CALL n -> let vs, stack' = split (n+1) stack in + | CALL (f, n) -> let args, stack' = split n stack in + if env#is_label f + then ( + let BEGIN (_, _, _, dgs) :: _ = env#labeled f in + match dgs with + | [] -> eval env ((prg', loc)::cstack, stack', glob, {args = Array.of_list (List.rev args); locals = [||]; closure = [||]}, i, o) (env#labeled f) + | _ -> + let closure = + Array.of_list @@ + List.map ( + function + | Value.Arg i -> loc.args.(i) + | Value.Local i -> loc.locals.(i) + | Value.Access i -> loc.closure.(i) + | _ -> invalid_arg "wrong value in CLOSURE") + dgs + in + eval env ((prg', loc)::cstack, stack', glob, {args = Array.of_list (List.rev args); locals = [||]; closure = closure}, i, o) (env#labeled f) + ) + else eval env (env#builtin f args ((cstack, stack', glob, loc, i, o) : config)) prg' + + | CALLC n -> let vs, stack' = split (n+1) stack in let f::args = List.rev vs in (match f with | Value.Builtin f -> @@ -313,7 +335,7 @@ object (self : 'self) | State.I -> State.G (Builtin.names, List.fold_left - (fun s (name, value) -> State.bind name (Value.Global name) s) + (fun s (name, value) -> State.bind name (Value.Fun name) s) State.undefined (Builtin.bindings ())) | _ -> @@ -420,7 +442,6 @@ object (self : 'self) | Value.Access n when n = ~-1 -> let index = scope.acc_index in let fundefs', loc = propagate_acc fundefs name in - (* let enclosing_loc = (*State.eval enclosing_st name*) in *) {< fundefs = fundefs'; scope = { @@ -470,7 +491,7 @@ let compile p = List.fold_left (fun (i, env, code) p -> let env, _, pcode = pattern env ldrop p in - i+1, env, ([DUP; LD (Value.Global ".elem"); SWAP; CONST i; CALL 2] @ pcode) :: code + i+1, env, ([DUP; CONST i; CALL (".elem", 2)] @ pcode) :: code ) (0, env, []) ps @@ -504,7 +525,7 @@ let compile p = let env, dsg = env#lookup name in env, ([DUP] @ - List.concat (List.map (fun i -> [LD (Value.Global ".elem"); SWAP; CONST i; CALL 2]) path) @ + List.concat (List.map (fun i -> [CONST i; CALL (".elem", 2)]) path) @ [ST dsg; DROP]) :: acc ) (env, []) @@ -554,24 +575,35 @@ let compile p = | Expr.String s -> env, false, [STRING s] | Expr.Binop (op, x, y) -> let lop, env = env#get_label in add_code (compile_list lop env [x; y]) lop false [BINOP op] - - | Expr.Call (f, args) -> let lcall, env = env#get_label in - add_code (compile_list lcall env (f :: args)) lcall false [CALL (List.length args)] + + | Expr.Call (f, args) -> let lcall, env = env#get_label in + (match f with + | Expr.Var name -> + let env, acc = env#lookup name in + (match acc with + | Value.Fun name -> + add_code (compile_list lcall env args) lcall false [CALL (name, List.length args)] + | _ -> + add_code (compile_list lcall env (f :: args)) lcall false [CALLC (List.length args)] + ) + + | _ -> add_code (compile_list lcall env (f :: args)) lcall false [CALLC (List.length args)] + ) | Expr.Array xs -> let lar, env = env#get_label in - add_code (compile_list lar env ((Expr.Var ".array") :: xs)) lar false [CALL (List.length xs)] + add_code (compile_list lar env xs) lar false [CALL (".array", List.length xs)] | Expr.Sexp (t, xs) -> let lsexp, env = env#get_label in add_code (compile_list lsexp env xs) lsexp false [SEXP (t, List.length xs)] | Expr.Elem (a, i) -> let lelem, env = env#get_label in - add_code (compile_list lelem env [Expr.Var ".elem"; a; i]) lelem false [CALL 2] + add_code (compile_list lelem env [a; i]) lelem false [CALL (".elem", 2)] | Expr.Length e -> let llen, env = env#get_label in - add_code (compile_list llen env [Expr.Var ".length"; e]) llen false [CALL 1] + add_code (compile_expr llen env e) llen false [CALL (".length", 1)] | Expr.StringVal e -> let lsv, env = env#get_label in - add_code (compile_list lsv env [Expr.Var ".stringval"; e]) lsv false [CALL 1] + add_code (compile_expr lsv env e) lsv false [CALL (".stringval", 1)] | Expr.Assign (x, e) -> let lassn, env = env#get_label in add_code (compile_list lassn env [x; e]) lassn false [match x with Expr.ElemRef _ -> STA | _ -> STI] @@ -669,5 +701,5 @@ let compile p = 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 prg = List.flatten prg in + let prg = List.flatten prg in prg diff --git a/src/X86.ml b/src/X86.ml index a31cf9242..dbefb19bc 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -1,5 +1,7 @@ open GT - +open Language +open SM + (* X86 codegeneration interface *) (* The registers: *) @@ -120,11 +122,14 @@ let compile env code = | ">=" -> "ge" | ">" -> "g" | _ -> failwith "unknown operator" - in (* + 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 = + 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 f = match f.[0] with '.' -> "B" ^ String.sub f 1 (String.length f - 1) | _ -> f in @@ -162,7 +167,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 ".string" 1 in + let env, call = call env (* TODO!!! ".string" *) 1 in (env, Mov (M ("$" ^ s), l) :: call) | LDA x -> @@ -191,7 +196,7 @@ let compile env code = ) | STA -> - call env ".sta" 3 + call env (* TODO! ".sta" *) 3 | STI -> let v, x, env' = env#pop2 in @@ -298,7 +303,19 @@ let compile env code = let x, env = env#pop in env#set_stack l, [Sar1 x; (*!!!*) Binop ("cmp", L 0, x); CJmp (s, l)] - | BEGIN (f, a, l) -> + | 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); + Mov (esp, edi); + Mov (M "$filler", esi); + Mov (M 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); @@ -307,25 +324,26 @@ let compile env code = 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) + *) ] | RET -> let x, env = env#pop in env, [Mov (x, eax); Jmp env#epilogue] - - | CALL (f, n) -> call env f n - + + | CALL (f, n) -> call env n + | SEXP (t, n) -> let s, env = env#allocate in - let env, code = call env ".sexp" (n+1) in + let env, code = call env (* TODO! ".sexp" *) (n+1) in env, [Mov (L env#hash t, s)] @ code | DROP -> @@ -343,44 +361,33 @@ let compile env code = | TAG (t, n) -> let s1, env = env#allocate in let s2, env = env#allocate in - let env, code = call env ".tag" 3 in + let env, code = call env (* TODO! ".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 ".array_patt" 2 in + let env, code = call env (* TODO! ".array_patt" *) 2 in env, [Mov (L n, s)] @ code - | PATT StrCmp -> call env ".string_patt" 2 + | PATT StrCmp -> call env (* TODO!!! ".string_patt" *) 2 | PATT patt -> - call env + call env (* TODO!!! (match patt with | Boxed -> ".boxed_patt" | UnBoxed -> ".unboxed_patt" | Array -> ".array_tag_patt" | String -> ".string_tag_patt" | Sexp -> ".sexp_tag_patt" - ) 1 - - | 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, [] + ) *)1 + + | i -> + invalid_arg (Printf.sprintf "invalid SM insn: %s\n" (GT.show(insn) i)) in let env'', code'' = compile' env' scode' in env'', [Meta (Printf.sprintf "# %s / % s" (GT.show(SM.insn) instr) stack)] @ code' @ code'' in compile' env code - *) invalid_arg "not implemented" (* A set of strings *) module S = Set.Make (String) @@ -448,10 +455,19 @@ class env = (* gets a name for a global variable *) method loc x = + match x with + | Value.Global name -> M ("global_" ^ name) + | Value.Fun name -> M name + | Value.Local i -> S i + | Value.Arg i -> S (- (i+1)) + | Value.Access i -> invalid_arg "closure access not yet implemented" + + (* try S (- (List.assoc x args) - 1) with Not_found -> try S (assoc x locals) with Not_found -> M ("global_" ^ x) - + *) + (* allocates a fresh position on a symbolic stack *) method allocate = let x, n = @@ -490,9 +506,9 @@ class env = (* registers a variable in the environment *) method variable x = - match self#loc x with - | M name -> {< globals = S.add name globals >} - | _ -> self + match x with + | Value.Global name -> {< globals = S.add name globals >} + | _ -> self (* registers a string constant *) method string x = @@ -511,13 +527,15 @@ 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 a l = - 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 >} + method enter f nlocals = + {< static_size = nlocals; stack_slots = nlocals; stack = []; fname = f >} + (* (* enters a scope *) method scope vars = let n = List.length vars in @@ -528,13 +546,15 @@ class env = 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 + (* (* 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 = let rec inner d acc = function @@ -549,18 +569,21 @@ class env = (* Generates an assembler text for a program: first compiles the program into the stack code, then generates x86 assember code, then prints the assembler file *) -let genasm (ds, stmt) = - let stmt = - Language.Expr.Seq ( - Language.Expr.Ignore (Language.Expr.Call (Language.Expr.Var "__gc_init", [])), - Language.Expr.Seq (stmt, Language.Expr.Return (Some (Language.Expr.Call (Language.Expr.Var "raw", [Language.Expr.Const 0])))) - ) - in - let env, code = - compile - (new env) - ((LABEL "main") :: (BEGIN ("main", 0, 0, [])) :: [] (* TODO! SM.compile (ds, stmt) *)) +let genasm prog = + let decorate e = + Expr.Seq ( + Expr.Ignore (Expr.Call (Expr.Var "__gc_init", [])), + Expr.Seq (e, Expr.Return (Some (Expr.Call (Expr.Var "raw", [Expr.Const 0])))) + ) + in + let expr = + match prog with + | Expr.Scope (defs, e) -> Expr.Scope (defs, decorate e) + | _ -> 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"; Meta (Printf.sprintf "filler:\t.fill\t%d, 4, 1" env#max_locals_size);