basicblock: rewrite buildCFG with states

diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs
index 7fd2e4830eca4c7699fafde8030da559f11b4fb5..7b690cf034c95a5a4bc69be7d93ae2e25dcd6b7e 100644 (file)
--- 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 1fb65e97023f32dab77b6c23f0af28148a9b2602..ba7ce315722e82be962d7d1543ff14780f328509 100644 (file)
--- 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 b5a6946483d3bc28c6597ee085f9c9544e68a497..db83f98b51465b917c3795da42a6dc8439d3ce11 100644 (file)
--- 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 661837f75008b1175f685f7dc058fa69bb0977d2..8ac7e7dc79d8b86e1097bd2b94d1d02d06cd89a2 100644 (file)
--- 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)