Mate/BasicBlocks.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Mate.BasicBlocks(
   3   BlockID,
   4   BasicBlock (..),
   5   BBEnd (..),
   6   MapBB,
   7   printMapBB,
   8   parseMethod,
   9   test_main,
  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
  19 import JVM.ClassFile
  20 import JVM.Converter
  21 import JVM.Assembler
  22
  23 import Mate.Utilities
  24 import Mate.Types
  25
  26
  27 -- for immediate representation to determine BBs
  28 type Offset = (Int, Maybe BBEnd) -- (offset in bytecode, offset to jump target)
  29 type OffIns = (Offset, Instruction)
  30
  31
  32 printMapBB :: Maybe MapBB -> IO ()
  33 printMapBB Nothing = putStrLn "No BasicBlock"
  34 printMapBB (Just hmap) = do
  35                      putStr "BlockIDs: "
  36                      let keys = fst $ unzip $ M.toList hmap
  37                      mapM_ (putStr . (flip (++)) ", " . show) keys
  38                      putStrLn "\n\nBasicBlocks:"
  39                      printMapBB' keys hmap
  40   where
  41   printMapBB' :: [BlockID] -> MapBB -> IO ()
  42   printMapBB' [] _ = return ()
  43   printMapBB' (i:is) hmap' = case M.lookup i hmap' of
  44                   Just bb -> do
  45                              putStrLn $ "Block " ++ (show i)
  46                              mapM_ putStrLn (map ((++) "\t" . show) $ code bb)
  47                              case successor bb of
  48                                Return -> putStrLn ""
  49                                FallThrough t1 -> putStrLn $ "Sucessor: " ++ (show t1) ++ "\n"
  50                                OneTarget t1 -> putStrLn $ "Sucessor: " ++ (show t1) ++ "\n"
  51                                TwoTarget t1 t2 -> putStrLn $ "Sucessor: " ++ (show t1) ++ ", " ++ (show t2) ++ "\n"
  52                              printMapBB' is hmap
  53                   Nothing -> error $ "BlockID " ++ show i ++ " not found."
  54
  55 testInstance :: String -> B.ByteString -> IO ()
  56 testInstance cf method = do
  57                       cls <- parseClassFile cf
  58                       hmap <- parseMethod cls method
  59                       printMapBB hmap
  60
  61 test_main :: IO ()
  62 test_main = do
  63   test_01
  64   test_02
  65   test_03
  66   test_04
  67
  68 test_01, test_02, test_03, test_04 :: IO ()
  69 test_01 = testInstance "./tests/Fib.class" "fib"
  70 test_02 = testInstance "./tests/While.class" "f"
  71 test_03 = testInstance "./tests/While.class" "g"
  72 test_04 = testInstance "./tests/Fac.class" "fac"
  73
  74
  75 parseMethod :: Class Resolved -> B.ByteString -> IO (Maybe MapBB)
  76 parseMethod cls method = do
  77                      putStr "BB: analysing: "
  78                      let msig = methodSignature $ (classMethods cls) !! 1
  79                      putStrLn $ toString (method `B.append` ": " `B.append` (encode msig))
  80                      return $ testCFG $ lookupMethod method cls
  81
  82
  83 testCFG :: Maybe (Method Resolved) -> Maybe MapBB
  84 testCFG (Just m) = case attrByName m "Code" of
  85        Nothing -> Nothing
  86        Just bytecode -> Just $ buildCFG $ codeInstructions $ decodeMethod bytecode
  87 testCFG _ = Nothing
  88
  89
  90 buildCFG :: [Instruction] -> MapBB
  91 buildCFG xs = buildCFG' M.empty xs' xs'
  92   where
  93   xs' :: [OffIns]
  94   xs' = markBackwardTargets $ calculateInstructionOffset xs
  95
  96 -- get already calculated jmp-targets and mark the predecessor of the
  97 -- target-instruction as "FallThrough". we just care about backwards
  98 -- jumps here (forward jumps are handled in buildCFG')
  99 markBackwardTargets :: [OffIns] -> [OffIns]
 100 markBackwardTargets [] = []
 101 markBackwardTargets (x:[]) = [x]
 102 markBackwardTargets insns@(x@((x_off,x_bbend),x_ins):y@((y_off,_),_):xs) =
 103   (x_new):(markBackwardTargets (y:xs))
 104   where
 105   x_new = if isTarget then checkX y_off else x
 106   checkX w16 = case x_bbend of
 107     Just _ -> x -- already marked, don't change
 108     Nothing -> ((x_off, Just $ FallThrough w16), x_ins) -- mark previous insn
 109
 110   -- look through all remaining insns in the stream if there is a jmp to `y'
 111   isTarget = case find cmpOffset insns of Just _ -> True; Nothing -> False
 112   cmpOffset ((_,(Just (OneTarget w16))),_) = w16 == y_off
 113   cmpOffset ((_,(Just (TwoTarget _ w16))),_) = w16 == y_off
 114   cmpOffset _ = False
 115
 116
 117 buildCFG' :: MapBB -> [OffIns] -> [OffIns] -> MapBB
 118 buildCFG' hmap [] _ = hmap
 119 buildCFG' hmap (((off, entry), _):xs) insns = buildCFG' (insertlist entryi hmap) xs insns
 120   where
 121   insertlist :: [BlockID] -> MapBB -> MapBB
 122   insertlist [] hmap' = hmap'
 123   insertlist (y:ys) hmap' = insertlist ys newhmap
 124     where
 125     newhmap = if M.member y hmap' then hmap' else M.insert y value hmap'
 126     value = parseBasicBlock y insns
 127
 128   entryi :: [BlockID]
 129   entryi = (if off == 0 then [0] else []) ++ -- also consider the entrypoint
 130         case entry of
 131         Just (TwoTarget t1 t2) -> [t1, t2]
 132         Just (OneTarget t) -> [t]
 133         Just (FallThrough t) -> [t]
 134         Just (Return) -> []
 135         Nothing -> []
 136
 137
 138 parseBasicBlock :: Int -> [OffIns] -> BasicBlock
 139 parseBasicBlock i insns = BasicBlock insonly endblock
 140   where
 141   startlist = dropWhile (\((x,_),_) -> x < i) insns
 142   (Just ((_,(Just endblock)),_), is) = takeWhilePlusOne validins startlist
 143   insonly = snd $ unzip is
 144
 145   -- also take last (non-matched) element and return it
 146   takeWhilePlusOne :: (a -> Bool) -> [a] -> (Maybe a,[a])
 147   takeWhilePlusOne _ [] = (Nothing,[])
 148   takeWhilePlusOne p (x:xs)
 149     | p x       =  let (lastins, list) = takeWhilePlusOne p xs in (lastins, (x:list))
 150     | otherwise =  (Just x,[x])
 151
 152   validins :: ((Int, Maybe BBEnd), Instruction) -> Bool
 153   validins ((_,x),_) = case x of Just _ -> False; Nothing -> True
 154
 155
 156 calculateInstructionOffset :: [Instruction] -> [OffIns]
 157 calculateInstructionOffset = cio' (0, Nothing)
 158   where
 159   newoffset :: Instruction -> Int -> Offset
 160   newoffset x off = (off + (fromIntegral $ B.length $ encodeInstructions [x]), Nothing)
 161
 162   addW16Signed :: Int -> Word16 -> Int
 163   addW16Signed i w16 = i + (fromIntegral s16)
 164     where s16 = (fromIntegral w16) :: Int16
 165
 166   cio' :: Offset -> [Instruction] -> [OffIns]
 167   cio' _ [] = []
 168   -- TODO(bernhard): add more instruction with offset (IF_ACMP, JSR, ...)
 169   cio' (off,_) (x:xs) = case x of
 170       IF _ w16 -> twotargets w16
 171       IF_ICMP _ w16 -> twotargets w16
 172       IF_ACMP _ w16 -> twotargets w16
 173       GOTO w16 -> onetarget w16
 174       IRETURN -> notarget
 175       ARETURN -> notarget
 176       RETURN -> notarget
 177       _ -> ((off, Nothing), x):next
 178     where
 179     notarget = ((off, Just Return), x):next
 180     onetarget w16 = ((off, Just $ OneTarget $ (off `addW16Signed` w16)), x):next
 181     twotargets w16 = ((off, Just $ TwoTarget (off + 3) (off `addW16Signed` w16)), x):next
 182     next = cio' (newoffset x off) xs