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 = (&&&) (buildClassID cls . eCatchType) eHandlerPC ce
 117
 118   let msig = methodSignature method
 119   printfBb $ printf "BB: analysing \"%s\"\n" $ toString (methodname `B.append` ": " `B.append` encode msig)
 120   printMapBB mapbb
 121   return $ RawMethod mapbb exceptionMap locals stacks argscount codelen
 122
 123
 124 testCFG :: Code -> MapBB
 125 testCFG c = buildCFG (codeInstructions c) (codeExceptions c)
 126   where
 127     buildCFG :: [Instruction] -> [CodeException] -> MapBB
 128     buildCFG xs excps = execState (mapM buildCFG' $ alltargets ++ handlerEntries) M.empty
 129       where
 130       (offins, targets) = runState (calculateInstructionOffset tryBlocks xs) S.empty
 131       alltargets = S.toList $ S.insert 0 targets
 132       tryBlocks = map (fromIntegral . eStartPC) excps
 133       handlerEntries = map (fromIntegral . eHandlerPC) excps
 134
 135       buildCFG' :: Int -> State MapBB ()
 136       buildCFG' off = do
 137         let value = parseBasicBlock off offins
 138         modify (M.insert off value)
 139
 140 parseBasicBlock :: Int -> [OffIns] -> BasicBlock
 141 parseBasicBlock i insns = emptyBasicBlock
 142           { code = insonly
 143           , bblength = lastoff - i + (insnLength lastins)
 144           , successor = endblock }
 145   where
 146     (lastblock, is) = takeWhilePlusOne validins omitins insns
 147     (_, _, insonly) = unzip3 is
 148     (lastoff, Just endblock, lastins) = fromJust lastblock
 149
 150     -- also take last (non-matched) element and return it
 151     takeWhilePlusOne :: (a -> Bool) -> (a -> Bool) -> [a] -> (Maybe a, [a])
 152     takeWhilePlusOne _ _ [] = (Nothing, [])
 153     takeWhilePlusOne p omit (x:xs)
 154       | omit x    = next
 155       | p x       = second (x:) next
 156       | otherwise = (Just x, [x])
 157       where
 158         next = takeWhilePlusOne p omit xs
 159
 160     validins :: OffIns -> Bool
 161     validins (_, x, _) = isNothing x
 162
 163     omitins :: OffIns -> Bool
 164     omitins (off, _, _) = off < i
 165
 166
 167 calculateInstructionOffset :: [BlockID] -> [Instruction] -> AnalyseState
 168 calculateInstructionOffset exstarts = cio' 0
 169   where
 170     addW16Signed i w16 = i + fromIntegral s16
 171       where s16 = fromIntegral w16 :: Int16
 172
 173     cio' :: Int -> [Instruction] -> AnalyseState
 174     cio' _ [] = return $ []
 175     cio' off (x:xs) = case x of
 176         IF _ w16 -> twotargets w16
 177         IF_ICMP _ w16 -> twotargets w16
 178         IF_ACMP _ w16 -> twotargets w16
 179         IFNONNULL w16 -> twotargets w16
 180         IFNULL w16 -> twotargets w16
 181         GOTO w16 -> onetarget w16
 182         ATHROW -> notarget
 183         IRETURN -> notarget
 184         ARETURN -> notarget
 185         RETURN -> notarget
 186         _ -> if newoffset `elem` exstarts
 187               then do
 188                 modify (S.insert newoffset)
 189                 ((off, Just $ OneTarget newoffset, x):) <$> next
 190               else normalins
 191       where
 192         normalins = do
 193           tailinsns <- next -- eval remaining instructions
 194           isNextInsATarget <- (S.member newoffset) <$> get
 195           let bbtyp = if isNextInsATarget
 196                 then Just $ FallThrough newoffset
 197                 else Nothing
 198           return $ (off, bbtyp, x):tailinsns
 199         notarget = ((off, Just Return, x):) <$> next
 200         onetarget w16 = do
 201           let jump = off `addW16Signed` w16
 202           modify (S.insert jump)
 203           ((off, Just $ OneTarget jump, x):) <$> next
 204         twotargets w16 = do
 205           let nojump = off + 3
 206           modify (S.insert nojump)
 207           let jump = off `addW16Signed` w16
 208           modify (S.insert jump)
 209           ((off, Just $ TwoTarget nojump jump, x):) <$> next
 210         next = cio' newoffset xs
 211         newoffset = off + insLen
 212         insLen = insnLength x
 213
 214 -- TODO(bernhard): does GHC memomize results? i.e. does it calculate the size
 215 --                 of `NOP' only once?
 216 insnLength :: Num a => Instruction -> a
 217 insnLength = fromIntegral . B.length . encodeInstructions . (:[])