Add compilation of constructors and basic values

5 files changed, 439 insertions, 2 deletions

diff --git a/snug-clean/src/MIPS/MIPS32.dcl b/snug-clean/src/MIPS/MIPS32.dcl
new file mode 100644
index 0000000..4789507
--- /dev/null
+++ b/snug-clean/src/MIPS/MIPS32.dcl
@@ -0,0 +1,96 @@
+definition module MIPS.MIPS32
+
+from StdOverloaded import class toString
+
+:: Line
+	= StartSection !String
+	| Align !Int
+	| Label !Label
+	| Instr !Instruction
+	| RawWord !Int
+	| RawAscii !String
+
+instance toString Line
+
+:: Instruction
+	= LoadByte !Signedness !TargetRegister !Offset !Base
+	| LoadHalfword !Signedness !TargetRegister !Offset !Base
+	| LoadWord !TargetRegister !Offset !Base
+	| StoreByte !TargetRegister !Offset !Base
+	| StoreHalfword !TargetRegister !Offset !Base
+	| StoreWord !TargetRegister !Offset !Base
+
+	| AddImmediate !Signedness !DestinationRegister !SourceRegister !Immediate
+	| AndImmediate !DestinationRegister !SourceRegister !Immediate
+	| LoadUpperImmediate !DestinationRegister !Immediate
+	| OrImmediate !DestinationRegister !SourceRegister !Immediate
+	| XorImmediate !DestinationRegister !SourceRegister !Immediate
+
+	| AddWord !Signedness !DestinationRegister !SourceRegister !TargetRegister
+	| AndWord !DestinationRegister !SourceRegister !TargetRegister
+	| NorWord !DestinationRegister !SourceRegister !TargetRegister
+	| OrWord !DestinationRegister !SourceRegister !TargetRegister
+	| SubWord !Signedness !DestinationRegister !SourceRegister !TargetRegister
+	| XorWord !DestinationRegister !SourceRegister !TargetRegister
+
+	| Jump !Link !JumpTarget
+	| BranchOn1 !BranchCondition1 !SourceRegister !Offset
+	| BranchOn2 !BranchCondition2 !SourceRegister !TargetRegister !Offset
+
+	| Break !Int
+	| Syscall !Int /* applications should also set v0 to the syscall argument */
+
+	| LoadAddress !DestinationRegister !Immediate
+	| Nop
+
+Move rd rs :== OrImmediate rd rs (Immediate 0)
+
+instance toString Instruction
+
+:: Signedness
+	= Signed
+	| Unsigned
+
+:: Base :== Register
+:: Offset :== Int /* 16-bit signed */
+
+:: DestinationRegister :== Register
+:: SourceRegister :== Register
+:: TargetRegister :== Register
+
+:: Register
+	= R0 /* always zero */
+	| AT /* reserved for assembler; do not use */
+	| V0 | V1 /* expression evaluations, integer results, static link for nested procedures */
+	| A !Int /* 0-3, integer arguments, values not preserved */
+	| T !Int /* 0-9, temporary, values not preserved */
+	| S !Int /* 0-7, saved, values preserved */
+	| K0 | K1 /* reserved for the kernel */
+	| GP /* global (heap) pointer */
+	| SP /* stack pointer */
+	| FP /* frame pointer if needed; otherwise saved register */
+	| RA /* return address; temporary */
+
+:: Immediate
+	= Immediate !Int /* 16-bit */
+	| Address !Offset !Label
+
+:: Link
+	= Link
+	| NoLink
+
+:: JumpTarget
+	= Direct !Immediate
+	| Register !Register
+
+:: Label :== String
+
+:: BranchCondition1
+	= BCGeZero !Link
+	| BCGtZero
+	| BCLeZero
+	| BCLtZero !Link
+
+:: BranchCondition2
+	= BCEq
+	| BCNe
diff --git a/snug-clean/src/MIPS/MIPS32.icl b/snug-clean/src/MIPS/MIPS32.icl
new file mode 100644
index 0000000..a124007
--- /dev/null
+++ b/snug-clean/src/MIPS/MIPS32.icl
@@ -0,0 +1,162 @@
+implementation module MIPS.MIPS32
+
+import StdEnv
+
+import Text
+
+instance toString Line
+where
+	toString (StartSection s) = "\t." +++ s
+	toString (Align i) = "\t.align\t" +++ toString i
+	toString (Label l) = l +++ ":"
+	toString (Instr i) = "\t" +++ toString i
+	toString (RawWord i) = "\t.word\t" +++ toString i
+	toString (RawAscii s) = concat3 "\t.ascii\t\"" s "\"" // TODO: escaping
+
+instance toString Instruction
+where
+	toString (LoadByte signed rt offset base) =
+		memInstrS (if (signed=:Signed) "lb" "lbu") rt (checkOffset offset) base
+	toString (LoadHalfword signed rt offset base) =
+		memInstrS (if (signed=:Signed) "lh" "lhu") rt (checkOffset offset) base
+	toString (LoadWord rt offset base) =
+		memInstrS "lw" rt (checkOffset offset) base
+	toString (StoreByte rt offset base) =
+		memInstrS "sb" rt (checkOffset offset) base
+	toString (StoreHalfword rt offset base) =
+		memInstrS "sh" rt (checkOffset offset) base
+	toString (StoreWord rt offset base) =
+		memInstrS "sw" rt (checkOffset offset) base
+
+	toString (AddImmediate signed rt rs imm) =
+		immediateInstrS (if (signed=:Signed) "addi" "addiu") rt rs (checkImmediate signed imm)
+	toString (AndImmediate rt rs imm) =
+		immediateInstrS "andi" rt rs (checkImmediate Unsigned imm)
+	toString (LoadUpperImmediate rt imm) =
+		concat ["lui\t",toString rt,",",toString (checkImmediate Unsigned imm)]
+	toString (OrImmediate rt rs imm) =
+		immediateInstrS "ori" rt rs (checkImmediate Unsigned imm)
+	toString (XorImmediate rt rs imm) =
+		immediateInstrS "xori" rt rs (checkImmediate Unsigned imm)
+
+	toString (AddWord signed rd rs rt) =
+		threeRegInstrS (if (signed=:Signed) "add" "addu") rd rs rt
+	toString (AndWord rd rs rt) =
+		threeRegInstrS "and" rd rs rt
+	toString (NorWord rd rs rt) =
+		threeRegInstrS "nor" rd rs rt
+	toString (OrWord rd rs rt) =
+		threeRegInstrS "or" rd rs rt
+	toString (SubWord signed rd rs rt) =
+		threeRegInstrS (if (signed=:Signed) "sub" "subu") rd rs rt
+	toString (XorWord rd rs rt) =
+		threeRegInstrS "xor" rd rs rt
+
+	toString (Jump link target) =
+		instr +++ toString target
+	where
+		instr = case (link, target) of
+			(NoLink, Direct _) -> "j\t"
+			(Link, Direct _) -> "jal\t"
+			(NoLink, Register _) -> "jr\t"
+			(Link, Register _) -> "jalr\t"
+	toString (BranchOn1 (BCGeZero link) rs offset) =
+		branch1InstrS (if (link=:Link) "bgezal" "bgez") rs (checkOffset offset)
+	toString (BranchOn1 BCGtZero rs offset) =
+		branch1InstrS "bgtz" rs (checkOffset offset)
+	toString (BranchOn1 BCLeZero rs offset) =
+		branch1InstrS "blez" rs (checkOffset offset)
+	toString (BranchOn1 (BCLtZero link) rs offset) =
+		branch1InstrS (if (link=:Link) "bltzal" "bltz") rs (checkOffset offset)
+	toString (BranchOn2 cond rs rt offset) =
+		immediateInstrS (if (cond=:BCEq) "beq" "bne") rs rt (Immediate (checkOffset offset))
+
+	toString (Break arg) =
+		"break\t" +++ toString arg
+	toString (Syscall arg) =
+		"syscall\t" +++ toString arg
+
+	toString (LoadAddress rd imm) =
+		concat4 "la\t" (toString rd) "," (toString imm)
+	toString Nop =
+		"nop"
+
+instance toString JumpTarget
+where
+	toString (Direct imm)
+		= toString imm
+	toString (Register r)
+		= toString r
+
+instance toString Immediate
+where
+	toString (Immediate i)
+		= toString i
+	toString (Address offset label)
+		| offset == 0
+			= label
+		| offset > 0
+			= concat3 label "+" (toString offset)
+			= concat3 label "-" (toString offset)
+
+memInstrS :: !String !Register !Offset !Base -> String
+memInstrS opcode rt 0 base = concat [opcode,"\t",toString rt,",(",toString base,")"]
+memInstrS opcode rt offset base = concat [opcode,"\t",toString rt,",",toString offset,"(",toString base,")"]
+
+immediateInstrS :: !String !TargetRegister !SourceRegister !Immediate -> String
+immediateInstrS opcode rt rs imm = concat [opcode,"\t",toString rt,",",toString rs,",",toString imm]
+
+threeRegInstrS :: !String !DestinationRegister !SourceRegister !TargetRegister -> String
+threeRegInstrS opcode rd rs rt = concat [opcode,"\t",toString rd,",",toString rs,",",toString rt]
+
+branch1InstrS :: !String !SourceRegister !Offset -> String
+branch1InstrS opcode rs offset = concat [opcode,"\t",toString rs,",",toString offset]
+
+instance toString Register
+where
+	toString reg = toString` (checkReg reg)
+	where
+		/* Sorted by estimated frequency for efficiency */
+		toString` (T n) = "$t" +++ toString n
+		toString` (S n) = "$s" +++ toString n
+		toString` (A n) = "$a" +++ toString n
+		toString` R0 = "$0"
+		toString` GP = "$gp"
+		toString` SP = "$sp"
+		toString` FP = "$fp"
+		toString` RA = "$ra"
+		toString` AT = "$at"
+		toString` V0 = "$v0"
+		toString` V1 = "$v1"
+		toString` K0 = "$k0"
+		toString` K1 = "$k1"
+
+checkReg :: !Register -> Register
+checkReg (T n) | not (0 <= n && n <= 9)
+	= abort ("non-existing register $t" +++ toString n +++ "\n")
+checkReg (S n) | not (0 <= n && n <= 7)
+	= abort ("non-existing register $s" +++ toString n +++ "\n")
+checkReg (A n) | not (0 <= n && n <= 3)
+	= abort ("non-existing register $a" +++ toString n +++ "\n")
+checkReg reg
+	= reg
+
+checkOffset :: !Int -> Int
+checkOffset offset
+	| 0 <= offset && offset <= 0x7fff
+		= offset
+	| offset >= -0x8000
+		= offset bitand 0xffff
+		= abort ("offset " +++ toString offset +++ " out of bounds\n")
+
+checkImmediate :: !Signedness !Immediate -> Immediate
+checkImmediate Signed (Immediate imm)
+	| 0 <= imm && imm <= 0x7fff
+		= Immediate imm
+	| imm >= -0x8000
+		= Immediate (imm bitand 0xffff)
+		= abort ("signed immediate " +++ toString imm +++ " out of bounds\n")
+checkImmediate Unsigned (Immediate imm)
+	| 0 <= imm && imm <= 0xffff
+		= Immediate imm
+		= abort ("unsigned immediate " +++ toString imm +++ " out of bounds\n")
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'
diff --git a/snug-clean/src/snug.icl b/snug-clean/src/snug.icl
index 1cdfcf6..23d24d0 100644
--- a/snug-clean/src/snug.icl
+++ b/snug-clean/src/snug.icl
@@ -3,20 +3,41 @@ module snug
 import StdEnv
 import StdMaybe
 
