diff options
Diffstat (limited to 'snug-clean/src/Snug/Compile.icl')
| -rw-r--r-- | snug-clean/src/Snug/Compile.icl | 185 |
1 files changed, 147 insertions, 38 deletions
diff --git a/snug-clean/src/Snug/Compile.icl b/snug-clean/src/Snug/Compile.icl index 0dd2959..0fb3e25 100644 --- a/snug-clean/src/Snug/Compile.icl +++ b/snug-clean/src/Snug/Compile.icl @@ -1,7 +1,5 @@ implementation module Snug.Compile -import StdEnv - import Control.Monad import Control.Monad.Fail import Control.Monad.State @@ -12,22 +10,22 @@ import Data.Functor import Data.List import qualified Data.Map from Data.Map import :: Map -from Text import concat4 +import qualified Data.Set +import Data.Tuple +import StdEnv +from Text import concat3, concat4 import MIPS.MIPS32 import Snug.Compile.ABI import Snug.Compile.Simulate +import Snug.Compile.Typing import Snug.Syntax -:: CompileM a :== StateT CompileState (MaybeError String) a - :: CompileState = { fresh_ident :: !Int , globals :: !Globals } -:: Locals :== Map SymbolIdent LocalLocation - :: LocalLocation = FrontPtrArg !Int instance == (Namespaced id) | == id @@ -43,7 +41,12 @@ where compile :: !Namespace ![Definition] -> MaybeError String [Line] compile ns defs = - flatten <$> evalStateT (mapM (compileDefinition ns) defs) init + flatten <$> evalStateT + ( + mapM (liftCases ns) defs <$&> flatten >>= \defs -> + mapM (compileDefinition ns) defs + ) + init where init = { fresh_ident = 0 @@ -76,22 +79,77 @@ where ] } -freshLabel :: CompileM Label -freshLabel = state \st -> ("_l" +++ toString (st.fresh_ident), {st & fresh_ident=st.fresh_ident+1}) +addGlobalFunction :: !(Namespaced SymbolIdent) !FunctionInfo -> CompileM () +addGlobalFunction sym fi = modify \s -> {s & globals.functions='Data.Map'.put sym fi s.globals.functions} -lookupConstructor :: !Namespace !ConstructorIdent -> CompileM ConstructorDef -lookupConstructor ns id = - gets (\s -> s.globals) >>= \globals -> - liftT $ mb2error - (concat4 "Unknown constructor " ns "." id) - ('Data.Map'.get {ns=ns, id=id} globals.constructors) +/** + * This pass ensures that `Case` only appears as the toplevel expression of a + * `FunDef`, and that the expression that is matched on is a `Symbol` (namely, + * one of the arguments to the function). It does this by creating new + * `FunDef`s for cases deeper in the rhs. For now we assume that the resulting + * `Case` expressions always make the expression that is matched on strict + * (which is strictly speaking not correct for expressions like `case x of _ -> + * ...`). + * + * 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) = + liftCasesFromExpr True expr <$&> \(defs,expr) -> [FunDef name args ret expr:defs] +where + liftCasesFromExpr toplevel e = case e of + BasicValue _ -> + pure ([], e) + Symbol _ -> + pure ([], e) + Constructor _ -> + pure ([], e) + Case e alts -> + mapM liftCasesFromAlt alts <$&> unzip <$&> appFst flatten >>= \(defs,alts) -> + liftCase e alts <$&> appFst ((++) defs) + ExpApp e1 e2 -> + liftCasesFromExpr False e1 >>= \(ds1,e1) -> + liftCasesFromExpr False e2 >>= \(ds2,e2) -> + pure (ds1 ++ ds2, ExpApp e1 e2) -lookupFunction :: !Namespace !SymbolIdent -> CompileM FunctionInfo -lookupFunction ns id = - gets (\s -> s.globals) >>= \globals -> - liftT $ mb2error - (concat4 "Unknown symbol " ns "." id) - ('Data.Map'.get {ns=ns, id=id} globals.functions) + liftCasesFromAlt (CaseAlternative pat expr) = + liftCasesFromExpr False expr <$&> appSnd (CaseAlternative pat) + + liftCase e alts = + 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 + , 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) = + freshLabel "test" >>= \funName -> + liftCases ns (FunDef funName [] ty expr) <$&> \defs -> + [TestDef name ty (Symbol funName) expected : defs] +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}) + +lookupConstructor :: !Namespace !ConstructorIdent !Globals -> MaybeError String ConstructorDef +lookupConstructor ns id globals = mb2error + (concat4 "Unknown constructor " ns "." id) + ('Data.Map'.get {ns=ns, id=id} globals.constructors) + +lookupFunction :: !Namespace !SymbolIdent !Globals -> MaybeError String FunctionInfo +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 @@ -100,6 +158,7 @@ compileDefinition ns (DataDef _ _ constructors) = (++) [StartSection "data"] <$> flatten <$> mapM (compileConstructor ns) constructors compileDefinition ns (FunDef id args ret expr) = + gets (\s -> s.globals) >>= \globals -> (++) (if (isEmpty args) [] ( [ StartSection "data" @@ -134,7 +193,13 @@ compileDefinition ns (FunDef id args ret expr) = // instead... (end modification) , Label n_label ] <$> - map Instr <$> compileExpr ns globals locals expr + case expr of + // 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 + _ -> + map Instr <$> compileExpr ns globals locals expr where closure_label i = closureLabel ns id i n_label = functionLabel ns NodeEntry id @@ -144,6 +209,29 @@ where & offset <- [0..] ] +compileCase :: !Namespace !Globals !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) +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 + BasicValuePattern bv -> + abort "compileCase: BasicValuePattern\n" // TODO + IdentPattern sym -> + map Instr <$> + compileExpr ns globals locals rhs // TODO: add sym to locals, update stack offsets + ConstructorPattern cons args -> + freshLabel "nomatch" >>= \nomatch -> + pure // TODO: match + [ Instr (Jump NoLink (Direct (Address 0 nomatch))) + , Label nomatch + ] + compileConstructor :: !Namespace !ConstructorDef -> CompileM [Line] compileConstructor ns (ConstructorDef id args) = pure [ Global label @@ -156,54 +244,54 @@ compileConstructor ns (ConstructorDef id args) = pure where label = constructorLabel ns id -compileExpr :: !Namespace !Locals !Expression -> CompileM [Instruction] -compileExpr ns locals expr = +compileExpr :: !Namespace !Globals !Locals !Expression -> CompileM [Instruction] +compileExpr ns globals locals expr = case simulate [SVRegOffset FrontEvalPtr 0] expr` of Error e -> fail ("Compiling an expression failed: " +++ e) Ok instrs -> pure instrs where - expr` = simulator ns locals expr >>| indirectAndEval + expr` = simulator ns globals locals expr >>| indirectAndEval -simulator :: !Namespace !Locals !Expression -> Simulator () -simulator _ _ (BasicValue bv) = +simulator :: !Namespace !Globals !Locals !Expression -> Simulator () +simulator _ _ _ (BasicValue bv) = pushBasicValue bv >>| buildCons (constructorLabel "" (label bv)) 1 where label (BVInt _) = "INT" label (BVChar _) = "CHAR" -simulator ns locals (Symbol id) = +simulator ns globals locals (Symbol id) = case 'Data.Map'.get id locals of ?Just (FrontPtrArg i) -> stackSize >>= \n -> pushArg (n-1) i ?None -> - liftT (lookupFunction ns id) >>= \info -> case info.arity of + liftT (lookupFunction ns id globals) >>= \info -> case info.arity of 0 -> buildThunk (functionLabel ns NodeEntry id) 0 _ -> fail "symbol with arity > 0" // TODO implement -simulator ns locals expr=:(ExpApp _ _) = +simulator ns globals locals expr=:(ExpApp _ _) = case f of Symbol id -> // TODO include locals - liftT (lookupFunction ns id) >>= \info + liftT (lookupFunction ns id globals) >>= \info | info.arity == length args -> - mapM_ (simulator ns locals) (reverse args) >>| + mapM_ (simulator ns globals locals) (reverse args) >>| buildThunk (functionLabel ns NodeEntry id) info.arity | info.arity > length args -> - mapM_ (simulator ns locals) (reverse args) >>| + mapM_ (simulator ns globals locals) (reverse args) >>| buildCons (closureLabel ns id (length args)) (length args) | info.arity < length args -> let (closure_args,extra_args) = splitAt info.arity args closure = foldl ExpApp f closure_args in - mapM_ (simulator ns locals) extra_args >>| - simulator ns locals closure >>| + mapM_ (simulator ns globals locals) extra_args >>| + simulator ns globals locals closure >>| mapM_ (\_ -> buildThunk (functionLabel "" NodeEntry "ap") 2) extra_args Constructor id -> - liftT (lookupConstructor ns id) >>= \(ConstructorDef _ arg_types) + liftT (lookupConstructor ns id globals) >>= \(ConstructorDef _ arg_types) | length arg_types == length args -> - mapM_ (simulator ns locals) (reverse args) >>| + mapM_ (simulator ns globals locals) (reverse args) >>| buildCons (constructorLabel ns id) (length args) | otherwise -> fail ("arity mismatch in application of " +++ id) // TODO implement _ -> // TODO @@ -213,11 +301,32 @@ where linearizeApp (ExpApp f x) xs = linearizeApp f [x:xs] linearizeApp e xs = (e, xs) +simulator ns globals locals (Case e alts) = + liftT (fail "case in simulator") +/* + simulator ns locals e >>| + //eval >>| // TODO + liftT freshLabel >>= \end -> + mapM (simulateAlternative end) alts >>| + label end +where + simulateAlternative end (CaseAlternative pattern expr) = + liftT freshLabel >>= \no_match -> + //simulatePattern no_match locals pattern >>= \new_locals -> + //simulator ns new_locals expr >>| + jump end >>| + label no_match simulator _ _ _ _ = // TODO pushBasicValue (BVInt 0) >>| buildCons (constructorLabel "" "INT") 1 +*/ // = BasicValue !BasicValue // | Symbol !SymbolIdent // | Constructor !ConstructorIdent // | Case !Expression ![CaseAlternative] // | ExpApp !Expression !Expression + +// = Wildcard +// | BasicValuePattern !BasicValue +// | IdentPattern !SymbolIdent +// | ConstructorPattern !ConstructorIdent ![SymbolIdent] |