basicblock: change order of `TwoTarget'

[mate.git] / Mate / BasicBlocks.hs

diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs
index f92059f8a90d787f298fc6f3ce09a963910152a4..25a418e4b64077fb55e19ec03d9ea043c1e7ce21 100644 (file)
--- a/Mate/BasicBlocks.hs
+++ b/Mate/BasicBlocks.hs
@@ -1,5 +1,12 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Mate.BasicBlocks where
+module Mate.BasicBlocks(
+  BlockID,
+  BasicBlock (..),
+  BBEnd (..),
+  MapBB,
+  printMapBB,
+  parseMethod
+  )where
 
 import Data.Binary
 import Data.Int
@@ -40,52 +47,51 @@ type Offset = (Int, Maybe BBEnd) -- (offset in bytecode, offset to jump target)
 type OffIns = (Offset, Instruction)
 
 
-main = do
-  args <- getArgs
-  case args of
-    [clspath] -> parseFile clspath "fib" -- TODO
-    _ -> error "Synopsis: dump-class File.class"
-
-
-parseFile :: String -> B.ByteString -> IO ()
-parseFile clspath method = do
-                     --clsFile <- decodeFile clspath
-                     --putStrLn $ showListIx $ M.assocs $ constsPool (clsFile :: Class Pointers)
-                     cls <- parseClassFile clspath
-                     --dumpClass cls    
-                     let mainmethod = lookupMethod method cls -- "main|([Ljava/lang/String;)V" cf
-                     let hmap = testCFG mainmethod
+printMapBB :: Maybe MapBB -> IO ()
+printMapBB Nothing = putStrLn "No BasicBlock"
+printMapBB (Just hmap) = do
                      putStr "BlockIDs: "
                      let keys = fst $ unzip $ H.toList hmap
                      mapM_ (putStr . (flip (++)) ", " . show) keys
                      putStrLn "\n\nBasicBlocks:"
-                     printMapBB keys hmap
-
-printMapBB :: [BlockID] -> MapBB -> IO ()
-printMapBB [] _ = return ()
-printMapBB (i:is) hmap = case H.lookup i hmap of
-                Just bb -> do
-                           putStrLn $ "Block " ++ (show i)
-                           mapM_ putStrLn (map ((++) "\t" . show) $ code bb)
-                           case successor bb of
-                             Return -> putStrLn ""
-                             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."
-
-test_01 = parseFile "./tests/Fib.class" "fib"
-test_02 = parseFile "./tests/While.class" "f"
-test_03 = parseFile "./tests/While.class" "g"
-
-
-testCFG :: Maybe (Method Resolved) -> MapBB
+                     printMapBB' keys hmap
+  where
+  printMapBB' :: [BlockID] -> MapBB -> IO ()
+  printMapBB' [] _ = return ()
+  printMapBB' (i:is) hmap = case H.lookup i hmap of
+                  Just bb -> do
+                             putStrLn $ "Block " ++ (show i)
+                             mapM_ putStrLn (map ((++) "\t" . show) $ code bb)
+                             case successor bb of
+                               Return -> putStrLn ""
+                               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."
+
+testInstance :: String -> B.ByteString -> IO ()
+testInstance cf method = do
+                      hmap <- parseMethod cf method
+                      printMapBB hmap
+
+test_01 = testInstance "./tests/Fib.class" "fib"
+test_02 = testInstance "./tests/While.class" "f"
+test_03 = testInstance "./tests/While.class" "g"
+
+
+parseMethod :: String -> B.ByteString -> IO (Maybe MapBB)
+parseMethod clspath method = do
+                     cls <- parseClassFile clspath
+                     return $ testCFG $ lookupMethod method cls
+
+
+testCFG :: Maybe (Method Resolved) -> Maybe MapBB
 testCFG (Just m) = case attrByName m "Code" of
-                     Nothing       -> error "no code"
+                     Nothing       -> Nothing
                      Just bytecode -> let code = decodeMethod bytecode
                                           instructions = codeInstructions code
-                                      in buildCFG instructions
-testCFG _        = error "no method to build cfg"
+                                      in Just $ buildCFG instructions
+testCFG _        = Nothing
 
 
 buildCFG :: [Instruction] -> MapBB
@@ -96,7 +102,7 @@ buildCFG xs = buildCFG' H.empty xs' xs'
 
 buildCFG' :: MapBB -> [OffIns] -> [OffIns] -> MapBB
 buildCFG' hmap [] _ = hmap
-buildCFG' hmap (((off, Just entry), _):xs) insns = buildCFG' (insertlist entryi hmap) xs insns
+buildCFG' hmap (((off, entry), _):xs) insns = buildCFG' (insertlist entryi hmap) xs insns
   where
   insertlist :: [BlockID] -> MapBB -> MapBB
   insertlist [] hmap = hmap
@@ -108,11 +114,10 @@ buildCFG' hmap (((off, Just entry), _):xs) insns = buildCFG' (insertlist entryi
   entryi :: [BlockID]
   entryi = (if off == 0 then [0] else []) ++ -- also consider the entrypoint
         case entry of
-        TwoTarget t1 t2 -> [t1, t2]
-        OneTarget t -> [t]
-        Return -> trace "should not happen" []
-
-buildCFG' hmap (((_, Nothing), _):xs) insns = buildCFG' hmap xs insns
+        Just (TwoTarget t1 t2) -> [t1, t2]
+        Just (OneTarget t) -> [t]
+        Just (Return) -> []
+        Nothing -> []
 
 
 parseBasicBlock :: Int -> [OffIns] -> BasicBlock
@@ -155,5 +160,5 @@ calculateInstructionOffset = cio' (0, Nothing)
     where
     notarget = ((off, Just Return), x):next
     onetarget w16 = ((off, Just $ OneTarget $ (off `addW16Signed` w16)), x):next
-    twotargets w16 = ((off, Just $ TwoTarget (off `addW16Signed` w16) (off + 3)), x):next
+    twotargets w16 = ((off, Just $ TwoTarget (off + 3) (off `addW16Signed` w16)), x):next
     next = cio' (newoffset x off) xs