summaryrefslogtreecommitdiff
path: root/VM.hs
diff options
context:
space:
mode:
authortomsmeding <tom.smeding@gmail.com>2019-11-26 21:35:44 +0100
committertomsmeding <tom.smeding@gmail.com>2019-11-26 21:35:44 +0100
commit88019fb54bca4ca6cd12e4683d721aa6068b876c (patch)
tree42bbde96348d459fca5d765f027bd0bd38eabbf2 /VM.hs
parentdb29f6d193988ebef66ecabdead0fd8f2ed3087d (diff)
Use IntMap's in VM; doesn't actually give much speed though
Diffstat (limited to 'VM.hs')
-rw-r--r--VM.hs28
1 files changed, 14 insertions, 14 deletions
diff --git a/VM.hs b/VM.hs
index 7812afd..3d78519 100644
--- a/VM.hs
+++ b/VM.hs
@@ -4,7 +4,7 @@ import Control.Monad
import Data.Char
import Data.List
import qualified Data.Map.Strict as Map
-import Data.Map.Strict ((!))
+import qualified Data.IntMap.Strict as IMap
import System.IO
import qualified System.IO.Error as IO
-- import Debug.Trace
@@ -19,13 +19,13 @@ data Info =
(Map.Map Name GlobFuncDef) -- global functions
[Value] -- data table
-type TempMap = Map.Map Int RunValue
+type TempMap = IMap.IntMap RunValue
data State = State
{ sTempMap :: TempMap
, sArgs :: [RunValue] {- current arguments -}
, sCloVals :: [RunValue] {- current closure -}
- , sHandles :: Map.Map Int Handle
+ , sHandles :: IMap.IntMap Handle
, sUniq :: Int
}
@@ -46,7 +46,7 @@ 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 [] [] (Map.fromList [(-1, stdin), (-2, stdout), (-3, stderr)]) 0
+ state = State IMap.empty [] [] (IMap.fromList [(-1, stdin), (-2, stdout), (-3, stderr)]) 0
in IO.catchIOError (void $ vmRunBB info state (head bbs)) vmErrorHandler
vmErrorHandler :: IOError -> IO ()
@@ -79,8 +79,8 @@ vmRunInstr info@(Info _ _ datas) state@(State { sTempMap = tmap, sArgs = args, s
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 !) $ if truthy (findRef tmap ref) then b1 else b2
- IJmp b -> vmRunBB info state (bbmap ! b)
+ IBr ref b1 b2 -> vmRunBB info state . (bbmap Map.!) $ if truthy (findRef tmap ref) then b1 else b2
+ IJmp b -> vmRunBB info state (bbmap Map.! b)
IRet ref -> return (findRef tmap ref, state)
ITailC cl as -> callClosure info state cl as
IExit -> IO.ioError (IO.userError kErrorExit)
@@ -88,14 +88,14 @@ vmRunTerm info@(Info bbmap _ _) state@(State { sTempMap = tmap }) term = case te
findRef :: TempMap -> Ref -> RunValue
findRef _ (RConst n) = RVNum n
-findRef tmap (RTemp i) = case Map.lookup i tmap of
+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 _ RNone = error "VM: None ref used"
assignRef :: State -> Ref -> RunValue -> State
-assignRef state (RTemp i) rv = state { sTempMap = Map.insert i rv (sTempMap state) }
+assignRef state (RTemp i) rv = state { sTempMap = IMap.insert i rv (sTempMap state) }
assignRef _ ref _ = error $ "VM: Unexpected ref " ++ show ref ++ " assigned"
callClosure :: Info -> State -> Ref -> [Ref] -> IO (RunValue, State)
@@ -144,21 +144,21 @@ vmRunBuiltin state "sys-open-file" [RVNum modenum, RVString path] = do
let mode = [ReadMode, WriteMode] !! modenum
fid = sUniq state
handle <- openFile (DS.unpack path) mode
- return (RVNum fid, state { sHandles = Map.insert fid handle (sHandles state), sUniq = fid + 1 })
+ return (RVNum fid, state { sHandles = IMap.insert fid handle (sHandles state), sUniq = fid + 1 })
vmRunBuiltin state "sys-close-file" [RVNum fid] = do
- hClose (sHandles state ! fid)
- return (RVList [], state { sHandles = Map.delete fid (sHandles state) })
+ hClose (sHandles state IMap.! fid)
+ return (RVList [], state { sHandles = IMap.delete fid (sHandles state) })
vmRunBuiltin state "sys-get-char" [RVNum fid] = do
- let h = sHandles state ! fid
+ let h = sHandles state IMap.! fid
eof <- hIsEOF h
if eof
then return (RVList [], state)
else hGetChar h >>= \ch -> return (RVString (DS.singleton ch), state)
vmRunBuiltin state "sys-put-string" [RVNum fid, RVString str] = do
- DS.hPutStr (sHandles state ! fid) str
+ DS.hPutStr (sHandles state IMap.! fid) str
return (RVList [], state)
vmRunBuiltin state "sys-flush" [RVNum fid] = do
- hFlush (sHandles state ! fid)
+ hFlush (sHandles state IMap.! fid)
return (RVList [], state)
vmRunBuiltin state "sys-stdin" [] = return (RVNum (-1), state)
vmRunBuiltin state "sys-stdout" [] = return (RVNum (-2), state)