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

1 files changed, 74 insertions, 48 deletions

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