aboutsummaryrefslogtreecommitdiff
path: root/snug-clean/src/Snug/Compile.icl
diff options
context:
space:
mode:
Diffstat (limited to 'snug-clean/src/Snug/Compile.icl')
-rw-r--r--snug-clean/src/Snug/Compile.icl122
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 ->
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 16:14:51 +0000