X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=Mate%2FBasicBlocks.hs;h=fbb61f7a06ecf6a471d5b33385953f58228ee19b;hb=f82dbecc763818452667ac568da96b7c5dd7cc97;hp=68d8cb9a8f44c0c83528b83ade08728cba24a129;hpb=562341501dfeab7e6ec85b54ec5f3f4aa1c02078;p=mate.git diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs index 68d8cb9..fbb61f7 100644 --- a/Mate/BasicBlocks.hs +++ b/Mate/BasicBlocks.hs @@ -1,74 +1,209 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -module Mate.BasicBlocks where +#include "debug.h" +module Mate.BasicBlocks( + BlockID, + BasicBlock (..), + BBEnd (..), + MapBB, +#ifdef DBG_BB + printMapBB, +#endif + parseMethod, + testCFG -- added by hs to perform benches from outside + )where import Data.Binary -import System.Environment +import Data.Int +import Data.List import qualified Data.Map as M import qualified Data.ByteString.Lazy as B -import JVM.Common import JVM.ClassFile import JVM.Converter -import JVM.Dump import JVM.Assembler +import Mate.Types +import Mate.Debug import Mate.Utilities -type Name = String -- use "virtual register id" instead? -data Type = JInt | JFloat -- add more -type Variable = (Type,Name) +#ifdef DEBUG +import Text.Printf +#endif --- Represents a CFG node -data BasicBlock = BasicBlock { - inputs :: [Variable], - outputs :: [Variable], - code :: [Instruction] } +-- for immediate representation to determine BBs +type Offset = (Int, Maybe BBEnd) -- (offset in bytecode, offset to jump target) +type OffIns = (Offset, Instruction) --- Represents a Control-Flow-Graph as --- Adjacency list (add matrix representation if appropriate) -type CFList = [(BasicBlock, [BasicBlock])] +#ifdef DBG_BB +printMapBB :: Maybe MapBB -> IO () +printMapBB Nothing = putStrLn "No BasicBlock" +printMapBB (Just hmap) = do + putStr "BlockIDs: " + let keys = M.keys 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 "" + FallThrough t1 -> putStrLn $ "Sucessor: " ++ (show t1) ++ "\n" + 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." +#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 + test_02 + test_03 + test_04 + +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" +test_04 = testInstance "./tests/Fac.class" "fac" +#endif +#endif + + +parseMethod :: Class Direct -> B.ByteString -> MethodSignature -> IO (Maybe MapBB) +parseMethod cls method sig = do + let maybe_bb = testCFG $ lookupMethodSig method sig cls + let msig = methodSignature $ classMethods cls !! 1 + printfBb "BB: analysing \"%s\"\n" $ toString (method `B.append` ": " `B.append` encode msig) +#ifdef DBG_BB + printMapBB maybe_bb +#endif + -- small example how to get information about + -- exceptions of a method + -- TODO: remove ;-) + let (Just m) = lookupMethodSig method 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 maybe_bb + + +testCFG :: Maybe (Method Direct) -> Maybe MapBB +testCFG m = do + m' <- m + bytecode <- attrByName m' "Code" + return $ buildCFG $ codeInstructions $ decodeMethod bytecode + + +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 -main = do - args <- getArgs - case args of - [clspath] -> parseFile clspath "fib" -- TODO - _ -> error "Synopsis: dump-class File.class" - + -- 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 -parseFile :: String -> B.ByteString -> IO () -parseFile clspath method = do - --clsFile <- decodeFile clspath - --putStrLn $ showListIx $ M.assocs $ constsPool (clsFile :: Class Pointers) - cls <- parseClassFile clspath - --dumpClass cls - let mainmethod = lookupMethod method cls -- "main|([Ljava/lang/String;)V" cf - mapM_ putStrLn (testCFG mainmethod) -test_01 = parseFile "./tests/Fib.class" "fib" -test_02 = parseFile "./tests/While.class" "f" -test_03 = parseFile "./tests/While.class" "g" +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 + 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 + where + startlist = dropWhile (\((x,_),_) -> x < i) insns + (Just ((_, Just endblock),_), is) = takeWhilePlusOne validins startlist + insonly = snd $ unzip is + -- 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]) -testCFG :: Maybe (Method Resolved) -> [String] -testCFG (Just m) = case attrByName m "Code" of - Nothing -> error "no code" - Just bytecode -> let code = decodeMethod bytecode - instructions = codeInstructions code - in buildCFG instructions -testCFG _ = error "no method to build cfg" + validins :: ((Int, Maybe BBEnd), Instruction) -> Bool + validins ((_,x),_) = case x of Just _ -> False; Nothing -> True -buildCFG :: [Instruction] -> [String] -buildCFG xs = map (\(x,y) -> show x ++ ", " ++ show y) xs' +calculateInstructionOffset :: [Instruction] -> [OffIns] +calculateInstructionOffset = cio' (0, Nothing) where - xs' = calculateInstructionOffset xs + newoffset :: Instruction -> Int -> Offset + newoffset x off = (off + fromIntegral (B.length $ encodeInstructions [x]), Nothing) -type Offset = Int -calculateInstructionOffset :: [Instruction] -> [(Offset, Instruction)] -calculateInstructionOffset = cio' 0 - where - cio' :: Offset -> [Instruction] -> [(Offset, Instruction)] + addW16Signed :: Int -> Word16 -> Int + addW16Signed i w16 = i + fromIntegral s16 + where s16 = fromIntegral w16 :: Int16 + + cio' :: Offset -> [Instruction] -> [OffIns] cio' _ [] = [] - cio' off (x:xs) = (off,x):(cio' newoffset xs) - where newoffset = off + (fromIntegral $ B.length $ encodeInstructions [x]) + -- 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 + IF_ACMP _ w16 -> twotargets w16 + IFNONNULL w16 -> twotargets w16 + IFNULL w16 -> twotargets w16 + GOTO w16 -> onetarget w16 + IRETURN -> notarget + ARETURN -> 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