From 5f86130930c19277fbf0ef3433cc43ab93aacf3f Mon Sep 17 00:00:00 2001
From: tomsmeding <tom.smeding@gmail.com>
Date: Tue, 26 Nov 2019 13:46:29 +0100
Subject: declare defines for top-level mutual recursion

---
 Compiler.hs | 40 +++++++++++++++++++++++++++++++---------
 1 file changed, 31 insertions(+), 9 deletions(-)

(limited to 'Compiler.hs')

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 ++
-- 
cgit v1.2.3-54-g00ecf