Mate/BasicBlocks.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Mate.BasicBlocks(
   3   BlockID,
   4   BasicBlock,
   5   BBEnd,
   6   MapBB,
   7   Method,
   8   printMapBB,
   9   parseMethod,
  10   testCFG -- added by hs to perform benches from outside
  11   )where
  12
  13 import Data.Binary hiding (get)
  14 import Data.Int
  15 import qualified Data.Map as M
  16 import qualified Data.Set as S
  17 import qualified Data.ByteString.Lazy as B
  18 import Data.Maybe
  19 import Control.Monad.State
  20 import Control.Applicative
  21 import Control.Arrow
  22
  23 import JVM.ClassFile
  24 import JVM.Converter
  25 import JVM.Assembler
  26
  27 import Mate.Types
  28 import Mate.Debug
  29 import Mate.Utilities
  30
  31 -- (offset in bytecode, offset to jump target, ins)
  32 type OffIns = (Int, Maybe BBEnd, Instruction)
  33
  34 type Target = BlockID
  35 type BBState = S.Set Target
  36 type AnalyseState = State BBState [OffIns]
  37
  38
  39 noException :: B.ByteString
  40 noException = B.empty
  41
  42 emptyBasicBlock :: BasicBlock
  43 emptyBasicBlock = BasicBlock
  44                     { code = []
  45                     , exception = noException
  46                     , successor = Return }
  47
  48 printMapBB :: MapBB -> IO ()
  49 printMapBB hmap = do
  50   printfBb "BlockIDs: "
  51   let keys = M.keys hmap
  52   mapM_ (printfBb . flip (++) ", " . show) keys
  53   printfBb "\n\nBasicBlocks:\n"
  54   printMapBB' keys hmap
  55     where
  56       printMapBB' :: [BlockID] -> MapBB -> IO ()
  57       printMapBB' [] _ = return ()
  58       printMapBB' (i:is) hmap' = case M.lookup i hmap' of
  59         Just bb -> do
  60           printfBb $ "Block " ++ show i ++ "\n"
  61           mapM_ (printfBb . flip (++) "\n" . (++) "\t" . show) $ code bb
  62           printfBb $ case successor bb of
  63             Return -> ""
  64             FallThrough t1 -> "Sucessor: " ++ show t1 ++ "\n"
  65             OneTarget t1 -> "Sucessor: " ++ show t1 ++ "\n"
  66             TwoTarget t1 t2 -> "Sucessor: " ++ show t1 ++ ", " ++ show t2 ++ "\n"
  67           printMapBB' is hmap
  68         Nothing -> error $ "BlockID " ++ show i ++ " not found."
  69
  70 {-
  71 testInstance :: String -> B.ByteString -> MethodSignature -> IO ()
  72 testInstance cf method sig = do
  73   cls <- parseClassFile cf
  74   hmap <- parseMethod cls method sig
  75   printMapBB hmap
  76
  77 test_main :: IO ()
  78 test_main = do
  79   test_01
  80   test_02
  81   test_03
  82   test_04
  83
  84 test_01, test_02, test_03, test_04 :: IO ()
  85 test_01 = testInstance "./tests/Fib.class" "fib"
  86 test_02 = testInstance "./tests/While.class" "f"
  87 test_03 = testInstance "./tests/While.class" "g"
  88 test_04 = testInstance "./tests/Fac.class" "fac"
  89 -}
  90
  91
  92 parseMethod :: Class Direct -> B.ByteString -> MethodSignature -> IO RawMethod
  93 parseMethod cls methodname sig = do
  94   let method = fromMaybe
  95                (error $ "method " ++ (show . toString) methodname ++ " not found")
  96                (lookupMethodSig methodname sig cls)
  97   let codeseg = fromMaybe
  98                 (error $ "codeseg " ++ (show . toString) methodname ++ " not found")
  99                 (attrByName method "Code")
 100   let decoded = decodeMethod codeseg
 101   let mapbb = testCFG cls decoded
 102   let locals = fromIntegral (codeMaxLocals decoded)
 103   let stacks = fromIntegral (codeStackSize decoded)
 104   let codelen = fromIntegral (codeLength decoded)
 105   let methoddirect = methodInfoToMethod (MethodInfo methodname "" sig) cls
 106   let isStatic = methodIsStatic methoddirect
 107   let nametype = methodNameType methoddirect
 108   let argscount = methodGetArgsCount nametype + (if isStatic then 0 else 1)
 109
 110   -- TODO: remove ;-)
 111   -- small example how to get information about
 112   -- exceptions of a method
 113   let (Just m) = lookupMethodSig methodname sig cls
 114   case attrByName m "Code" of
 115     Nothing ->
 116       printfBb $ printf "exception: no handler for this method\n"
 117     Just exceptionstream ->
 118       printfBb $ printf "exception: \"%s\"\n" (show $ codeExceptions $ decodeMethod exceptionstream)
 119   -- [/remove]
 120   let msig = methodSignature method
 121   printfBb $ printf "BB: analysing \"%s\"\n" $ toString (methodname `B.append` ": " `B.append` encode msig)
 122   printMapBB mapbb
 123   return $ RawMethod mapbb locals stacks argscount codelen
 124
 125
 126 testCFG :: Class Direct -> Code -> MapBB
 127 testCFG cls c = buildCFG (codeInstructions c) (codeExceptions c)
 128   where
 129     buildCFG :: [Instruction] -> [CodeException] -> MapBB
 130     buildCFG xs excps = execState (mapM buildCFG' $ alltargets ++ handlerEntries) M.empty
 131       where
 132       (offins, targets) = runState (calculateInstructionOffset tryBlocks xs) S.empty
 133       alltargets = S.toList $ S.insert 0 targets
 134       tryBlocks = map (fromIntegral . eStartPC) excps
 135       handlerEntries = map (fromIntegral . eHandlerPC) excps
 136
 137       exceptionMap :: M.Map (Word16, Word16) [(B.ByteString, Word16)]
 138       exceptionMap = foldl f M.empty excps
 139         where
 140           f emap ce =
 141             if M.member key emap
 142               then M.adjust (value:) key emap
 143               else M.insert key [value] emap
 144               where
 145                 key = (&&&) eStartPC eEndPC ce
 146                 value = (&&&) (buildClassID cls . eCatchType) eHandlerPC ce
 147
 148       buildCFG' :: Int -> State MapBB ()
 149       buildCFG' off = do
 150         let value = parseBasicBlock off offins
 151         modify (M.insert off value)
 152
 153 parseBasicBlock :: Int -> [OffIns] -> BasicBlock
 154 parseBasicBlock i insns = emptyBasicBlock { code = insonly, successor = endblock }
 155   where
 156     (lastblock, is) = takeWhilePlusOne validins omitins insns
 157     (_, _, insonly) = unzip3 is
 158     (_, Just endblock, _) = fromJust lastblock
 159
 160     -- also take last (non-matched) element and return it
 161     takeWhilePlusOne :: (a -> Bool) -> (a -> Bool) -> [a] -> (Maybe a, [a])
 162     takeWhilePlusOne _ _ [] = (Nothing, [])
 163     takeWhilePlusOne p omit (x:xs)
 164       | omit x    = next
 165       | p x       = second (x:) next
 166       | otherwise = (Just x, [x])
 167       where
 168         next = takeWhilePlusOne p omit xs
 169
 170     validins :: OffIns -> Bool
 171     validins (_, x, _) = isNothing x
 172
 173     omitins :: OffIns -> Bool
 174     omitins (off, _, _) = off < i
 175
 176
 177 calculateInstructionOffset :: [BlockID] -> [Instruction] -> AnalyseState
 178 calculateInstructionOffset exstarts = cio' 0
 179   where
 180     addW16Signed i w16 = i + fromIntegral s16
 181       where s16 = fromIntegral w16 :: Int16
 182
 183     cio' :: Int -> [Instruction] -> AnalyseState
 184     cio' _ [] = return $ []
 185     cio' off (x:xs) = case x of
 186         IF _ w16 -> twotargets w16
 187         IF_ICMP _ w16 -> twotargets w16
 188         IF_ACMP _ w16 -> twotargets w16
 189         IFNONNULL w16 -> twotargets w16
 190         IFNULL w16 -> twotargets w16
 191         GOTO w16 -> onetarget w16
 192         ATHROW -> notarget
 193         IRETURN -> notarget
 194         ARETURN -> notarget
 195         RETURN -> notarget
 196         _ -> if newoffset `elem` exstarts
 197               then do
 198                 modify (S.insert newoffset)
 199                 ((off, Just $ OneTarget newoffset, x):) <$> next
 200               else normalins
 201       where
 202         normalins = do
 203           tailinsns <- next -- eval remaining instructions
 204           isNextInsATarget <- (S.member newoffset) <$> get
 205           let bbtyp = if isNextInsATarget
 206                 then Just $ FallThrough newoffset
 207                 else Nothing
 208           return $ (off, bbtyp, x):tailinsns
 209         notarget = ((off, Just Return, x):) <$> next
 210         onetarget w16 = do
 211           let jump = off `addW16Signed` w16
 212           modify (S.insert jump)
 213           ((off, Just $ OneTarget jump, x):) <$> next
 214         twotargets w16 = do
 215           let nojump = off + 3
 216           modify (S.insert nojump)
 217           let jump = off `addW16Signed` w16
 218           modify (S.insert jump)
 219           ((off, Just $ TwoTarget nojump jump, x):) <$> next
 220         next = cio' newoffset xs
 221         newoffset = off + insLen
 222         insLen = insnLength x
 223
 224 -- TODO(bernhard): does GHC memomize results? i.e. does it calculate the size
 225 --                 of `NOP' only once?
 226 insnLength :: Num a => Instruction -> a
 227 insnLength = fromIntegral . B.length . encodeInstructions . (:[])