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...

diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs
index 7db4eed..03051f7 100644 (file)
--- 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 (file)
--- 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') $