Add stack simulator for compilation

5 files changed, 217 insertions, 52 deletions

diff --git a/snug-clean/src/Snug/Compile.icl b/snug-clean/src/Snug/Compile.icl
index 2a9d9e4..26fd5af 100644
--- a/snug-clean/src/Snug/Compile.icl
+++ b/snug-clean/src/Snug/Compile.icl
@@ -2,12 +2,15 @@ implementation module Snug.Compile
 
 import StdEnv
 
+import Control.Monad
+import Data.Func
 import Data.List
 import qualified Data.Map
 from Data.Map import :: Map
-import Text
 
 import MIPS.MIPS32
+import Snug.Compile.ABI
+import Snug.Compile.Simulate
 import Snug.Syntax
 
 :: Locals :== Map SymbolIdent MemoryLocation
@@ -16,15 +19,6 @@ import Snug.Syntax
 	= InRegister !Register
 	| Indirect !Register !Offset
 
-:: EntryPoint
-	= NodeEntry
-
-BackPrintPtr :== S 0
-FrontPrintPtr :== S 1
-BackEvalPtr :== S 2
-FrontEvalPtr :== S 3
-HeapPtr :== GP
-
 instance == (Namespaced id) | == id
 where
 	(==) x y = x.id == y.id && x.ns == y.ns
@@ -79,52 +73,21 @@ compileConstructor ns _ (ConstructorDef id args) =
 	]
 
 compileExpr :: !Namespace !Globals !Locals !Expression -> [Instruction]
-compileExpr _ _ _ (BasicValue bv) =
-	// Build new node
-	[ LoadAddress (T 0) (Address 2 (constructorLabel "" (label bv)))
-	, StoreWord (T 0) 0 HeapPtr
-	] ++
-	loadImmediate bv ++
-	[ StoreWord (T 0) 4 HeapPtr
-	// Overwrite old node with indirection
-	, LoadAddress (T 0) (Address 0 (functionLabel "" NodeEntry "indir"))
-	, StoreWord (T 0) 0 FrontEvalPtr
-	, StoreWord HeapPtr 4 FrontEvalPtr
-	// Update front and heap pointers; return
-	, Move FrontEvalPtr HeapPtr
-	, Jump NoLink (Direct (Address 0 "eval"))
-	, AddImmediate Signed GP GP (Immediate 8)
-	]
+compileExpr ns globals locals expr = simulate $
+	simulator ns globals locals expr >>|
+	indirectAndEval
+
+simulator :: !Namespace !Globals !Locals !Expression -> Simulator ()
+simulator _ _ _ (BasicValue bv) =
+	pushBasicValue bv >>|
+	buildCons (constructorLabel "" (label bv)) 1
 where
 	label (BVInt _) = "INT"
 	label (BVChar _) = "CHAR"
-
-	loadImmediate (BVInt i)
-		| 0 <= i && i < 0x10000 =
-			[ OrImmediate (T 0) R0 (Immediate i)
-			]
-		| 0 > i && i >= -0x8000 =
-			[ AddImmediate Signed (T 0) R0 (Immediate i)
-			]
-		| otherwise =
-			[ LoadUpperImmediate (T 0) (Immediate (i >> 16))
-			, OrImmediate (T 0) (T 0) (Immediate (i bitand 0xffff))
-			]
-compileExpr _ _ _ _ = [Nop]// TODO
+simulator _ _ _ _ = // TODO
+	pushBasicValue (BVInt 0) >>|
+	buildCons (constructorLabel "" "INT") 1
 //	| Symbol !SymbolIdent
 //	| Constructor !ConstructorIdent
 //	| Case !Expression ![CaseAlternative]
 //	| ExpApp !Expression !Expression
