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