[commit: ghc] wip/T14152: Slight refactoring (pull out ExitifyM) (4bfa11c)

[git at git.haskell.org]

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

On branch  : wip/T14152
Link       : http://ghc.haskell.org/trac/ghc/changeset/4bfa11ce5dc8b55b06739f85d550b2e2eb2c5211/ghc

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

commit 4bfa11ce5dc8b55b06739f85d550b2e2eb2c5211
Author: Joachim Breitner <mail at joachim-breitner.de>
Date:   Wed Sep 6 15:09:21 2017 +0100

    Slight refactoring (pull out ExitifyM)
    
    (will be squashed in the final push)


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

4bfa11ce5dc8b55b06739f85d550b2e2eb2c5211
 compiler/simplCore/Exitify.hs | 65 +++++++++++++++++++++++--------------------
 1 file changed, 35 insertions(+), 30 deletions(-)

diff --git a/compiler/simplCore/Exitify.hs b/compiler/simplCore/Exitify.hs
index 2079347..916ae73 100644
--- a/compiler/simplCore/Exitify.hs
+++ b/compiler/simplCore/Exitify.hs
@@ -11,6 +11,7 @@ import VarSet
 import VarEnv
 import CoreFVs
 import FastString
+import Type
 
 import Data.Bifunctor
 import Control.Monad
@@ -107,10 +108,9 @@ exitify in_scope pairs =
             -- Assemble the RHS of the exit join point
             let rhs = mkLams args e
                 ty = exprType rhs
-            -- Pick a suitable name
-            v <- mkExitJoinId ty (length args) captured
-            -- Remember this binding
-            addExit v rhs
+            let avoid = in_scope `extendInScopeSetList` captured
+            -- Remember this binding under a suitable name
+            v <- addExit avoid ty (length args) rhs
             -- And call it from here
             return $ mkVarApps (Var v) args
       where
@@ -169,29 +169,34 @@ exitify in_scope pairs =
     go _ ann_e = return (deAnnotate ann_e)
 
 
-    -- Picks a new unique, which is disjoint from
-    --  * the free variables of the whole joinrec
-    --  * any bound variables (captured)
-    --  * any exit join points created so far.
-    mkExitJoinId ty join_arity captured = do
-        fs <- get
-        let avoid = in_scope `extendInScopeSetList` captured
-                             `extendInScopeSetList` (map fst fs)
-                             `extendInScopeSet` exit_id_tmpl -- just cosmetics
-        return (uniqAway avoid exit_id_tmpl)
-      where
-        exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ty
-                        `asJoinId` join_arity
-                        `setIdOccInfo` exit_occ_info
-
-        exit_occ_info =
-            OneOcc { occ_in_lam = True
-                   , occ_one_br = True
-                   , occ_int_cxt = False
-                   , occ_tail = AlwaysTailCalled join_arity }
-
-    addExit v rhs = do
-        fs <- get
-        put ((v,rhs):fs)
-
-
+-- Picks a new unique, which is disjoint from
+--  * the free variables of the whole joinrec
+--  * any bound variables (captured)
+--  * any exit join points created so far.
+mkExitJoinId :: InScopeSet -> Type -> JoinArity -> ExitifyM JoinId
+mkExitJoinId in_scope ty join_arity = do
+    fs <- get
+    let avoid = in_scope `extendInScopeSetList` (map fst fs)
+                         `extendInScopeSet` exit_id_tmpl -- just cosmetics
+    return (uniqAway avoid exit_id_tmpl)
+  where
+    exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique ty
+                    `asJoinId` join_arity
+                    `setIdOccInfo` exit_occ_info
+
+    exit_occ_info =
+        OneOcc { occ_in_lam = True
+               , occ_one_br = True
+               , occ_int_cxt = False
+               , occ_tail = AlwaysTailCalled join_arity }
+
+addExit :: InScopeSet -> Type -> JoinArity -> CoreExpr -> ExitifyM JoinId
+addExit in_scope ty join_arity rhs = do
+    -- Pick a suitable name
+    v <- mkExitJoinId in_scope ty join_arity
+    fs <- get
+    put ((v,rhs):fs)
+    return v
+
+
+type ExitifyM =  State [(JoinId, CoreExpr)]