[commit: ghc] master: procPointAnalysis doesn't need UniqSM (27287c8)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/27287c802010ddf4f5d633de6b61b40a50a38c64/ghc

>---------------------------------------------------------------

commit 27287c802010ddf4f5d633de6b61b40a50a38c64
Author: Michal Terepeta <michal.terepeta at gmail.com>
Date:   Wed Dec 14 16:47:05 2016 -0500

    procPointAnalysis doesn't need UniqSM
    
    `procPointAnalysis` doesn't need to run in `UniqSM` (it consists of a
    single `return` and the call to `analyzeCmm` function which is pure).
    Making it non-monadic simplifies the code a bit.
    
    Signed-off-by: Michal Terepeta <michal.terepeta at gmail.com>
    
    Test Plan: validate
    
    Reviewers: austin, bgamari, simonmar
    
    Reviewed By: simonmar
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D2837


>---------------------------------------------------------------

27287c802010ddf4f5d633de6b61b40a50a38c64
 compiler/cmm/CmmPipeline.hs  |  4 +--
 compiler/cmm/CmmProcPoint.hs | 58 ++++++++++++++++++++------------------------
 2 files changed, 28 insertions(+), 34 deletions(-)

diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index b19e418..a0fe4b1 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -109,8 +109,8 @@ cpsTop hsc_env proc =
        g <- if splitting_proc_points
             then do
                ------------- Split into separate procedures -----------------------
-               pp_map  <- {-# SCC "procPointAnalysis" #-} runUniqSM $
-                          procPointAnalysis proc_points g
+               let pp_map = {-# SCC "procPointAnalysis" #-}
+                            procPointAnalysis proc_points g
                dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" $
                     ppr pp_map
                g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 608654f..3dc7ac4 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -131,10 +131,9 @@ instance Outputable Status where
 -- Once you know what the proc-points are, figure out
 -- what proc-points each block is reachable from
 -- See Note [Proc-point analysis]
-procPointAnalysis :: ProcPointSet -> CmmGraph -> UniqSM (LabelMap Status)
+procPointAnalysis :: ProcPointSet -> CmmGraph -> LabelMap Status
 procPointAnalysis procPoints cmmGraph@(CmmGraph {g_graph = graph}) =
-    return $
-        analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints
+    analyzeCmmFwd procPointLattice procPointTransfer cmmGraph initProcPoints
   where
     initProcPoints =
         mkFactBase
@@ -189,36 +188,31 @@ minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph
 minimalProcPointSet platform callProcPoints g
   = extendPPSet platform g (postorderDfs g) callProcPoints
 
-extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
+extendPPSet
+    :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> UniqSM ProcPointSet
 extendPPSet platform g blocks procPoints =
-    do env <- procPointAnalysis procPoints g
-       -- pprTrace "extensPPSet" (ppr env) $ return ()
-       let add block pps = let id = entryLabel block
-                           in  case mapLookup id env of
-                                 Just ProcPoint -> setInsert id pps
-                                 _ -> pps
-           procPoints' = foldGraphBlocks add setEmpty g
-           newPoints = mapMaybe ppSuccessor blocks
-           newPoint  = listToMaybe newPoints
-           ppSuccessor b =
-               let nreached id = case mapLookup id env `orElse`
-                                       pprPanic "no ppt" (ppr id <+> ppr b) of
-                                   ProcPoint -> 1
-                                   ReachedBy ps -> setSize ps
-                   block_procpoints = nreached (entryLabel b)
-                   -- | Looking for a successor of b that is reached by
-                   -- more proc points than b and is not already a proc
-                   -- point.  If found, it can become a proc point.
-                   newId succ_id = not (setMember succ_id procPoints') &&
-                                   nreached succ_id > block_procpoints
-               in  listToMaybe $ filter newId $ successors b
-{-
-       case newPoints of
-           []  -> return procPoints'
-           pps -> extendPPSet g blocks
-                    (foldl extendBlockSet procPoints' pps)
--}
-       case newPoint of
+    let env = procPointAnalysis procPoints g
+        add block pps = let id = entryLabel block
+                        in  case mapLookup id env of
+                              Just ProcPoint -> setInsert id pps
+                              _ -> pps
+        procPoints' = foldGraphBlocks add setEmpty g
+        newPoints = mapMaybe ppSuccessor blocks
+        newPoint  = listToMaybe newPoints
+        ppSuccessor b =
+            let nreached id = case mapLookup id env `orElse`
+                                    pprPanic "no ppt" (ppr id <+> ppr b) of
+                                ProcPoint -> 1
+                                ReachedBy ps -> setSize ps
+                block_procpoints = nreached (entryLabel b)
+                -- | Looking for a successor of b that is reached by
+                -- more proc points than b and is not already a proc
+                -- point.  If found, it can become a proc point.
+                newId succ_id = not (setMember succ_id procPoints') &&
+                                nreached succ_id > block_procpoints
+            in  listToMaybe $ filter newId $ successors b
+
+    in case newPoint of
          Just id ->
              if setMember id procPoints'
                 then panic "added old proc pt"