GC: TwoSpace copy evacuation basically works

[mate.git] / Mate / BasicBlocks.hs

diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs
index d863f55d36e6833d7a42a80ef7caa623acc08e35..c94e6d1dc8229e93f40caa680086d531ebc838e9 100644 (file)
--- a/Mate/BasicBlocks.hs
+++ b/Mate/BasicBlocks.hs
@@ -1,15 +1,11 @@
-{-# LANGUAGE CPP #-}
 {-# LANGUAGE OverloadedStrings #-}
-#include "debug.h"
 module Mate.BasicBlocks(
   BlockID,
   BasicBlock,
   BBEnd,
   MapBB,
   Method,
-#ifdef DBG_BB
   printMapBB,
-#endif
   parseMethod,
   testCFG -- added by hs to perform benches from outside
   )where
@@ -19,6 +15,7 @@ import Data.Int
 import Data.List
 import qualified Data.Map as M
 import qualified Data.ByteString.Lazy as B
+import Data.Maybe
 
 import JVM.ClassFile
 import JVM.Converter
@@ -28,49 +25,40 @@ import Mate.Types
 import Mate.Debug
 import Mate.Utilities
 
-#ifdef DEBUG
-import Text.Printf
-#endif
-
 -- for immediate representation to determine BBs
 type Offset = (Int, Maybe BBEnd) -- (offset in bytecode, offset to jump target)
 type OffIns = (Offset, Instruction)
 
 
-#ifdef DBG_BB
 printMapBB :: MapBB -> IO ()
 printMapBB hmap = do
-  putStr "BlockIDs: "
+  printfBb "BlockIDs: "
   let keys = M.keys hmap
-  mapM_ (putStr . (flip (++)) ", " . show) keys
-  putStrLn "\n\nBasicBlocks:"
+  mapM_ (printfBb . flip (++) ", " . show) keys
+  printfBb "\n\nBasicBlocks:\n"
   printMapBB' keys hmap
     where
       printMapBB' :: [BlockID] -> MapBB -> IO ()
       printMapBB' [] _ = return ()
       printMapBB' (i:is) hmap' = case M.lookup i hmap' of
         Just bb -> do
-          putStrLn $ "Block " ++ (show i)
-          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"
+          printfBb $ "Block " ++ show i ++ "\n"
+          mapM_ (printfBb . flip (++) "\n" . (++) "\t" . show) $ code bb
+          printfBb $ case successor bb of
+            Return -> ""
+            FallThrough t1 -> "Sucessor: " ++ show t1 ++ "\n"
+            OneTarget t1 -> "Sucessor: " ++ show t1 ++ "\n"
+            TwoTarget t1 t2 -> "Sucessor: " ++ show t1 ++ ", " ++ show t2 ++ "\n"
           printMapBB' is hmap
         Nothing -> error $ "BlockID " ++ show i ++ " not found."
-#endif
 
-#if 0
-#ifdef DBG_BB
+{-
 testInstance :: String -> B.ByteString -> MethodSignature -> IO ()
 testInstance cf method sig = do
   cls <- parseClassFile cf
   hmap <- parseMethod cls method sig
   printMapBB hmap
-#endif
 
-#ifdef DBG_BB
 test_main :: IO ()
 test_main = do
   test_01
@@ -83,44 +71,40 @@ 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
-#endif
+-}
 
 
 parseMethod :: Class Direct -> B.ByteString -> MethodSignature -> IO RawMethod
 parseMethod cls methodname sig = do
-  let method = case lookupMethodSig methodname sig cls of
-        Just m -> m
-        Nothing -> error $ "method " ++ (show . toString) methodname ++ " not found"
-  let codeseg = case attrByName method "Code" of
-        Just m -> m
-        Nothing -> error $ "codeseg " ++ (show . toString) methodname ++ " not found"
+  let method = fromMaybe
+               (error $ "method " ++ (show . toString) methodname ++ " not found")
+               (lookupMethodSig methodname sig cls)
+  let codeseg = fromMaybe
+                (error $ "codeseg " ++ (show . toString) methodname ++ " not found")
+                (attrByName method "Code")
   let decoded = decodeMethod codeseg
   let mapbb = testCFG decoded
   let locals = fromIntegral (codeMaxLocals decoded)
   let stacks = fromIntegral (codeStackSize decoded)
+  let codelen = fromIntegral (codeLength decoded)
   let methoddirect = methodInfoToMethod (MethodInfo methodname "" sig) cls
   let isStatic = methodIsStatic methoddirect
   let nametype = methodNameType methoddirect
   let argscount = methodGetArgsCount nametype + (if isStatic then 0 else 1)
 
-  let msig = methodSignature $ classMethods cls !! 1
-  printfBb "BB: analysing \"%s\"\n" $ toString (methodname `B.append` ": " `B.append` encode msig)
-#ifdef DBG_BB
-  case maybe_bb of
-    Just m -> printMapBB $ rawMapBB m
-    Nothing -> return ()
-#endif
+  let msig = methodSignature method
+  printfBb $ printf "BB: analysing \"%s\"\n" $ toString (methodname `B.append` ": " `B.append` encode msig)
+  printMapBB mapbb
   -- small example how to get information about
   -- exceptions of a method
   -- TODO: remove ;-)
   let (Just m) = lookupMethodSig methodname sig cls
   case attrByName m "Code" of
     Nothing ->
-      printfBb "exception: no handler for this method\n"
+      printfBb $ printf "exception: no handler for this method\n"
     Just exceptionstream ->
-      printfBb "exception: \"%s\"\n" (show $ codeExceptions $ decodeMethod exceptionstream)
-  return $ RawMethod mapbb locals stacks argscount
+      printfBb $ printf "exception: \"%s\"\n" (show $ codeExceptions $ decodeMethod exceptionstream)
+  return $ RawMethod mapbb locals stacks argscount codelen
 
 
 testCFG :: Code -> MapBB