From fdc2d9026667ed62abc086eac2049b79e19c9967 Mon Sep 17 00:00:00 2001
From: Bernhard Urban <lewurm@gmail.com>
Date: Tue, 17 Apr 2012 23:57:31 +0200
Subject: [PATCH] basicblocks: also consider back references

as we just iterate the instruction stream when generating basicblocks, we need
extra handling for back references.
the solution adds a further pass, which marks targets of jumps (actually it
marks the instruction right *before* the target)

kudos @ tests/Fac.java for being a useful testcase :-)
---
 Mate/BasicBlocks.hs | 32 +++++++++++++++++++++++++++++---
 Mate/MethodPool.hs  |  3 ++-
 Mate/X86CodeGen.hs  |  2 ++
 3 files changed, 33 insertions(+), 4 deletions(-)

diff --git a/Mate/BasicBlocks.hs b/Mate/BasicBlocks.hs
index de1d11b..14f8999 100644
--- a/Mate/BasicBlocks.hs
+++ b/Mate/BasicBlocks.hs
@@ -11,6 +11,7 @@ module Mate.BasicBlocks(
 
 import Data.Binary
 import Data.Int
+import Data.List
 import qualified Data.Map as M
 import qualified Data.ByteString.Lazy as B
 
@@ -30,7 +31,7 @@ data BasicBlock = BasicBlock {
                      successor :: BBEnd }
 
 -- describes (leaving) edges of a CFG node
-data BBEnd = Return | OneTarget BlockID | TwoTarget BlockID BlockID deriving Show
+data BBEnd = Return | FallThrough BlockID | OneTarget BlockID | TwoTarget BlockID BlockID deriving Show
 
 type MapBB = M.Map BlockID BasicBlock
 
@@ -56,6 +57,7 @@ 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
@@ -72,11 +74,13 @@ 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"
 
 
 parseMethod :: Class Resolved -> B.ByteString -> IO (Maybe MapBB)
@@ -98,7 +102,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 +141,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 -> []
 
diff --git a/Mate/MethodPool.hs b/Mate/MethodPool.hs
index d7faa88..e7a1aeb 100644
--- a/Mate/MethodPool.hs
+++ b/Mate/MethodPool.hs
@@ -42,11 +42,12 @@ getMethodEntry signal_from ptr_mmap ptr_cmap = do
   let (method, cls, cpidx) = cmap M.! w32_from
   case M.lookup method mmap of
     Nothing -> do
-      printf "getMethodEntry(from 0x%08x): no method found. compile it\n" w32_from
+      printf "getMethodEntry(from 0x%08x): no method \"%s\" found. compile it\n" w32_from (show method)
       -- TODO(bernhard): maybe we have to load the class first?
       --                 (Or better in X86CodeGen?)
       let (CMethod _ nt) = (constsPool cls) M.! cpidx
       hmap <- parseMethod cls (ntName nt)
+      printMapBB hmap
       case hmap of
         Just hmap' -> do
           entry <- compileBB hmap' cls method
diff --git a/Mate/X86CodeGen.hs b/Mate/X86CodeGen.hs
index 23165dd..270368f 100644
--- a/Mate/X86CodeGen.hs
+++ b/Mate/X86CodeGen.hs
@@ -157,6 +157,8 @@ emitFromBB cls hmap =  do
           let calls' = calls `M.union` (M.fromList $ catMaybes cs)
           case successor bb of
             Return -> return (calls', bbstarts')
+            FallThrough t -> do
+              efBB (t, hmap M.! t) calls' bbstarts' lmap
             OneTarget t -> do
               efBB (t, hmap M.! t) calls' bbstarts' lmap
             TwoTarget t1 t2 -> do
-- 
2.25.1