1 {-# LANGUAGE OverloadedStrings #-}
2 module Mate.BasicBlocks(
10 testCFG -- added by hs to perform benches from outside
13 import Data.Binary hiding (get)
15 import qualified Data.Map as M
16 import qualified Data.Set as S
17 import qualified Data.ByteString.Lazy as B
19 import Control.Monad.State
20 import Control.Applicative
31 -- (offset in bytecode, offset to jump target, ins)
32 type OffIns = (Int, Maybe BBEnd, Instruction)
35 type BBState = S.Set Target
36 type AnalyseState = State BBState [OffIns]
39 emptyBasicBlock :: BasicBlock
40 emptyBasicBlock = BasicBlock
43 , successor = Return }
45 printMapBB :: MapBB -> IO ()
48 let keys = M.keys hmap
49 mapM_ (printfBb . flip (++) ", " . show) keys
50 printfBb "\n\nBasicBlocks:\n"
53 printMapBB' :: [BlockID] -> MapBB -> IO ()
54 printMapBB' [] _ = return ()
55 printMapBB' (i:is) hmap' = case M.lookup i hmap' of
57 printfBb $ "Block " ++ show i ++ ". len: " ++ (show $ bblength bb) ++ "\n"
58 mapM_ (printfBb . flip (++) "\n" . (++) "\t" . show) $ code bb
59 printfBb $ case successor bb of
61 FallThrough t1 -> "Sucessor: " ++ show t1 ++ "\n"
62 OneTarget t1 -> "Sucessor: " ++ show t1 ++ "\n"
63 TwoTarget t1 t2 -> "Sucessor: " ++ show t1 ++ ", " ++ show t2 ++ "\n"
65 Nothing -> error $ "BlockID " ++ show i ++ " not found."
68 testInstance :: String -> B.ByteString -> MethodSignature -> IO ()
69 testInstance cf method sig = do
70 cls <- parseClassFile cf
71 hmap <- parseMethod cls method sig
81 test_01, test_02, test_03, test_04 :: IO ()
82 test_01 = testInstance "./tests/Fib.class" "fib"
83 test_02 = testInstance "./tests/While.class" "f"
84 test_03 = testInstance "./tests/While.class" "g"
85 test_04 = testInstance "./tests/Fac.class" "fac"
89 parseMethod :: Class Direct -> B.ByteString -> MethodSignature -> IO RawMethod
90 parseMethod cls methodname sig = do
91 let method = fromMaybe
92 (error $ "method " ++ (show . toString) methodname ++ " not found")
93 (lookupMethodSig methodname sig cls)
94 let codeseg = fromMaybe
95 (error $ "codeseg " ++ (show . toString) methodname ++ " not found")
96 (attrByName method "Code")
97 let decoded = decodeMethod codeseg
98 let mapbb = testCFG decoded
99 let locals = fromIntegral (codeMaxLocals decoded)
100 let stacks = fromIntegral (codeStackSize decoded)
101 let codelen = fromIntegral (codeLength decoded)
102 let methoddirect = methodInfoToMethod (MethodInfo methodname "" sig) cls
103 let isStatic = methodIsStatic methoddirect
104 let nametype = methodNameType methoddirect
105 let argscount = methodGetArgsCount nametype + (if isStatic then 0 else 1)
107 let exceptionMap :: ExceptionMap
108 exceptionMap = foldl f M.empty $ codeExceptions decoded
112 then M.adjust (value:) key emap
113 else M.insert key [value] emap
115 key = (&&&) eStartPC eEndPC ce
116 value = (&&&) (buildClassID cls . eCatchType) eHandlerPC ce
118 let msig = methodSignature method
119 printfBb $ printf "BB: analysing \"%s\"\n" $ toString (methodname `B.append` ": " `B.append` encode msig)
121 return $ RawMethod mapbb exceptionMap locals stacks argscount codelen
124 testCFG :: Code -> MapBB
125 testCFG c = buildCFG (codeInstructions c) (codeExceptions c)
127 buildCFG :: [Instruction] -> [CodeException] -> MapBB
128 buildCFG xs excps = execState (mapM buildCFG' $ alltargets ++ handlerEntries) M.empty
130 (offins, targets) = runState (calculateInstructionOffset tryBlocks xs) S.empty
131 alltargets = S.toList $ S.insert 0 targets
132 tryBlocks = map (fromIntegral . eStartPC) excps
133 handlerEntries = map (fromIntegral . eHandlerPC) excps
135 buildCFG' :: Int -> State MapBB ()
137 let value = parseBasicBlock off offins
138 modify (M.insert off value)
140 parseBasicBlock :: Int -> [OffIns] -> BasicBlock
141 parseBasicBlock i insns = emptyBasicBlock
143 , bblength = lastoff - i + (insnLength lastins)
144 , successor = endblock }
146 (lastblock, is) = takeWhilePlusOne validins omitins insns
147 (_, _, insonly) = unzip3 is
148 (lastoff, Just endblock, lastins) = fromJust lastblock
150 -- also take last (non-matched) element and return it
151 takeWhilePlusOne :: (a -> Bool) -> (a -> Bool) -> [a] -> (Maybe a, [a])
152 takeWhilePlusOne _ _ [] = (Nothing, [])
153 takeWhilePlusOne p omit (x:xs)
155 | p x = second (x:) next
156 | otherwise = (Just x, [x])
158 next = takeWhilePlusOne p omit xs
160 validins :: OffIns -> Bool
161 validins (_, x, _) = isNothing x
163 omitins :: OffIns -> Bool
164 omitins (off, _, _) = off < i
167 calculateInstructionOffset :: [BlockID] -> [Instruction] -> AnalyseState
168 calculateInstructionOffset exstarts = cio' 0
170 addW16Signed i w16 = i + fromIntegral s16
171 where s16 = fromIntegral w16 :: Int16
173 cio' :: Int -> [Instruction] -> AnalyseState
174 cio' _ [] = return $ []
175 cio' off (x:xs) = case x of
176 IF _ w16 -> twotargets w16
177 IF_ICMP _ w16 -> twotargets w16
178 IF_ACMP _ w16 -> twotargets w16
179 IFNONNULL w16 -> twotargets w16
180 IFNULL w16 -> twotargets w16
181 GOTO w16 -> onetarget w16
186 _ -> if newoffset `elem` exstarts
188 modify (S.insert newoffset)
189 ((off, Just $ OneTarget newoffset, x):) <$> next
193 tailinsns <- next -- eval remaining instructions
194 isNextInsATarget <- (S.member newoffset) <$> get
195 let bbtyp = if isNextInsATarget
196 then Just $ FallThrough newoffset
198 return $ (off, bbtyp, x):tailinsns
199 notarget = ((off, Just Return, x):) <$> next
201 let jump = off `addW16Signed` w16
202 modify (S.insert jump)
203 ((off, Just $ OneTarget jump, x):) <$> next
206 modify (S.insert nojump)
207 let jump = off `addW16Signed` w16
208 modify (S.insert jump)
209 ((off, Just $ TwoTarget nojump jump, x):) <$> next
210 next = cio' newoffset xs
211 newoffset = off + insLen
212 insLen = insnLength x
214 -- TODO(bernhard): does GHC memomize results? i.e. does it calculate the size
215 -- of `NOP' only once?
216 insnLength :: Num a => Instruction -> a
217 insnLength = fromIntegral . B.length . encodeInstructions . (:[])