Add compilation of constructors and basic values

2 files changed, 158 insertions, 0 deletions

diff --git a/snug-clean/src/Snug/Compile.dcl b/snug-clean/src/Snug/Compile.dcl
new file mode 100644
index 0000000..d329156
--- /dev/null
+++ b/snug-clean/src/Snug/Compile.dcl
@@ -0,0 +1,28 @@
+definition module Snug.Compile
+
+from Data.Map import :: Map
+
+from MIPS.MIPS32 import :: Line
+from Snug.Syntax import :: ConstructorDef, :: ConstructorIdent, :: Definition,
+	:: SymbolIdent, :: Type
+
+:: Namespace :== String
+
+:: Namespaced id =
+	{ ns :: !Namespace
+	, id :: !id
+	}
+
+:: Globals =
+	{ constructors :: !Map (Namespaced ConstructorIdent) ConstructorDef
+	, functions    :: !Map (Namespaced SymbolIdent) FunctionInfo
+	}
+
+:: FunctionInfo =
+	{ arity :: !Int
+	, type :: !Type
+	}
+
+compile :: !Namespace ![Definition] -> [Line]
+
+compileDefinition :: !Namespace !Globals !Definition -> [Line]
diff --git a/snug-clean/src/Snug/Compile.icl b/snug-clean/src/Snug/Compile.icl
new file mode 100644
index 0000000..2a9d9e4
--- /dev/null
+++ b/snug-clean/src/Snug/Compile.icl
@@ -0,0 +1,130 @@
+implementation module Snug.Compile
+
+import StdEnv
+
+import Data.List
+import qualified Data.Map
+from Data.Map import :: Map
+import Text
+
+import MIPS.MIPS32
+import Snug.Syntax
+
+:: Locals :== Map SymbolIdent MemoryLocation
+
+:: MemoryLocation
+	= 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
+
+instance < (Namespaced id) | < id
+where
+	(<) x y
+		| x.id < y.id = True
+		| x.id > y.id = False
+		| otherwise = x.ns < y.ns
+
+compile :: !Namespace ![Definition] -> [Line]
+compile ns defs =
+	concatMap (compileDefinition ns globals) defs
+where
+	globals =
+		{ constructors = 'Data.Map'.fromList
+			[ ({ns="", id="INT"}, ConstructorDef "INT" [])
+			]
+		, functions = 'Data.Map'.newMap
+		}
+
+compileDefinition :: !Namespace !Globals !Definition -> [Line]
+compileDefinition _ _ (TypeDef _ _) =
+	[]
+compileDefinition ns globals (DataDef _ _ constructors) =
+	[ StartSection "data"
+	: concatMap (compileConstructor ns globals) constructors
+	]
+compileDefinition ns globals (FunDef id args ret expr) =
+	[ StartSection "text"
+	, Align 3 // to have 3 bits unused in addresses
+	, RawWord (sum [2^i \\ i <- [0..] & _ <- args]) // all strict for now, TODO change
+	, RawWord (length args) // arity
+	, Label (functionLabel ns NodeEntry id)
+	: map Instr (compileExpr ns globals locals expr)
+	]
+where
+	locals = 'Data.Map'.fromList
+		[ (id, Indirect FrontEvalPtr (offset*4))
+		\\ (id,_) <- args
+		& offset <- [1..]
+		]
+
+compileConstructor :: !Namespace !Globals !ConstructorDef -> [Line]
+compileConstructor ns _ (ConstructorDef id args) =
+	[ Align 3 // to have 3 bits unused in addresses
+	, Label (constructorLabel ns id)
+	, RawWord (length args) // arity
+	, RawWord (size id) // length name
+	, RawAscii id // name
+	]
+
+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)
+	]
+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
+//	| 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'