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
  14 import Data.Int
  15 import Data.List
  16 import qualified Data.Map as M
  17 import qualified Data.ByteString.Lazy as B
  18 import Data.Maybe
  19 import Control.Monad.State
  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' = markBackwardTargets $ calculateInstructionOffset xs
 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] -> [OffIns]
 127 markBackwardTargets [] = []
 128 markBackwardTargets (x:[]) = [x]
 129 markBackwardTargets insns@(x@(x_off,x_bbend,x_ins):y@(y_off,_,_):xs) =
 130   x_new:markBackwardTargets (y:xs)
 131     where
 132       x_new = case x_bbend of
 133         Just _ -> x -- already marked, don't change
 134         Nothing -> if isTarget then checkX y_off else x
 135       checkX w16 = case x_bbend of
 136         Nothing -> (x_off, Just $ FallThrough w16, x_ins) -- mark previous insn
 137         _ -> error "basicblock: something is wrong"
 138
 139       -- look through all remaining insns in the stream if there is a jmp to `y'
 140       isTarget = case find cmpOffset insns of Just _ -> True; Nothing -> False
 141       cmpOffset (_,Just (OneTarget w16),_) = w16 == y_off
 142       cmpOffset (_,Just (TwoTarget _ w16),_) = w16 == y_off
 143       cmpOffset _ = False
 144
 145
 146 buildCFG' :: MapBB -> [OffIns] -> [OffIns] -> MapBB
 147 buildCFG' hmap [] _ = hmap
 148 buildCFG' hmap ((off, entry, _):xs) insns = buildCFG' (insertlist entryi hmap) xs insns
 149   where
 150     insertlist :: [BlockID] -> MapBB -> MapBB
 151     insertlist [] hmap' = hmap'
 152     insertlist (y:ys) hmap' = insertlist ys newhmap
 153       where
 154         newhmap = if M.member y hmap' then hmap' else M.insert y value hmap'
 155         value = parseBasicBlock y insns
 156     entryi :: [BlockID]
 157     entryi = if off == 0 then 0:ys else ys -- also consider the entrypoint
 158       where
 159         ys = case entry of
 160           Just (TwoTarget t1 t2) -> [t1, t2]
 161           Just (OneTarget t) -> [t]
 162           Just (FallThrough t) -> [t]
 163           Just Return -> []
 164           Nothing -> []
 165
 166
 167 parseBasicBlock :: Int -> [OffIns] -> BasicBlock
 168 parseBasicBlock i insns = BasicBlock insonly endblock
 169   where
 170     startlist = dropWhile (\(x,_,_) -> x < i) insns
 171     (Just (_, Just endblock, _), is) = takeWhilePlusOne validins startlist
 172     (_, _, insonly) = unzip3 is
 173
 174     -- also take last (non-matched) element and return it
 175     takeWhilePlusOne :: (a -> Bool) -> [a] -> (Maybe a,[a])
 176     takeWhilePlusOne _ [] = (Nothing,[])
 177     takeWhilePlusOne p (x:xs)
 178       | p x       =  let (lastins, list) = takeWhilePlusOne p xs in (lastins, x:list)
 179       | otherwise =  (Just x,[x])
 180
 181     validins :: (Int, Maybe BBEnd, Instruction) -> Bool
 182     validins (_,x,_) = case x of Just _ -> False; Nothing -> True
 183
 184
 185 calculateInstructionOffset :: [Instruction] -> [OffIns]
 186 calculateInstructionOffset = cio' (0, Nothing, NOP)
 187   where
 188     newoffset :: Instruction -> Int -> OffIns
 189     newoffset x off = (off + fromIntegral (B.length $ encodeInstructions [x]), Nothing, NOP)
 190
 191     addW16Signed :: Int -> Word16 -> Int
 192     addW16Signed i w16 = i + fromIntegral s16
 193       where s16 = fromIntegral w16 :: Int16
 194
 195     cio' :: OffIns -> [Instruction] -> [OffIns]
 196     cio' _ [] = []
 197     -- TODO(bernhard): add more instruction with offset (IF_ACMP, JSR, ...)
 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 = (off, Just $ OneTarget (off `addW16Signed` w16), x):next
 212         twotargets w16 = (off, Just $ TwoTarget (off + 3) (off `addW16Signed` w16), x):next
 213         next = cio' (newoffset x off) xs