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