summaryrefslogtreecommitdiff
path: root/VM.hs
diff options
context:
space:
mode:
Diffstat (limited to 'VM.hs')
-rw-r--r--VM.hs13
1 files changed, 10 insertions, 3 deletions
diff --git a/VM.hs b/VM.hs
index 8d7bb80..8786cfa 100644
--- a/VM.hs
+++ b/VM.hs
@@ -30,6 +30,7 @@ data State = State
, sStack :: [RunValue] {- IPush/IPop stack -}
, sHandles :: IMap.IntMap Handle
, sUniq :: Int
+ , sHeatmap :: IMap.IntMap Int
}
-- TODO: are more constructors from Value needed?
@@ -52,6 +53,7 @@ vmRun irprogram@(IRProgram bbs gfds datas) = do
let bbmap = Map.fromList [(bidOf bb, bb) | bb <- bbs]
info = Info bbmap gfds datas
state = State tmap [] [] [] (IMap.fromList [(-1, stdin), (-2, stdout), (-3, stderr)]) 0
+ IMap.empty
IO.catchIOError (void $ vmRunBB info state (head bbs)) vmErrorHandler
vmErrorHandler :: IOError -> IO ()
@@ -59,8 +61,11 @@ 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
+vmRunBB info state (BB bid inss term) = do
+ state' <- foldM (vmRunInstr info)
+ (state { sHeatmap = IMap.insertWith (+) bid 1 (sHeatmap state) })
+ -- state
+ inss
vmRunTerm info state' term
vmRunInstr :: Info -> State -> Instruction -> IO State
@@ -115,7 +120,9 @@ vmRunTerm info@(Info bbmap _ _) state@(State { sTempMap = tmap }) term = case te
IJmp b -> vmRunBB info state (bbmap Map.! b)
IRet ref -> (,state) <$> findRef tmap ref
ITailC cl as -> callClosure info state cl as
- IExit -> IO.ioError (IO.userError kErrorExit)
+ IExit -> do
+ hPutStrLn stderr (show (sHeatmap state))
+ IO.ioError (IO.userError kErrorExit)
IUnknown -> undefined
findRef :: TempMap -> Ref -> IO RunValue