From: Bernhard Urban <lewurm@gmail.com>
Date: Tue, 3 Apr 2012 22:49:00 +0000 (+0200)
Subject: basicblock: refactor function interface
X-Git-Url: http://wien.tomnetworks.com/gitweb/?p=mate.git;a=commitdiff_plain;h=679c78bcb0cf09332ec84859c0c6373273cdc604

basicblock: refactor function interface
---

diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs
index f92059f..45ec857 100644
--- 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