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 emptyBasicBlock :: BasicBlock
  40 emptyBasicBlock = BasicBlock
  41                     { code = []
  42                     , bblength = 0
  43                     , successor = Return }
  44
  45 printMapBB :: MapBB -> IO ()
  46 printMapBB hmap = do
  47   printfBb "BlockIDs: "
  48   let keys = M.keys hmap
  49   mapM_ (printfBb . flip (++) ", " . show) keys
  50   printfBb "\n\nBasicBlocks:\n"
  51   printMapBB' keys hmap
  52     where
  53       printMapBB' :: [BlockID] -> MapBB -> IO ()
  54       printMapBB' [] _ = return ()
  55       printMapBB' (i:is) hmap' = case M.lookup i hmap' of
  56         Just bb -> do
  57           printfBb $ "Block " ++ show i ++ ". len: " ++ (show $ bblength bb) ++ "\n"
  58           mapM_ (printfBb . flip (++) "\n" . (++) "\t" . show) $ code bb
  59           printfBb $ case successor bb of
  60             Return -> ""
  61             FallThrough t1 -> "Sucessor: " ++ show t1 ++ "\n"
  62             OneTarget t1 -> "Sucessor: " ++ show t1 ++ "\n"
  63             TwoTarget t1 t2 -> "Sucessor: " ++ show t1 ++ ", " ++ show t2 ++ "\n"
  64           printMapBB' is hmap
  65         Nothing -> error $ "BlockID " ++ show i ++ " not found."
  66
  67 {-
  68 testInstance :: String -> B.ByteString -> MethodSignature -> IO ()
  69 testInstance cf method sig = do
  70   cls <- parseClassFile cf
  71   hmap <- parseMethod cls method sig
  72   printMapBB hmap
  73
  74 test_main :: IO ()
  75 test_main = do
  76   test_01
  77   test_02
  78   test_03
  79   test_04
  80
  81 test_01, test_02, test_03, test_04 :: IO ()
  82 test_01 = testInstance "./tests/Fib.class" "fib"
  83 test_02 = testInstance "./tests/While.class" "f"
  84 test_03 = testInstance "./tests/While.class" "g"
  85 test_04 = testInstance "./tests/Fac.class" "fac"
  86 -}
  87
  88
  89 parseMethod :: Class Direct -> B.ByteString -> MethodSignature -> IO RawMethod
  90 parseMethod cls methodname sig = do
  91   let method = fromMaybe
  92                (error $ "method " ++ (show . toString) methodname ++ " not found")
  93                (lookupMethodSig methodname sig cls)
  94   let codeseg = fromMaybe
  95                 (error $ "codeseg " ++ (show . toString) methodname ++ " not found")
  96                 (attrByName method "Code")
  97   let decoded = decodeMethod codeseg
  98   let mapbb = testCFG decoded
  99   let locals = fromIntegral (codeMaxLocals decoded)
 100   let stacks = fromIntegral (codeStackSize decoded)
 101   let codelen = fromIntegral (codeLength decoded)
 102   let methoddirect = methodInfoToMethod (MethodInfo methodname "" sig) cls
 103   let isStatic = methodIsStatic methoddirect
 104   let nametype = methodNameType methoddirect
 105   let argscount = methodGetArgsCount nametype + (if isStatic then 0 else 1)
 106
 107   let exceptionMap :: ExceptionMap
 108       exceptionMap = foldl f M.empty $ codeExceptions decoded
 109         where
 110           f emap ce =
 111             if M.member key emap
 112               then M.adjust (value:) key emap
 113               else M.insert key [value] emap
 114               where
 115                 key = (&&&) eStartPC eEndPC ce
 116                 value = (&&&) g eHandlerPC ce
 117                   where
 118                     g ce' = case eCatchType ce' of
 119                         0 -> B.empty
 120                         x -> buildClassID cls x
 121
 122   let msig = methodSignature method
 123   printfBb $ printf "BB: analysing \"%s\"\n" $ toString (methodname `B.append` ": " `B.append` encode msig)
 124   printMapBB mapbb
 125   return $ RawMethod mapbb exceptionMap locals stacks argscount codelen
 126
 127
 128 testCFG :: Code -> MapBB
 129 testCFG c = buildCFG (codeInstructions c) (codeExceptions c)
 130   where
 131     buildCFG :: [Instruction] -> [CodeException] -> MapBB
 132     buildCFG xs excps = execState (mapM buildCFG' $ alltargets ++ handlerEntries) M.empty
 133       where
 134       (offins, targets) = runState (calculateInstructionOffset tryBlocks xs) S.empty
 135       alltargets = S.toList $ S.insert 0 targets
 136       tryBlocks = map (fromIntegral . eStartPC) excps
 137       handlerEntries = map (fromIntegral . eHandlerPC) excps
 138
 139       buildCFG' :: Int -> State MapBB ()
 140       buildCFG' off = do
 141         let value = parseBasicBlock off offins
 142         modify (M.insert off value)
 143
 144 parseBasicBlock :: Int -> [OffIns] -> BasicBlock
 145 parseBasicBlock i insns = emptyBasicBlock
 146           { code = zip offsets insonly
 147           , bblength = lastoff - i + (insnLength lastins)
 148           , successor = endblock }
 149   where
 150     (lastblock, is) = takeWhilePlusOne validins omitins insns
 151     (offsets, _, insonly) = unzip3 is
 152     (lastoff, Just endblock, lastins) = fromJust lastblock
 153
 154     -- also take last (non-matched) element and return it
 155     takeWhilePlusOne :: (a -> Bool) -> (a -> Bool) -> [a] -> (Maybe a, [a])
 156     takeWhilePlusOne _ _ [] = (Nothing, [])
 157     takeWhilePlusOne p omit (x:xs)
 158       | omit x    = next
 159       | p x       = second (x:) next
 160       | otherwise = (Just x, [x])
 161       where
 162         next = takeWhilePlusOne p omit xs
 163
 164     validins :: OffIns -> Bool
 165     validins (_, x, _) = isNothing x
 166
 167     omitins :: OffIns -> Bool
 168     omitins (off, _, _) = off < i
 169
 170
 171 calculateInstructionOffset :: [BlockID] -> [Instruction] -> AnalyseState
 172 calculateInstructionOffset exstarts = cio' 0
 173   where
 174     addW16Signed i w16 = i + fromIntegral s16
 175       where s16 = fromIntegral w16 :: Int16
 176
 177     cio' :: Int -> [Instruction] -> AnalyseState
 178     cio' _ [] = return $ []
 179     cio' off (x:xs) = case x of
 180         IF _ w16 -> twotargets w16
 181         IF_ICMP _ w16 -> twotargets w16
 182         IF_ACMP _ w16 -> twotargets w16
 183         IFNONNULL w16 -> twotargets w16
 184         IFNULL w16 -> twotargets w16
 185         GOTO w16 -> onetarget w16
 186         ATHROW -> notarget
 187         IRETURN -> notarget
 188         ARETURN -> notarget
 189         RETURN -> notarget
 190         _ -> if newoffset `elem` exstarts
 191               then do
 192                 modify (S.insert newoffset)
 193                 ((off, Just $ OneTarget newoffset, x):) <$> next
 194               else normalins
 195       where
 196         normalins = do
 197           tailinsns <- next -- eval remaining instructions
 198           isNextInsATarget <- (S.member newoffset) <$> get
 199           let bbtyp = if isNextInsATarget
 200                 then Just $ FallThrough newoffset
 201                 else Nothing
 202           return $ (off, bbtyp, x):tailinsns
 203         notarget = ((off, Just Return, x):) <$> next
 204         onetarget w16 = do
 205           let jump = off `addW16Signed` w16
 206           modify (S.insert jump)
 207           ((off, Just $ OneTarget jump, x):) <$> next
 208         twotargets w16 = do
 209           let nojump = off + 3
 210           modify (S.insert nojump)
 211           let jump = off `addW16Signed` w16
 212           modify (S.insert jump)
 213           ((off, Just $ TwoTarget nojump jump, x):) <$> next
 214         next = cio' newoffset xs
 215         newoffset = off + insLen
 216         insLen = insnLength x
 217
 218 -- TODO(bernhard): does GHC memomize results? i.e. does it calculate the size
 219 --                 of `NOP' only once?
 220 insnLength :: Num a => Instruction -> a
 221 insnLength = fromIntegral . B.length . encodeInstructions . (:[])