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