exception: small example of how interfacing hs-java
[mate.git] / Mate / BasicBlocks.hs
index de1d11b6da4b6658d396987230c3b00188608de5..1b03622c2369ebef3530529a9ea8c7d82a042613 100644 (file)
@@ -1,16 +1,21 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
 module Mate.BasicBlocks(
   BlockID,
   BasicBlock (..),
   BBEnd (..),
   MapBB,
+#ifdef DEBUG
   printMapBB,
+  test_main,
+#endif
   parseMethod,
-  test_main
+  testCFG -- added by hs to perform benches from outside
   )where
 
 import Data.Binary
 import Data.Int
+import Data.List
 import qualified Data.Map as M
 import qualified Data.ByteString.Lazy as B
 
@@ -19,26 +24,18 @@ import JVM.Converter
 import JVM.Assembler
 
 import Mate.Utilities
+import Mate.Types
 
+#ifdef DEBUG
+import Text.Printf
+#endif
 
-type BlockID = Int
--- Represents a CFG node
-data BasicBlock = BasicBlock {
-                     -- inputs  :: [Variable],
-                     -- outputs :: [Variable],
-                     code    :: [Instruction],
-                     successor :: BBEnd }
-
--- describes (leaving) edges of a CFG node
-data BBEnd = Return | OneTarget BlockID | TwoTarget BlockID BlockID deriving Show
-
-type MapBB = M.Map BlockID BasicBlock
-
--- for immediate representation for determine BBs
+-- for immediate representation to determine BBs
 type Offset = (Int, Maybe BBEnd) -- (offset in bytecode, offset to jump target)
 type OffIns = (Offset, Instruction)
 
 
+#ifdef DEBUG
 printMapBB :: Maybe MapBB -> IO ()
 printMapBB Nothing = putStrLn "No BasicBlock"
 printMapBB (Just hmap) = do
@@ -56,35 +53,56 @@ printMapBB (Just hmap) = do
                              mapM_ putStrLn (map ((++) "\t" . show) $ code bb)
                              case successor bb of
                                Return -> putStrLn ""
+                               FallThrough t1 -> putStrLn $ "Sucessor: " ++ (show t1) ++ "\n"
                                OneTarget t1 -> putStrLn $ "Sucessor: " ++ (show t1) ++ "\n"
                                TwoTarget t1 t2 -> putStrLn $ "Sucessor: " ++ (show t1) ++ ", " ++ (show t2) ++ "\n"
                              printMapBB' is hmap
                   Nothing -> error $ "BlockID " ++ show i ++ " not found."
+#endif
 
+#ifdef DEBUG
 testInstance :: String -> B.ByteString -> IO ()
 testInstance cf method = do
                       cls <- parseClassFile cf
                       hmap <- parseMethod cls method
                       printMapBB hmap
+#endif
 
+#ifdef DEBUG
 test_main :: IO ()
 test_main = do
   test_01
   test_02
   test_03
+  test_04
 
-test_01, test_02, test_03 :: IO ()
+test_01, test_02, test_03, test_04 :: IO ()
 test_01 = testInstance "./tests/Fib.class" "fib"
 test_02 = testInstance "./tests/While.class" "f"
 test_03 = testInstance "./tests/While.class" "g"
+test_04 = testInstance "./tests/Fac.class" "fac"
+#endif
 
 
 parseMethod :: Class Resolved -> B.ByteString -> IO (Maybe MapBB)
 parseMethod cls method = do
+                     let maybe_bb = testCFG $ lookupMethod method cls
+#ifdef DEBUG
                      putStr "BB: analysing: "
                      let msig = methodSignature $ (classMethods cls) !! 1
-                     B.putStrLn (method `B.append` ": " `B.append` (encode msig))
-                     return $ testCFG $ lookupMethod method cls
+                     putStrLn $ toString (method `B.append` ": " `B.append` (encode msig))
+                     printMapBB maybe_bb
+#endif
+#ifdef DEBUG
+                     -- small example how to get information about
+                     -- exceptions of a method
+                     -- TODO: remove ;-)
+                     let (Just m) = lookupMethod method cls
+                     case attrByName m "Code" of
+                      Nothing -> printf "exception: no handler for this method\n"
+                      Just exceptionstream -> printf "exception: \"%s\"\n" (show $ codeExceptions $ decodeMethod exceptionstream)
+#endif
+                     return maybe_bb
 
 
 testCFG :: Maybe (Method Resolved) -> Maybe MapBB
@@ -98,7 +116,28 @@ buildCFG :: [Instruction] -> MapBB
 buildCFG xs = buildCFG' M.empty xs' xs'
   where
   xs' :: [OffIns]
-  xs' = calculateInstructionOffset xs
+  xs' = markBackwardTargets $ calculateInstructionOffset xs
+
+-- get already calculated jmp-targets and mark the predecessor of the
+-- target-instruction as "FallThrough". we just care about backwards
+-- jumps here (forward jumps are handled in buildCFG')
+markBackwardTargets :: [OffIns] -> [OffIns]
+markBackwardTargets [] = []
+markBackwardTargets (x:[]) = [x]
+markBackwardTargets insns@(x@((x_off,x_bbend),x_ins):y@((y_off,_),_):xs) =
+  (x_new):(markBackwardTargets (y:xs))
+  where
+  x_new = if isTarget then checkX y_off else x
+  checkX w16 = case x_bbend of
+    Just _ -> x -- already marked, don't change
+    Nothing -> ((x_off, Just $ FallThrough w16), x_ins) -- mark previous insn
+
+  -- look through all remaining insns in the stream if there is a jmp to `y'
+  isTarget = case find cmpOffset insns of Just _ -> True; Nothing -> False
+  cmpOffset ((_,(Just (OneTarget w16))),_) = w16 == y_off
+  cmpOffset ((_,(Just (TwoTarget _ w16))),_) = w16 == y_off
+  cmpOffset _ = False
+
 
 buildCFG' :: MapBB -> [OffIns] -> [OffIns] -> MapBB
 buildCFG' hmap [] _ = hmap
@@ -116,6 +155,7 @@ buildCFG' hmap (((off, entry), _):xs) insns = buildCFG' (insertlist entryi hmap)
         case entry of
         Just (TwoTarget t1 t2) -> [t1, t2]
         Just (OneTarget t) -> [t]
+        Just (FallThrough t) -> [t]
         Just (Return) -> []
         Nothing -> []
 
@@ -154,8 +194,10 @@ calculateInstructionOffset = cio' (0, Nothing)
   cio' (off,_) (x:xs) = case x of
       IF _ w16 -> twotargets w16
       IF_ICMP _ w16 -> twotargets w16
+      IF_ACMP _ w16 -> twotargets w16
       GOTO w16 -> onetarget w16
       IRETURN -> notarget
+      ARETURN -> notarget
       RETURN -> notarget
       _ -> ((off, Nothing), x):next
     where