[SPBGU] T02 Vasily Fedorov

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")
-}
+   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
+}

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")
-}
+   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)
+}

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
-}
+}

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
-}
+}