From 63d6d6072e95b98f1db963a27e361bb3dafe37b4 Mon Sep 17 00:00:00 2001
From: Camil Staps
Date: Tue, 28 Feb 2023 20:49:17 +0100
Subject: Remove aborts in Snug.Compile, use MonadFail instead
---
snug-clean/src/Snug/Compile.dcl | 5 ++-
snug-clean/src/Snug/Compile.icl | 73 ++++++++++++++++++++++-------------------
snug-clean/src/snug.icl | 4 ++-
3 files changed, 44 insertions(+), 38 deletions(-)
(limited to 'snug-clean/src')
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 []
diff --git a/snug-clean/src/snug.icl b/snug-clean/src/snug.icl
index 23d24d0..45b39a1 100644
--- a/snug-clean/src/snug.icl
+++ b/snug-clean/src/snug.icl
@@ -31,7 +31,9 @@ Start w
# mbDefs = parseSnug input
defs = fromOk mbDefs
| isError mbDefs = abort ("Failed to parse: " +++ fromError mbDefs +++ "\n")
- # assembly = compile "main" defs
+ # mbAssembly = compile "main" defs
+ assembly = fromOk mbAssembly
+ | isError mbAssembly = abort ("Failed to compile: " +++ fromError mbAssembly +++ "\n")
# assembly = join "\n" (map toString assembly)
# (mbErr,w) = writeFile output assembly w
| isError mbErr = abort ("Failed to write output: " +++ toString (fromError mbErr) +++ "\n")
--
cgit v1.2.3