From e13a12b7b217ecea358f4dd853d27ffa44d161c8 Mon Sep 17 00:00:00 2001
From: "dias@eecs.harvard.edu" <unknown>
Date: Tue, 14 Oct 2008 16:03:54 +0000
Subject: [PATCH] Removed space and time inefficiency in procpoint splitting I
 was adding extra jumps to every procpoint, even when the
 split-off graph referred to only some of the procpoints. No
 effect on correctness, but a big effect on space/time
 efficiency when there are lots of procpoints...

---
 compiler/cmm/CmmCPSZ.hs       |    6 +++---
 compiler/cmm/CmmProcPointZ.hs |   20 ++++++++++++++++++--
 2 files changed, 21 insertions(+), 5 deletions(-)

diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs
index 7db4eed..03051f7 100644
--- a/compiler/cmm/CmmCPSZ.hs
+++ b/compiler/cmm/CmmCPSZ.hs
@@ -43,7 +43,7 @@ import StaticFlags
 --    The SRT needs to be threaded because it is grown lazily.
 protoCmmCPSZ :: HscEnv -- Compilation env including
                        -- dynamic flags: -dcmm-lint -ddump-cps-cmm
-             -> (TopSRT, [CmmZ])  -- SRT table and 
+             -> (TopSRT, [CmmZ])  -- SRT table and accumulating list of compiled procs
              -> CmmZ              -- Input C-- with Procedures
              -> IO (TopSRT, [CmmZ]) -- Output CPS transformed C--
 protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops)
@@ -110,8 +110,8 @@ cpsTop hsc_env (CmmProc h l args g) =
        -- UGH... manifestSP can require updates to the procPointMap.
        -- We can probably do something quicker here for the update...
        procPointMap  <- run $ procPointAnalysis procPoints g
-       gs <- pprTrace "procPointMap" (ppr procPointMap) $
-               run $ splitAtProcPoints l callPPs procPoints procPointMap areaMap
+       dump Opt_D_dump_cmmz "procpoint map" procPointMap
+       gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap areaMap
                                        (CmmProc h l args g)
        mapM (dump Opt_D_dump_cmmz "after splitting") gs
        let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs
index 7cf477a..58c63cb 100644
--- a/compiler/cmm/CmmProcPointZ.hs
+++ b/compiler/cmm/CmmProcPointZ.hs
@@ -423,8 +423,22 @@ splitAtProcPoints entry_label callPPs procPoints procMap areaMap
                   l' = if elemBlockSet pp callPPs then entryLblToInfoLbl l else l
               return (extendBlockEnv env pp bid, b : bs)
          add_jumps (newGraphEnv) (ppId, blockEnv) =
-           do (jumpEnv, jumpBlocks) <-
-                 foldM add_jump_block (emptyBlockEnv, []) (fmToList procLabels)
+           do let needed_jumps = -- find which procpoints we currently branch to
+                    foldBlockEnv' add_if_branch_to_pp [] blockEnv
+                  add_if_branch_to_pp block rst =
+                    case last (unzip block) of
+                      LastOther (LastBranch id) -> add_if_pp id rst
+                      LastOther (LastCondBranch _ ti fi) ->
+                        add_if_pp ti (add_if_pp fi rst)
+                      LastOther (LastSwitch _ tbl) -> foldr add_if_pp rst (catMaybes tbl)
+                      _ -> rst
+                  add_if_pp id rst = case lookupFM procLabels id of
+                                       Just x -> (id, x) : rst
+                                       Nothing -> rst
+                     -- fmToList procLabels
+              (jumpEnv, jumpBlocks) <-
+                 foldM add_jump_block (emptyBlockEnv, []) needed_jumps
+                  -- update the entry block
               let (b_off, b) = -- get the stack offset on entry into the block and
                                -- remove the offset from the block (it goes in new graph)
                     case lookupBlockEnv blockEnv ppId of -- get the procpoint block
@@ -434,8 +448,10 @@ splitAtProcPoints entry_label callPPs procPoints procMap areaMap
                       Nothing -> panic "couldn't find entry block while splitting"
                   blockEnv' = extendBlockEnv blockEnv ppId b
                   off = if ppId == entry then e_off else b_off
+                  -- replace branches to procpoints with branches to jumps
                   LGraph _ _ blockEnv'' = 
                     replaceBranches jumpEnv $ LGraph ppId off blockEnv'
+                  -- add the jump blocks to the graph
                   blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
               let g' = LGraph ppId off blockEnv'''
               pprTrace "g' pre jumps" (ppr g') $
-- 
1.7.10.4