X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=Mate%2FBasicBlocks.hs;h=7fd2e4830eca4c7699fafde8030da559f11b4fb5;hb=2ac2a68eb5b709caa636d1a9a56a40268d378550;hp=332bd56a6c7aefbf1784a87b65c9241933ecd1f1;hpb=73099439d888ced6806791d0e24b2ffae4086f51;p=mate.git diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs index 332bd56..7fd2e48 100644 --- a/Mate/BasicBlocks.hs +++ b/Mate/BasicBlocks.hs @@ -1,177 +1,225 @@ {-# LANGUAGE OverloadedStrings #-} module Mate.BasicBlocks( BlockID, - BasicBlock (..), - BBEnd (..), + BasicBlock, + BBEnd, MapBB, + Method, printMapBB, parseMethod, - test_main + testCFG -- added by hs to perform benches from outside )where -import Data.Binary +import Data.Binary hiding (get) import Data.Int import qualified Data.Map as M 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 import JVM.Assembler +import Mate.Types +import Mate.Debug import Mate.Utilities +-- (offset in bytecode, offset to jump target, ins) +type OffIns = (Int, Maybe BBEnd, Instruction) -type BlockID = Int --- Represents a CFG node -data BasicBlock = BasicBlock { - -- inputs :: [Variable], - -- outputs :: [Variable], - code :: [Instruction], - successor :: BBEnd } +type Targets = [BlockID] +type BBState = Targets +type AnalyseState = State BBState [OffIns] --- describes (leaving) edges of a CFG node -data BBEnd = Return | OneTarget BlockID | TwoTarget BlockID BlockID deriving Show -type MapBB = M.Map BlockID BasicBlock +noException :: B.ByteString +noException = B.empty --- for immediate representation for determine BBs -type Offset = (Int, Maybe BBEnd) -- (offset in bytecode, offset to jump target) -type OffIns = (Offset, Instruction) +emptyBasicBlock :: BasicBlock +emptyBasicBlock = BasicBlock + { code = [] + , exception = noException + , successor = Return } - -printMapBB :: Maybe MapBB -> IO () -printMapBB Nothing = putStrLn "No BasicBlock" -printMapBB (Just hmap) = do - putStr "BlockIDs: " - let keys = fst $ unzip $ M.toList hmap - mapM_ (putStr . (flip (++)) ", " . show) keys - putStrLn "\n\nBasicBlocks:" - 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 "" - OneTarget t1 -> putStrLn $ "Sucessor: " ++ (show t1) ++ "\n" - TwoTarget t1 t2 -> putStrLn $ "Sucessor: " ++ (show t1) ++ ", " ++ (show t2) ++ "\n" - printMapBB' is hmap - Nothing -> error $ "BlockID " ++ show i ++ " not found." - -testInstance :: String -> B.ByteString -> IO () -testInstance cf method = do - cls <- parseClassFile cf - hmap <- parseMethod cls method - printMapBB hmap +printMapBB :: MapBB -> IO () +printMapBB hmap = do + printfBb "BlockIDs: " + let keys = M.keys hmap + 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 + printfBb $ "Block " ++ show i ++ "\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." + +{- +testInstance :: String -> B.ByteString -> MethodSignature -> IO () +testInstance cf method sig = do + cls <- parseClassFile cf + hmap <- parseMethod cls method sig + printMapBB hmap test_main :: IO () test_main = do test_01 test_02 test_03 + test_04 -test_01, test_02, test_03 :: IO () +test_01, test_02, test_03, test_04 :: IO () test_01 = testInstance "./tests/Fib.class" "fib" test_02 = testInstance "./tests/While.class" "f" test_03 = testInstance "./tests/While.class" "g" - - -parseMethod :: Class Resolved -> B.ByteString -> IO (Maybe MapBB) -parseMethod cls method = do - -- TODO(bernhard): remove me! just playing around with - -- hs-java interface. - -- we get that index at the INVOKESTATIC insn - putStrLn "via constpool @2:" - let cp = constsPool cls - let (CMethod rc nt) = cp M.! (2 :: Word16) - -- rc :: Link stage B.ByteString - -- nt :: Link stage (NameType Method) - B.putStrLn $ "rc: " `B.append` rc - B.putStrLn $ "nt: " `B.append` (encode $ ntSignature nt) - - putStrLn "via methods:" - let msig = methodSignature $ (classMethods cls) !! 1 - B.putStrLn (method `B.append` ": " `B.append` (encode msig)) - - return $ testCFG $ lookupMethod method cls - - -testCFG :: Maybe (Method Resolved) -> Maybe MapBB -testCFG (Just m) = case attrByName m "Code" of - Nothing -> Nothing - Just bytecode -> Just $ buildCFG $ codeInstructions $ decodeMethod bytecode -testCFG _ = Nothing - +test_04 = testInstance "./tests/Fac.class" "fac" +-} + + +parseMethod :: Class Direct -> B.ByteString -> MethodSignature -> IO RawMethod +parseMethod cls methodname sig = do + let method = fromMaybe + (error $ "method " ++ (show . toString) methodname ++ " not found") + (lookupMethodSig methodname sig cls) + let codeseg = fromMaybe + (error $ "codeseg " ++ (show . toString) methodname ++ " not found") + (attrByName method "Code") + let decoded = decodeMethod codeseg + let mapbb = testCFG decoded + let locals = fromIntegral (codeMaxLocals decoded) + let stacks = fromIntegral (codeStackSize decoded) + let codelen = fromIntegral (codeLength decoded) + let methoddirect = methodInfoToMethod (MethodInfo methodname "" sig) cls + let isStatic = methodIsStatic methoddirect + 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 + -- 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 + + +testCFG :: Code -> MapBB +testCFG = buildCFG . codeInstructions buildCFG :: [Instruction] -> MapBB buildCFG xs = buildCFG' M.empty xs' xs' where xs' :: [OffIns] - xs' = calculateInstructionOffset xs + xs' = evalState (calculateInstructionOffset xs) [] + buildCFG' :: MapBB -> [OffIns] -> [OffIns] -> MapBB buildCFG' hmap [] _ = hmap -buildCFG' hmap (((off, entry), _):xs) insns = buildCFG' (insertlist entryi hmap) xs insns +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] else []) ++ -- also consider the entrypoint - case entry of - Just (TwoTarget t1 t2) -> [t1, t2] - Just (OneTarget t) -> [t] - Just (Return) -> [] - Nothing -> [] + 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 -> [] parseBasicBlock :: Int -> [OffIns] -> BasicBlock -parseBasicBlock i insns = BasicBlock insonly endblock +parseBasicBlock i insns = emptyBasicBlock { code = insonly, 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 + (_, Just endblock, _) = fromJust lastblock + + -- also take last (non-matched) element and return it + 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 - -- 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]) + validins :: OffIns -> Bool + validins (_, x, _) = isNothing x - validins :: ((Int, Maybe BBEnd), Instruction) -> Bool - validins ((_,x),_) = case x of Just _ -> False; Nothing -> True + omitins :: OffIns -> Bool + omitins (off, _, _) = off < i -calculateInstructionOffset :: [Instruction] -> [OffIns] -calculateInstructionOffset = cio' (0, Nothing) +calculateInstructionOffset :: [Instruction] -> AnalyseState +calculateInstructionOffset = cio' (0, Nothing, NOP) where - newoffset :: Instruction -> Int -> Offset - newoffset x off = (off + (fromIntegral $ B.length $ encodeInstructions [x]), Nothing) - - addW16Signed :: Int -> Word16 -> Int - 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 - IF _ w16 -> twotargets w16 - IF_ICMP _ w16 -> twotargets w16 - GOTO w16 -> onetarget w16 - IRETURN -> notarget - RETURN -> notarget - _ -> ((off, Nothing), x):next - 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 + addW16Signed :: Int -> Word16 -> Int + addW16Signed i w16 = i + fromIntegral s16 + where s16 = fromIntegral w16 :: Int16 + + cio' :: OffIns -> [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 + IRETURN -> notarget + ARETURN -> notarget + RETURN -> notarget + _ -> normalins + where + normalins = do + tailinsns <- next -- eval remaining instructions + isNextInsATarget <- (elem 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:) + ((off, Just $ OneTarget jump, x):) <$> next + twotargets w16 = do + let nojump = off + 3 + modify (nojump:) + let jump = off `addW16Signed` w16 + modify (jump:) + ((off, Just $ TwoTarget nojump jump, x):) <$> next + 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? +insnLength :: Num a => Instruction -> a +insnLength = fromIntegral . B.length . encodeInstructions . (:[])