X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=Mate%2FBasicBlocks.hs;h=af0074980304d46240f287156071856805b21b32;hb=ecec298c7b0723081b1aea7447eae6f04118df34;hp=955f4f51191d1eae16ebef98636f75d4a4a58a22;hpb=120517704ac01a6d957b1904d63ab707a0c4ee95;p=mate.git diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs index 955f4f5..af00749 100644 --- a/Mate/BasicBlocks.hs +++ b/Mate/BasicBlocks.hs @@ -1,25 +1,24 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -#include "debug.h" module Mate.BasicBlocks( BlockID, BasicBlock, BBEnd, MapBB, Method, -#ifdef DBG_BB printMapBB, -#endif parseMethod, testCFG -- added by hs to perform benches from outside )where -import Data.Binary +import Data.Binary hiding (get) import Data.Int -import Data.List 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 +import Control.Applicative +import Control.Arrow import JVM.ClassFile import JVM.Converter @@ -29,49 +28,49 @@ import Mate.Types import Mate.Debug import Mate.Utilities -#ifdef DEBUG -import Text.Printf -#endif +-- (offset in bytecode, offset to jump target, ins) +type OffIns = (Int, Maybe BBEnd, Instruction) --- for immediate representation to determine BBs -type Offset = (Int, Maybe BBEnd) -- (offset in bytecode, offset to jump target) -type OffIns = (Offset, Instruction) +type Target = BlockID +type BBState = S.Set Target +type AnalyseState = State BBState [OffIns] -#ifdef DBG_BB +emptyBasicBlock :: BasicBlock +emptyBasicBlock = BasicBlock + { code = [] + , bblength = 0 + , successor = Return } + printMapBB :: MapBB -> IO () printMapBB hmap = do - putStr "BlockIDs: " + printfBb "BlockIDs: " let keys = M.keys hmap - mapM_ (putStr . (flip (++)) ", " . show) keys - putStrLn "\n\nBasicBlocks:" + mapM_ (printfBb . flip (++) ", " . show) keys + printfBb "\n\nBasicBlocks:\n" printMapBB' keys hmap where printMapBB' :: [BlockID] -> MapBB -> IO () printMapBB' [] _ = return () printMapBB' (i:is) hmap' = case M.lookup i hmap' of Just bb -> do - putStrLn $ "Block " ++ (show i) - mapM_ putStrLn (map ((++) "\t" . show) $ code bb) - case successor bb of - Return -> putStrLn "" - FallThrough t1 -> putStrLn $ "Sucessor: " ++ (show t1) ++ "\n" - OneTarget t1 -> putStrLn $ "Sucessor: " ++ (show t1) ++ "\n" - TwoTarget t1 t2 -> putStrLn $ "Sucessor: " ++ (show t1) ++ ", " ++ (show t2) ++ "\n" + printfBb $ "Block " ++ show i ++ ". len: " ++ (show $ bblength bb) ++ "\n" + mapM_ (printfBb . flip (++) "\n" . (++) "\t" . show) $ code bb + printfBb $ case successor bb of + Return -> "" + FallThrough t1 -> "Sucessor: " ++ show t1 ++ "\n" + OneTarget t1 -> "Sucessor: " ++ show t1 ++ "\n" + TwoTarget t1 t2 -> "Sucessor: " ++ show t1 ++ ", " ++ show t2 ++ "\n" printMapBB' is hmap Nothing -> error $ "BlockID " ++ show i ++ " not found." -#endif -#if 0 -#ifdef DBG_BB +{- testInstance :: String -> B.ByteString -> MethodSignature -> IO () testInstance cf method sig = do cls <- parseClassFile cf hmap <- parseMethod cls method sig printMapBB hmap -#endif -#ifdef DBG_BB test_main :: IO () test_main = do test_01 @@ -84,8 +83,7 @@ test_01 = testInstance "./tests/Fib.class" "fib" test_02 = testInstance "./tests/While.class" "f" test_03 = testInstance "./tests/While.class" "g" test_04 = testInstance "./tests/Fac.class" "fac" -#endif -#endif +-} parseMethod :: Class Direct -> B.ByteString -> MethodSignature -> IO RawMethod @@ -106,118 +104,114 @@ 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 = (&&&) (buildClassID cls . eCatchType) eHandlerPC ce + let msig = methodSignature method - printfBb "BB: analysing \"%s\"\n" $ toString (methodname `B.append` ": " `B.append` encode msig) -#ifdef DBG_BB + printfBb $ printf "BB: analysing \"%s\"\n" $ toString (methodname `B.append` ": " `B.append` encode msig) printMapBB mapbb -#endif - -- 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 "exception: no handler for this method\n" - Just exceptionstream -> - printfBb "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' - where - xs' :: [OffIns] - xs' = markBackwardTargets $ calculateInstructionOffset xs - --- 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] -> [OffIns] -markBackwardTargets [] = [] -markBackwardTargets (x:[]) = [x] -markBackwardTargets insns@(x@((x_off,x_bbend),x_ins):y@((y_off,_),_):xs) = - x_new:markBackwardTargets (y:xs) - where - x_new = if isTarget then checkX y_off else x - checkX w16 = case x_bbend of - Just _ -> x -- already marked, don't change - Nothing -> ((x_off, Just $ FallThrough w16), x_ins) -- mark previous insn - - -- look through all remaining insns in the stream if there is a jmp to `y' - isTarget = case find cmpOffset insns of Just _ -> True; Nothing -> False - cmpOffset ((_,Just (OneTarget w16)),_) = w16 == y_off - cmpOffset ((_,Just (TwoTarget _ w16)),_) = w16 == y_off - cmpOffset _ = False - - -buildCFG' :: MapBB -> [OffIns] -> [OffIns] -> MapBB -buildCFG' hmap [] _ = hmap -buildCFG' hmap (((off, entry), _):xs) insns = buildCFG' (insertlist entryi hmap) xs insns +testCFG c = buildCFG (codeInstructions c) (codeExceptions c) 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 = insonly + , bblength = lastoff - i + (insnLength lastins) + , successor = endblock } where - startlist = dropWhile (\((x,_),_) -> x < i) insns - (Just ((_, Just endblock),_), is) = takeWhilePlusOne validins startlist - insonly = snd $ unzip is + (lastblock, is) = takeWhilePlusOne validins omitins insns + (_, _, insonly) = unzip3 is + (lastoff, Just endblock, lastins) = fromJust lastblock -- also take last (non-matched) element and return it - takeWhilePlusOne :: (a -> Bool) -> [a] -> (Maybe a,[a]) - takeWhilePlusOne _ [] = (Nothing,[]) - takeWhilePlusOne p (x:xs) - | p x = let (lastins, list) = takeWhilePlusOne p xs in (lastins, x:list) - | otherwise = (Just x,[x]) + takeWhilePlusOne :: (a -> Bool) -> (a -> Bool) -> [a] -> (Maybe a, [a]) + takeWhilePlusOne _ _ [] = (Nothing, []) + takeWhilePlusOne p omit (x:xs) + | omit x = next + | p x = second (x:) next + | otherwise = (Just x, [x]) + where + next = takeWhilePlusOne p omit xs - validins :: ((Int, Maybe BBEnd), Instruction) -> Bool - validins ((_,x),_) = case x of Just _ -> False; Nothing -> True + validins :: OffIns -> Bool + validins (_, x, _) = isNothing x + omitins :: OffIns -> Bool + omitins (off, _, _) = off < i -calculateInstructionOffset :: [Instruction] -> [OffIns] -calculateInstructionOffset = cio' (0, Nothing) - where - newoffset :: Instruction -> Int -> Offset - newoffset x off = (off + fromIntegral (B.length $ encodeInstructions [x]), Nothing) - addW16Signed :: Int -> Word16 -> Int +calculateInstructionOffset :: [BlockID] -> [Instruction] -> AnalyseState +calculateInstructionOffset exstarts = cio' 0 + where addW16Signed i w16 = i + fromIntegral s16 where s16 = fromIntegral w16 :: Int16 - cio' :: Offset -> [Instruction] -> [OffIns] - cio' _ [] = [] - -- TODO(bernhard): add more instruction with offset (IF_ACMP, JSR, ...) - cio' (off,_) (x:xs) = case x of + cio' :: Int -> [Instruction] -> AnalyseState + cio' _ [] = return $ [] + 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 - notarget = ((off, Just Return), x):next - onetarget w16 = ((off, Just $ OneTarget (off `addW16Signed` w16)), x):next - twotargets w16 = ((off, Just $ TwoTarget (off + 3) (off `addW16Signed` w16)), x):next - next = cio' (newoffset x off) xs + 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 (S.insert jump) + ((off, Just $ OneTarget jump, x):) <$> next + twotargets w16 = do + let nojump = off + 3 + modify (S.insert nojump) + let jump = off `addW16Signed` w16 + modify (S.insert jump) + ((off, Just $ TwoTarget nojump jump, x):) <$> next + 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? +insnLength :: Num a => Instruction -> a +insnLength = fromIntegral . B.length . encodeInstructions . (:[])