From 64cfe7a9b841e5fe7cdb1f35d5dc60303b87cf14 Mon Sep 17 00:00:00 2001
From: tomsmeding <tom.smeding@gmail.com>
Date: Sat, 14 Dec 2019 23:25:37 +0100
Subject: BB heatmap for poor-man's profiling of lisp code

---
 VM.hs | 13 ++++++++++---
 1 file 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
-- 
cgit v1.2.3-54-g00ecf