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 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 :: Code -> MapBB
 127 testCFG c = buildCFG (codeInstructions c) (codeExceptions c)
 128
 129 buildCFG :: [Instruction] -> [CodeException] -> MapBB
 130 buildCFG xs excps = execState (mapM (buildCFG' offins) $ 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 buildCFG' :: [OffIns] -> Int -> State MapBB ()
 138 buildCFG' insns off = do
 139   let value = parseBasicBlock off insns
 140   modify (M.insert off value)
 141
 142 parseBasicBlock :: Int -> [OffIns] -> BasicBlock
 143 parseBasicBlock i insns = emptyBasicBlock { code = insonly, successor = endblock }
 144   where
 145     (lastblock, is) = takeWhilePlusOne validins omitins insns
 146     (_, _, insonly) = unzip3 is
 147     (_, Just endblock, _) = fromJust lastblock
 148
 149     -- also take last (non-matched) element and return it
 150     takeWhilePlusOne :: (a -> Bool) -> (a -> Bool) -> [a] -> (Maybe a, [a])
 151     takeWhilePlusOne _ _ [] = (Nothing, [])
 152     takeWhilePlusOne p omit (x:xs)
 153       | omit x    = next
 154       | p x       = second (x:) next
 155       | otherwise = (Just x, [x])
 156       where
 157         next = takeWhilePlusOne p omit xs
 158
 159     validins :: OffIns -> Bool
 160     validins (_, x, _) = isNothing x
 161
 162     omitins :: OffIns -> Bool
 163     omitins (off, _, _) = off < i
 164
 165
 166 calculateInstructionOffset :: [BlockID] -> [Instruction] -> AnalyseState
 167 calculateInstructionOffset exstarts = cio' 0
 168   where
 169     addW16Signed i w16 = i + fromIntegral s16
 170       where s16 = fromIntegral w16 :: Int16
 171
 172     cio' :: Int -> [Instruction] -> AnalyseState
 173     cio' _ [] = return $ []
 174     cio' off (x:xs) = case x of
 175         IF _ w16 -> twotargets w16
 176         IF_ICMP _ w16 -> twotargets w16
 177         IF_ACMP _ w16 -> twotargets w16
 178         IFNONNULL w16 -> twotargets w16
 179         IFNULL w16 -> twotargets w16
 180         GOTO w16 -> onetarget w16
 181         ATHROW -> notarget
 182         IRETURN -> notarget
 183         ARETURN -> notarget
 184         RETURN -> notarget
 185         _ -> if newoffset `elem` exstarts
 186               then do
 187                 modify (S.insert newoffset)
 188                 ((off, Just $ OneTarget newoffset, x):) <$> next
 189               else normalins
 190       where
 191         normalins = do
 192           tailinsns <- next -- eval remaining instructions
 193           isNextInsATarget <- (S.member newoffset) <$> get
 194           let bbtyp = if isNextInsATarget
 195                 then Just $ FallThrough newoffset
 196                 else Nothing
 197           return $ (off, bbtyp, x):tailinsns
 198         notarget = ((off, Just Return, x):) <$> next
 199         onetarget w16 = do
 200           let jump = off `addW16Signed` w16
 201           modify (S.insert jump)
 202           ((off, Just $ OneTarget jump, x):) <$> next
 203         twotargets w16 = do
 204           let nojump = off + 3
 205           modify (S.insert nojump)
 206           let jump = off `addW16Signed` w16
 207           modify (S.insert jump)
 208           ((off, Just $ TwoTarget nojump jump, x):) <$> next
 209         next = cio' newoffset xs
 210         newoffset = off + insLen
 211         insLen = insnLength x
 212
 213 -- TODO(bernhard): does GHC memomize results? i.e. does it calculate the size
 214 --                 of `NOP' only once?
 215 insnLength :: Num a => Instruction -> a
 216 insnLength = fromIntegral . B.length . encodeInstructions . (:[])