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 printMapBB :: MapBB -> IO ()
  39 printMapBB hmap = do
  40   printfBb "BlockIDs: "
  41   let keys = M.keys hmap
  42   mapM_ (printfBb . flip (++) ", " . show) keys
  43   printfBb "\n\nBasicBlocks:\n"
  44   printMapBB' keys hmap
  45     where
  46       printMapBB' :: [BlockID] -> MapBB -> IO ()
  47       printMapBB' [] _ = return ()
  48       printMapBB' (i:is) hmap' = case M.lookup i hmap' of
  49         Just bb -> do
  50           printfBb $ "Block " ++ show i ++ "\n"
  51           mapM_ (printfBb . flip (++) "\n" . (++) "\t" . show) $ code bb
  52           printfBb $ case successor bb of
  53             Return -> ""
  54             FallThrough t1 -> "Sucessor: " ++ show t1 ++ "\n"
  55             OneTarget t1 -> "Sucessor: " ++ show t1 ++ "\n"
  56             TwoTarget t1 t2 -> "Sucessor: " ++ show t1 ++ ", " ++ show t2 ++ "\n"
  57           printMapBB' is hmap
  58         Nothing -> error $ "BlockID " ++ show i ++ " not found."
  59
  60 {-
  61 testInstance :: String -> B.ByteString -> MethodSignature -> IO ()
  62 testInstance cf method sig = do
  63   cls <- parseClassFile cf
  64   hmap <- parseMethod cls method sig
  65   printMapBB hmap
  66
  67 test_main :: IO ()
  68 test_main = do
  69   test_01
  70   test_02
  71   test_03
  72   test_04
  73
  74 test_01, test_02, test_03, test_04 :: IO ()
  75 test_01 = testInstance "./tests/Fib.class" "fib"
  76 test_02 = testInstance "./tests/While.class" "f"
  77 test_03 = testInstance "./tests/While.class" "g"
  78 test_04 = testInstance "./tests/Fac.class" "fac"
  79 -}
  80
  81
  82 parseMethod :: Class Direct -> B.ByteString -> MethodSignature -> IO RawMethod
  83 parseMethod cls methodname sig = do
  84   let method = fromMaybe
  85                (error $ "method " ++ (show . toString) methodname ++ " not found")
  86                (lookupMethodSig methodname sig cls)
  87   let codeseg = fromMaybe
  88                 (error $ "codeseg " ++ (show . toString) methodname ++ " not found")
  89                 (attrByName method "Code")
  90   let decoded = decodeMethod codeseg
  91   let mapbb = testCFG decoded
  92   let locals = fromIntegral (codeMaxLocals decoded)
  93   let stacks = fromIntegral (codeStackSize decoded)
  94   let codelen = fromIntegral (codeLength decoded)
  95   let methoddirect = methodInfoToMethod (MethodInfo methodname "" sig) cls
  96   let isStatic = methodIsStatic methoddirect
  97   let nametype = methodNameType methoddirect
  98   let argscount = methodGetArgsCount nametype + (if isStatic then 0 else 1)
  99
 100   let msig = methodSignature method
 101   printfBb $ printf "BB: analysing \"%s\"\n" $ toString (methodname `B.append` ": " `B.append` encode msig)
 102   printMapBB mapbb
 103   -- small example how to get information about
 104   -- exceptions of a method
 105   -- TODO: remove ;-)
 106   let (Just m) = lookupMethodSig methodname sig cls
 107   case attrByName m "Code" of
 108     Nothing ->
 109       printfBb $ printf "exception: no handler for this method\n"
 110     Just exceptionstream ->
 111       printfBb $ printf "exception: \"%s\"\n" (show $ codeExceptions $ decodeMethod exceptionstream)
 112   return $ RawMethod mapbb locals stacks argscount codelen
 113
 114
 115 testCFG :: Code -> MapBB
 116 testCFG = buildCFG . codeInstructions
 117
 118 buildCFG :: [Instruction] -> MapBB
 119 buildCFG xs = buildCFG' M.empty xs' xs'
 120   where
 121   xs' :: [OffIns]
 122   xs' = evalState (calculateInstructionOffset xs >>= markBackwardTargets) []
 123
 124 -- get already calculated jmp-targets and mark the predecessor of the
 125 -- target-instruction as "FallThrough". we just care about backwards
 126 -- jumps here (forward jumps are handled in buildCFG')
 127 markBackwardTargets :: [OffIns] -> AnalyseState
 128 markBackwardTargets [] = return []
 129 markBackwardTargets (x:[]) = return [x]
 130 markBackwardTargets (x@(x_off,x_bbend,x_ins):y@(y_off,_,_):xs) = do
 131   rest <- markBackwardTargets (y:xs)
 132   targets <- get
 133   let isTarget = y_off `elem` targets
 134       x_new = case x_bbend of
 135         Just _ -> x -- already marked, don't change
 136         Nothing -> if isTarget then checkX y_off else x
 137       checkX w16 = case x_bbend of
 138         Nothing -> (x_off, Just $ FallThrough w16, x_ins) -- mark previous insn
 139         _ -> error "basicblock: something is wrong"
 140   return $ x_new:rest
 141
 142
 143
 144 buildCFG' :: MapBB -> [OffIns] -> [OffIns] -> MapBB
 145 buildCFG' hmap [] _ = hmap
 146 buildCFG' hmap ((off, entry, _):xs) insns = buildCFG' (insertlist entryi hmap) xs insns
 147   where
 148     insertlist :: [BlockID] -> MapBB -> MapBB
 149     insertlist [] hmap' = hmap'
 150     insertlist (y:ys) hmap' = insertlist ys newhmap
 151       where
 152         newhmap = if M.member y hmap' then hmap' else M.insert y value hmap'
 153         value = parseBasicBlock y insns
 154     entryi :: [BlockID]
 155     entryi = if off == 0 then 0:ys else ys -- also consider the entrypoint
 156       where
 157         ys = case entry of
 158           Just (TwoTarget t1 t2) -> [t1, t2]
 159           Just (OneTarget t) -> [t]
 160           Just (FallThrough t) -> [t]
 161           Just Return -> []
 162           Nothing -> []
 163
 164
 165 parseBasicBlock :: Int -> [OffIns] -> BasicBlock
 166 parseBasicBlock i insns = BasicBlock insonly endblock
 167   where
 168     (lastblock, is) = takeWhilePlusOne validins omitins insns
 169     (_, _, insonly) = unzip3 is
 170     (_, Just endblock, _) = fromJust lastblock
 171
 172     -- also take last (non-matched) element and return it
 173     takeWhilePlusOne :: (a -> Bool) -> (a -> Bool) -> [a] -> (Maybe a, [a])
 174     takeWhilePlusOne _ _ [] = (Nothing, [])
 175     takeWhilePlusOne p omit (x:xs)
 176       | omit x    = next
 177       | p x       = second (x:) next
 178       | otherwise = (Just x, [x])
 179       where
 180         next = takeWhilePlusOne p omit xs
 181
 182     validins :: OffIns -> Bool
 183     validins (_, x, _) = isNothing x
 184
 185     omitins :: OffIns -> Bool
 186     omitins (off, _, _) = off < i
 187
 188
 189 calculateInstructionOffset :: [Instruction] -> AnalyseState
 190 calculateInstructionOffset = cio' (0, Nothing, NOP)
 191   where
 192     addW16Signed :: Int -> Word16 -> Int
 193     addW16Signed i w16 = i + fromIntegral s16
 194       where s16 = fromIntegral w16 :: Int16
 195
 196     cio' :: OffIns -> [Instruction] -> AnalyseState
 197     cio' _ [] = return $ []
 198     cio' (off,_,_) (x:xs) = case x of
 199         IF _ w16 -> twotargets w16
 200         IF_ICMP _ w16 -> twotargets w16
 201         IF_ACMP _ w16 -> twotargets w16
 202         IFNONNULL w16 -> twotargets w16
 203         IFNULL w16 -> twotargets w16
 204         GOTO w16 -> onetarget w16
 205         IRETURN -> notarget
 206         ARETURN -> notarget
 207         RETURN -> notarget
 208         _ -> ((off, Nothing, x):) <$> next
 209       where
 210         notarget = ((off, Just Return, x):) <$> next
 211         onetarget w16 = do
 212           let jump = off `addW16Signed` w16
 213           modify (jump:)
 214           ((off, Just $ OneTarget jump, x):) <$> next
 215         twotargets w16 = do
 216           let nojump = off + 3
 217           modify (nojump:)
 218           let jump = off `addW16Signed` w16
 219           modify (jump:)
 220           ((off, Just $ TwoTarget nojump jump, x):) <$> next
 221         next = cio' newoffset xs
 222         newoffset = (off + insnLength x, Nothing, NOP)
 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 . (:[])