X-Git-Url: http://wien.tomnetworks.com/gitweb/?a=blobdiff_plain;f=Mate%2FBasicBlocks.hs;h=7fd2e4830eca4c7699fafde8030da559f11b4fb5;hb=2ac2a68eb5b709caa636d1a9a56a40268d378550;hp=c94e6d1dc8229e93f40caa680086d531ebc838e9;hpb=4c360eaabc8e7259b3011f69397501dcfca17786;p=mate.git diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs index c94e6d1..7fd2e48 100644 --- a/Mate/BasicBlocks.hs +++ b/Mate/BasicBlocks.hs @@ -10,12 +10,14 @@ module Mate.BasicBlocks( 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.ByteString.Lazy as B import Data.Maybe +import Control.Monad.State +import Control.Applicative +import Control.Arrow import JVM.ClassFile import JVM.Converter @@ -25,10 +27,22 @@ import Mate.Types import Mate.Debug import Mate.Utilities --- for immediate representation to determine BBs -type Offset = (Int, Maybe BBEnd) -- (offset in bytecode, offset to jump target) -type OffIns = (Offset, Instruction) +-- (offset in bytecode, offset to jump target, ins) +type OffIns = (Int, Maybe BBEnd, Instruction) +type Targets = [BlockID] +type BBState = Targets +type AnalyseState = State BBState [OffIns] + + +noException :: B.ByteString +noException = B.empty + +emptyBasicBlock :: BasicBlock +emptyBasicBlock = BasicBlock + { code = [] + , exception = noException + , successor = Return } printMapBB :: MapBB -> IO () printMapBB hmap = do @@ -114,32 +128,12 @@ 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 + 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' @@ -159,37 +153,39 @@ buildCFG' hmap (((off, entry), _):xs) insns = buildCFG' (insertlist entryi hmap) 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] -> (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) +calculateInstructionOffset :: [Instruction] -> AnalyseState +calculateInstructionOffset = cio' (0, Nothing, NOP) + where 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 + 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 @@ -199,9 +195,31 @@ calculateInstructionOffset = cio' (0, Nothing) IRETURN -> notarget ARETURN -> notarget RETURN -> notarget - _ -> ((off, Nothing), x):next + _ -> 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 <- (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 . (:[])