X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=Mate%2FBasicBlocks.hs;h=2f96a40fe66ee6ce5b86b644141b3e3cf269b964;hb=HEAD;hp=e81282022ceb9ba2b7f423bb54ea7934f0d5017e;hpb=c2cb52c1fb9f86a4b5d2bc584ce8a7f07a03f014;p=mate.git diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs index e812820..2f96a40 100644 --- 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,17 @@ 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] +emptyBasicBlock :: BasicBlock +emptyBasicBlock = BasicBlock + { code = [] + , bblength = 0 + , successor = Return } + printMapBB :: MapBB -> IO () printMapBB hmap = do printfBb "BlockIDs: " @@ -47,7 +54,7 @@ printMapBB hmap = do printMapBB' [] _ = return () printMapBB' (i:is) hmap' = case M.lookup i hmap' of Just bb -> do - printfBb $ "Block " ++ show i ++ "\n" + printfBb $ "Block " ++ show i ++ ". len: " ++ (show $ bblength bb) ++ "\n" mapM_ (printfBb . flip (++) "\n" . (++) "\t" . show) $ code bb printfBb $ case successor bb of Return -> "" @@ -97,77 +104,52 @@ parseMethod cls methodname sig = do let nametype = methodNameType methoddirect let argscount = methodGetArgsCount nametype + (if isStatic then 0 else 1) + let exceptionMap :: ExceptionMap + exceptionMap = foldl f M.empty $ codeExceptions decoded + where + f emap ce = + if M.member key emap + then M.adjust (value:) key emap + else M.insert key [value] emap + where + key = (&&&) eStartPC eEndPC ce + value = (&&&) g eHandlerPC ce + where + g ce' = case eCatchType ce' of + 0 -> B.empty + x -> buildClassID cls x + let msig = methodSignature method printfBb $ printf "BB: analysing \"%s\"\n" $ toString (methodname `B.append` ": " `B.append` encode msig) printMapBB mapbb - -- 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) - return $ RawMethod mapbb locals stacks argscount codelen + return $ RawMethod mapbb exceptionMap locals stacks argscount codelen testCFG :: Code -> MapBB -testCFG = buildCFG . codeInstructions - -buildCFG :: [Instruction] -> MapBB -buildCFG xs = buildCFG' M.empty xs' xs' +testCFG c = buildCFG (codeInstructions c) (codeExceptions c) 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 - 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 + buildCFG :: [Instruction] -> [CodeException] -> MapBB + buildCFG xs excps = execState (mapM buildCFG' $ alltargets ++ handlerEntries) M.empty 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' :: Int -> State MapBB () + buildCFG' off = do + let value = parseBasicBlock off offins + modify (M.insert off value) parseBasicBlock :: Int -> [OffIns] -> BasicBlock -parseBasicBlock i insns = BasicBlock insonly endblock +parseBasicBlock i insns = emptyBasicBlock + { code = zip offsets insonly + , bblength = lastoff - i + (insnLength lastins) + , successor = endblock } where (lastblock, is) = takeWhilePlusOne validins omitins insns - (_, _, insonly) = unzip3 is - (_, Just endblock, _) = fromJust lastblock + (offsets, _, insonly) = unzip3 is + (lastoff, Just endblock, lastins) = fromJust lastblock -- also take last (non-matched) element and return it takeWhilePlusOne :: (a -> Bool) -> (a -> Bool) -> [a] -> (Maybe a, [a]) @@ -186,40 +168,52 @@ parseBasicBlock i insns = BasicBlock insonly 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 - _ -> ((off, Nothing, x):) <$> next + _ -> 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 <- (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) + newoffset = off + insLen + insLen = insnLength x -- TODO(bernhard): does GHC memomize results? i.e. does it calculate the size -- of `NOP' only once?