declare defines for top-level mutual recursion

6 files changed, 68 insertions, 11 deletions

diff --git a/AST.hs b/AST.hs
index 5fd2518..2953227 100644
--- a/AST.hs
+++ b/AST.hs
@@ -13,6 +13,7 @@ data Value
     | VString String
     | VName Name
     | VQuoted Value
+    | VDeclare Name
     | VDefine Name Value
     | VLambda [Name] Value
     | VLambdaRec Name [Name] Value
@@ -31,6 +32,7 @@ instance Show Value where
     show (VString s) = show s
     show (VName n) = n
     show (VQuoted e) = '\'' : show e
+    show (VDeclare n) = "(declare " ++ n ++ ")"
     show (VDefine n v) = "(define " ++ n ++ " " ++ show v ++ ")"
     show (VLambda as v) = "(lambda (" ++ intercalate " " as ++ ") " ++ show v ++ ")"
     show (VLambdaRec rn as v) = "(lambdarec " ++ rn ++ " (" ++ intercalate " " as ++ ") " ++ show v ++ ")"
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 ++
diff --git a/CompilerMacros.hs b/CompilerMacros.hs
index a2d9600..086ad2e 100644
--- a/CompilerMacros.hs
+++ b/CompilerMacros.hs
@@ -13,6 +13,9 @@ process (VList [VName "define", VName name, VList args, body])
 process (VList [VName "define", VName name, value]) = VDefine name (process value)
 process (VList (VName "define" : _)) = error "Invalid 'define' syntax"
 
+process (VList [VName "declare", VName name]) = process (VDeclare name)
+process (VList (VName "declare" : _)) = error "Invalid 'declare' syntax"
+
 process (VList [VName "lambda", VList args, body])
     | Just names <- mapM fromVName args = process (VLambda names body)
     | otherwise = error "Invalid 'lambda' syntax: Invalid argument list"
@@ -44,6 +47,7 @@ process (VList [VName "cond"]) = error "Invalid 'cond' syntax: Even number of ar
 
 process (VList values) = VList (map process values)
 
+process (VDeclare name) = VDeclare name
 process (VDefine name body) = VDefine name (process body)
 process (VLambda args body) = VLambda args (process body)
 process (VLambdaRec recname args body) = VLambdaRec recname args (process body)
diff --git a/VM.hs b/VM.hs
index 5f7a818..bed0596 100644
--- a/VM.hs
+++ b/VM.hs
@@ -3,7 +3,6 @@ module VM(vmRun) where
 import Control.Monad
 import Data.Char
 import Data.List
-import Data.Maybe
 import qualified Data.Map.Strict as Map
 import Data.Map.Strict ((!))
 import System.IO
@@ -88,7 +87,9 @@ vmRunTerm info@(Info bbmap _ _) state@(State { sTempMap = tmap }) term = case te
 
 findRef :: TempMap -> Ref -> RunValue
 findRef _ (RConst n) = RVNum n
-findRef tmap (RTemp i) = fromJust (Map.lookup i tmap)
+findRef tmap (RTemp i) = case Map.lookup i tmap of
+                             Nothing -> error "Use of declared but uninitialised variable"
+                             Just v -> v
 findRef _ (RSClo name) = RVClosure name []
 findRef _ RNone = error "VM: None ref used"
 
diff --git a/tests/mutual-recursion.lisp b/tests/mutual-recursion.lisp
new file mode 100644
index 0000000..4c054ea
--- /dev/null
+++ b/tests/mutual-recursion.lisp
@@ -0,0 +1,15 @@
+#include "stdlib.lisp"
+
+(declare g)
+
+(define f (n)
+    (do
+        (print (concat "f " (number->string n)))
+        (if (>= n 100) n (g (* 2 n)))))
+
+(define g (n)
+    (do
+        (print (concat "g " (number->string n)))
+        (if (>= n 100) n (f (+ n 1)))))
+
+(print (f 1))
diff --git a/tests/mutual-recursion.out b/tests/mutual-recursion.out
new file mode 100644
index 0000000..7e2e305
--- /dev/null
+++ b/tests/mutual-recursion.out
@@ -0,0 +1,13 @@
+f 1
+g 2
+f 3
+g 6
+f 7
+g 14
+f 15
+g 30
+f 31
+g 62
+f 63
+g 126
+126