aboutsummaryrefslogtreecommitdiff
path: root/snug-clean/src/Snug
diff options
context:
space:
mode:
Diffstat (limited to 'snug-clean/src/Snug')
-rw-r--r--snug-clean/src/Snug/Compile.dcl14
-rw-r--r--snug-clean/src/Snug/Compile.icl185
-rw-r--r--snug-clean/src/Snug/Compile/Simulate.icl2
-rw-r--r--snug-clean/src/Snug/Compile/Typing.dcl13
-rw-r--r--snug-clean/src/Snug/Compile/Typing.icl14
-rw-r--r--snug-clean/src/Snug/Syntax.dcl7
-rw-r--r--snug-clean/src/Snug/Syntax.icl34
7 files changed, 230 insertions, 39 deletions
diff --git a/snug-clean/src/Snug/Compile.dcl b/snug-clean/src/Snug/Compile.dcl
index 9ad66ff..ef223b8 100644
--- a/snug-clean/src/Snug/Compile.dcl
+++ b/snug-clean/src/Snug/Compile.dcl
@@ -1,5 +1,6 @@
definition module Snug.Compile
+from Control.Monad.State import :: StateT
from Data.Error import :: MaybeError
from Data.Map import :: Map
@@ -24,4 +25,17 @@ from Snug.Syntax import :: ConstructorDef, :: ConstructorIdent, :: Definition,
, type :: !Type
}
+:: CompileM a :== StateT CompileState (MaybeError String) a
+
+:: CompileState
+
+:: Locals :== Map SymbolIdent LocalLocation
+
+:: Local =
+ { location :: !LocalLocation
+ , type :: !Type
+ }
+
+:: LocalLocation
+
compile :: !Namespace ![Definition] -> MaybeError String [Line]
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]
diff --git a/snug-clean/src/Snug/Compile/Simulate.icl b/snug-clean/src/Snug/Compile/Simulate.icl
index b443913..57f249c 100644
--- a/snug-clean/src/Snug/Compile/Simulate.icl
+++ b/snug-clean/src/Snug/Compile/Simulate.icl
@@ -147,4 +147,4 @@ indirectAndEval =
, AddImmediate Signed HeapPtr HeapPtr (Immediate hp_offset)
]
_ ->
- fail "unexpected top of stack in indirect\n"
+ fail "unexpected top of stack in indirectAndEval\n"
diff --git a/snug-clean/src/Snug/Compile/Typing.dcl b/snug-clean/src/Snug/Compile/Typing.dcl
new file mode 100644
index 0000000..b395587
--- /dev/null
+++ b/snug-clean/src/Snug/Compile/Typing.dcl
@@ -0,0 +1,13 @@
+definition module Snug.Compile.Typing
+
+from Control.Monad.State import :: StateT
+from Data.Error import :: MaybeError
+from Data.Map import :: Map
+
+from Snug.Compile import :: CompileM, :: CompileState, :: LocalLocation,
+ :: Locals
+from Snug.Syntax import :: Expression, :: SymbolIdent, :: Type
+
+class type a :: !Locals !a -> CompileM Type
+
+instance type Expression
diff --git a/snug-clean/src/Snug/Compile/Typing.icl b/snug-clean/src/Snug/Compile/Typing.icl
new file mode 100644
index 0000000..5587da7
--- /dev/null
+++ b/snug-clean/src/Snug/Compile/Typing.icl
@@ -0,0 +1,14 @@
+implementation module Snug.Compile.Typing
+
+import Data.Error
+
+import Snug.Syntax
+
+instance type Expression
+where
+ type locals e = case e of
+ BasicValue bv -> type locals bv
+ Symbol sym -> // TODO
+ Constructor cons -> // TODO
+ Case _ alts -> checkSameTypes "case alternatives" [type locals e \\ CaseAlternative _ e <- alts]
+ ExpApp e1 e2 -> // TODO
diff --git a/snug-clean/src/Snug/Syntax.dcl b/snug-clean/src/Snug/Syntax.dcl
index 5246dcd..f6ff0f2 100644
--- a/snug-clean/src/Snug/Syntax.dcl
+++ b/snug-clean/src/Snug/Syntax.dcl
@@ -1,5 +1,7 @@
definition module Snug.Syntax
+from Data.Set import :: Set
+
:: TypeIdent :== String
:: TypeVarIdent :== String
:: ConstructorIdent :== String
@@ -38,3 +40,8 @@ definition module Snug.Syntax
| TypeDef !TypeIdent !Type
| FunDef !SymbolIdent ![(SymbolIdent, Type)] !Type !Expression
| TestDef !String !Type !Expression !String
+
+class usedSymbols a :: !a -> Set SymbolIdent
+instance usedSymbols [a] | usedSymbols a
+instance usedSymbols (a, b) | usedSymbols a & usedSymbols b
+instance usedSymbols CaseAlternative, Expression, Pattern
diff --git a/snug-clean/src/Snug/Syntax.icl b/snug-clean/src/Snug/Syntax.icl
index f886750..839e067 100644
--- a/snug-clean/src/Snug/Syntax.icl
+++ b/snug-clean/src/Snug/Syntax.icl
@@ -1 +1,35 @@
implementation module Snug.Syntax
+
+import qualified Data.Set
+from Data.Set import :: Set
+import StdEnv
+
+none = 'Data.Set'.newSet
+
+instance usedSymbols [a] | usedSymbols a
+where
+ usedSymbols xs = 'Data.Set'.unions (map usedSymbols xs)
+
+instance usedSymbols (a, b) | usedSymbols a & usedSymbols b
+where
+ usedSymbols (x,y) = 'Data.Set'.union (usedSymbols x) (usedSymbols y)
+
+instance usedSymbols CaseAlternative
+where
+ usedSymbols (CaseAlternative pat expr) =
+ 'Data.Set'.difference (usedSymbols expr) (usedSymbols pat)
+
+instance usedSymbols Expression
+where
+ usedSymbols (BasicValue _) = none
+ usedSymbols (Symbol sym) = none
+ usedSymbols (Constructor _) = none
+ usedSymbols (Case e alts) = usedSymbols (e, alts)
+ usedSymbols (ExpApp e1 e2) = usedSymbols (e1, e2)
+
+instance usedSymbols Pattern
+where
+ usedSymbols Wildcard = none
+ usedSymbols (BasicValuePattern _) = none
+ usedSymbols (IdentPattern id) = 'Data.Set'.singleton id
+ usedSymbols (ConstructorPattern _ syms) = 'Data.Set'.fromList syms
generated by cgit v1.2.3 (git 2.39.1) at 2025-03-12 23:15:37 +0000