basicblock: handle athrow as return

[mate.git] / Mate / BasicBlocks.hs

diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs
index 7fd2e4830eca4c7699fafde8030da559f11b4fb5..179560087db79b55ece4054dec80f1369921fcd1 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,8 +31,8 @@ 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]
 
 
@@ -106,51 +107,37 @@ parseMethod cls methodname sig = do
   let nametype = methodNameType methoddirect
   let argscount = methodGetArgsCount nametype + (if isStatic then 0 else 1)
 
-  let msig = methodSignature method
-  printfBb $ printf "BB: analysing \"%s\"\n" $ toString (methodname `B.append` ": " `B.append` encode msig)
-  printMapBB mapbb
+  -- TODO: remove ;-)
   -- small example how to get information about
   -- exceptions of a method
-  -- TODO: remove ;-)
   let (Just m) = lookupMethodSig methodname sig cls
   case attrByName m "Code" of
     Nothing ->
       printfBb $ printf "exception: no handler for this method\n"
     Just exceptionstream ->
       printfBb $ printf "exception: \"%s\"\n" (show $ codeExceptions $ decodeMethod exceptionstream)
+  -- [/remove]
+  let msig = methodSignature method
+  printfBb $ printf "BB: analysing \"%s\"\n" $ toString (methodname `B.append` ": " `B.append` encode msig)
+  printMapBB mapbb
   return $ RawMethod mapbb locals stacks argscount codelen
 
 
 testCFG :: Code -> MapBB
-testCFG = buildCFG . codeInstructions
-
-buildCFG :: [Instruction] -> MapBB
-buildCFG xs = buildCFG' M.empty xs' xs'
-  where
-  xs' :: [OffIns]
-  xs' = evalState (calculateInstructionOffset xs) []
+testCFG c = buildCFG (codeInstructions c) (codeExceptions c)
 
-
-buildCFG' :: MapBB -> [OffIns] -> [OffIns] -> MapBB
-buildCFG' hmap [] _ = hmap
-buildCFG' hmap ((off, entry, _):xs) insns = buildCFG' (insertlist entryi hmap) xs insns
+buildCFG :: [Instruction] -> [CodeException] -> MapBB
+buildCFG xs excps = execState (mapM (buildCFG' offins) $ alltargets ++ handlerEntries) 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 tryBlocks xs) S.empty
+  alltargets = S.toList $ S.insert 0 targets
+  tryBlocks = map (fromIntegral . eStartPC) excps
+  handlerEntries = map (fromIntegral . eHandlerPC) excps
 
+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 = emptyBasicBlock { code = insonly, successor = endblock }
@@ -176,30 +163,34 @@ parseBasicBlock i insns = emptyBasicBlock { code = insonly, successor = endblock
     omitins (off, _, _) = off < i
 
 
-calculateInstructionOffset :: [Instruction] -> AnalyseState
-calculateInstructionOffset = cio' (0, Nothing, NOP)
+calculateInstructionOffset :: [BlockID] -> [Instruction] -> AnalyseState
+calculateInstructionOffset exstarts = cio' 0
   where
-    addW16Signed :: Int -> Word16 -> Int
     addW16Signed i w16 = i + fromIntegral s16
       where s16 = fromIntegral w16 :: Int16
 
-    cio' :: OffIns -> [Instruction] -> AnalyseState
+    cio' :: Int -> [Instruction] -> AnalyseState
     cio' _ [] = return $ []
-    cio' (off,_,_) (x:xs) = case x of
+    cio' off (x:xs) = case x of
         IF _ w16 -> twotargets w16
         IF_ICMP _ w16 -> twotargets w16
         IF_ACMP _ w16 -> twotargets w16
         IFNONNULL w16 -> twotargets w16
         IFNULL w16 -> twotargets w16
         GOTO w16 -> onetarget w16
+        ATHROW -> notarget
         IRETURN -> notarget
         ARETURN -> notarget
         RETURN -> notarget
-        _ -> normalins
+        _ -> if newoffset `elem` exstarts
+              then do
+                modify (S.insert newoffset)
+                ((off, Just $ OneTarget newoffset, x):) <$> next
+              else normalins
       where
         normalins = do
           tailinsns <- next -- eval remaining instructions
-          isNextInsATarget <- (elem newoffset) <$> get
+          isNextInsATarget <- (S.member newoffset) <$> get
           let bbtyp = if isNextInsATarget
                 then Just $ FallThrough newoffset
                 else Nothing
@@ -207,17 +198,17 @@ calculateInstructionOffset = cio' (0, Nothing, NOP)
         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' nextins xs
-        nextins = (newoffset, Nothing, NOP)
-        newoffset = off + insnLength x
+        next = cio' newoffset xs
+        newoffset = off + insLen
+        insLen = insnLength x
 
 -- TODO(bernhard): does GHC memomize results? i.e. does it calculate the size
 --                 of `NOP' only once?