diff --git a/regression/Makefile b/regression/Makefile index dd683f623..0fc4b3f96 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/deep-expressions/Makefile b/regression/deep-expressions/Makefile index aad474763..fe0e5468b 100644 --- a/regression/deep-expressions/Makefile +++ b/regression/deep-expressions/Makefile @@ -7,7 +7,7 @@ RC = ../../src/rc.opt check: $(TESTS) $(TESTS): %: %.expr -# @RC_RUNTIME=../../runtime $(RC) $< && cat $@.input | ./$@ > $@.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 diff --git a/regression/expressions/Makefile b/regression/expressions/Makefile index aad474763..fe0e5468b 100644 --- a/regression/expressions/Makefile +++ b/regression/expressions/Makefile @@ -7,7 +7,7 @@ RC = ../../src/rc.opt check: $(TESTS) $(TESTS): %: %.expr -# @RC_RUNTIME=../../runtime $(RC) $< && cat $@.input | ./$@ > $@.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 diff --git a/regression/test024.expr b/regression/test024.expr index 0d2dca7d6..40f696c8a 100644 --- a/regression/test024.expr +++ b/regression/test024.expr @@ -6,6 +6,8 @@ fun test2 (b) { a := b } +read (x); + test1 (); write (a); diff --git a/regression/test025.expr b/regression/test025.expr index 11ce787f8..0f0d7a0ab 100644 --- a/regression/test025.expr +++ b/regression/test025.expr @@ -16,6 +16,8 @@ fun print () { write (c) } +read (x); + a := 100; b := 200; c := 300; diff --git a/regression/test026.expr b/regression/test026.expr index 984d2c1d5..1961411f7 100644 --- a/regression/test026.expr +++ b/regression/test026.expr @@ -19,6 +19,8 @@ fun print () { write (c) } +read (x); + a := 100; b := 200; c := 300; diff --git a/regression/test026.input b/regression/test026.input index c22708346..573541ac9 100644 --- a/regression/test026.input +++ b/regression/test026.input @@ -1 +1 @@ -0 \ No newline at end of file +0 diff --git a/regression/test027.expr b/regression/test027.expr index 919970d7a..6303f30e3 100644 --- a/regression/test027.expr +++ b/regression/test027.expr @@ -21,6 +21,8 @@ fun test2 (b) { print () } +read (x); + a := 100; b := 200; c := 300; diff --git a/regression/test032.expr b/regression/test032.expr index 2cc53fe7e..2a95a652b 100644 --- a/regression/test032.expr +++ b/regression/test032.expr @@ -5,6 +5,8 @@ fun ack (m, n) { fi } +read (x); + for m := 0, m <= 3, m := m+1 do for n := 0, n <= 8, n := n+1 do write (ack (m, n)) diff --git a/regression/test033.expr b/regression/test033.expr index f26c389dd..6a564e5a5 100644 --- a/regression/test033.expr +++ b/regression/test033.expr @@ -8,5 +8,7 @@ fun test (n, m) local i, s { return s } +read (x); + write (test (10, 100)); write (test (100, 10)) \ No newline at end of file diff --git a/src/Driver.ml b/src/Driver.ml index c4e5f628b..f5912b60f 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -25,11 +25,9 @@ let main = match parse infile with | `Ok prog -> if to_compile - then failwith "Not implemented yet" - (* + then let basename = Filename.chop_suffix infile ".expr" in - ignore @@ X86.build prog basename - *) + ignore @@ X86.build prog basename else let rec read acc = try diff --git a/src/SM.ml b/src/SM.ml index 8f62de99f..6618f3182 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -10,11 +10,12 @@ open Language (* load a variable to the stack *) | LD of string (* store a variable from the stack *) | ST of string (* a label *) | LABEL of string -(* unconditional jump *) | JMP of string +(* unconditional jump *) | JMP of string (* conditional jump *) | CJMP of string * string -(* begins procedure definition *) | BEGIN of string list * string list +(* begins procedure definition *) | BEGIN of string * string list * string list (* end procedure definition *) | END -(* calls a procedure *) | CALL of string with show +(* calls a function/procedure *) | CALL of string * int * bool +(* returns from a function *) | RET of bool with show (* The type for the stack machine program *) type prg = insn list @@ -46,18 +47,18 @@ let rec eval env ((cstack, stack, ((st, i, o) as c)) as conf) = function | LABEL _ -> eval env conf prg' | JMP l -> eval env conf (env#labeled l) | CJMP (c, l) -> let x::stack' = stack in eval env (cstack, stack', (st, i, o)) (if (c = "z" && x = 0) || (c = "nz" && x <> 0) then env#labeled l else prg') - | CALL f -> eval env ((prg', st)::cstack, stack, c) (env#labeled f) - | BEGIN (args, locals) -> let rec combine acc args stack = + | CALL (f, _, _) -> eval env ((prg', st)::cstack, stack, c) (env#labeled f) + | BEGIN (_, args, locals) -> let rec combine acc args stack = match args, stack with | [], _ -> List.rev acc, stack | a::args', s::stack' -> combine ((a, s)::acc) args' stack' in let state', stack' = combine [] args stack 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 -> (match cstack with - | (prg', st')::cstack' -> eval env (cstack', stack, (State.leave st st', i, o)) prg' - | [] -> conf - ) + | END | RET _ -> (match cstack with + | (prg', st')::cstack' -> eval env (cstack', stack, (State.leave st st', i, o)) prg' + | [] -> conf + ) ) (* Top-level evaluation @@ -86,14 +87,14 @@ let run p i = *) let compile (defs, p) = let label s = "L" ^ s in - let rec call f args = + let rec call f args p = let args_code = List.concat @@ List.map expr (List.rev args) in - args_code @ [CALL (label f)] + args_code @ [CALL (label f, List.length args, p)] and expr = function | Expr.Var x -> [LD x] | Expr.Const n -> [CONST n] | Expr.Binop (op, x, y) -> expr x @ expr y @ [BINOP op] - | Expr.Call (f, args) -> call f args + | Expr.Call (f, args) -> call f args false in let rec compile_stmt l env = function | Stmt.Read x -> env, false, [READ; ST x] @@ -121,15 +122,15 @@ let compile (defs, p) = let env , flag, body = compile_stmt check env s in env, false, [LABEL loop] @ body @ (if flag then [LABEL check] else []) @ (expr c) @ [CJMP ("z", loop)] - | Stmt.Call (f, args) -> env, false, call f args + | Stmt.Call (f, args) -> env, false, call f args true - | Stmt.Return e -> env, false, (match e with Some e -> expr e | None -> []) @ [END] + | Stmt.Return e -> env, false, (match e with Some e -> expr e | None -> []) @ [RET (e <> None)] in let compile_def env (name, (args, locals, stmt)) = let lend, env = env#get_label in let env, flag, code = compile_stmt lend env stmt in env, - [LABEL name; BEGIN (args, locals)] @ + [LABEL name; BEGIN (name, args, locals)] @ code @ (if flag then [LABEL lend] else []) @ [END] @@ -148,5 +149,5 @@ let compile (defs, p) = in let lend, env = env#get_label in let _, flag, code = compile_stmt lend env p in - (LABEL "main" :: if flag then code @ [LABEL lend] else code) @ [END] @ (List.concat def_code) + (if flag then code @ [LABEL lend] else code) @ [END] @ (List.concat def_code) diff --git a/src/X86.ml b/src/X86.ml index bd946ae29..ca66b3628 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -43,7 +43,8 @@ type instr = (* a label in the code *) | Label of string (* a conditional jump *) | CJmp of string * string (* a non-conditional jump *) | Jmp of string - +(* directive *) | Meta of string + (* Instruction printer *) let show instr = let binop = function @@ -58,7 +59,9 @@ let show instr = in let opnd = function | R i -> regs.(i) - | S i -> Printf.sprintf "-%d(%%ebp)" ((i+1) * word_size) + | S i -> if i >= 0 + then Printf.sprintf "-%d(%%ebp)" ((i+1) * word_size) + else Printf.sprintf "%d(%%ebp)" (8+(-i-1) * word_size) | M x -> x | L i -> Printf.sprintf "$%d" i in @@ -75,6 +78,7 @@ let show instr = | 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 + | Meta s -> Printf.sprintf "%s\n" s (* Opening stack machine to use instructions without fully qualified names *) open SM @@ -96,7 +100,7 @@ let compile env code = | ">" -> "g" | _ -> failwith "unknown operator" in - let rec compile' env scode = + let rec compile' env scode = let on_stack = function S _ -> true | _ -> false in match scode with | [] -> env, [] @@ -116,15 +120,15 @@ let compile env code = let s, env' = (env#global x)#allocate in env', (match s with - | S _ | M _ -> [Mov (M (env'#loc x), eax); Mov (eax, s)] - | _ -> [Mov (M (env'#loc x), s)] + | S _ | M _ -> [Mov (env'#loc x, eax); Mov (eax, s)] + | _ -> [Mov (env'#loc x, s)] ) | ST x -> let s, env' = (env#global x)#pop in env', (match s with - | S _ | M _ -> [Mov (s, eax); Mov (eax, M (env'#loc x))] - | _ -> [Mov (s, M (env'#loc x))] + | S _ | M _ -> [Mov (s, eax); Mov (eax, env'#loc x)] + | _ -> [Mov (s, env'#loc x)] ) | BINOP op -> let x, y, env' = env#pop2 in @@ -189,6 +193,41 @@ let compile env code = | CJMP (s, l) -> let x, env = env#pop in env, [Binop ("cmp", L 0, x); CJmp (s, l)] + + | BEGIN (f, a, l) -> + let env = env#enter f a l in + env, [Push ebp; Mov (esp, ebp); Binop ("-", M ("$" ^ env#lsize), esp)] + + | END -> + env, [Label env#epilogue; + Mov (ebp, esp); + Pop ebp; + Ret; + Meta (Printf.sprintf "\t.set\t%s,\t%d" env#lsize (env#allocated * word_size)) + ] + + | RET b -> + if b + 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 @ 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 let env'', code'' = compile' env' scode' in env'', code' @ code'' @@ -199,15 +238,23 @@ let compile env code = module S = Set.Make (String) (* Environment implementation *) +let make_assoc l = List.combine l (List.init (List.length l) (fun x -> x)) + class env = object (self) - val stack_slots = 0 (* maximal number of stack positions *) - val globals = S.empty (* a set of global variables *) - val stack = [] (* symbolic stack *) - + val globals = S.empty (* a set of global variables *) + val stack_slots = 0 (* maximal number of stack positions *) + val stack = [] (* symbolic stack *) + val args = [] (* function arguments *) + val locals = [] (* function local variables *) + val fname = "" (* function name *) + (* gets a name for a global variable *) - method loc x = "global_" ^ x - + 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) + (* allocates a fresh position on a symbolic stack *) method allocate = let x, n = @@ -226,7 +273,7 @@ class env = method push y = {< stack = y::stack >} (* pops one operand from the symbolic stack *) - method pop = let x::stack' = stack in x, {< stack = stack' >} + method pop = let x::stack' = stack in x, {< stack = stack' >} (* pops two operands from the symbolic stack *) method pop2 = let x::y::stack' = stack in x, y, {< stack = stack' >} @@ -234,48 +281,49 @@ class env = (* registers a global variable in the environment *) method global x = {< globals = S.add ("global_" ^ x) globals >} - (* gets the number of allocated stack slots *) - method allocated = stack_slots - (* gets all global variables *) method globals = S.elements globals + + (* gets a number of stack positions allocated *) + method allocated = stack_slots + + (* enters a function *) + method enter f a l = + {< stack_slots = List.length l; stack = []; locals = make_assoc l; args = make_assoc a; fname = f >} + + (* 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 = + List.filter (function R _ -> true | _ -> false) stack + end - -(* Compiles a unit: generates x86 machine code for the stack program and surrounds it - with function prologue/epilogue -*) -let compile_unit env scode = - let env, code = compile env scode in - env, - ([Push ebp; Mov (esp, ebp); Binop ("-", L (word_size*env#allocated), esp)] @ - code @ - [Mov (ebp, esp); Pop ebp; Binop ("^", eax, eax); Ret] - ) - + (* 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 prog = - let env, code = compile_unit (new env) (SM.compile prog) in +let genasm (ds, stmt) = + let stmt = Language.Stmt.Seq (stmt, Language.Stmt.Return (Some (Language.Expr.Const 0))) in + let env, code = + compile + (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 asm = Buffer.create 1024 in - Buffer.add_string asm "\t.data\n"; - List.iter - (fun s -> - Buffer.add_string asm (Printf.sprintf "%s:\t.int\t0\n" s) - ) - env#globals; - Buffer.add_string asm "\t.text\n"; - Buffer.add_string asm "\t.globl\tmain\n"; - Buffer.add_string asm "main:\n"; List.iter (fun i -> Buffer.add_string asm (Printf.sprintf "%s\n" @@ show i)) - code; + (data @ [Meta "\t.text"; Meta "\t.globl\tmain"] @ code); Buffer.contents asm (* Builds a program: generates the assembler file and compiles it with the gcc toolchain *) -let build stmt name = +let build prog name = let outf = open_out (Printf.sprintf "%s.s" name) in - Printf.fprintf outf "%s" (genasm stmt); + Printf.fprintf outf "%s" (genasm prog); close_out outf; let inc = try Sys.getenv "RC_RUNTIME" with _ -> "../runtime" in Sys.command (Printf.sprintf "gcc -m32 -o %s %s/runtime.o %s.s" name inc name)