X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=Mate%2FBasicBlocks.hs;h=2a8ac22513df29f49bd56b55f912a1ee1a6425e6;hb=da245b03d80644c22b011acba31acacb880d8327;hp=bf34eee25e57d1e3c6ff138d0b30962f0e8178b8;hpb=08cb32d77e6427a2e1bac5d9c10de4f2b26f523c;p=mate.git diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs index bf34eee..2a8ac22 100644 --- a/Mate/BasicBlocks.hs +++ b/Mate/BasicBlocks.hs @@ -3,12 +3,12 @@ #include "debug.h" module Mate.BasicBlocks( BlockID, - BasicBlock (..), - BBEnd (..), + BasicBlock, + BBEnd, MapBB, + Method, #ifdef DBG_BB printMapBB, - test_main, #endif parseMethod, testCFG -- added by hs to perform benches from outside @@ -24,9 +24,9 @@ import JVM.ClassFile import JVM.Converter import JVM.Assembler -import Mate.Utilities import Mate.Types import Mate.Debug +import Mate.Utilities #ifdef DEBUG import Text.Printf @@ -38,11 +38,10 @@ type OffIns = (Offset, Instruction) #ifdef DBG_BB -printMapBB :: Maybe MapBB -> IO () -printMapBB Nothing = putStrLn "No BasicBlock" -printMapBB (Just hmap) = do +printMapBB :: MapBB -> IO () +printMapBB hmap = do putStr "BlockIDs: " - let keys = fst $ unzip $ M.toList hmap + let keys = M.keys hmap mapM_ (putStr . (flip (++)) ", " . show) keys putStrLn "\n\nBasicBlocks:" printMapBB' keys hmap @@ -62,11 +61,12 @@ printMapBB (Just hmap) = do Nothing -> error $ "BlockID " ++ show i ++ " not found." #endif +#if 0 #ifdef DBG_BB -testInstance :: String -> B.ByteString -> IO () -testInstance cf method = do +testInstance :: String -> B.ByteString -> MethodSignature -> IO () +testInstance cf method sig = do cls <- parseClassFile cf - hmap <- parseMethod cls method + hmap <- parseMethod cls method sig printMapBB hmap #endif @@ -84,31 +84,39 @@ 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 Resolved -> B.ByteString -> IO (Maybe MapBB) -parseMethod cls method = do - let maybe_bb = testCFG $ lookupMethod method cls - let msig = methodSignature $ (classMethods cls) !! 1 - printfBb "BB: analysing \"%s\"\n" $ toString (method `B.append` ": " `B.append` (encode msig)) +parseMethod :: Class Direct -> B.ByteString -> MethodSignature -> IO (Maybe RawMethod) +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 + case maybe_bb of + Just m -> printMapBB $ rawMapBB m + Nothing -> return () #endif -- small example how to get information about -- exceptions of a method -- TODO: remove ;-) - let (Just m) = lookupMethod method cls + 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) + Just exceptionstream -> do + printfBb "exception: \"%s\"\n" (show $ codeExceptions $ decodeMethod exceptionstream) return maybe_bb -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 +testCFG :: Maybe (Method Direct) -> Maybe RawMethod +testCFG m = do + m' <- m + codeseg <- attrByName m' "Code" + let decoded = decodeMethod codeseg + let mapbb = buildCFG $ codeInstructions decoded + let locals = fromIntegral (codeMaxLocals decoded) + let stacks = fromIntegral (codeStackSize decoded) + return $ RawMethod mapbb locals stacks buildCFG :: [Instruction] -> MapBB @@ -124,7 +132,7 @@ 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)) + x_new:markBackwardTargets (y:xs) where x_new = if isTarget then checkX y_off else x checkX w16 = case x_bbend of @@ -133,8 +141,8 @@ markBackwardTargets insns@(x@((x_off,x_bbend),x_ins):y@((y_off,_),_):xs) = -- 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 ((_,Just (OneTarget w16)),_) = w16 == y_off + cmpOffset ((_,Just (TwoTarget _ w16)),_) = w16 == y_off cmpOffset _ = False @@ -150,27 +158,27 @@ buildCFG' hmap (((off, entry), _):xs) insns = buildCFG' (insertlist entryi 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 (FallThrough t) -> [t] - Just (Return) -> [] - Nothing -> [] + 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 + (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)) + | p x = let (lastins, list) = takeWhilePlusOne p xs in (lastins, x:list) | otherwise = (Just x,[x]) validins :: ((Int, Maybe BBEnd), Instruction) -> Bool @@ -181,11 +189,11 @@ calculateInstructionOffset :: [Instruction] -> [OffIns] calculateInstructionOffset = cio' (0, Nothing) where newoffset :: Instruction -> Int -> Offset - newoffset x off = (off + (fromIntegral $ B.length $ encodeInstructions [x]), Nothing) + 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 + addW16Signed i w16 = i + fromIntegral s16 + where s16 = fromIntegral w16 :: Int16 cio' :: Offset -> [Instruction] -> [OffIns] cio' _ [] = [] @@ -194,6 +202,8 @@ calculateInstructionOffset = cio' (0, Nothing) 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 @@ -201,6 +211,6 @@ calculateInstructionOffset = cio' (0, Nothing) _ -> ((off, Nothing), x):next where notarget = ((off, Just Return), x):next - onetarget w16 = ((off, Just $ OneTarget $ (off `addW16Signed` w16)), 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