Continue with cases WIP: todo is matching code for basic values and adding locals for constructor arguments in a patterncases

6 files changed, 128 insertions, 75 deletions

diff --git a/snug-clean/src/Snug/Compile.dcl b/snug-clean/src/Snug/Compile.dcl
index ef223b8..dd8bef1 100644
--- a/snug-clean/src/Snug/Compile.dcl
+++ b/snug-clean/src/Snug/Compile.dcl
@@ -29,13 +29,15 @@ from Snug.Syntax import :: ConstructorDef, :: ConstructorIdent, :: Definition,
 
 :: CompileState
 
-:: Locals :== Map SymbolIdent LocalLocation
+:: Locals :== Map SymbolIdent Symbol
 
-:: Local =
-	{ location :: !LocalLocation
-	, type :: !Type
-	}
+:: Symbol
+	= LocalSymbol !LocalLocation
+	| FunctionSymbol !FunctionInfo
+	| ConstructorSymbol !ConstructorDef
 
 :: LocalLocation
 
 compile :: !Namespace ![Definition] -> MaybeError String [Line]
+
+lookupConstructorM :: !ConstructorIdent -> CompileM ConstructorDef
diff --git a/snug-clean/src/Snug/Compile.icl b/snug-clean/src/Snug/Compile.icl
index 0fb3e25..601acb0 100644
--- a/snug-clean/src/Snug/Compile.icl
+++ b/snug-clean/src/Snug/Compile.icl
@@ -18,11 +18,11 @@ from Text import concat3, concat4
 import MIPS.MIPS32
 import Snug.Compile.ABI
 import Snug.Compile.Simulate
-import Snug.Compile.Typing
 import Snug.Syntax
 
 :: CompileState =
