diff options
Diffstat (limited to 'Compiler.hs')
| -rw-r--r-- | Compiler.hs | 40 |
1 files changed, 31 insertions, 9 deletions
diff --git a/Compiler.hs b/Compiler.hs index 59b82af..19cdbf0 100644 --- a/Compiler.hs +++ b/Compiler.hs @@ -18,6 +18,7 @@ data TaggedValue | TVString String | TVName Name (Maybe Int) -- Nothing: unknown (external/builtin), Just n: defined n lambdas up (0 = current lambda arg) | TVQuoted Value + | TVDeclare Name | TVDefine Name TaggedValue | TVLambda (Maybe Name) [Name] TaggedValue [Name] -- (recname) (args) (body) (closure slot names) | TVLet (Name, TaggedValue) TaggedValue @@ -35,6 +36,7 @@ analyseValue = go (Map.empty, 0) VString s -> TVString s VName name -> TVName name (Map.lookup name envd) VQuoted value -> TVQuoted value + VDeclare name -> TVDeclare name VDefine name value -> TVDefine name (go env value) VLambda args body -> let depth' = depth + 1 @@ -62,6 +64,7 @@ analyseValue = go (Map.empty, 0) collectEscapes _ (TVName _ Nothing) = Set.empty -- external/builtin names do not need to be captured collectEscapes _ (TVNum _) = Set.empty collectEscapes _ (TVString _) = Set.empty + collectEscapes _ (TVDeclare _) = Set.empty collectEscapes _ (TVQuoted _) = Set.empty collectEscapes _ TVEllipsis = Set.empty @@ -71,6 +74,7 @@ data CompState = CompState , csBlocks :: Map.Map Int BB , csCurrent :: Int , csScopes :: [Map.Map Name ScopeItem] + , csDeclares :: Map.Map Name Ref , csDefines :: Map.Map Name Ref , csBuiltins :: Set.Set Name , csFunctions :: Map.Map Name GlobFuncDef @@ -98,7 +102,7 @@ bbId :: BB -> Int bbId (BB i _ _) = i initState :: CompState -initState = CompState 0 Map.empty undefined [] Map.empty builtinSet Map.empty [] +initState = CompState 0 Map.empty undefined [] Map.empty Map.empty builtinSet Map.empty [] runCM :: CM a -> Either String a runCM act = runExcept $ evalStateT (unCM act) initState @@ -145,11 +149,14 @@ setTerm :: Terminator -> CM () setTerm term = modifyBlock $ \(BB i inss _) -> BB i inss term lookupVar :: Name -> CM (Either ScopeItem Ref) -lookupVar name = gets csScopes >>= \scopes -> case msum (map (Map.lookup name) scopes) of - Just si -> return (Left si) - Nothing -> gets csDefines >>= \defines -> case Map.lookup name defines of - Just ref -> return (Right ref) - Nothing -> return (Left SIGlobal) +lookupVar name = + gets csScopes >>= \scopes -> case msum (map (Map.lookup name) scopes) of + Just si -> return (Left si) + Nothing -> gets csDefines >>= \defines -> case Map.lookup name defines of + Just ref -> return (Right ref) + Nothing -> gets csDeclares >>= \declares -> case Map.lookup name declares of + Just ref -> return (Right ref) + Nothing -> return (Left SIGlobal) dataTableAdd :: Value -> CM Int dataTableAdd v = state $ \ctx -> (length (csDatas ctx), ctx {csDatas = csDatas ctx ++ [v]}) @@ -157,6 +164,14 @@ dataTableAdd v = state $ \ctx -> (length (csDatas ctx), ctx {csDatas = csDatas c functionAdd :: Name -> GlobFuncDef -> CM () functionAdd name gfd = modify $ \s -> s {csFunctions = Map.insert name gfd (csFunctions s)} +declareAdd :: Name -> Ref -> CM () +declareAdd name ref = modify $ \s -> s {csDeclares = Map.insert name ref (csDeclares s)} + +declarePop :: Name -> CM (Maybe Ref) +declarePop name = state $ \s -> case Map.lookup name (csDeclares s) of + Nothing -> (Nothing, s) + Just ref -> (Just ref, s { csDeclares = Map.delete name (csDeclares s) }) + defineAdd :: Name -> Ref -> CM () defineAdd name ref = modify $ \s -> s {csDefines = Map.insert name ref (csDefines s)} @@ -253,12 +268,19 @@ genTValue (TVQuoted v) nextnext = do addIns (r, IData i) setTerm $ IJmp nextnext return r -genTValue (TVDefine name value) nextnext = do +genTValue (TVDeclare name) nextnext = do dref <- genTemp + declareAdd name dref + setTerm $ IJmp nextnext + return RNone +genTValue (TVDefine name value) nextnext = do + dref <- declarePop name >>= maybe genTemp return defineAdd name dref - vref <- genTValue value nextnext - -- traceM $ "Defining '" ++ name ++ "', ref " ++ show dref ++ ", with value " ++ show vref + b <- newBlock + vref <- genTValue value b + switchBlock b addIns (dref, IAssign vref) + setTerm $ IJmp nextnext return RNone genTValue (TVLambda mrecname args body closure) nextnext = do let bindpairs = maybe [] (\n -> [(n, SIParam 0)]) mrecname ++ |