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   )where
  11
  12 import Data.Binary
  13 import Data.Int
  14 import qualified Data.Map as M
  15 import qualified Data.ByteString.Lazy as B
  16
  17 import JVM.ClassFile
  18 import JVM.Converter
  19 import JVM.Assembler
  20
  21 import Mate.Utilities
  22
  23
  24 type BlockID = Int
  25 -- Represents a CFG node
  26 data BasicBlock = BasicBlock {
  27                      -- inputs  :: [Variable],
  28                      -- outputs :: [Variable],
  29                      code    :: [Instruction],
  30                      successor :: BBEnd }
  31
  32 -- describes (leaving) edges of a CFG node
  33 data BBEnd = Return | OneTarget BlockID | TwoTarget BlockID BlockID deriving Show
  34
  35 type MapBB = M.Map BlockID BasicBlock
  36
  37 -- for immediate representation for determine BBs
  38 type Offset = (Int, Maybe BBEnd) -- (offset in bytecode, offset to jump target)
  39 type OffIns = (Offset, Instruction)
  40
  41
  42 printMapBB :: Maybe MapBB -> IO ()
  43 printMapBB Nothing = putStrLn "No BasicBlock"
  44 printMapBB (Just hmap) = do
  45                      putStr "BlockIDs: "
  46                      let keys = fst $ unzip $ M.toList hmap
  47                      mapM_ (putStr . (flip (++)) ", " . show) keys
  48                      putStrLn "\n\nBasicBlocks:"
  49                      printMapBB' keys hmap
  50   where
  51   printMapBB' :: [BlockID] -> MapBB -> IO ()
  52   printMapBB' [] _ = return ()
  53   printMapBB' (i:is) hmap' = case M.lookup i hmap' of
  54                   Just bb -> do
  55                              putStrLn $ "Block " ++ (show i)
  56                              mapM_ putStrLn (map ((++) "\t" . show) $ code bb)
  57                              case successor bb of
  58                                Return -> putStrLn ""
  59                                OneTarget t1 -> putStrLn $ "Sucessor: " ++ (show t1) ++ "\n"
  60                                TwoTarget t1 t2 -> putStrLn $ "Sucessor: " ++ (show t1) ++ ", " ++ (show t2) ++ "\n"
  61                              printMapBB' is hmap
  62                   Nothing -> error $ "BlockID " ++ show i ++ " not found."
  63
  64 testInstance :: String -> B.ByteString -> IO ()
  65 testInstance cf method = do
  66                       hmap <- parseMethod cf method
  67                       printMapBB hmap
  68
  69 test_main :: IO ()
  70 test_main = do
  71   test_01
  72   test_02
  73   test_03
  74
  75 test_01, test_02, test_03 :: IO ()
  76 test_01 = testInstance "./tests/Fib.class" "fib"
  77 test_02 = testInstance "./tests/While.class" "f"
  78 test_03 = testInstance "./tests/While.class" "g"
  79
  80
  81 parseMethod :: String -> B.ByteString -> IO (Maybe MapBB)
  82 parseMethod clspath method = do
  83                      cls <- parseClassFile clspath
  84                      return $ testCFG $ lookupMethod method cls
  85
  86
  87 testCFG :: Maybe (Method Resolved) -> Maybe MapBB
  88 testCFG (Just m) = case attrByName m "Code" of
  89        Nothing -> Nothing
  90        Just bytecode -> Just $ buildCFG $ codeInstructions $ decodeMethod bytecode
  91 testCFG _ = Nothing
  92
  93
  94 buildCFG :: [Instruction] -> MapBB
  95 buildCFG xs = buildCFG' M.empty xs' xs'
  96   where
  97   xs' :: [OffIns]
  98   xs' = calculateInstructionOffset xs
  99
 100 buildCFG' :: MapBB -> [OffIns] -> [OffIns] -> MapBB
 101 buildCFG' hmap [] _ = hmap
 102 buildCFG' hmap (((off, entry), _):xs) insns = buildCFG' (insertlist entryi hmap) xs insns
 103   where
 104   insertlist :: [BlockID] -> MapBB -> MapBB
 105   insertlist [] hmap' = hmap'
 106   insertlist (y:ys) hmap' = insertlist ys newhmap
 107     where
 108     newhmap = if M.member y hmap' then hmap' else M.insert y value hmap'
 109     value = parseBasicBlock y insns
 110
 111   entryi :: [BlockID]
 112   entryi = (if off == 0 then [0] else []) ++ -- also consider the entrypoint
 113         case entry of
 114         Just (TwoTarget t1 t2) -> [t1, t2]
 115         Just (OneTarget t) -> [t]
 116         Just (Return) -> []
 117         Nothing -> []
 118
 119
 120 parseBasicBlock :: Int -> [OffIns] -> BasicBlock
 121 parseBasicBlock i insns = BasicBlock insonly endblock
 122   where
 123   startlist = dropWhile (\((x,_),_) -> x < i) insns
 124   (Just ((_,(Just endblock)),_), is) = takeWhilePlusOne validins startlist
 125   insonly = snd $ unzip is
 126
 127   -- also take last (non-matched) element and return it
 128   takeWhilePlusOne :: (a -> Bool) -> [a] -> (Maybe a,[a])
 129   takeWhilePlusOne _ [] = (Nothing,[])
 130   takeWhilePlusOne p (x:xs)
 131     | p x       =  let (lastins, list) = takeWhilePlusOne p xs in (lastins, (x:list))
 132     | otherwise =  (Just x,[x])
 133
 134   validins :: ((Int, Maybe BBEnd), Instruction) -> Bool
 135   validins ((_,x),_) = case x of Just _ -> False; Nothing -> True
 136
 137
 138 calculateInstructionOffset :: [Instruction] -> [OffIns]
 139 calculateInstructionOffset = cio' (0, Nothing)
 140   where
 141   newoffset :: Instruction -> Int -> Offset
 142   newoffset x off = (off + (fromIntegral $ B.length $ encodeInstructions [x]), Nothing)
 143
 144   addW16Signed :: Int -> Word16 -> Int
 145   addW16Signed i w16 = i + (fromIntegral s16)
 146     where s16 = (fromIntegral w16) :: Int16
 147
 148   cio' :: Offset -> [Instruction] -> [OffIns]
 149   cio' _ [] = []
 150   -- TODO(bernhard): add more instruction with offset (IF_ACMP, JSR, ...)
 151   cio' (off,_) (x:xs) = case x of
 152       IF _ w16 -> twotargets w16
 153       IF_ICMP _ w16 -> twotargets w16
 154       GOTO w16 -> onetarget w16
 155       IRETURN -> notarget
 156       _ -> ((off, Nothing), x):next
 157     where
 158     notarget = ((off, Just Return), x):next
 159     onetarget w16 = ((off, Just $ OneTarget $ (off `addW16Signed` w16)), x):next
 160     twotargets w16 = ((off, Just $ TwoTarget (off + 3) (off `addW16Signed` w16)), x):next
 161     next = cio' (newoffset x off) xs