From b4cb8e6b7b66e82580b0637ec5a9d9b7531121b4 Mon Sep 17 00:00:00 2001
From: Bernhard Urban <lewurm@gmail.com>
Date: Wed, 5 Sep 2012 19:52:48 +0200
Subject: [PATCH] basicblock: rewrite buildCFG with states

---
 Mate/BasicBlocks.hs | 33 +++++++++++++--------------------
 Mate/Debug.hs       |  5 +++--
 Mate/MethodPool.hs  |  1 +
 Mate/X86CodeGen.hs  |  2 +-
 4 files changed, 18 insertions(+), 23 deletions(-)

diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs
index 7fd2e48..7b690cf 100644
--- a/Mate/BasicBlocks.hs
+++ b/Mate/BasicBlocks.hs
@@ -15,6 +15,7 @@ import Data.Int
 import qualified Data.Map as M
 import qualified Data.ByteString.Lazy as B
 import Data.Maybe
+import Data.List
 import Control.Monad.State
 import Control.Applicative
 import Control.Arrow
@@ -125,32 +126,24 @@ testCFG :: Code -> MapBB
 testCFG = buildCFG . codeInstructions
 
 buildCFG :: [Instruction] -> MapBB
-buildCFG xs = buildCFG' M.empty xs' xs'
+buildCFG xs = execState (buildCFG' 0 xs') M.empty
   where
   xs' :: [OffIns]
   xs' = evalState (calculateInstructionOffset xs) []
 
 
-buildCFG' :: MapBB -> [OffIns] -> [OffIns] -> MapBB
-buildCFG' hmap [] _ = hmap
-buildCFG' hmap ((off, entry, _):xs) insns = buildCFG' (insertlist entryi hmap) xs insns
-  where
-    insertlist :: [BlockID] -> MapBB -> MapBB
-    insertlist [] hmap' = hmap'
-    insertlist (y:ys) hmap' = insertlist ys newhmap
-      where
-        newhmap = if M.member y hmap' then hmap' else M.insert y value hmap'
-        value = parseBasicBlock y insns
-    entryi :: [BlockID]
-    entryi = if off == 0 then 0:ys else ys -- also consider the entrypoint
-      where
-        ys = case entry of
-          Just (TwoTarget t1 t2) -> [t1, t2]
-          Just (OneTarget t) -> [t]
-          Just (FallThrough t) -> [t]
-          Just Return -> []
-          Nothing -> []
 
+buildCFG' :: Int -> [OffIns] -> State MapBB ()
+buildCFG' off insns = do
+  isMember <- M.member off <$> get
+  when (not isMember) $ do
+    let value = parseBasicBlock off insns
+    modify (M.insert off value)
+    case successor value of
+      TwoTarget t1 t2 -> buildCFG' t1 insns >> buildCFG' t2 insns
+      OneTarget t -> buildCFG' t insns
+      FallThrough t -> buildCFG' t insns
+      Return -> return ()
 
 parseBasicBlock :: Int -> [OffIns] -> BasicBlock
 parseBasicBlock i insns = emptyBasicBlock { code = insonly, successor = endblock }
diff --git a/Mate/Debug.hs b/Mate/Debug.hs
index 1fb65e9..ba7ce31 100644
--- a/Mate/Debug.hs
+++ b/Mate/Debug.hs
@@ -28,8 +28,9 @@ mateDEBUG = False
 
 {-# INLINE printString #-}
 printString :: String -> String -> IO ()
-printString prefix str = when mateDEBUG $ hPutStr logHandle . (++) prefix $ str
-
+printString prefix str = do
+  when mateDEBUG $ hPutStr logHandle . (++) prefix $ str
+  hFlush logHandle
 
 printfJit, printfBb, printfMp, printfCp, printfStr, printfInfo  :: String -> IO ()
 {-
diff --git a/Mate/MethodPool.hs b/Mate/MethodPool.hs
index b5a6946..db83f98 100644
--- a/Mate/MethodPool.hs
+++ b/Mate/MethodPool.hs
@@ -137,6 +137,7 @@ compileBB rawmethod methodinfo = do
   tmap <- getTrapMap
 
   cls <- getClassFile (methClassName methodinfo)
+  printfJit $ printf "emit code of \"%s\" from \"%s\":\n" (toString $ methName methodinfo) (toString $ methClassName methodinfo)
   let ebb = emitFromBB cls rawmethod
   let cgconfig = defaultCodeGenConfig { codeBufferSize = fromIntegral $ rawCodeLength rawmethod * 32 }
   (_, Right right) <- runCodeGenWithConfig ebb () () cgconfig
diff --git a/Mate/X86CodeGen.hs b/Mate/X86CodeGen.hs
index 661837f..8ac7e7d 100644
--- a/Mate/X86CodeGen.hs
+++ b/Mate/X86CodeGen.hs
@@ -63,7 +63,7 @@ emitFromBB cls method = do
   hmap = rawMapBB method
 
   getLabel :: BlockID -> [(BlockID, Label)] -> Label
-  getLabel _ [] = error "label not found!"
+  getLabel bid [] = error $ "label " ++ show bid ++ " not found"
   getLabel i ((x,l):xs) = if i==x then l else getLabel i xs
 
   efBB :: (BlockID, BasicBlock) -> TrapMap -> BBStarts -> [(BlockID, Label)] -> CodeGen e s (TrapMap, BBStarts)
-- 
2.25.1