From 5f86130930c19277fbf0ef3433cc43ab93aacf3f Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Tue, 26 Nov 2019 13:46:29 +0100 Subject: declare defines for top-level mutual recursion --- AST.hs | 2 ++ Compiler.hs | 40 +++++++++++++++++++++++++++++++--------- CompilerMacros.hs | 4 ++++ VM.hs | 5 +++-- tests/mutual-recursion.lisp | 15 +++++++++++++++ tests/mutual-recursion.out | 13 +++++++++++++ 6 files changed, 68 insertions(+), 11 deletions(-) create mode 100644 tests/mutual-recursion.lisp create mode 100644 tests/mutual-recursion.out 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 -- cgit v1.2.3-54-g00ecf