basicblock: build up CFG differently

[mate.git] / Mate / BasicBlocks.hs

diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs
index e81282022ceb9ba2b7f423bb54ea7934f0d5017e..3d520b7999f0b9a87e454f0b615514bd3e2482f0 100644 (file)
--- a/Mate/BasicBlocks.hs
+++ b/Mate/BasicBlocks.hs
@@ -13,6 +13,7 @@ module Mate.BasicBlocks(
 import Data.Binary hiding (get)
 import Data.Int
 import qualified Data.Map as M
+import qualified Data.Set as S
 import qualified Data.ByteString.Lazy as B
 import Data.Maybe
 import Control.Monad.State
@@ -30,11 +31,20 @@ import Mate.Utilities
 -- (offset in bytecode, offset to jump target, ins)
 type OffIns = (Int, Maybe BBEnd, Instruction)
 
-type Targets = [BlockID]
-type BBState = Targets
+type Target = BlockID
+type BBState = S.Set Target
 type AnalyseState = State BBState [OffIns]
 
 
+noException :: B.ByteString
+noException = B.empty
+
+emptyBasicBlock :: BasicBlock
+emptyBasicBlock = BasicBlock
+                    { code = []
+                    , exception = noException
+                    , successor = Return }
+
 printMapBB :: MapBB -> IO ()
 printMapBB hmap = do
   printfBb "BlockIDs: "
@@ -116,54 +126,18 @@ testCFG :: Code -> MapBB
 testCFG = buildCFG . codeInstructions
 
 buildCFG :: [Instruction] -> MapBB
-buildCFG xs = buildCFG' M.empty xs' xs'
-  where
-  xs' :: [OffIns]
-  xs' = evalState (calculateInstructionOffset xs >>= markBackwardTargets) []
-
--- get already calculated jmp-targets and mark the predecessor of the
--- target-instruction as "FallThrough". we just care about backwards
--- jumps here (forward jumps are handled in buildCFG')
-markBackwardTargets :: [OffIns] -> AnalyseState
-markBackwardTargets [] = return []
-markBackwardTargets (x:[]) = return [x]
-markBackwardTargets (x@(x_off,x_bbend,x_ins):y@(y_off,_,_):xs) = do
-  rest <- markBackwardTargets (y:xs)
-  targets <- get
-  let isTarget = y_off `elem` targets
-      x_new = case x_bbend of
-        Just _ -> x -- already marked, don't change
-        Nothing -> if isTarget then checkX y_off else x
-      checkX w16 = case x_bbend of
-        Nothing -> (x_off, Just $ FallThrough w16, x_ins) -- mark previous insn
-        _ -> error "basicblock: something is wrong"
-  return $ x_new:rest
-
-
-
-buildCFG' :: MapBB -> [OffIns] -> [OffIns] -> MapBB
-buildCFG' hmap [] _ = hmap
-buildCFG' hmap ((off, entry, _):xs) insns = buildCFG' (insertlist entryi hmap) xs insns
+buildCFG xs = execState (mapM (buildCFG' offins) alltargets) M.empty
   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 -> []
+  (offins, targets) = runState (calculateInstructionOffset xs) S.empty
+  alltargets = S.toList $ S.insert 0 targets
 
+buildCFG' :: [OffIns] -> Int -> State MapBB ()
+buildCFG' insns off = do
+  let value = parseBasicBlock off insns
+  modify (M.insert off value)
 
 parseBasicBlock :: Int -> [OffIns] -> BasicBlock
-parseBasicBlock i insns = BasicBlock insonly endblock
+parseBasicBlock i insns = emptyBasicBlock { code = insonly, successor = endblock }
   where
     (lastblock, is) = takeWhilePlusOne validins omitins insns
     (_, _, insonly) = unzip3 is
@@ -205,21 +179,29 @@ calculateInstructionOffset = cio' (0, Nothing, NOP)
         IRETURN -> notarget
         ARETURN -> notarget
         RETURN -> notarget
-        _ -> ((off, Nothing, x):) <$> next
+        _ -> normalins
       where
+        normalins = do
+          tailinsns <- next -- eval remaining instructions
+          isNextInsATarget <- (S.member newoffset) <$> get
+          let bbtyp = if isNextInsATarget
+                then Just $ FallThrough newoffset
+                else Nothing
+          return $ (off, bbtyp, x):tailinsns
         notarget = ((off, Just Return, x):) <$> next
         onetarget w16 = do
           let jump = off `addW16Signed` w16
-          modify (jump:)
+          modify (S.insert jump)
           ((off, Just $ OneTarget jump, x):) <$> next
         twotargets w16 = do
           let nojump = off + 3
-          modify (nojump:)
+          modify (S.insert nojump)
           let jump = off `addW16Signed` w16
-          modify (jump:)
+          modify (S.insert jump)
           ((off, Just $ TwoTarget nojump jump, x):) <$> next
-        next = cio' newoffset xs
-        newoffset = (off + insnLength x, Nothing, NOP)
+        next = cio' nextins xs
+        nextins = (newoffset, Nothing, NOP)
+        newoffset = off + insnLength x
 
 -- TODO(bernhard): does GHC memomize results? i.e. does it calculate the size
 --                 of `NOP' only once?