From f9bcf22542b30b75c73cc9d45a91561998b083dc Mon Sep 17 00:00:00 2001 From: tomsmeding Date: Tue, 26 Nov 2019 22:11:28 +0100 Subject: Use IOArray for TempMap in VM --- Intermediate.hs | 3 +++ VM.hs | 65 ++++++++++++++++++++++++++++++++------------------------- lisphs.cabal | 2 +- 3 files changed, 40 insertions(+), 30 deletions(-) diff --git a/Intermediate.hs b/Intermediate.hs index a020509..efa0e40 100644 --- a/Intermediate.hs +++ b/Intermediate.hs @@ -64,6 +64,9 @@ termOf (BB _ _ t) = t class AllRefs a where allRefs :: a -> [Ref] +instance AllRefs IRProgram where + allRefs (IRProgram bbs _ _) = allRefs bbs + instance AllRefs BB where allRefs (BB _ inss term) = sortUniq $ concatMap (allRefs . snd) inss ++ allRefs term diff --git a/VM.hs b/VM.hs index 554a310..c996e7b 100644 --- a/VM.hs +++ b/VM.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE TupleSections, LambdaCase #-} module VM(vmRun) where +import qualified Data.Array.IO as A import Control.Monad import Data.Char import Data.List @@ -19,7 +21,7 @@ data Info = (Map.Map Name GlobFuncDef) -- global functions [Value] -- data table -type TempMap = IMap.IntMap RunValue +type TempMap = A.IOArray Int RunValue data State = State { sTempMap :: TempMap @@ -44,11 +46,13 @@ kErrorExit :: String kErrorExit = "VM:exit" vmRun :: IRProgram -> IO () -vmRun (IRProgram bbs gfds datas) = +vmRun irprogram@(IRProgram bbs gfds datas) = do + let alltemps = onlyTemporaries (allRefs irprogram) + tmap <- A.newArray (minimum alltemps, maximum alltemps) (RVNum 0) let bbmap = Map.fromList [(bidOf bb, bb) | bb <- bbs] info = Info bbmap gfds datas - state = State IMap.empty [] [] [] (IMap.fromList [(-1, stdin), (-2, stdout), (-3, stderr)]) 0 - in IO.catchIOError (void $ vmRunBB info state (head bbs)) vmErrorHandler + state = State tmap [] [] [] (IMap.fromList [(-1, stdin), (-2, stdout), (-3, stderr)]) 0 + IO.catchIOError (void $ vmRunBB info state (head bbs)) vmErrorHandler vmErrorHandler :: IOError -> IO () vmErrorHandler e = @@ -63,69 +67,72 @@ vmRunInstr :: Info -> State -> Instruction -> IO State -- vmRunInstr _ _ ins | traceShow ins False = undefined vmRunInstr info@(Info _ _ datas) state (dest, instr) = case instr of IAssign ref -> - return (assignRef state dest (findRef (sTempMap state) ref)) + findRef (sTempMap state) ref >>= assignRef state dest IParam i -> let args = sArgs state - in if i < length args then return (assignRef state dest (args !! i)) + in if i < length args then assignRef state dest (args !! i) else error $ show args ++ ", " ++ show i ++ ", param-out-of-range" IClosure i -> let closure = sCloVals state - in if i < length closure then return (assignRef state dest (closure !! i)) + in if i < length closure then 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))) + if i < length datas then assignRef state dest (toRunValue (datas !! i)) else error "data-out-of-range" ICallC cl as -> do (rv, state') <- callClosure info state cl as - return (assignRef state' dest rv) + assignRef state' dest rv IAllocClo name clrefs -> - let cloVals = (map (findRef (sTempMap state)) clrefs) - in return (assignRef state dest (RVClosure name cloVals)) + RVClosure name <$> mapM (findRef (sTempMap state)) clrefs >>= assignRef state dest IDiscard ref -> case ref of - RTemp i -> return (state { sTempMap = IMap.delete i (sTempMap state) }) + RTemp _ -> assignRef state ref (RVNum 0) _ -> return state IPush refs -> - return (state { sStack = map (findRef (sTempMap state)) refs ++ sStack state }) + mapM (findRef (sTempMap state)) refs >>= \values -> + return (state { sStack = values ++ sStack state }) IPop refs -> if length (sStack state) >= length refs then let (values, newStack) = splitAt (length refs) (sStack state) state' = state { sStack = newStack } - in return (foldl (uncurry . assignRef) state' (zip refs values)) + in foldM (uncurry . assignRef) state' (zip refs values) else error "VM: IPop on too-small stack" vmRunTerm :: Info -> State -> Terminator -> IO (RunValue, State) vmRunTerm info@(Info bbmap _ _) state@(State { sTempMap = tmap }) term = case term of - IBr ref b1 b2 -> vmRunBB info state . (bbmap Map.!) $ if truthy (findRef tmap ref) then b1 else b2 + IBr ref b1 b2 -> do + val <- findRef tmap ref + vmRunBB info state . (bbmap Map.!) $ if truthy val then b1 else b2 IJmp b -> vmRunBB info state (bbmap Map.! b) - IRet ref -> return (findRef tmap ref, state) + IRet ref -> (,state) <$> findRef tmap ref ITailC cl as -> callClosure info state cl as IExit -> IO.ioError (IO.userError kErrorExit) IUnknown -> undefined -findRef :: TempMap -> Ref -> RunValue -findRef _ (RConst n) = RVNum n -findRef tmap (RTemp i) = case IMap.lookup i tmap of - Nothing -> error "Use of declared but uninitialised variable" - Just v -> v -findRef _ (RSClo name) = RVClosure name [] +findRef :: TempMap -> Ref -> IO RunValue +findRef _ (RConst n) = return (RVNum n) +findRef tmap (RTemp i) = A.readArray tmap i +findRef _ (RSClo name) = return (RVClosure name []) findRef _ RNone = error "VM: None ref used" -assignRef :: State -> Ref -> RunValue -> State -assignRef state (RTemp i) rv = state { sTempMap = IMap.insert i rv (sTempMap state) } +assignRef :: State -> Ref -> RunValue -> IO State +assignRef state (RTemp i) rv = do + A.writeArray (sTempMap state) i rv + return state -- TODO: now assignRef doesn't even mutate the state object anymore assignRef _ ref _ = error $ "VM: Unexpected ref " ++ show ref ++ " assigned" callClosure :: Info -> State -> Ref -> [Ref] -> IO (RunValue, State) callClosure info@(Info bbmap gfds _) state@(State { sTempMap = tmap }) cl as = - case findRef tmap cl of + findRef tmap cl >>= \case RVClosure clname clvals -> case Map.lookup clname gfds of Just (GlobFuncDef b _ _) -> do - (rv, state') <- vmRunBB info (state { sArgs = map (findRef tmap) as, sCloVals = clvals }) - (bbmap Map.! b) + args <- mapM (findRef tmap) as + (rv, state') <- vmRunBB info (state { sArgs = args, sCloVals = clvals }) (bbmap Map.! b) return (rv, state' { sArgs = sArgs state, sCloVals = sCloVals state }) - Nothing -> + Nothing -> do -- Take 'tail as' to skip the first self-link argument - vmRunBuiltin state clname (map (findRef tmap) (tail as)) + args <- mapM (findRef tmap) (tail as) + vmRunBuiltin state clname args obj -> error $ "VM: Cannot call non-closure object: " ++ show obj vmRunBuiltin :: State -> Name -> [RunValue] -> IO (RunValue, State) diff --git a/lisphs.cabal b/lisphs.cabal index 131deb4..ec986fc 100644 --- a/lisphs.cabal +++ b/lisphs.cabal @@ -12,5 +12,5 @@ executable lisp default-language: Haskell2010 ghc-options: -Wall -O2 build-depends: base >= 4 && < 5, - containers, filepath, mtl, parsec, text + array, containers, filepath, mtl, parsec, text other-modules: AST, Compiler, CompilerMacros, DString, Intermediate, Liveness, Optimiser, Parser, Stackify, Util, VM -- cgit v1.2.3-54-g00ecf