-
-constructorLabel :: !Namespace !ConstructorIdent -> Label
-constructorLabel "" id = "_c" +++ id // for built-in constructors
-constructorLabel ns id = concat4 "__" ns "_c" id // TODO escaping
-
-functionLabel :: !Namespace !EntryPoint !ConstructorIdent -> Label
-functionLabel ns entry_point id // TODO escaping
-	| size ns == 0
-		= {#'_',e} +++ id
-		= concat4 "__" ns {#'_',e} id
-where
-	e = case entry_point of
-		NodeEntry -> 'n'
diff --git a/snug-clean/src/Snug/Compile/ABI.dcl b/snug-clean/src/Snug/Compile/ABI.dcl
new file mode 100644
index 0000000..938a65e
--- /dev/null
+++ b/snug-clean/src/Snug/Compile/ABI.dcl
@@ -0,0 +1,21 @@
+definition module Snug.Compile.ABI
+
+from MIPS.MIPS32 import :: Label, :: Register(GP,S,T)
+from Snug.Compile import :: Namespace
+from Snug.Syntax import :: ConstructorIdent, :: SymbolIdent
+
+:: EntryPoint
+	= NodeEntry
+
+BackPrintPtr :== S 0
+FrontPrintPtr :== S 1
+
+BackEvalPtr :== S 2
+FrontEvalPtr :== S 3
+
+HeapPtr :== GP
+
+TempImm :== T 0
+
+constructorLabel :: !Namespace !ConstructorIdent -> Label
+functionLabel :: !Namespace !EntryPoint !SymbolIdent -> Label
diff --git a/snug-clean/src/Snug/Compile/ABI.icl b/snug-clean/src/Snug/Compile/ABI.icl
new file mode 100644
index 0000000..66a8d5c
--- /dev/null
+++ b/snug-clean/src/Snug/Compile/ABI.icl
@@ -0,0 +1,38 @@
+implementation module Snug.Compile.ABI
+
+import StdEnv
+
+import Text
+
+import MIPS.MIPS32
+import Snug.Compile
+
+constructorLabel :: !Namespace !ConstructorIdent -> Label
+constructorLabel "" id = "_c" +++ id // for built-in constructors
+constructorLabel ns id = concat4 "__" (escapeLabel ns) "_c" (escapeLabel id)
+
+functionLabel :: !Namespace !EntryPoint !SymbolIdent -> Label
+functionLabel ns entry_point id
+	| size ns == 0
+		= {#'_',e} +++ escapeLabel id
+		= concat4 "__" (escapeLabel ns) {#'_',e} (escapeLabel id)
+where
+	e = case entry_point of
+		NodeEntry -> 'n'
+
+escapeLabel :: !String -> String
+escapeLabel s = {#c \\ c <- escape [c \\ c <-: s]}
+where
+	escape [] = []
+	escape [c:cs] | isAlphanum c = [c:escape cs]
+	escape ['_':cs] = ['__':escape cs]
+	escape ['`':cs] = ['_B':escape cs]
+	escape [':':cs] = ['_C':escape cs]
+	escape ['.':cs] = ['_D':escape cs]
+	escape ['>':cs] = ['_G':escape cs]
+	escape ['=':cs] = ['_I':escape cs]
+	escape ['<':cs] = ['_L':escape cs]
+	escape ['-':cs] = ['_M':escape cs]
+	escape ['+':cs] = ['_P':escape cs]
+	escape ['\'':cs] = ['_Q':escape cs]
+	escape ['~':cs] = ['_T':escape cs]
diff --git a/snug-clean/src/Snug/Compile/Simulate.dcl b/snug-clean/src/Snug/Compile/Simulate.dcl
new file mode 100644
index 0000000..a61d631
--- /dev/null
+++ b/snug-clean/src/Snug/Compile/Simulate.dcl
@@ -0,0 +1,25 @@
+definition module Snug.Compile.Simulate
+
+from Control.Applicative import class Applicative, class pure, class <*>
+from Control.Monad import class Monad
+from Control.Monad.Identity import :: Identity, instance Functor Identity,
+	instance Monad Identity, instance pure Identity, instance <*> Identity
+from Control.Monad.State import :: State, :: StateT,
+	instance Functor (StateT s m), instance Monad (StateT s m),
+	instance pure (StateT s m), instance <*> (StateT s m)
+from Data.Functor import class Functor
+
+from MIPS.MIPS32 import :: Instruction, :: Label
+from Snug.Syntax import :: BasicValue
+
+:: Simulator a :== State SimulationState a
+
+:: SimulationState
+
+simulate :: !(Simulator a) -> [Instruction]
+
+buildCons :: !Label !Int -> Simulator ()
+
+pushBasicValue :: !BasicValue -> Simulator ()
+
+indirectAndEval :: Simulator ()
diff --git a/snug-clean/src/Snug/Compile/Simulate.icl b/snug-clean/src/Snug/Compile/Simulate.icl
new file mode 100644
index 0000000..d1d65ac
--- /dev/null
+++ b/snug-clean/src/Snug/Compile/Simulate.icl
@@ -0,0 +1,118 @@
+implementation module Snug.Compile.Simulate
+
+import StdEnv
+
+import Control.Monad
+import Control.Monad.Identity
+import Control.Monad.State
+import Data.Functor
+
+import MIPS.MIPS32
+import Snug.Compile.ABI
+import Snug.Syntax
+
+:: SimulationState =
+	{ instrs    :: ![[Instruction]]
+	, hp_offset :: !Int
+	, stack     :: ![StackValue]
+	}
+
+:: StackValue
+	= SVImmediate !Immediate
+	| SVRegOffset !Register !Offset /* value is reg + offset */
+
+simulate :: !(Simulator a) -> [Instruction]
+simulate sim = flatten (reverse (execState sim initial).instrs)
+where
+	// TODO: when finishing:
+	// - check that the stack is empty
+	// - update heap pointer
+	initial =
+		{ instrs = []
+		, hp_offset = 0
+		, stack = []
+		}
+
+add :: ![Instruction] -> Simulator ()
+add is = modify \s -> {s & instrs=[is:s.instrs]}
+
+push :: StackValue -> Simulator ()
+push sv = modify \s -> {s & stack=[sv:s.stack]}
+
+pop :: Simulator StackValue
+pop =
+	getState >>= \{stack} ->
+	modify (\s -> {s & stack=tl stack}) $> hd stack
+
+write_heap :: !StackValue -> Simulator StackValue
+write_heap sv =
+	getState >>= \{hp_offset} ->
+	storeStackValue sv hp_offset HeapPtr >>|
+	modify (\s -> {s & hp_offset=hp_offset+4}) $>
+	SVRegOffset HeapPtr hp_offset
+
+storeStackValue :: !StackValue !Offset !Register -> Simulator ()
+storeStackValue (SVImmediate (Immediate i)) doffset dreg
+	| i == 0 = add
+		[ StoreWord R0 doffset dreg
+		]
+	| 0 <= i && i < 0x10000 = add
+		[ OrImmediate TempImm R0 (Immediate i)
+		, StoreWord TempImm doffset dreg
+		]
+	| 0 > i && i >= -0x8000 = add
+		[ AddImmediate Signed TempImm R0 (Immediate i)
+		, StoreWord TempImm doffset dreg
+		]
+	| otherwise = add
+		[ LoadUpperImmediate TempImm (Immediate (i >> 16))
+		, OrImmediate TempImm TempImm (Immediate (i bitand 0xffff))
+		, StoreWord TempImm doffset dreg
+		]
+storeStackValue (SVImmediate imm=:(Address _ _)) doffset dreg = add
+	[ LoadAddress TempImm imm
+	, StoreWord TempImm doffset dreg
+	]
+storeStackValue (SVRegOffset reg 0) doffset dreg = add
+	[ StoreWord reg doffset dreg
+	]
+storeStackValue (SVRegOffset reg offset) doffset dreg = add
+	[ AddImmediate Signed TempImm reg (Immediate offset)
+	, StoreWord TempImm doffset dreg
+	]
+
+buildCons :: !Label !Int -> Simulator ()
+buildCons cons nargs =
+	write_heap (SVImmediate (Address 2 cons)) >>= \addr ->
+	mapM_ (\_ -> pop >>= write_heap) [1..nargs] >>|
+	push addr
+
+pushBasicValue :: !BasicValue -> Simulator ()
+pushBasicValue val = push (SVImmediate (Immediate imm))
+where
+	imm = case val of
+		BVInt i -> i
+		BVChar c -> toInt c
+
+indirectAndEval :: Simulator ()
+indirectAndEval =
+	pop >>= \sv ->
+	case sv of
+		SVRegOffset HeapPtr offset ->
+			add
+				// Build indirection
+				[ LoadAddress TempImm (Address 0 (functionLabel "" NodeEntry "indir"))
+				, StoreWord TempImm 0 FrontEvalPtr
+				] >>|
+			storeStackValue sv 4 FrontEvalPtr >>|
+			add
+				// Evaluate
+				[ AddImmediate Signed FrontEvalPtr HeapPtr (Immediate offset)
+				, Jump NoLink (Direct (Address 0 "eval"))
+				] >>|
+			getState >>= \{hp_offset} ->
+			add
+				[ AddImmediate Signed HeapPtr HeapPtr (Immediate hp_offset)
+				]
+		_ ->
+			abort "unexpected top of stack in indirect\n"