BBEnd (..),
MapBB,
printMapBB,
- parseMethod
+ parseMethod,
+ test_main,
+ testCFG -- added by hs to perform benches from outside
)where
import Data.Binary
import Data.Int
-import qualified Data.Map as H
-import System.Environment
+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 Debug.Trace
-
import Mate.Utilities
+import Mate.Types
-type Name = String -- use "virtual register id" instead?
-data Type = JInt | JFloat -- add more
-type Variable = (Type,Name)
-
-type BlockID = Int
--- Represents a CFG node
-data BasicBlock = BasicBlock {
- -- inputs :: [Variable],
- -- outputs :: [Variable],
- code :: [Instruction],
- successor :: BBEnd }
-
--- describes (leaving) edges of a CFG node
-data BBEnd = Return | OneTarget BlockID | TwoTarget BlockID BlockID deriving Show
-type MapBB = H.Map BlockID BasicBlock
-
--- for immediate representation for determine BBs
+-- for immediate representation to determine BBs
type Offset = (Int, Maybe BBEnd) -- (offset in bytecode, offset to jump target)
type OffIns = (Offset, Instruction)
printMapBB Nothing = putStrLn "No BasicBlock"
printMapBB (Just hmap) = do
putStr "BlockIDs: "
- let keys = fst $ unzip $ H.toList hmap
+ 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 H.lookup i hmap of
+ 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
testInstance :: String -> B.ByteString -> IO ()
testInstance cf method = do
- hmap <- parseMethod cf method
+ cls <- parseClassFile cf
+ hmap <- parseMethod cls method
printMapBB hmap
+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"
-parseMethod :: String -> B.ByteString -> IO (Maybe MapBB)
-parseMethod clspath method = do
- cls <- parseClassFile clspath
+parseMethod :: Class Resolved -> B.ByteString -> IO (Maybe MapBB)
+parseMethod cls method = do
+ putStr "BB: analysing: "
+ 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 -> let code = decodeMethod bytecode
- instructions = codeInstructions code
- in Just $ buildCFG instructions
-testCFG _ = Nothing
+ Nothing -> Nothing
+ Just bytecode -> Just $ buildCFG $ codeInstructions $ decodeMethod bytecode
+testCFG _ = Nothing
buildCFG :: [Instruction] -> MapBB
-buildCFG xs = buildCFG' H.empty xs' xs'
+buildCFG xs = buildCFG' M.empty xs' xs'
where
xs' :: [OffIns]
- xs' = calculateInstructionOffset xs
+ 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, Just 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 (x:xs) hmap = insertlist xs newhmap
+ insertlist [] hmap' = hmap'
+ insertlist (y:ys) hmap' = insertlist ys newhmap
where
- newhmap = if H.member x hmap then hmap else H.insert x value hmap
- value = parseBasicBlock x insns
+ 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
- TwoTarget t1 t2 -> [t1, t2]
- OneTarget t -> [t]
- Return -> trace "should not happen" []
-
-buildCFG' hmap (((_, Nothing), _):xs) insns = buildCFG' hmap xs insns
+ Just (TwoTarget t1 t2) -> [t1, t2]
+ Just (OneTarget t) -> [t]
+ Just (FallThrough t) -> [t]
+ Just (Return) -> []
+ Nothing -> []
parseBasicBlock :: Int -> [OffIns] -> BasicBlock
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 `addW16Signed` w16) (off + 3)), x):next
+ twotargets w16 = ((off, Just $ TwoTarget (off + 3) (off `addW16Signed` w16)), x):next
next = cio' (newoffset x off) xs
projects / mate.git / blobdiff