-	{ fresh_ident :: !Int
+	{ namespace   :: !Namespace
+	, fresh_ident :: !Int
 	, globals     :: !Globals
 	}
 
@@ -39,17 +39,20 @@ where
 		| x.id > y.id = False
 		| otherwise = x.ns < y.ns
 
+:: Type | NoType
+
 compile :: !Namespace ![Definition] -> MaybeError String [Line]
 compile ns defs =
 	flatten <$> evalStateT
 		(
-			mapM (liftCases ns) defs <$&> flatten >>= \defs ->
-			mapM (compileDefinition ns) defs
+			mapM liftCases defs <$&> flatten >>= \defs ->
+			mapM compileDefinition defs
 		)
 		init
 where
 	init =
-		{ fresh_ident = 0
+		{ namespace = ns
+		, fresh_ident = 0
 		, globals = combineGlobals [builtin, gatherGlobals ns defs]
 		}
 
@@ -94,14 +97,9 @@ addGlobalFunction sym fi = modify \s -> {s & globals.functions='Data.Map'.put sy
  * TODO: the remaining work for this changeset consists of:
  * - Generating the correct matching code in `compileCase`
  * - Adding a fallthrough case in the base case of `compileCase`
- * - Correctly determining the type of generated `FunDef`s in `liftCases`.
- *   Types are currently not used, so an alternative is to do type checking
- *   before `liftCases` and do `liftCases` at an untyped stage. But since we
- *   need type inference in the end anyway it is not so clear what the benefit
- *   of a separate untyped stage would be.
  */
-liftCases :: !Namespace !Definition -> CompileM [Definition]
-liftCases ns (FunDef name args ret expr) =
+liftCases :: !Definition -> CompileM [Definition]
+liftCases (FunDef name args ret expr) =
 	liftCasesFromExpr True expr <$&> \(defs,expr) -> [FunDef name args ret expr:defs]
 where
 	liftCasesFromExpr toplevel e = case e of
@@ -123,24 +121,31 @@ where
 		liftCasesFromExpr False expr <$&> appSnd (CaseAlternative pat)
 
 	liftCase e alts =
+		gets (\s -> s.namespace) >>= \ns ->
 		freshLabel "case" >>= \funName ->
-		addGlobalFunction {ns=ns, id=funName} {arity=length argsToLift + 1, type=undef} $> // TODO type
-		( [FunDef funName (argsToLift ++ [("_casearg", undef)]) undef (Case (Symbol "_casearg") alts)] // TODO types
+		addGlobalFunction {ns=ns, id=funName} {arity=length argsToLift + 1, type=NoType} $>
+		( [FunDef funName (argsToLift ++ [("_casearg", NoType)]) NoType (Case (Symbol "_casearg") alts)]
 		, foldl ExpApp (Symbol funName) ([Symbol sym \\ (sym,_) <- argsToLift] ++ [e])
 		)
 	where
 		usedSyms = usedSymbols (e, alts)
 		argsToLift = [arg \\ arg=:(sym,_) <- args | 'Data.Set'.member sym usedSyms]
-liftCases ns (TestDef name ty expr expected) =
+liftCases (TestDef name ty expr expected) =
+	gets (\s -> s.namespace) >>= \ns ->
 	freshLabel "test" >>= \funName ->
-	liftCases ns (FunDef funName [] ty expr) <$&> \defs ->
+	liftCases (FunDef funName [] ty expr) <$&> \defs ->
 	[TestDef name ty (Symbol funName) expected : defs]
-liftCases _ def =
+liftCases def =
 	pure [def]
 
 freshLabel :: !String -> CompileM Label
 freshLabel prefix = state \st -> (concat3 "_l" prefix (toString st.fresh_ident), {st & fresh_ident=st.fresh_ident+1})
 
+lookupConstructorM :: !ConstructorIdent -> CompileM ConstructorDef
+lookupConstructorM id =
+	gets (\s -> (s.namespace, s.globals)) >>= \(ns,globals) ->
+	liftT (lookupConstructor ns id globals)
+
 lookupConstructor :: !Namespace !ConstructorIdent !Globals -> MaybeError String ConstructorDef
 lookupConstructor ns id globals = mb2error
 	(concat4 "Unknown constructor " ns "." id)
@@ -151,20 +156,26 @@ lookupFunction ns id globals = mb2error
 	(concat4 "Unknown symbol " ns "." id)
 	('Data.Map'.get {ns=ns, id=id} globals.functions)
 
-compileDefinition :: !Namespace !Definition -> CompileM [Line]
-compileDefinition _ (TypeDef _ _) = pure
+lookupLocal :: !SymbolIdent !Locals -> MaybeError String Symbol
+lookupLocal id locals = mb2error
+	("Unknown local " +++ id)
+	('Data.Map'.get id locals)
+
+compileDefinition :: !Definition -> CompileM [Line]
+compileDefinition (TypeDef _ _) = pure
 	[]
-compileDefinition ns (DataDef _ _ constructors) =
+compileDefinition (DataDef _ _ constructors) =
 	(++) [StartSection "data"] <$>
-	flatten <$> mapM (compileConstructor ns) constructors
-compileDefinition ns (FunDef id args ret expr) =
-	gets (\s -> s.globals) >>= \globals ->
+	flatten <$> mapM compileConstructor constructors
+compileDefinition (FunDef id args ret expr) =
+	gets (\s -> s.namespace) >>= \ns ->
+	let n_label = functionLabel ns NodeEntry id in
 	(++)
 		(if (isEmpty args) [] (
 			[ StartSection "data"
 			, Align 2
 			] ++ flatten
-			[[ Label (closure_label i)
+			[[ Label (closureLabel ns id i)
 			// TODO: Ideally we would use the following here:
 			//, RawByte i // pointer arity
 			//, RawByte 0 // basic value arity
@@ -197,43 +208,60 @@ compileDefinition ns (FunDef id args ret expr) =
 		// due to liftCases, all Case expressions are on the top level and have
 		// a Symbol as expression which is the last argument to the function
 		Case (Symbol local) alts ->
-			compileCase ns globals locals local alts
+			compileCase locals local alts
 		_ ->
-			map Instr <$> compileExpr ns globals locals expr
+			map Instr <$> compileExpr locals expr
 where
-	closure_label i = closureLabel ns id i
-	n_label = functionLabel ns NodeEntry id
 	locals = 'Data.Map'.fromList
-		[ (id, FrontPtrArg offset)
+		[ (id, LocalSymbol (FrontPtrArg offset))
 		\\ (id,_) <- args
 		& offset <- [0..]
 		]
 
-compileCase :: !Namespace !Globals !Locals !SymbolIdent ![CaseAlternative] -> CompileM [Line]
-compileCase _ _ _ _ [] =
+compileCase :: !Locals !SymbolIdent ![CaseAlternative] -> CompileM [Line]
+compileCase _ _ [] =
 	pure [] // TODO: add catch for partial cases
-compileCase ns globals locals exprSymbol [CaseAlternative pat rhs:rest] =
-	liftM2 (++) caseAlt (compileCase ns globals locals exprSymbol rest)
+compileCase locals exprSymbol [CaseAlternative pat rhs:rest] =
+	liftM2 (++) caseAlt (compileCase locals exprSymbol rest)
 where
 	// NB: we can assume that the expression has been evaluated; cases are strict
 	caseAlt = case pat of
 		Wildcard ->
 			map Instr <$>
-			compileExpr ns globals locals rhs
+			compileExpr locals rhs
 		BasicValuePattern bv ->
 			abort "compileCase: BasicValuePattern\n" // TODO
 		IdentPattern sym ->
-			map Instr <$>
-			compileExpr ns globals locals rhs // TODO: add sym to locals, update stack offsets
+			liftT (lookupLocal exprSymbol locals) >>= \exprSymbol ->
+			map Instr <$> compileExpr ('Data.Map'.put sym exprSymbol locals) rhs
 		ConstructorPattern cons args ->
+			gets (\s -> s.namespace) >>= \ns ->
+			freshLabel "match" >>= \match ->
 			freshLabel "nomatch" >>= \nomatch ->
-			pure // TODO: match
-				[ Instr (Jump NoLink (Direct (Address 0 nomatch)))
-				, Label nomatch
+			liftT (lookupLocal exprSymbol locals) >>= \(LocalSymbol (FrontPtrArg i)) ->
+			compileExpr locals rhs >>= \rhs -> // TODO: add args to locals
+			pure $
+				map Instr
+				[ LoadAddress (TempImm 0) (Address 0 (constructorLabel ns cons))
+				, LoadWord (TempImm 1) 0 FrontEvalPtr
+				, LoadWord (TempImm 1) (4+4*i) (TempImm 1)
+				, LoadWord (TempImm 1) 0 (TempImm 1)
+				// TODO: if the rhs is small enough we can use `bne t0,t1,nomatch` instead of a jump
+				, BranchOn2 BCEq (TempImm 0) (TempImm 1) match 4 // TODO what is the right offset to `match`?
+				, Nop
+				, Jump NoLink (Direct (Address 0 nomatch))
+				, Nop
+				] ++
+				[ Label match
+				: map Instr rhs
+				] ++
+				[ Label nomatch
 				]
 
-compileConstructor :: !Namespace !ConstructorDef -> CompileM [Line]
-compileConstructor ns (ConstructorDef id args) = pure
+compileConstructor :: !ConstructorDef -> CompileM [Line]
+compileConstructor (ConstructorDef id args) =
+	gets (\s -> s.namespace) <$&> \ns ->
+	let label = constructorLabel ns id in
 	[ Global label
 	, Align 1
 	, Label label
@@ -241,16 +269,14 @@ compileConstructor ns (ConstructorDef id args) = pure
 	, RawByte 0 // basic value arity
 	//, RawByte -1 // number of arguments still to be curried in (unused for constructors)
 	]
-where
-	label = constructorLabel ns id
 
-compileExpr :: !Namespace !Globals !Locals !Expression -> CompileM [Instruction]
-compileExpr ns globals locals expr =
+compileExpr :: !Locals !Expression -> CompileM [Instruction]
+compileExpr locals expr =
+	gets (\s -> (s.namespace, s.globals)) >>= \(ns,globals) ->
+	let expr` = simulator ns globals locals expr >>| indirectAndEval in
 	case simulate [SVRegOffset FrontEvalPtr 0] expr` of
 		Error e -> fail ("Compiling an expression failed: " +++ e)
 		Ok instrs -> pure instrs
-where
-	expr` = simulator ns globals locals expr >>| indirectAndEval
 
 simulator :: !Namespace !Globals !Locals !Expression -> Simulator ()
 simulator _ _ _ (BasicValue bv) =
@@ -261,7 +287,7 @@ where
 	label (BVChar _) = "CHAR"
 simulator ns globals locals (Symbol id) =
 	case 'Data.Map'.get id locals of
-		?Just (FrontPtrArg i) ->
+		?Just (LocalSymbol (FrontPtrArg i)) ->
 			stackSize >>= \n ->
 			pushArg (n-1) i
 		?None ->
diff --git a/snug-clean/src/Snug/Compile/ABI.dcl b/snug-clean/src/Snug/Compile/ABI.dcl
index c7fe7ad..7d3a63a 100644
--- a/snug-clean/src/Snug/Compile/ABI.dcl
+++ b/snug-clean/src/Snug/Compile/ABI.dcl
@@ -1,5 +1,11 @@
 definition module Snug.Compile.ABI
 
+from StdBool import not, &&
+from StdClass import class Ord(<=)
+from StdInt import instance < Int
+from StdMisc import abort
+from StdOverloaded import class <(<)
+
 from MIPS.MIPS32 import :: Label, :: Register(GP,S,T)
 from Snug.Compile import :: Namespace
 from Snug.Syntax import :: ConstructorIdent, :: SymbolIdent
@@ -17,7 +23,7 @@ TextEndDataStart :== S 7
 
 HeapPtr :== GP
 
-TempImm :== T 0
+TempImm i :== if (0 <= i && i <= 1) (T i) (abort "TempImm out of range\n")
 
 constructorLabel :: !Namespace !ConstructorIdent -> Label
 functionLabel :: !Namespace !EntryPoint !SymbolIdent -> Label
diff --git a/snug-clean/src/Snug/Compile/Simulate.icl b/snug-clean/src/Snug/Compile/Simulate.icl
index 57f249c..ab13cde 100644
--- a/snug-clean/src/Snug/Compile/Simulate.icl
+++ b/snug-clean/src/Snug/Compile/Simulate.icl
@@ -59,32 +59,32 @@ storeStackValue (SVImmediate (Immediate i)) doffset dreg
 		[ StoreWord R0 doffset dreg
 		]
 	| 0 <= i && i < 0x10000 = add
-		[ OrImmediate TempImm R0 (Immediate i)
-		, StoreWord TempImm doffset dreg
+		[ OrImmediate (TempImm 0) R0 (Immediate i)
+		, StoreWord (TempImm 0) doffset dreg
 		]
 	| 0 > i && i >= -0x8000 = add
-		[ AddImmediate Signed TempImm R0 (Immediate i)
-		, StoreWord TempImm doffset dreg
+		[ AddImmediate Signed (TempImm 0) R0 (Immediate i)
+		, StoreWord (TempImm 0) doffset dreg
 		]
 	| otherwise = add
-		[ LoadUpperImmediate TempImm (Immediate (i >> 16))
-		, OrImmediate TempImm TempImm (Immediate (i bitand 0xffff))
-		, StoreWord TempImm doffset dreg
+		[ LoadUpperImmediate (TempImm 0) (Immediate (i >> 16))
+		, OrImmediate (TempImm 0) (TempImm 0) (Immediate (i bitand 0xffff))
+		, StoreWord (TempImm 0) doffset dreg
 		]
 storeStackValue (SVImmediate imm=:(Address _ _)) doffset dreg = add
-	[ LoadAddress TempImm imm
-	, StoreWord TempImm doffset dreg
+	[ LoadAddress (TempImm 0) imm
+	, StoreWord (TempImm 0) 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
+	[ AddImmediate Signed (TempImm 0) reg (Immediate offset)
+	, StoreWord (TempImm 0) doffset dreg
 	]
 storeStackValue (SVIndirect offset reg) doffset dreg = add
-	[ LoadWord TempImm offset reg
-	, StoreWord TempImm doffset dreg
+	[ LoadWord (TempImm 0) offset reg
+	, StoreWord (TempImm 0) doffset dreg
 	]
 
 buildCons :: !Label !Int -> Simulator ()
@@ -126,8 +126,8 @@ indirectAndEval =
 		SVRegOffset HeapPtr offset ->
 			add
 				// Build indirection
-				[ LoadAddress TempImm (Address 0 (functionLabel "" NodeEntry "indir"))
-				, StoreWord TempImm 0 FrontEvalPtr
+				[ LoadAddress (TempImm 0) (Address 0 (functionLabel "" NodeEntry "indir"))
+				, StoreWord (TempImm 0) 0 FrontEvalPtr
 				] >>|
 			storeStackValue sv 4 FrontEvalPtr >>|
 			getState >>= \{hp_offset} ->
@@ -141,8 +141,8 @@ indirectAndEval =
 			// We only need to overwrite the descriptor with an indirection
 			getState >>= \{hp_offset} ->
 			add
-				[ LoadAddress TempImm (Address 0 (functionLabel "" NodeEntry "indir"))
-				, StoreWord TempImm 0 FrontEvalPtr
+				[ LoadAddress (TempImm 0) (Address 0 (functionLabel "" NodeEntry "indir"))
+				, StoreWord (TempImm 0) 0 FrontEvalPtr
 				, Jump NoLink (Direct (Address 0 "eval"))
 				, AddImmediate Signed HeapPtr HeapPtr (Immediate hp_offset)
 				]
diff --git a/snug-clean/src/Snug/Compile/Typing.icl b/snug-clean/src/Snug/Compile/Typing.icl
index 5587da7..4d69aca 100644
--- a/snug-clean/src/Snug/Compile/Typing.icl
+++ b/snug-clean/src/Snug/Compile/Typing.icl
@@ -7,8 +7,24 @@ import Snug.Syntax
 instance type Expression
 where
 	type locals e = case e of
-		BasicValue bv -> type locals bv
+		BasicValue bv ->
+			type locals bv
 		Symbol sym -> // TODO
-		Constructor cons -> // TODO
-		Case _ alts -> checkSameTypes "case alternatives" [type locals e \\ CaseAlternative _ e <- alts]
-		ExpApp e1 e2 -> // TODO
+		Constructor cons ->
+			lookupConstructorM ns cons >>= \(ConstructorDef _ args ret) ->
+			foldr TyFun ret args
+		Case _ alts ->
+			checkSameTypes "case alternatives" [type locals e \\ CaseAlternative _ e <- alts]
+		ExpApp e1 e2 ->
+			type locals e1 >>= \t1 -> case t1 of
+				TyFun t1arg t1ret ->
+					type locals e2 >>= \t2 ->
+					unify t1arg t2 ->
+					resolve t1ret
+				TyVar _ ->
+					freshTyVar >>= \t1arg ->
+					freshTyVar >>= \t1ret ->
+					unify t1arg t2 ->
+					resolve t1ret
+				_ ->
+					fail "ExpApp: first argument cannot be unified with a function type"
diff --git a/snug-clean/src/Snug/Syntax.dcl b/snug-clean/src/Snug/Syntax.dcl
index f6ff0f2..88fefde 100644
--- a/snug-clean/src/Snug/Syntax.dcl
+++ b/snug-clean/src/Snug/Syntax.dcl
@@ -11,6 +11,9 @@ from Data.Set import :: Set
 	= Type !TypeIdent
 	| TyVar !TypeVarIdent
 	| TyApp !Type !Type
+	| TyFun !Type !Type
+
+	| ..
 
 :: ConstructorDef
 	= ConstructorDef !ConstructorIdent ![Type]