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 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 (mapM (buildCFG' offins) alltargets) M.empty
 130   where
 131   (offins, targets) = runState (calculateInstructionOffset xs) S.empty
 132   alltargets = S.toList $ S.insert 0 targets
 133
 134 buildCFG' :: [OffIns] -> Int -> State MapBB ()
 135 buildCFG' insns off = do
 136   let value = parseBasicBlock off insns
 137   modify (M.insert off value)
 138
 139 parseBasicBlock :: Int -> [OffIns] -> BasicBlock
 140 parseBasicBlock i insns = emptyBasicBlock { code = insonly, successor = endblock }
 141   where
 142     (lastblock, is) = takeWhilePlusOne validins omitins insns
 143     (_, _, insonly) = unzip3 is
 144     (_, Just endblock, _) = fromJust lastblock
 145
 146     -- also take last (non-matched) element and return it
 147     takeWhilePlusOne :: (a -> Bool) -> (a -> Bool) -> [a] -> (Maybe a, [a])
 148     takeWhilePlusOne _ _ [] = (Nothing, [])
 149     takeWhilePlusOne p omit (x:xs)
 150       | omit x    = next
 151       | p x       = second (x:) next
 152       | otherwise = (Just x, [x])
 153       where
 154         next = takeWhilePlusOne p omit xs
 155
 156     validins :: OffIns -> Bool
 157     validins (_, x, _) = isNothing x
 158
 159     omitins :: OffIns -> Bool
 160     omitins (off, _, _) = off < i
 161
 162
 163 calculateInstructionOffset :: [Instruction] -> AnalyseState
 164 calculateInstructionOffset = cio' (0, Nothing, NOP)
 165   where
 166     addW16Signed :: Int -> Word16 -> Int
 167     addW16Signed i w16 = i + fromIntegral s16
 168       where s16 = fromIntegral w16 :: Int16
 169
 170     cio' :: OffIns -> [Instruction] -> AnalyseState
 171     cio' _ [] = return $ []
 172     cio' (off,_,_) (x:xs) = case x of
 173         IF _ w16 -> twotargets w16
 174         IF_ICMP _ w16 -> twotargets w16
 175         IF_ACMP _ w16 -> twotargets w16
 176         IFNONNULL w16 -> twotargets w16
 177         IFNULL w16 -> twotargets w16
 178         GOTO w16 -> onetarget w16
 179         IRETURN -> notarget
 180         ARETURN -> notarget
 181         RETURN -> notarget
 182         _ -> normalins
 183       where
 184         normalins = do
 185           tailinsns <- next -- eval remaining instructions
 186           isNextInsATarget <- (S.member newoffset) <$> get
 187           let bbtyp = if isNextInsATarget
 188                 then Just $ FallThrough newoffset
 189                 else Nothing
 190           return $ (off, bbtyp, x):tailinsns
 191         notarget = ((off, Just Return, x):) <$> next
 192         onetarget w16 = do
 193           let jump = off `addW16Signed` w16
 194           modify (S.insert jump)
 195           ((off, Just $ OneTarget jump, x):) <$> next
 196         twotargets w16 = do
 197           let nojump = off + 3
 198           modify (S.insert nojump)
 199           let jump = off `addW16Signed` w16
 200           modify (S.insert jump)
 201           ((off, Just $ TwoTarget nojump jump, x):) <$> next
 202         next = cio' nextins xs
 203         nextins = (newoffset, Nothing, NOP)
 204         newoffset = off + insnLength x
 205
 206 -- TODO(bernhard): does GHC memomize results? i.e. does it calculate the size
 207 --                 of `NOP' only once?
 208 insnLength :: Num a => Instruction -> a
 209 insnLength = fromIntegral . B.length . encodeInstructions . (:[])