From 0e1f435314b382cb78056f04d0997df43e4f8fcf Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Mon, 26 Mar 2018 21:34:51 +0200 Subject: Rename files for case-sensitive file system --- AST.hs | 46 +++++++++ Compiler.hs | 286 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Intermediate.hs | 95 +++++++++++++++++++ Main.hs | 29 ++++++ Optimiser.hs | 24 +++++ Parser.hs | 93 ++++++++++++++++++ VM.hs | 136 +++++++++++++++++++++++++++ ast.hs | 46 --------- compiler.hs | 286 -------------------------------------------------------- intermediate.hs | 95 ------------------- main.hs | 29 ------ optimiser.hs | 24 ----- parser.hs | 93 ------------------ vm.hs | 136 --------------------------- 14 files changed, 709 insertions(+), 709 deletions(-) create mode 100644 AST.hs create mode 100644 Compiler.hs create mode 100644 Intermediate.hs create mode 100644 Main.hs create mode 100644 Optimiser.hs create mode 100644 Parser.hs create mode 100644 VM.hs delete mode 100644 ast.hs delete mode 100644 compiler.hs delete mode 100644 intermediate.hs delete mode 100644 main.hs delete mode 100644 optimiser.hs delete mode 100644 parser.hs delete mode 100644 vm.hs diff --git a/AST.hs b/AST.hs new file mode 100644 index 0000000..eae5af8 --- /dev/null +++ b/AST.hs @@ -0,0 +1,46 @@ +module AST where + +import Data.List + + +data Program = Program [Value] + +type Name = String + +data Value + = VList [Value] + | VNum Int + | VString String + | VName Name + | VQuoted Value + | VLambda [Name] Value + | VBuiltin String + | VEllipsis + deriving (Eq) + + +instance Show Program where + show (Program l) = intercalate "\n" $ map show l + +instance Show Value where + show (VList es) = '(' : intercalate " " (map show es) ++ ")" + show (VNum i) = show i + show (VString s) = show s + show (VName n) = n + show (VQuoted e) = '\'' : show e + show (VLambda as v) = "(lambda (" ++ intercalate " " as ++ ") " ++ show v ++ ")" + show (VBuiltin str) = "[[builtin " ++ str ++ "]]" + show VEllipsis = "..." + + +fromVName :: Value -> Maybe Name +fromVName (VName s) = Just s +fromVName _ = Nothing + +fromVNum :: Value -> Maybe Int +fromVNum (VNum i) = Just i +fromVNum _ = Nothing + +fromVString :: Value -> Maybe String +fromVString (VString s) = Just s +fromVString _ = Nothing diff --git a/Compiler.hs b/Compiler.hs new file mode 100644 index 0000000..2e3b80b --- /dev/null +++ b/Compiler.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-} +module Compiler(IRProgram, compileProgram) where + +import Control.Monad.Except +import Control.Monad.State.Strict +import Data.List +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set +import Debug.Trace + +import AST +import Intermediate + + +data TaggedValue + = TVList [TaggedValue] + | TVNum Int + | TVString String + | TVName Name (Maybe Int) -- Nothing: unknown, Just n: defined n lambdas up (0 = current lambda arg) + | TVQuoted Value + | TVDefine Name TaggedValue + | TVLambda [Name] TaggedValue [Name] -- (args) (body) (closure slot names) + | TVEllipsis + deriving Show + +-- also does some preprocessing, like parsing lambda's and defines +analyseValue :: Value -> TaggedValue +analyseValue = go [] + where + go :: [Set.Set Name] -> Value -> TaggedValue + go scopes (VList [VName "define", VName name, VList args, body]) + | Just names <- mapM fromVName args = go scopes (VList [VName "define", VName name, VLambda names body]) + | otherwise = error "Invalid 'define' shorthand syntax: Invalid argument list" + go scopes (VList [VName "define", VName name, value]) = TVDefine name (go scopes value) + go scopes (VList [VName "lambda", VList args, body]) + | Just names <- mapM fromVName args = go scopes (VLambda names body) + | otherwise = error "Invalid 'lambda' syntax: Invalid argument list" + go _ (VList (VName "lambda" : _)) = error "Invalid 'lambda' syntax" + go scopes (VList values) = TVList (map (go scopes) values) + go _ (VNum n) = TVNum n + go _ (VString s) = TVString s + go scopes (VName name) = TVName name (findIndex id (map (Set.member name) scopes)) + go _ (VQuoted value) = TVQuoted value + go scopes (VLambda args body) = + let t = go (Set.fromList args : scopes) body + in TVLambda args t (Set.toList (collectEscapes 0 t)) + go _ (VBuiltin _) = undefined + go _ VEllipsis = TVEllipsis + + collectEscapes :: Int -> TaggedValue -> Set.Set Name + collectEscapes limit (TVList values) = Set.unions (map (collectEscapes limit) values) + collectEscapes limit (TVName name (Just n)) | n > limit = Set.singleton name + collectEscapes limit (TVLambda _ body _) = collectEscapes (limit + 1) body + collectEscapes _ _ = Set.empty + + +data CompState = CompState + { csNextId :: Int + , csBlocks :: Map.Map Int BB + , csCurrent :: Int + , csScopes :: [Map.Map Name ScopeItem] + , csDefines :: Map.Map Name Ref + , csBuiltins :: Map.Map Name () + , csFunctions :: Map.Map Name GlobFuncDef + , csDatas :: [Value] } + deriving Show + +data ScopeItem = SIParam Int | SIClosure Int | SIGlobal + deriving Show + +newtype CM a = CM {unCM :: StateT CompState (Except String) a} + deriving (Functor, Applicative, Monad, MonadState CompState, MonadError String) + +-- TODO: extra info like number of arguments, dunno, might be useful +builtinMap :: Map.Map Name () +builtinMap = Map.fromList [ + ("+", ()), ("-", ()), ("<=", ()), ("print", ()), + ("list", ()), ("car", ()), ("cdr", ())] + +bbId :: BB -> Int +bbId (BB i _ _) = i + +initState :: CompState +initState = CompState 0 Map.empty undefined [] Map.empty builtinMap Map.empty [] + +runCM :: CM a -> Either String a +runCM act = runExcept $ evalStateT (unCM act) initState + +genId :: CM Int +genId = state $ \s -> (csNextId s, s {csNextId = csNextId s + 1}) + +genTemp :: CM Ref +genTemp = liftM RTemp genId + +newBlock :: CM Int +newBlock = do + i <- genId + modify $ \s -> s {csBlocks = Map.insert i (BB i [] IUnknown) (csBlocks s)} + return i + +switchBlock :: Int -> CM () +switchBlock i = modify $ \s -> s {csCurrent = i} + +newBlockSwitch :: CM Int +newBlockSwitch = do + i <- newBlock + switchBlock i + return i + +rememberBlock :: CM a -> CM a +rememberBlock act = do + b <- gets csCurrent + res <- act + switchBlock b + return res + +modifyBlock :: (BB -> BB) -> CM () +modifyBlock f = do + st <- get + let current = csCurrent st + Just bb = Map.lookup current (csBlocks st) + put $ st {csBlocks = Map.insert current (f bb) (csBlocks st)} + +addIns :: Instruction -> CM () +addIns ins = modifyBlock $ \(BB i inss term) -> BB i (inss ++ [ins]) term + +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) + +dataTableAdd :: Value -> CM Int +dataTableAdd v = state $ \ctx -> (length (csDatas ctx), ctx {csDatas = csDatas ctx ++ [v]}) + +functionAdd :: Name -> GlobFuncDef -> CM () +functionAdd name gfd = modify $ \s -> s {csFunctions = Map.insert name gfd (csFunctions s)} + +defineAdd :: Name -> Ref -> CM () +defineAdd name ref = modify $ \s -> s {csDefines = Map.insert name ref (csDefines s)} + +withScope :: Map.Map Name ScopeItem -> CM a -> CM a +withScope sc act = do + modify $ \s -> s {csScopes = sc : csScopes s} + res <- act + modify $ \s -> s {csScopes = tail (csScopes s)} + return res + + +compileProgram :: Program -> Either String IRProgram +compileProgram (Program values) = runCM $ do + bstart <- newBlockSwitch + forM_ values $ \value -> do + bnext <- newBlock + ref <- genTValue (analyseValue value) bnext + switchBlock bnext + addIns (RNone, IDiscard ref) + setTerm IExit + ([firstbb], otherbbs) <- liftM (partition ((== bstart) . bbId) . Map.elems) (gets csBlocks) + funcs <- gets csFunctions + datas <- gets csDatas + return (IRProgram (firstbb : otherbbs) funcs datas) + +genTValue :: TaggedValue -> Int -> CM Ref +genTValue (TVList []) _ = throwError "Empty call" +genTValue (TVList (TVName "do" _ : stmts)) nextnext = do + forM_ (init stmts) $ \stmt -> do + b <- newBlock + r <- genTValue stmt b + switchBlock b + addIns (RNone, IDiscard r) + genTValue (last stmts) nextnext +genTValue (TVList [TVName "if" _, cond, val1, val2]) nextnext = do + b1 <- newBlock + bthen <- newBlock + belse <- newBlock + bthen' <- newBlock + belse' <- newBlock + + condref <- genTValue cond b1 + switchBlock b1 + setTerm $ IBr condref bthen belse + resref <- genTemp + + switchBlock bthen + thenref <- genTValue val1 bthen' + switchBlock bthen' + addIns (resref, IAssign thenref) + setTerm $ IJmp nextnext + + switchBlock belse + elseref <- genTValue val2 belse' + switchBlock belse' + addIns (resref, IAssign elseref) + setTerm $ IJmp nextnext + + return resref +genTValue (TVList (TVName "if" _ : _)) _ = throwError "Invalid 'if' syntax" +genTValue (TVList (funcexpr : args)) nextnext = do + refs <- forM args $ \value -> do + bnext <- newBlock + ref <- genTValue value bnext + switchBlock bnext + return ref + b <- newBlock + funcref <- genTValue funcexpr b + switchBlock b + resref <- genTemp + addIns (resref, ICallC funcref refs) + setTerm $ IJmp nextnext + return resref +genTValue (TVNum n) nextnext = do + setTerm $ IJmp nextnext + return (RConst n) +genTValue (TVString s) nextnext = do + i <- dataTableAdd (VString s) + r <- genTemp + addIns (r, IData i) + setTerm $ IJmp nextnext + return r +genTValue (TVQuoted v) nextnext = do + i <- dataTableAdd v + r <- genTemp + addIns (r, IData i) + setTerm $ IJmp nextnext + return r +genTValue (TVDefine name value) nextnext = do + dref <- genTemp + defineAdd name dref + vref <- genTValue value nextnext + -- traceM $ "Defining '" ++ name ++ "', ref " ++ show dref ++ ", with value " ++ show vref + addIns (dref, IAssign vref) + return RNone +genTValue (TVLambda args body closure) nextnext = do + startb <- rememberBlock $ + withScope (Map.fromList (zip args (map SIParam [0..]) ++ zip closure (map SIClosure [0..]))) $ do + b <- newBlockSwitch + b2 <- newBlock + ref <- genTValue body b2 + switchBlock b2 + setTerm $ IRet ref + return b + uid <- genId + let uname = show uid ++ "L" -- starts with digit, so cannot clash with user-defined name + functionAdd uname (GlobFuncDef startb (length args) closure) + resref <- case closure of + [] -> return (RSClo uname) + _ -> do + refs <- forM closure $ \cname -> do + b <- newBlock + r <- genTValue (TVName cname undefined) b + switchBlock b + return r + r <- genTemp + addIns (r, IAllocClo uname refs) + return r + setTerm $ IJmp nextnext + return resref +genTValue (TVName name _) nextnext = do + r <- genTemp + lookupVar name >>= \si -> case si of + Right ref -> addIns (r, IAssign ref) + Left (SIParam n) -> addIns (r, IParam n) + Left (SIClosure n) -> addIns (r, IClosure n) + Left SIGlobal -> do + funcs <- gets csFunctions + builtins <- gets csBuiltins + case (Map.lookup name funcs, Map.lookup name builtins) of + (Just (GlobFuncDef _ _ []), _) -> addIns (r, IAssign (RSClo name)) + (Just (GlobFuncDef _ _ cs), _) -> do + refs <- foldM (\refs' cname -> do + b <- newBlock + r' <- genTValue (TVName cname undefined) b + switchBlock b + return (r' : refs')) + [] cs + addIns (r, IAllocClo name refs) + (_, Just ()) -> addIns (r, IAssign (RSClo name)) + _ -> throwError $ "Use of undefined name \"" ++ name ++ "\"" + setTerm $ IJmp nextnext + return r +genTValue TVEllipsis _ = throwError "Ellipses not supported in compiler" diff --git a/Intermediate.hs b/Intermediate.hs new file mode 100644 index 0000000..c72e81c --- /dev/null +++ b/Intermediate.hs @@ -0,0 +1,95 @@ +module Intermediate where + +import Data.List +import qualified Data.Map.Strict as Map + +import AST + + +data IRProgram = + IRProgram [BB] + (Map.Map Name GlobFuncDef) + [Value] -- data table + +data GlobFuncDef = + GlobFuncDef Int -- BB id of implementation + Int -- number of arguments + [Name] -- closure slots + +data BB = BB Int [Instruction] Terminator + +type Instruction = (Ref, InsCode) + +data Ref + = RConst Int + | RTemp Int + | RSClo Name -- static closure object of a function + | RNone + deriving Eq + +data InsCode + = IAssign Ref + | IParam Int + | IClosure Int + | IData Int + | ICallC Ref [Ref] + | IAllocClo Name [Ref] + | IDiscard Ref + deriving Eq + +data Terminator + = IBr Ref Int Int + | IJmp Int + | IRet Ref + | IExit + | IUnknown + deriving Eq + + +bidOf :: BB -> Int +bidOf (BB i _ _) = i + +termOf :: BB -> Terminator +termOf (BB _ _ t) = t + + +instance Show IRProgram where + show (IRProgram bbs gfds datas) = intercalate "\n" $ + ["IRPROGRAM", "Data Table:"] ++ map (("- " ++) . show) datas ++ + ["Global functions:"] ++ map (\(n, gfd) -> "- " ++ n ++ ": " ++ show gfd) (Map.assocs gfds) ++ + ["Blocks:"] ++ [intercalate "\n" (map show bbs)] + +instance Show GlobFuncDef where + show (GlobFuncDef bbid na []) = "BB " ++ show bbid ++ " (" ++ show na ++ ")" + show (GlobFuncDef bbid na cs) = + "BB " ++ show bbid ++ " (" ++ show na ++ ") (closure slots: " ++ intercalate ", " cs ++ ")" + +instance Show BB where + show (BB i inss term) = + "BB " ++ show i ++ + concatMap (\(r, ic) -> case r of + RNone -> "\n " ++ show ic + _ -> "\n " ++ show r ++ " <- " ++ show ic) inss ++ + "\n " ++ show term + +instance Show Ref where + show (RConst n) = show n + show (RTemp n) = "t" ++ show n + show (RSClo name) = "SC(\"" ++ name ++ "\")" + show RNone = "<>" + +instance Show InsCode where + show (IAssign r) = "assign " ++ show r + show (IParam n) = "param " ++ show n + show (IClosure n) = "closure " ++ show n + show (IData n) = "data " ++ show n + show (ICallC r as) = "callc " ++ show r ++ " " ++ show as + show (IAllocClo name vs) = "alloc-closure \"" ++ name ++ "\" " ++ show vs + show (IDiscard r) = "discard " ++ show r + +instance Show Terminator where + show (IBr r b1 b2) = "br " ++ show r ++ " " ++ show b1 ++ " " ++ show b2 + show (IJmp b) = "jmp " ++ show b + show (IRet r) = "ret " ++ show r + show IExit = "exit" + show IUnknown = "<>" diff --git a/Main.hs b/Main.hs new file mode 100644 index 0000000..b56edfe --- /dev/null +++ b/Main.hs @@ -0,0 +1,29 @@ +module Main where + +import System.Environment +import System.Exit + +import Compiler +import Optimiser +import Parser +import VM + + +usage :: IO () +usage = do + progname <- getProgName + putStrLn $ "Usage: " ++ progname ++ " [filename.lisp]" + +main :: IO () +main = do + clargs <- getArgs + source <- case clargs of + [] -> getContents + [fname] -> readFile fname + _ -> usage >> exitFailure + + prog <- parseProgram source >>= either (die . show) return + irprog <- either die return (compileProgram prog) + let opt = optimise irprog + -- print opt + vmRun opt diff --git a/Optimiser.hs b/Optimiser.hs new file mode 100644 index 0000000..c4c60cb --- /dev/null +++ b/Optimiser.hs @@ -0,0 +1,24 @@ +module Optimiser(optimise) where + +import Data.List + +import Intermediate + + +optimise :: IRProgram -> IRProgram +optimise (IRProgram bbs gfds datas) = IRProgram (mergeBlocks bbs) gfds datas + +mergeBlocks :: [BB] -> [BB] +mergeBlocks [] = [] +mergeBlocks allbbs@(BB startb _ _ : _) = + uncurry (++) (partition ((== startb) . bidOf) (go allbbs (length allbbs))) + where + go [] _ = [] + go bbs 0 = bbs + go (bb@(BB bid inss term) : bbs) n = case partition (hasJumpTo bid . termOf) bbs of + ([], _) -> go (bbs ++ [bb]) (n - 1) + ([BB bid' inss' _], rest) -> go (BB bid' (inss' ++ inss) term : rest) n + _ -> go (bbs ++ [bb]) (n - 1) + + hasJumpTo bid (IJmp a) = a == bid + hasJumpTo _ _ = False diff --git a/Parser.hs b/Parser.hs new file mode 100644 index 0000000..93d457c --- /dev/null +++ b/Parser.hs @@ -0,0 +1,93 @@ +module Parser(parseProgram, parseExpression) where + +import Control.Monad +import Control.Monad.Trans +import Data.Char +import Text.Parsec +import Text.Parsec.Pos + +import AST + + +type Parser = ParsecT String () IO + + +parseProgram :: String -> IO (Either ParseError Program) +parseProgram = runParserT pProgram () "" + +pProgram :: Parser Program +pProgram = between pWhiteComment eof (liftM Program (many pValue)) + + +parseExpression :: String -> IO (Either ParseError Value) +parseExpression = runParserT pExpression () "" + +pExpression :: Parser Value +pExpression = between pWhiteComment eof pValue + + +pValue :: Parser Value +pValue = pPPC <|> pVEllipsis <|> pVList <|> pVNum <|> pVString <|> pVName <|> pVQuoted "value" + +pVList :: Parser Value +pVList = flip label "list" $ do + symbol "(" + exs <- many pValue + symbol ")" + return $ VList exs + +pVNum :: Parser Value +pVNum = liftM (VNum . read) (many1 digit) <* pWhiteComment "number" + +pVString :: Parser Value +pVString = fmap VString pString + +pVName :: Parser Value +pVName = flip label "name" $ do + first <- satisfy isFirstNameChar + rest <- many (satisfy isNameChar) + pWhiteComment + return $ VName $ first : rest + where + isNameChar c = ((c >= '*' && c <= 'z') || c `elem` "!$%&|~") && c /= ';' + isFirstNameChar c = isNameChar c && not (isDigit c) + +pVQuoted :: Parser Value +pVQuoted = char '\'' >> liftM VQuoted pValue "quoted value" + +pVEllipsis :: Parser Value +pVEllipsis = symbol "..." >> return VEllipsis "ellipsis" + +pPPC :: Parser Value +pPPC = flip label "preprocessor command" $ do + symbol "#include" + fname <- pString + src <- liftIO $ readFile fname + stateBackup <- getParserState + void $ setParserState (State ("(do " ++ src ++ ")") (initialPos fname) ()) + result <- pValue <* eof + void $ setParserState stateBackup + return result + + +symbol :: String -> Parser () +symbol s = try (string s) >> pWhiteComment + +pString :: Parser String +pString = flip label "string" $ do + void $ char '"' + s <- manyTill anyChar (symbol "\"") + return s + +pWhiteComment :: Parser () +pWhiteComment = do + pWhitespace + void $ many $ pComment >> pWhitespace + where + pWhitespace :: Parser () + pWhitespace = void (many space) "whitespace" + + pComment :: Parser () + pComment = flip label "comment" $ do + void $ char ';' + void (manyTill anyChar (void endOfLine <|> eof)) diff --git a/VM.hs b/VM.hs new file mode 100644 index 0000000..b3b19e4 --- /dev/null +++ b/VM.hs @@ -0,0 +1,136 @@ +module VM(vmRun) where + +import Control.Monad +import Data.List +import Data.Maybe +import qualified Data.Map.Strict as Map +import Data.Map.Strict ((!)) +import System.IO +import qualified System.IO.Error as IO +import Debug.Trace + +import AST +import Intermediate + + +data Info = + Info (Map.Map Int BB) -- basic blocks + (Map.Map Name GlobFuncDef) -- global functions + [Value] -- data table + +type TempMap = Map.Map Int RunValue + +data State = State TempMap ([RunValue] {- current arguments -}, [RunValue] {- current closure -}) + +-- TODO: are more constructors from Value needed? +data RunValue + = RVClosure Name [RunValue] + | RVList [RunValue] + | RVNum Int + | RVString String + | RVQuoted RunValue + | RVName Name + deriving Show + +kErrorExit :: String +kErrorExit = "VM:exit" + +vmRun :: IRProgram -> IO () +vmRun (IRProgram bbs gfds datas) = + let bbmap = Map.fromList [(bidOf bb, bb) | bb <- bbs] + info = Info bbmap gfds datas + state = State Map.empty ([], []) + in IO.catchIOError (void $ vmRunBB info state (head bbs)) vmErrorHandler + +vmErrorHandler :: IOError -> IO () +vmErrorHandler e = + if IO.isUserError e && IO.ioeGetErrorString e == kErrorExit then return () else IO.ioError e + +vmRunBB :: Info -> State -> BB -> IO (RunValue, State) +vmRunBB info state (BB _ inss term) = do + state' <- foldM (vmRunInstr info) state inss + vmRunTerm info state' term + +vmRunInstr :: Info -> State -> Instruction -> IO State +-- vmRunInstr _ _ ins | traceShow ins False = undefined +vmRunInstr info@(Info bbmap gfds datas) state@(State tmap (args, closure)) (dest, instr) = case instr of + IAssign ref -> return (assignRef state dest (findRef tmap ref)) + IParam i -> + if i < length args then return (assignRef state dest (args !! i)) + else error $ show closure ++ ", " ++ show i ++ ", param-out-of-range" + IClosure i -> + if i < length closure then return (assignRef state dest (closure !! i)) + else error $ show closure ++ ", " ++ show i ++ ", closure-out-of-range" + IData i -> + if i < length datas then return (assignRef state dest (toRunValue (datas !! i))) + else error "data-out-of-range" + ICallC cl as -> + -- trace ("callc " ++ show (findRef tmap cl) ++ " " ++ show (map (findRef tmap) as)) $ + case findRef tmap cl of + RVClosure clname clvals -> case Map.lookup clname gfds of + Just (GlobFuncDef b _ _) -> + let Just bb = Map.lookup b bbmap + in do + -- traceM ("call " ++ show cl ++ " with arguments " ++ show (map (findRef tmap) as)) + (rv, _) <- vmRunBB info (State tmap (map (findRef tmap) as, clvals)) bb + return (assignRef state dest rv) + Nothing -> liftM (assignRef state dest) (vmRunBuiltin clname (map (findRef tmap) as)) + obj -> error $ "VM: Cannot call non-closure object: " ++ show obj + IAllocClo name clrefs -> return (assignRef state dest (RVClosure name (map (findRef tmap) clrefs))) + IDiscard _ -> return state + +vmRunTerm :: Info -> State -> Terminator -> IO (RunValue, State) +vmRunTerm info@(Info bbmap _ _) state@(State tmap _) term = case term of + IBr ref b1 b2 -> vmRunBB info state . (bbmap !) $ if truthy (findRef tmap ref) then b1 else b2 + IJmp b -> vmRunBB info state (bbmap ! b) + IRet ref -> return (findRef tmap ref, state) + IExit -> IO.ioError (IO.userError kErrorExit) + IUnknown -> undefined + +findRef :: TempMap -> Ref -> RunValue +findRef _ (RConst n) = RVNum n +findRef tmap (RTemp i) = fromJust (Map.lookup i tmap) +findRef _ (RSClo name) = RVClosure name [] +findRef _ RNone = error "VM: None ref used" + +assignRef :: State -> Ref -> RunValue -> State +assignRef (State tmap pair) (RTemp i) rv = State (Map.insert i rv tmap) pair +assignRef _ ref _ = error $ "VM: Unexpected ref " ++ show ref ++ " assigned" + +vmRunBuiltin :: Name -> [RunValue] -> IO RunValue +-- vmRunBuiltin name args | trace (name ++ " " ++ show args) False = undefined +vmRunBuiltin "print" as = putStrLn (intercalate ", " (map printshow as)) >> return (RVList []) +vmRunBuiltin "<=" [RVNum a, RVNum b] = return (RVNum (fromEnum (a <= b))) +vmRunBuiltin "+" [RVNum a, RVNum b] = return (RVNum (a + b)) +vmRunBuiltin "-" [RVNum a, RVNum b] = return (RVNum (a - b)) +vmRunBuiltin "car" [RVList l] = case l of + a : _ -> return a + _ -> throw "Empty list in 'car'" +vmRunBuiltin "cdr" [RVList l] = case l of + _ : a -> return (RVList a) + _ -> throw "Empty list in 'cdr'" +vmRunBuiltin "list" values = return (RVList values) +vmRunBuiltin name args = error (name ++ " " ++ show args) + +printshow :: RunValue -> String +printshow (RVString str) = str +printshow (RVList values) = show values +printshow (RVNum i) = show i +printshow (RVQuoted value) = '\'' : show value +printshow (RVClosure _ _) = "[closure]" +printshow (RVName name) = name + +truthy :: RunValue -> Bool +truthy (RVNum n) = n /= 0 +truthy _ = True + +toRunValue :: Value -> RunValue +toRunValue (VList values) = RVList (map toRunValue values) +toRunValue (VNum i) = RVNum i +toRunValue (VString s) = RVString s +toRunValue (VQuoted value) = RVQuoted (toRunValue value) +toRunValue (VName name) = RVName name +toRunValue _ = undefined + +throw :: String -> IO a +throw s = hPutStrLn stderr s >> IO.ioError (IO.userError kErrorExit) diff --git a/ast.hs b/ast.hs deleted file mode 100644 index eae5af8..0000000 --- a/ast.hs +++ /dev/null @@ -1,46 +0,0 @@ -module AST where - -import Data.List - - -data Program = Program [Value] - -type Name = String - -data Value - = VList [Value] - | VNum Int - | VString String - | VName Name - | VQuoted Value - | VLambda [Name] Value - | VBuiltin String - | VEllipsis - deriving (Eq) - - -instance Show Program where - show (Program l) = intercalate "\n" $ map show l - -instance Show Value where - show (VList es) = '(' : intercalate " " (map show es) ++ ")" - show (VNum i) = show i - show (VString s) = show s - show (VName n) = n - show (VQuoted e) = '\'' : show e - show (VLambda as v) = "(lambda (" ++ intercalate " " as ++ ") " ++ show v ++ ")" - show (VBuiltin str) = "[[builtin " ++ str ++ "]]" - show VEllipsis = "..." - - -fromVName :: Value -> Maybe Name -fromVName (VName s) = Just s -fromVName _ = Nothing - -fromVNum :: Value -> Maybe Int -fromVNum (VNum i) = Just i -fromVNum _ = Nothing - -fromVString :: Value -> Maybe String -fromVString (VString s) = Just s -fromVString _ = Nothing diff --git a/compiler.hs b/compiler.hs deleted file mode 100644 index 2e3b80b..0000000 --- a/compiler.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving #-} -module Compiler(IRProgram, compileProgram) where - -import Control.Monad.Except -import Control.Monad.State.Strict -import Data.List -import qualified Data.Map.Strict as Map -import qualified Data.Set as Set -import Debug.Trace - -import AST -import Intermediate - - -data TaggedValue - = TVList [TaggedValue] - | TVNum Int - | TVString String - | TVName Name (Maybe Int) -- Nothing: unknown, Just n: defined n lambdas up (0 = current lambda arg) - | TVQuoted Value - | TVDefine Name TaggedValue - | TVLambda [Name] TaggedValue [Name] -- (args) (body) (closure slot names) - | TVEllipsis - deriving Show - --- also does some preprocessing, like parsing lambda's and defines -analyseValue :: Value -> TaggedValue -analyseValue = go [] - where - go :: [Set.Set Name] -> Value -> TaggedValue - go scopes (VList [VName "define", VName name, VList args, body]) - | Just names <- mapM fromVName args = go scopes (VList [VName "define", VName name, VLambda names body]) - | otherwise = error "Invalid 'define' shorthand syntax: Invalid argument list" - go scopes (VList [VName "define", VName name, value]) = TVDefine name (go scopes value) - go scopes (VList [VName "lambda", VList args, body]) - | Just names <- mapM fromVName args = go scopes (VLambda names body) - | otherwise = error "Invalid 'lambda' syntax: Invalid argument list" - go _ (VList (VName "lambda" : _)) = error "Invalid 'lambda' syntax" - go scopes (VList values) = TVList (map (go scopes) values) - go _ (VNum n) = TVNum n - go _ (VString s) = TVString s - go scopes (VName name) = TVName name (findIndex id (map (Set.member name) scopes)) - go _ (VQuoted value) = TVQuoted value - go scopes (VLambda args body) = - let t = go (Set.fromList args : scopes) body - in TVLambda args t (Set.toList (collectEscapes 0 t)) - go _ (VBuiltin _) = undefined - go _ VEllipsis = TVEllipsis - - collectEscapes :: Int -> TaggedValue -> Set.Set Name - collectEscapes limit (TVList values) = Set.unions (map (collectEscapes limit) values) - collectEscapes limit (TVName name (Just n)) | n > limit = Set.singleton name - collectEscapes limit (TVLambda _ body _) = collectEscapes (limit + 1) body - collectEscapes _ _ = Set.empty - - -data CompState = CompState - { csNextId :: Int - , csBlocks :: Map.Map Int BB - , csCurrent :: Int - , csScopes :: [Map.Map Name ScopeItem] - , csDefines :: Map.Map Name Ref - , csBuiltins :: Map.Map Name () - , csFunctions :: Map.Map Name GlobFuncDef - , csDatas :: [Value] } - deriving Show - -data ScopeItem = SIParam Int | SIClosure Int | SIGlobal - deriving Show - -newtype CM a = CM {unCM :: StateT CompState (Except String) a} - deriving (Functor, Applicative, Monad, MonadState CompState, MonadError String) - --- TODO: extra info like number of arguments, dunno, might be useful -builtinMap :: Map.Map Name () -builtinMap = Map.fromList [ - ("+", ()), ("-", ()), ("<=", ()), ("print", ()), - ("list", ()), ("car", ()), ("cdr", ())] - -bbId :: BB -> Int -bbId (BB i _ _) = i - -initState :: CompState -initState = CompState 0 Map.empty undefined [] Map.empty builtinMap Map.empty [] - -runCM :: CM a -> Either String a -runCM act = runExcept $ evalStateT (unCM act) initState - -genId :: CM Int -genId = state $ \s -> (csNextId s, s {csNextId = csNextId s + 1}) - -genTemp :: CM Ref -genTemp = liftM RTemp genId - -newBlock :: CM Int -newBlock = do - i <- genId - modify $ \s -> s {csBlocks = Map.insert i (BB i [] IUnknown) (csBlocks s)} - return i - -switchBlock :: Int -> CM () -switchBlock i = modify $ \s -> s {csCurrent = i} - -newBlockSwitch :: CM Int -newBlockSwitch = do - i <- newBlock - switchBlock i - return i - -rememberBlock :: CM a -> CM a -rememberBlock act = do - b <- gets csCurrent - res <- act - switchBlock b - return res - -modifyBlock :: (BB -> BB) -> CM () -modifyBlock f = do - st <- get - let current = csCurrent st - Just bb = Map.lookup current (csBlocks st) - put $ st {csBlocks = Map.insert current (f bb) (csBlocks st)} - -addIns :: Instruction -> CM () -addIns ins = modifyBlock $ \(BB i inss term) -> BB i (inss ++ [ins]) term - -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) - -dataTableAdd :: Value -> CM Int -dataTableAdd v = state $ \ctx -> (length (csDatas ctx), ctx {csDatas = csDatas ctx ++ [v]}) - -functionAdd :: Name -> GlobFuncDef -> CM () -functionAdd name gfd = modify $ \s -> s {csFunctions = Map.insert name gfd (csFunctions s)} - -defineAdd :: Name -> Ref -> CM () -defineAdd name ref = modify $ \s -> s {csDefines = Map.insert name ref (csDefines s)} - -withScope :: Map.Map Name ScopeItem -> CM a -> CM a -withScope sc act = do - modify $ \s -> s {csScopes = sc : csScopes s} - res <- act - modify $ \s -> s {csScopes = tail (csScopes s)} - return res - - -compileProgram :: Program -> Either String IRProgram -compileProgram (Program values) = runCM $ do - bstart <- newBlockSwitch - forM_ values $ \value -> do - bnext <- newBlock - ref <- genTValue (analyseValue value) bnext - switchBlock bnext - addIns (RNone, IDiscard ref) - setTerm IExit - ([firstbb], otherbbs) <- liftM (partition ((== bstart) . bbId) . Map.elems) (gets csBlocks) - funcs <- gets csFunctions - datas <- gets csDatas - return (IRProgram (firstbb : otherbbs) funcs datas) - -genTValue :: TaggedValue -> Int -> CM Ref -genTValue (TVList []) _ = throwError "Empty call" -genTValue (TVList (TVName "do" _ : stmts)) nextnext = do - forM_ (init stmts) $ \stmt -> do - b <- newBlock - r <- genTValue stmt b - switchBlock b - addIns (RNone, IDiscard r) - genTValue (last stmts) nextnext -genTValue (TVList [TVName "if" _, cond, val1, val2]) nextnext = do - b1 <- newBlock - bthen <- newBlock - belse <- newBlock - bthen' <- newBlock - belse' <- newBlock - - condref <- genTValue cond b1 - switchBlock b1 - setTerm $ IBr condref bthen belse - resref <- genTemp - - switchBlock bthen - thenref <- genTValue val1 bthen' - switchBlock bthen' - addIns (resref, IAssign thenref) - setTerm $ IJmp nextnext - - switchBlock belse - elseref <- genTValue val2 belse' - switchBlock belse' - addIns (resref, IAssign elseref) - setTerm $ IJmp nextnext - - return resref -genTValue (TVList (TVName "if" _ : _)) _ = throwError "Invalid 'if' syntax" -genTValue (TVList (funcexpr : args)) nextnext = do - refs <- forM args $ \value -> do - bnext <- newBlock - ref <- genTValue value bnext - switchBlock bnext - return ref - b <- newBlock - funcref <- genTValue funcexpr b - switchBlock b - resref <- genTemp - addIns (resref, ICallC funcref refs) - setTerm $ IJmp nextnext - return resref -genTValue (TVNum n) nextnext = do - setTerm $ IJmp nextnext - return (RConst n) -genTValue (TVString s) nextnext = do - i <- dataTableAdd (VString s) - r <- genTemp - addIns (r, IData i) - setTerm $ IJmp nextnext - return r -genTValue (TVQuoted v) nextnext = do - i <- dataTableAdd v - r <- genTemp - addIns (r, IData i) - setTerm $ IJmp nextnext - return r -genTValue (TVDefine name value) nextnext = do - dref <- genTemp - defineAdd name dref - vref <- genTValue value nextnext - -- traceM $ "Defining '" ++ name ++ "', ref " ++ show dref ++ ", with value " ++ show vref - addIns (dref, IAssign vref) - return RNone -genTValue (TVLambda args body closure) nextnext = do - startb <- rememberBlock $ - withScope (Map.fromList (zip args (map SIParam [0..]) ++ zip closure (map SIClosure [0..]))) $ do - b <- newBlockSwitch - b2 <- newBlock - ref <- genTValue body b2 - switchBlock b2 - setTerm $ IRet ref - return b - uid <- genId - let uname = show uid ++ "L" -- starts with digit, so cannot clash with user-defined name - functionAdd uname (GlobFuncDef startb (length args) closure) - resref <- case closure of - [] -> return (RSClo uname) - _ -> do - refs <- forM closure $ \cname -> do - b <- newBlock - r <- genTValue (TVName cname undefined) b - switchBlock b - return r - r <- genTemp - addIns (r, IAllocClo uname refs) - return r - setTerm $ IJmp nextnext - return resref -genTValue (TVName name _) nextnext = do - r <- genTemp - lookupVar name >>= \si -> case si of - Right ref -> addIns (r, IAssign ref) - Left (SIParam n) -> addIns (r, IParam n) - Left (SIClosure n) -> addIns (r, IClosure n) - Left SIGlobal -> do - funcs <- gets csFunctions - builtins <- gets csBuiltins - case (Map.lookup name funcs, Map.lookup name builtins) of - (Just (GlobFuncDef _ _ []), _) -> addIns (r, IAssign (RSClo name)) - (Just (GlobFuncDef _ _ cs), _) -> do - refs <- foldM (\refs' cname -> do - b <- newBlock - r' <- genTValue (TVName cname undefined) b - switchBlock b - return (r' : refs')) - [] cs - addIns (r, IAllocClo name refs) - (_, Just ()) -> addIns (r, IAssign (RSClo name)) - _ -> throwError $ "Use of undefined name \"" ++ name ++ "\"" - setTerm $ IJmp nextnext - return r -genTValue TVEllipsis _ = throwError "Ellipses not supported in compiler" diff --git a/intermediate.hs b/intermediate.hs deleted file mode 100644 index c72e81c..0000000 --- a/intermediate.hs +++ /dev/null @@ -1,95 +0,0 @@ -module Intermediate where - -import Data.List -import qualified Data.Map.Strict as Map - -import AST - - -data IRProgram = - IRProgram [BB] - (Map.Map Name GlobFuncDef) - [Value] -- data table - -data GlobFuncDef = - GlobFuncDef Int -- BB id of implementation - Int -- number of arguments - [Name] -- closure slots - -data BB = BB Int [Instruction] Terminator - -type Instruction = (Ref, InsCode) - -data Ref - = RConst Int - | RTemp Int - | RSClo Name -- static closure object of a function - | RNone - deriving Eq - -data InsCode - = IAssign Ref - | IParam Int - | IClosure Int - | IData Int - | ICallC Ref [Ref] - | IAllocClo Name [Ref] - | IDiscard Ref - deriving Eq - -data Terminator - = IBr Ref Int Int - | IJmp Int - | IRet Ref - | IExit - | IUnknown - deriving Eq - - -bidOf :: BB -> Int -bidOf (BB i _ _) = i - -termOf :: BB -> Terminator -termOf (BB _ _ t) = t - - -instance Show IRProgram where - show (IRProgram bbs gfds datas) = intercalate "\n" $ - ["IRPROGRAM", "Data Table:"] ++ map (("- " ++) . show) datas ++ - ["Global functions:"] ++ map (\(n, gfd) -> "- " ++ n ++ ": " ++ show gfd) (Map.assocs gfds) ++ - ["Blocks:"] ++ [intercalate "\n" (map show bbs)] - -instance Show GlobFuncDef where - show (GlobFuncDef bbid na []) = "BB " ++ show bbid ++ " (" ++ show na ++ ")" - show (GlobFuncDef bbid na cs) = - "BB " ++ show bbid ++ " (" ++ show na ++ ") (closure slots: " ++ intercalate ", " cs ++ ")" - -instance Show BB where - show (BB i inss term) = - "BB " ++ show i ++ - concatMap (\(r, ic) -> case r of - RNone -> "\n " ++ show ic - _ -> "\n " ++ show r ++ " <- " ++ show ic) inss ++ - "\n " ++ show term - -instance Show Ref where - show (RConst n) = show n - show (RTemp n) = "t" ++ show n - show (RSClo name) = "SC(\"" ++ name ++ "\")" - show RNone = "<>" - -instance Show InsCode where - show (IAssign r) = "assign " ++ show r - show (IParam n) = "param " ++ show n - show (IClosure n) = "closure " ++ show n - show (IData n) = "data " ++ show n - show (ICallC r as) = "callc " ++ show r ++ " " ++ show as - show (IAllocClo name vs) = "alloc-closure \"" ++ name ++ "\" " ++ show vs - show (IDiscard r) = "discard " ++ show r - -instance Show Terminator where - show (IBr r b1 b2) = "br " ++ show r ++ " " ++ show b1 ++ " " ++ show b2 - show (IJmp b) = "jmp " ++ show b - show (IRet r) = "ret " ++ show r - show IExit = "exit" - show IUnknown = "<>" diff --git a/main.hs b/main.hs deleted file mode 100644 index b56edfe..0000000 --- a/main.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Main where - -import System.Environment -import System.Exit - -import Compiler -import Optimiser -import Parser -import VM - - -usage :: IO () -usage = do - progname <- getProgName - putStrLn $ "Usage: " ++ progname ++ " [filename.lisp]" - -main :: IO () -main = do - clargs <- getArgs - source <- case clargs of - [] -> getContents - [fname] -> readFile fname - _ -> usage >> exitFailure - - prog <- parseProgram source >>= either (die . show) return - irprog <- either die return (compileProgram prog) - let opt = optimise irprog - -- print opt - vmRun opt diff --git a/optimiser.hs b/optimiser.hs deleted file mode 100644 index c4c60cb..0000000 --- a/optimiser.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Optimiser(optimise) where - -import Data.List - -import Intermediate - - -optimise :: IRProgram -> IRProgram -optimise (IRProgram bbs gfds datas) = IRProgram (mergeBlocks bbs) gfds datas - -mergeBlocks :: [BB] -> [BB] -mergeBlocks [] = [] -mergeBlocks allbbs@(BB startb _ _ : _) = - uncurry (++) (partition ((== startb) . bidOf) (go allbbs (length allbbs))) - where - go [] _ = [] - go bbs 0 = bbs - go (bb@(BB bid inss term) : bbs) n = case partition (hasJumpTo bid . termOf) bbs of - ([], _) -> go (bbs ++ [bb]) (n - 1) - ([BB bid' inss' _], rest) -> go (BB bid' (inss' ++ inss) term : rest) n - _ -> go (bbs ++ [bb]) (n - 1) - - hasJumpTo bid (IJmp a) = a == bid - hasJumpTo _ _ = False diff --git a/parser.hs b/parser.hs deleted file mode 100644 index 93d457c..0000000 --- a/parser.hs +++ /dev/null @@ -1,93 +0,0 @@ -module Parser(parseProgram, parseExpression) where - -import Control.Monad -import Control.Monad.Trans -import Data.Char -import Text.Parsec -import Text.Parsec.Pos - -import AST - - -type Parser = ParsecT String () IO - - -parseProgram :: String -> IO (Either ParseError Program) -parseProgram = runParserT pProgram () "" - -pProgram :: Parser Program -pProgram = between pWhiteComment eof (liftM Program (many pValue)) - - -parseExpression :: String -> IO (Either ParseError Value) -parseExpression = runParserT pExpression () "" - -pExpression :: Parser Value -pExpression = between pWhiteComment eof pValue - - -pValue :: Parser Value -pValue = pPPC <|> pVEllipsis <|> pVList <|> pVNum <|> pVString <|> pVName <|> pVQuoted "value" - -pVList :: Parser Value -pVList = flip label "list" $ do - symbol "(" - exs <- many pValue - symbol ")" - return $ VList exs - -pVNum :: Parser Value -pVNum = liftM (VNum . read) (many1 digit) <* pWhiteComment "number" - -pVString :: Parser Value -pVString = fmap VString pString - -pVName :: Parser Value -pVName = flip label "name" $ do - first <- satisfy isFirstNameChar - rest <- many (satisfy isNameChar) - pWhiteComment - return $ VName $ first : rest - where - isNameChar c = ((c >= '*' && c <= 'z') || c `elem` "!$%&|~") && c /= ';' - isFirstNameChar c = isNameChar c && not (isDigit c) - -pVQuoted :: Parser Value -pVQuoted = char '\'' >> liftM VQuoted pValue "quoted value" - -pVEllipsis :: Parser Value -pVEllipsis = symbol "..." >> return VEllipsis "ellipsis" - -pPPC :: Parser Value -pPPC = flip label "preprocessor command" $ do - symbol "#include" - fname <- pString - src <- liftIO $ readFile fname - stateBackup <- getParserState - void $ setParserState (State ("(do " ++ src ++ ")") (initialPos fname) ()) - result <- pValue <* eof - void $ setParserState stateBackup - return result - - -symbol :: String -> Parser () -symbol s = try (string s) >> pWhiteComment - -pString :: Parser String -pString = flip label "string" $ do - void $ char '"' - s <- manyTill anyChar (symbol "\"") - return s - -pWhiteComment :: Parser () -pWhiteComment = do - pWhitespace - void $ many $ pComment >> pWhitespace - where - pWhitespace :: Parser () - pWhitespace = void (many space) "whitespace" - - pComment :: Parser () - pComment = flip label "comment" $ do - void $ char ';' - void (manyTill anyChar (void endOfLine <|> eof)) diff --git a/vm.hs b/vm.hs deleted file mode 100644 index b3b19e4..0000000 --- a/vm.hs +++ /dev/null @@ -1,136 +0,0 @@ -module VM(vmRun) where - -import Control.Monad -import Data.List -import Data.Maybe -import qualified Data.Map.Strict as Map -import Data.Map.Strict ((!)) -import System.IO -import qualified System.IO.Error as IO -import Debug.Trace - -import AST -import Intermediate - - -data Info = - Info (Map.Map Int BB) -- basic blocks - (Map.Map Name GlobFuncDef) -- global functions - [Value] -- data table - -type TempMap = Map.Map Int RunValue - -data State = State TempMap ([RunValue] {- current arguments -}, [RunValue] {- current closure -}) - --- TODO: are more constructors from Value needed? -data RunValue - = RVClosure Name [RunValue] - | RVList [RunValue] - | RVNum Int - | RVString String - | RVQuoted RunValue - | RVName Name - deriving Show - -kErrorExit :: String -kErrorExit = "VM:exit" - -vmRun :: IRProgram -> IO () -vmRun (IRProgram bbs gfds datas) = - let bbmap = Map.fromList [(bidOf bb, bb) | bb <- bbs] - info = Info bbmap gfds datas - state = State Map.empty ([], []) - in IO.catchIOError (void $ vmRunBB info state (head bbs)) vmErrorHandler - -vmErrorHandler :: IOError -> IO () -vmErrorHandler e = - if IO.isUserError e && IO.ioeGetErrorString e == kErrorExit then return () else IO.ioError e - -vmRunBB :: Info -> State -> BB -> IO (RunValue, State) -vmRunBB info state (BB _ inss term) = do - state' <- foldM (vmRunInstr info) state inss - vmRunTerm info state' term - -vmRunInstr :: Info -> State -> Instruction -> IO State --- vmRunInstr _ _ ins | traceShow ins False = undefined -vmRunInstr info@(Info bbmap gfds datas) state@(State tmap (args, closure)) (dest, instr) = case instr of - IAssign ref -> return (assignRef state dest (findRef tmap ref)) - IParam i -> - if i < length args then return (assignRef state dest (args !! i)) - else error $ show closure ++ ", " ++ show i ++ ", param-out-of-range" - IClosure i -> - if i < length closure then return (assignRef state dest (closure !! i)) - else error $ show closure ++ ", " ++ show i ++ ", closure-out-of-range" - IData i -> - if i < length datas then return (assignRef state dest (toRunValue (datas !! i))) - else error "data-out-of-range" - ICallC cl as -> - -- trace ("callc " ++ show (findRef tmap cl) ++ " " ++ show (map (findRef tmap) as)) $ - case findRef tmap cl of - RVClosure clname clvals -> case Map.lookup clname gfds of - Just (GlobFuncDef b _ _) -> - let Just bb = Map.lookup b bbmap - in do - -- traceM ("call " ++ show cl ++ " with arguments " ++ show (map (findRef tmap) as)) - (rv, _) <- vmRunBB info (State tmap (map (findRef tmap) as, clvals)) bb - return (assignRef state dest rv) - Nothing -> liftM (assignRef state dest) (vmRunBuiltin clname (map (findRef tmap) as)) - obj -> error $ "VM: Cannot call non-closure object: " ++ show obj - IAllocClo name clrefs -> return (assignRef state dest (RVClosure name (map (findRef tmap) clrefs))) - IDiscard _ -> return state - -vmRunTerm :: Info -> State -> Terminator -> IO (RunValue, State) -vmRunTerm info@(Info bbmap _ _) state@(State tmap _) term = case term of - IBr ref b1 b2 -> vmRunBB info state . (bbmap !) $ if truthy (findRef tmap ref) then b1 else b2 - IJmp b -> vmRunBB info state (bbmap ! b) - IRet ref -> return (findRef tmap ref, state) - IExit -> IO.ioError (IO.userError kErrorExit) - IUnknown -> undefined - -findRef :: TempMap -> Ref -> RunValue -findRef _ (RConst n) = RVNum n -findRef tmap (RTemp i) = fromJust (Map.lookup i tmap) -findRef _ (RSClo name) = RVClosure name [] -findRef _ RNone = error "VM: None ref used" - -assignRef :: State -> Ref -> RunValue -> State -assignRef (State tmap pair) (RTemp i) rv = State (Map.insert i rv tmap) pair -assignRef _ ref _ = error $ "VM: Unexpected ref " ++ show ref ++ " assigned" - -vmRunBuiltin :: Name -> [RunValue] -> IO RunValue --- vmRunBuiltin name args | trace (name ++ " " ++ show args) False = undefined -vmRunBuiltin "print" as = putStrLn (intercalate ", " (map printshow as)) >> return (RVList []) -vmRunBuiltin "<=" [RVNum a, RVNum b] = return (RVNum (fromEnum (a <= b))) -vmRunBuiltin "+" [RVNum a, RVNum b] = return (RVNum (a + b)) -vmRunBuiltin "-" [RVNum a, RVNum b] = return (RVNum (a - b)) -vmRunBuiltin "car" [RVList l] = case l of - a : _ -> return a - _ -> throw "Empty list in 'car'" -vmRunBuiltin "cdr" [RVList l] = case l of - _ : a -> return (RVList a) - _ -> throw "Empty list in 'cdr'" -vmRunBuiltin "list" values = return (RVList values) -vmRunBuiltin name args = error (name ++ " " ++ show args) - -printshow :: RunValue -> String -printshow (RVString str) = str -printshow (RVList values) = show values -printshow (RVNum i) = show i -printshow (RVQuoted value) = '\'' : show value -printshow (RVClosure _ _) = "[closure]" -printshow (RVName name) = name - -truthy :: RunValue -> Bool -truthy (RVNum n) = n /= 0 -truthy _ = True - -toRunValue :: Value -> RunValue -toRunValue (VList values) = RVList (map toRunValue values) -toRunValue (VNum i) = RVNum i -toRunValue (VString s) = RVString s -toRunValue (VQuoted value) = RVQuoted (toRunValue value) -toRunValue (VName name) = RVName name -toRunValue _ = undefined - -throw :: String -> IO a -throw s = hPutStrLn stderr s >> IO.ioError (IO.userError kErrorExit) -- cgit v1.2.3