diff --git a/src/Expr.lama b/src/Expr.lama index e5b9224e4c..0333026937 100644 --- a/src/Expr.lama +++ b/src/Expr.lama @@ -11,5 +11,27 @@ import State; -- Const (int) | -- Binop (string, expr, expr) public fun evalExpr (st, expr) { - failure("evalExpr not implemented\n") -} \ No newline at end of file + case expr of + Var (name) -> name.st + | Const (x) -> x + | Binop (op, left, right) -> st.evalOp (op, st.evalExpr (left), st.evalExpr (right)) + esac +} + +public fun evalOp (st, op, left, right) { + case op of + "!!" -> left !! right + | "&&" -> left && right + | "==" -> left == right + | "!=" -> left != right + | "<=" -> left <= right + | "<" -> left < right + | ">=" -> left >= right + | ">" -> left > right + | "+" -> left + right + | "-" -> left - right + | "*" -> left * right + | "/" -> left / right + | "%" -> left % right + esac +} diff --git a/src/SM.lama b/src/SM.lama index f1a8385de5..079cb7704d 100644 --- a/src/SM.lama +++ b/src/SM.lama @@ -21,10 +21,22 @@ public fun showSMInsn (i) { public fun showSM (prg) { map(fun (i) {showSMInsn(i) ++ "\n"}, prg).stringcat } + +fun evalSingle ([stack, state, world], insn) { + case insn of + READ -> let [next, bumped] = world.readWorld in [next : stack, state, bumped] + | WRITE -> let (head : tail) = stack in [tail, state, head.writeWorld (world)] + | BINOP(s) -> let (right : left : tail) = stack in [(evalOp (state, s, left, right)) : tail, state, world] + | LD(x) -> [x.state : stack, state, world] + | ST(x) -> let (head : tail) = stack in [tail, state <- [x, head], world] + | CONST(n) -> [n : stack, state, world] + esac +} + -- Stack machine interpreter. Takes an SM-configuration and a program, -- returns a final configuration fun eval (c, insns) { - failure("SM eval not implemented\n") + foldl(evalSingle, c, insns) } -- Runs a stack machine for a given input and a given program, returns an output public fun evalSM (input, insns) { @@ -34,11 +46,22 @@ public fun evalSM (input, insns) { -- Takes an expression, returns a list (of, possibly, lists) -- of stack machine instructions fun compileExpr (expr) { - failure("compileExpr not implemented\n") + case expr of + Var (name) -> {LD (name)} + | Const (x) -> {CONST (x)} + | Binop (op, left, right) -> {left.compileExpr, right.compileExpr, BINOP (op)} + esac } -- Compiles a statement into a stack machine code. -- Takes a statement, returns a list of stack machine -- instructions. public fun compileSM (stmt) { - failure("compileSM not implemented\n") -} \ No newline at end of file + deepFlatten( + case stmt of + Assn (name, expr) -> {expr.compileExpr, ST (name)} + | Seq (head, tail) -> {head.compileSM, tail.compileSM} + | Skip -> {} + | Read (buffer) -> {READ, ST (buffer)} + | Write (expr) -> {expr.compileExpr, WRITE} + esac) +} diff --git a/src/Stmt.lama b/src/Stmt.lama index bc266c53a8..4677c0c174 100644 --- a/src/Stmt.lama +++ b/src/Stmt.lama @@ -14,10 +14,16 @@ import World; -- Skip | -- Read (string) | -- Write (expr) | -fun eval (c, stmt) { - failure("Stmt eval not implemented\n") +fun eval ([s, w], stmt) { + case stmt of + Assn (name, expr) -> [s <- [name, s.evalExpr (expr)], w] + | Seq (head, tail) -> eval (eval ([s, w], head), tail) + | Skip -> [s, w] + | Read (buffer) -> let [next, bumped] = w.readWorld in [s <- [buffer, next], bumped] + | Write (expr) -> [s, (s.evalExpr (expr)).writeWorld (w)] + esac } -- Evaluates a program with a given input and returns an output public fun evalStmt (input, stmt) { eval([emptyState, createWorld(input)], stmt).snd.getOutput -} \ No newline at end of file +} diff --git a/src/X86_64.lama b/src/X86_64.lama index 8c7da6dcce..303f9c5f85 100644 --- a/src/X86_64.lama +++ b/src/X86_64.lama @@ -8,7 +8,7 @@ import Fun; -- Assembler language interface -- The registers: - + var regs = ["%rbx", "%rcx", "%rsi", "%rdi", "%r8" , "%r9" , "%r10", "%r11", "%r12", "%r13", "%r14", "%r15", @@ -17,7 +17,7 @@ var regs = ["%rbx", "%rcx", "%rsi", "%rdi", -- We can not freely operate with all register; only with 12 by now var nRegs = regs.length - 5; --- For convenience we define the following synonyms for the registers: +-- For convenience we define the following synonyms for the registers: var rbx = R (0), rcx = R (1), rsi = R (2), @@ -38,37 +38,37 @@ var rbx = R (0), -- We need to know the word size to calculate offsets correctly var wordSize = 8; --- We need to distinguish the following operand types: --- R (int) -- hard register --- S (int) -- a position on the hardware stack --- M (string) -- a named memory location --- L (int) -- an immediate operand +-- We need to distinguish the following operand types: +-- R (int) -- hard register +-- S (int) -- a position on the hardware stack +-- M (string) -- a named memory location +-- L (int) -- an immediate operand -- Some x86 instruction (we do not need all of them): --- Mov (opnd, opnd) -- copies a value from the first to the second operand --- Binop (string, opnd, opnd) -- makes a binary operation; note, the first operand +-- Mov (opnd, opnd) -- copies a value from the first to the second operand +-- Binop (string, opnd, opnd) -- makes a binary operation; note, the first operand -- designates x86 operator, not the source language one --- IDiv (opnd) -- x86 integer division, see instruction set reference --- Cqo -- see instruction set reference --- Set (string, string) -- sets a value from flags; the first operand is the +-- IDiv (opnd) -- x86 integer division, see instruction set reference +-- Cqo -- see instruction set reference +-- Set (string, string) -- sets a value from flags; the first operand is the -- suffix, which determines the value being set, the -- the second --- (sub)register name -- Push (opnd) -- pushes the operand on the hardware stack -- Pop (opnd) -- pops from the hardware stack to the operand --- Call (string) -- calls a function by its name +-- Call (string) -- calls a function by its name -- Ret -- returns from a function -- Meta (string) -- metainformation (declarations, etc.) - + -- Machine instruction printer fun insnString (insn) { - + fun binopString (op) { case op of "+" -> "addq" | "-" -> "subq" | "*" -> "imulq" | "&&" -> "andq" - | "!!" -> "orq" + | "!!" -> "orq" | "^" -> "xorq" | "cmp" -> "cmpq" esac @@ -82,7 +82,7 @@ fun insnString (insn) { | L (i) -> sprintf ("$%d", i) esac } - + case insn of Cqo -> "\tcqo\n" | Set (suf, s) -> sprintf ("\tset%s\t%s\n", suf, s) @@ -114,12 +114,12 @@ fun makeEnv (stack, stackSlots, globals) { fun envString () { sprintf ("Stack : %s\nStackSlots: %d\nGlobals : %s\n", stack.string, stackSlots, elements (globals).string) } - + -- Allocates a new position on the symbolic stack; -- returns a pair: a location for allocated item and -- an updated environment fun allocate () { - case + case case stack of {} -> [rbx, 0] | S (n) : _ -> [S (n+1), n+2] @@ -159,7 +159,7 @@ fun makeEnv (stack, stackSlots, globals) { fun loc (name) { M (globalName (name)) } - + -- Gets a list of global variables from the environment fun getGlobals () { globals.elements @@ -251,7 +251,7 @@ fun stackOpnd (opnd) { case opnd of S (_) -> true | _ -> false - esac + esac } -- Checks if an operand resides in memory @@ -285,6 +285,62 @@ fun suffix (op) { esac } +fun reqularBinop (op, [y, x, env], code) { + code <+ Binop (op, y, x) +} + +fun comparison (op, y, x) { + singletonBuffer(Binop ("^", rax, rax)) + <+ Binop ("cmp", y, x) + <+ Set (op.suffix, "%al") + <+ Mov (rax, x) +} + +fun comparisonZero (x) { + comparison ("!=", L (0), x) +} + +fun logicalBinop (op, [y, x, env], code) { + code + <+> comparisonZero (x) + <+> comparisonZero (y) + <+ Binop (op, y, x) +} + +fun comparisonBinop (op, [y, x, env], code) { + code <+> comparison (op, y, x) +} + +fun divisionBinop (op, [y, x, env], code) { + code + <+ Binop ("^", rdx, rdx) + <+ Mov (x, rax) + <+ IDiv (y) + <+ (case op of + "/" -> Mov (rax, x) + | "%" -> Mov (rdx, x) + esac) +} + +fun compileBinop (op, stack@[y, x, env], code) { + [env.push(x), + case op of + "!!" -> logicalBinop (op, stack, code) + | "&&" -> logicalBinop (op, stack, code) + | "==" -> comparisonBinop (op, stack, code) + | "!=" -> comparisonBinop (op, stack, code) + | "<=" -> comparisonBinop (op, stack, code) + | "<" -> comparisonBinop (op, stack, code) + | ">=" -> comparisonBinop (op, stack, code) + | ">" -> comparisonBinop (op, stack, code) + | "+" -> reqularBinop (op, stack, code) + | "-" -> reqularBinop (op, stack, code) + | "*" -> reqularBinop (op, stack, code) + | "/" -> divisionBinop (op, stack, code) + | "%" -> divisionBinop (op, stack, code) + esac] +} + -- Compiles stack machine code into a list of x86 instructions. Takes an environment -- and stack machine code, returns an updated environment and x86 code. fun compile (env, code) { @@ -295,12 +351,23 @@ fun compile (env, code) { READ -> case env.allocate of [s, env] -> [env, code <+ Call ("Lread") <+ Mov (rax, s)] - esac + esac | WRITE -> case env.pop of [s, env] -> [env, code <+ Mov (s, rdi) <+ Call ("Lwrite")] esac - | _ -> failure ("codegeneration for instruction %s is not yet implemented\n", i.string) + | BINOP(op) -> compileBinop (op, env.pop2, code) + | LD(name) -> + case env.allocate of + [s, env] -> [env, code <+> env.loc(name).move(s)] + esac + | ST(name) -> + let [s, env] = env.pop in let env = env.addGlobal(name) in + [env, code <+> s.move(env.loc(name))] + | CONST(x) -> + case env.allocate of + [s, env] -> [env, code <+ Mov (L (x), s)] + esac esac }, [env, emptyBuffer ()], code) } @@ -310,7 +377,7 @@ fun compile (env, code) { public fun compileX86 (code) { case compile (initEnv (), code) of [env, code] -> - map (insnString, + map (insnString, getBuffer $ singletonBuffer (Meta ("\t.global\tmain\n")) <+> dataSection (listBuffer $ map (dataDef, getGlobals (env))) <+> @@ -322,4 +389,4 @@ public fun compileX86 (code) { ) ).stringcat esac -} \ No newline at end of file +}