Removed warnings, made Haddock happy, added examples in documentation

[ghc-hetmet.git] / compiler / cmm / CmmProcPointZ.hs

diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs
index 7cf477a..712461d 100644 (file)
--- a/compiler/cmm/CmmProcPointZ.hs
+++ b/compiler/cmm/CmmProcPointZ.hs
@@ -366,8 +366,8 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv
                   insert z succId m =
                     do (b, bmap) <- z
                        (b, bs)   <- insertBetween b m succId
-                       pprTrace "insert for succ" (ppr succId <> ppr m) $
-                        return $ (b, foldl (flip insertBlock) bmap bs)
+                       -- pprTrace "insert for succ" (ppr succId <> ppr m) $ do
+                       return $ (b, foldl (flip insertBlock) bmap bs)
                   finish (b@(Block bid _ _), bmap) =
                     return $ (extendBlockEnv bmap bid b)
           skip b@(Block bid _ _) bs =
@@ -385,7 +385,7 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv
 -- Input invariant: A block should only be reachable from a single ProcPoint.
 splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
                      AreaMap -> CmmTopZ -> FuelMonad [CmmTopZ]
-splitAtProcPoints entry_label callPPs procPoints procMap areaMap
+splitAtProcPoints entry_label callPPs procPoints procMap _areaMap
                   (CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args
                            g@(LGraph entry e_off blocks)) =
   do -- Build a map from procpoints to the blocks they reach
@@ -402,7 +402,7 @@ splitAtProcPoints entry_label callPPs procPoints procMap areaMap
                where graph  = lookupBlockEnv graphEnv procId `orElse` emptyBlockEnv
                      graph' = extendBlockEnv graph bid b
      graphEnv_pre <- return $ fold_blocks addBlock emptyBlockEnv g
-     graphEnv <- return $ pprTrace "graphEnv" (ppr graphEnv_pre) graphEnv_pre
+     graphEnv <- {- pprTrace "graphEnv" (ppr graphEnv_pre) -} return graphEnv_pre
      -- Build a map from proc point BlockId to labels for their new procedures
      let add_label map pp = return $ addToFM map pp lbl
            where lbl = if pp == entry then entry_label else blockLbl pp
@@ -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,16 +448,18 @@ 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') $
-               return (extendBlockEnv newGraphEnv ppId g')
+              -- pprTrace "g' pre jumps" (ppr g') $ do
+              return (extendBlockEnv newGraphEnv ppId g')
      graphEnv_pre <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv
-     graphEnv <- return $ pprTrace "graphEnv with jump blocks" (ppr graphEnv_pre)
+     graphEnv <- return $ -- pprTrace "graphEnv with jump blocks" (ppr graphEnv_pre)
                                          graphEnv_pre
-     let to_proc (bid, g@(LGraph g_entry _ blocks)) | elemBlockSet bid callPPs =
+     let to_proc (bid, g) | elemBlockSet bid callPPs =
            if bid == entry then 
              CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args g
            else
@@ -460,9 +476,9 @@ splitAtProcPoints entry_label callPPs procPoints procMap areaMap
            compare (expectJust "block_order" $ lookupBlockEnv block_order bid)
                    (expectJust "block_order" $ lookupBlockEnv block_order bid')
      procs <- return $ map to_proc $ sortBy sort_fn $ blockEnvToList graphEnv
-     return $ pprTrace "procLabels" (ppr procLabels)
-            $ pprTrace "splitting graphs" (ppr procs)
-            $ procs
+     return -- pprTrace "procLabels" (ppr procLabels)
+            -- pprTrace "splitting graphs" (ppr procs)
+            procs
 splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
 
 ----------------------------------------------------------------