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 --- vm.hs | 136 ------------------------------------------------------------------ 1 file changed, 136 deletions(-) delete mode 100644 vm.hs (limited to 'vm.hs') 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-54-g00ecf