diff options
Diffstat (limited to 'snug-clean/src/Snug')
| -rw-r--r-- | snug-clean/src/Snug/Compile.dcl | 5 | ||||
| -rw-r--r-- | snug-clean/src/Snug/Compile.icl | 73 |
2 files changed, 41 insertions, 37 deletions
diff --git a/snug-clean/src/Snug/Compile.dcl b/snug-clean/src/Snug/Compile.dcl index d329156..9ad66ff 100644 --- a/snug-clean/src/Snug/Compile.dcl +++ b/snug-clean/src/Snug/Compile.dcl @@ -1,5 +1,6 @@ definition module Snug.Compile +from Data.Error import :: MaybeError from Data.Map import :: Map from MIPS.MIPS32 import :: Line @@ -23,6 +24,4 @@ from Snug.Syntax import :: ConstructorDef, :: ConstructorIdent, :: Definition, , type :: !Type } -compile :: !Namespace ![Definition] -> [Line] - -compileDefinition :: !Namespace !Globals !Definition -> [Line] +compile :: !Namespace ![Definition] -> MaybeError String [Line] diff --git a/snug-clean/src/Snug/Compile.icl b/snug-clean/src/Snug/Compile.icl index 645c9ed..de7078a 100644 --- a/snug-clean/src/Snug/Compile.icl +++ b/snug-clean/src/Snug/Compile.icl @@ -3,8 +3,11 @@ implementation module Snug.Compile import StdEnv import Control.Monad +import Control.Monad.Fail +import Control.Monad.State import Data.Error import Data.Func +import Data.Functor import Data.List import qualified Data.Map from Data.Map import :: Map @@ -14,6 +17,8 @@ import Snug.Compile.ABI import Snug.Compile.Simulate import Snug.Syntax +:: CompileM a :== MaybeError String a + :: Locals :== Map SymbolIdent LocalLocation :: LocalLocation = FrontPtrArg !Int @@ -29,9 +34,9 @@ where | x.id > y.id = False | otherwise = x.ns < y.ns -compile :: !Namespace ![Definition] -> [Line] +compile :: !Namespace ![Definition] -> MaybeError String [Line] compile ns defs = - concatMap (compileDefinition ns globals) defs + flatten <$> mapM (compileDefinition ns globals) defs where globals = combineGlobals [ builtin @@ -70,29 +75,29 @@ lookupConstructor ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.constructors lookupFunction :: !Namespace !SymbolIdent !Globals -> ?FunctionInfo lookupFunction ns id globs = 'Data.Map'.get {ns=ns, id=id} globs.functions -compileDefinition :: !Namespace !Globals !Definition -> [Line] -compileDefinition _ _ (TypeDef _ _) = +compileDefinition :: !Namespace !Globals !Definition -> CompileM [Line] +compileDefinition _ _ (TypeDef _ _) = pure [] compileDefinition ns globals (DataDef _ _ constructors) = - [ StartSection "data" - : concatMap (compileConstructor ns globals) constructors - ] + (++) [StartSection "data"] <$> + flatten <$> mapM (compileConstructor ns globals) constructors compileDefinition ns globals (FunDef id args ret expr) = - [ StartSection "text" - , Global label - // TODO: Ideally we would use the following here: - //, Align 1 - //, RawByte (sum [2^i \\ i <- [0..] & _ <- args]) // all strict for now, TODO change - //, RawByte (length args) // arity - // But since SPIM does not allow .byte in the text section, we use: - , Align 2 - , RawWord - (sum [2^i \\ i <- [0..] & _ <- args] bitor // all strict for now, TODO change - (length args << 8)) // arity - // instead... (end modification) - , Label label - : map Instr (compileExpr ns globals locals expr) - ] + (++) + [ StartSection "text" + , Global label + // TODO: Ideally we would use the following here: + //, Align 1 + //, RawByte (sum [2^i \\ i <- [0..] & _ <- args]) // all strict for now, TODO change + //, RawByte (length args) // arity + // But since SPIM does not allow .byte in the text section, we use: + , Align 2 + , RawWord + (sum [2^i \\ i <- [0..] & _ <- args] bitor // all strict for now, TODO change + (length args << 8)) // arity + // instead... (end modification) + , Label label + ] <$> + map Instr <$> compileExpr ns globals locals expr where label = functionLabel ns NodeEntry id locals = 'Data.Map'.fromList @@ -101,8 +106,8 @@ where & offset <- [0..] ] -compileConstructor :: !Namespace !Globals !ConstructorDef -> [Line] -compileConstructor ns _ (ConstructorDef id args) = +compileConstructor :: !Namespace !Globals !ConstructorDef -> CompileM [Line] +compileConstructor ns _ (ConstructorDef id args) = pure [ Global label , Align 1 , Label label @@ -113,11 +118,11 @@ compileConstructor ns _ (ConstructorDef id args) = where label = constructorLabel ns id -compileExpr :: !Namespace !Globals !Locals !Expression -> [Instruction] +compileExpr :: !Namespace !Globals !Locals !Expression -> CompileM [Instruction] compileExpr ns globals locals expr = case simulate [SVRegOffset FrontEvalPtr 0] expr` of - Error e -> abort ("Compiling an expression failed: " +++ e +++ "\n") - Ok instrs -> instrs + Error e -> fail ("Compiling an expression failed: " +++ e) + Ok instrs -> pure instrs where expr` = simulator ns globals locals expr >>| indirectAndEval @@ -134,31 +139,31 @@ simulator ns globals locals (Symbol id) = stackSize >>= \n -> pushArg (n-1) i ?None -> case lookupFunction ns id globals of - ?None -> abort ("unknown symbol: " +++ id +++ "\n") // TODO pass error up + ?None -> fail ("unknown symbol: " +++ id) ?Just info -> case info.arity of 0 -> buildThunk (functionLabel ns NodeEntry id) 0 _ -> - abort "symbol with arity > 0\n" // TODO implement + fail "symbol with arity > 0" // TODO implement simulator ns globals locals expr=:(ExpApp _ _) = case f of Symbol id -> // TODO include locals case lookupFunction ns id globals of - ?None -> abort ("unknown symbol: " +++ id +++ "\n") // TODO pass error up + ?None -> fail ("unknown symbol: " +++ id) ?Just info | info.arity == length args -> mapM_ (simulator ns globals locals) (reverse args) >>| buildThunk (functionLabel ns NodeEntry id) info.arity - _ -> abort ("arity mismatch in application\n") // TODO implement + _ -> fail "arity mismatch in application" // TODO implement Constructor id -> case lookupConstructor ns id globals of - ?None -> abort ("unknown constructor: " +++ id +++ "\n") // TODO pass error up + ?None -> fail ("unknown constructor: " +++ id) ?Just (ConstructorDef _ arg_types) | length arg_types == length args -> mapM_ (simulator ns globals locals) (reverse args) >>| buildCons (constructorLabel ns id) (length args) - _ -> abort ("arity mismatch in application of " +++ id +++ "\n") // TODO implement + _ -> fail ("arity mismatch in application of " +++ id) // TODO implement _ -> // TODO - abort "unexpected lhs of function application\n" + fail "unexpected lhs of function application" where (f, args) = linearizeApp expr [] |