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