+import Data.Error
+import Data.List
 import System.CommandLine
+import System.File
+import System.FilePath
+import Text
 
+import MIPS.MIPS32
+import Snug.Compile
 import Snug.Parse
 
+/* Note: after compiling with
+ *   snug program.snug
+ * an assembly file program.s is generated, which can be run with SPIM using
+ *   spim -delayed_branches <(cat driver.s program.s)
+ */
+
 Start w
 	# ([prog:args],w) = getCommandLine w
 	| length args <> 1 = abort ("Usage: " +++ prog +++ " INPUT\n")
 	# input = hd args
+	  output = dropExtension input +++ ".s"
 	# (mbInput,w) = readFile input w
 	  input = fromJust mbInput
 	| isNone mbInput = abort "Failed to read input\n"
-	| otherwise = parseSnug input
+	# mbDefs = parseSnug input
+	  defs = fromOk mbDefs
+	| isError mbDefs = abort ("Failed to parse: " +++ fromError mbDefs +++ "\n")
+	# assembly = compile "main" defs
+	# assembly = join "\n" (map toString assembly)
+	# (mbErr,w) = writeFile output assembly w
+	| isError mbErr = abort ("Failed to write output: " +++ toString (fromError mbErr) +++ "\n")
+	| otherwise = w
 
-readFile :: !String !*World -> (!?[Char], !*World)
+readFile :: !FilePath !*World -> (!?[Char], !*World)
 readFile path w
 	# (ok,f,w) = fopen path FReadData w
 	| not ok = (?None, w)