wip

6 files changed, 138 insertions, 107 deletions

diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs
index 1ef5f09945..eb70b4740d 100644
--- a/compiler/GHC/Core/Opt/Pipeline.hs
+++ b/compiler/GHC/Core/Opt/Pipeline.hs
@@ -789,7 +789,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
            ((binds1, rules1), counts1) <-
              initSmpl logger dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs sz $
                do { (floats, env1) <- {-# SCC "SimplTopBinds" #-}
-                                      simplTopBinds simpl_env tagged_binds
+                                      simplTopBinds (dopt Opt_D_dump_simpl dflags) simpl_env tagged_binds
 
                       -- Apply the substitution to rules defined in this module
                       -- for imported Ids.  Eg  RULE map my_f = blah
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 791478a546..8462b5a84a 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -80,16 +80,22 @@ import GHC.Types.Var.Env
 import GHC.Types.Unique.FM
 import Control.Concurrent.QSem
 import Control.Exception
-import GHC.Core.Subst (Subst, substRecBndrs, substBind, mkEmptySubst, substInScope, extendSubstWithVar)
+import GHC.Core.Subst (Subst, substRecBndrs, substBind, mkEmptySubst, substInScope, extendSubstWithVar, substExpr, extendInScope, substIdOcc, isInScope, clone_id_hack, substIdInfo)
 import Data.Foldable
 import Data.Traversable
 import GHC.Data.OrdList (toOL)
-import GHC.Types.Var.Set (IdSet, mkVarSet, dVarSetElems)
+import GHC.Types.Var.Set (IdSet, mkVarSet, dVarSetElems, partitionVarSet, elemVarSet)
 import qualified Data.IntMap.Strict as IntMap
-import GHC.Types.Unique.Set (getUniqSet, isEmptyUniqSet, nonDetEltsUniqSet)
+import GHC.Types.Unique.Set (getUniqSet, isEmptyUniqSet, nonDetEltsUniqSet, addListToUniqSet, elementOfUniqSet, emptyUniqSet, addOneToUniqSet, UniqSet, mkUniqSet)
 import qualified Data.IntSet as IntSet
 import GHC.Types.Unique (Unique)
-import GHC.Types.Unique.Supply (uniqFromMask)
+import GHC.Types.Unique.Supply (uniqFromMask, initUs_)
+import GHC.Types.Unique (getUnique)
+import qualified Data.Monoid as Mon
+import Control.Applicative
+import GHC.Cmm.Dataflow.Collections (UniqueSet)
+import System.IO (fixIO)
+import Control.Monad.Fix
 
 {-
 The guts of the simplifier is in this module, but the driver loop for
@@ -225,58 +231,69 @@ too small to show up in benchmarks.
 ************************************************************************
 -}
 
-substSimplFloats :: Subst -> SimplFloats -> (Subst, SimplFloats)
-substSimplFloats subst sf@SimplFloats{sfJoinFloats, sfLetFloats = LetFloats bind_ol ff} = let
-  (new_subst, new_binds) = ASSERT (null sfJoinFloats)
-        mapAccumL substBind subst (toList bind_ol)
-  in (new_subst, sf { sfLetFloats = LetFloats (toOL new_binds) ff
-                    , sfInScope = sfInScope sf `unionInScope` substInScope new_subst
-                    })
-
-
-simplEnvInscopeLocals :: SimplEnv -> IdSet
-simplEnvInscopeLocals env = let
-  inscope_intmap = ufmToSet_Directly . getUniqSet . getInScopeVars  . seInScope $ env
-  (_,xs0) = IntSet.split (getKey minLocalUnique) inscope_intmap
-  (xs, _) = IntSet.split (getKey maxLocalUnique) xs0
-  in mkVarSet
-     [ x
-     | y :: Unique <- [minLocalUnique,maxLocalUnique] ++
-                [ mkUniqueGrimily x | x <- IntSet.toList xs]
-     , Just x <- [lookupInScope_Directly (seInScope env) y]
-     ]
-
-simplSubstLocals :: SimplEnv -> (SimplFloats, SimplEnv) -> IO (SimplFloats, SimplEnv)
-simplSubstLocals env0 (this_float,this_env) = do
-    let
-      inscope_locals_acc = simplEnvInscopeLocals env0
-    ASSERT (isEmptyUniqSet inscope_locals_acc) pure ()
-    let
-      inscope_locals = simplEnvInscopeLocals this_env
-    new_ids <- for (nonDetEltsUniqSet inscope_locals) $ \x -> (x,) . setVarUnique x <$> uniqFromMask 'z'
-    let subst = foldr (\(old, new) acc -> extendSubstWithVar acc old new)
-                        (mkEmptySubst $ seInScope env0) new_ids
-        (_, new_floats) = substSimplFloats subst this_float
-    pure (new_floats, setInScopeFromF this_env new_floats)
-
--- simplCombineEnvs :: MonadUnique m => SimplEnv -> [(SimplEnv, SimplFloats)] -> m (SimplFloats, SimplEnv)
--- simplCombineEnvs env0 envs = foldlM go (emptyFloats env0, env0) envs where
---   go (acc_floats, acc_env) (this_float, this_env) = do
---     let
---       inscope_locals_acc = simplEnvInscopeLocals acc_env
---     ASSERT (null inscope_locals_acc) pure ()
---     let
---       inscope_locals = simplEnvInscopeLocals this_env
---     new_ids <- for inscope_locals $ \x -> (x,) . setVarUnique x <$> getUniqueM
---     let subst = foldr (\(old, new) acc -> extendSubstWithVar acc old new)
---                         (mkEmptySubst $ seInScope acc_env) new_ids
---         (_, new_floats) = substSimplFloats subst this_float
---         floats = acc_floats `unionFloats` new_floats
---     pure (setInScopeFromF acc_env floats, floats)
-
-simplTopBinds :: SimplEnv -> ([(Int, InBind)], M.Map Int [Int]) -> SimplM (SimplFloats, SimplEnv)
+-- TODO rename
+simplScc :: ResimplEnv -> [SimplR] -> InBind -> SimplM SimplR
+simplScc (should_trace, env0, our_binders) deps b = do
+  let traceM | should_trace = pprTraceM
+             | otherwise = \_ _ -> pure ()
+  let (_floats0, envs0) =  unzip $ deps
+
+  traceM "simplScc:start:(#deps,binders)" $ ppr (length deps, bindersOf b)
+  -- when (any (> 1) check) $ pprPanic "simplScc" $ ppr (floats0, b)
+  let
+    !inscope = foldr unionInScope (seInScope env0) (seInScope <$> envs0)
+    these_binds = bindersOfBinds [b]
+    inscope_less_ours = foldl' delInScopeSet inscope these_binds
+    no_collisions x y = plusUFM_C arrrrrg x y where
+      arrrrrg = pprPanic "collision" $ ppr (x,y)
+    env1 = env0 { seInScope = inscope, seIdSubst = foldr no_collisions emptyUFM (seIdSubst <$> envs0)
+                }
+
+  traceM  "simplScc:env1:" $ ppr env1
+  (floats1, env2) <- simpl_bind env1 b
+  traceM  "simplScc:simpl_bind:(floats1,env1)" $ ppr (floats1,env2)
+  -- pprTraceM "simplScc2" $ ppr b
+
+
+
+  -- construct
+  (subst, new_binds) <-  getUniqueSupplyM >>= \x -> pure . initUs_ x $ mfix $ \ ~(subst0,_) -> let
+    go_id s i = do
+      u <- getUniqueM
+      pure $ case () of
+        _ | i `elemVarSet` our_binders -> let
+              j = maybeModifyIdInfo (substIdInfo True subst0 i (idInfo i)) i
+              in (extendInScope s j, j)
+          -- | is_local bndr  = subst_id_bndr acc_env bndr (flip setVarUnique u)
+          | isLocalId i -> let
+              (new_subst, new_bndr) = clone_id_hack True subst0 s (i, u)
+              in (extendSubstWithVar new_subst i new_bndr, new_bndr)
+          | otherwise -> (extendInScope s i, i)
+    go acc_subst bind = case bind of
+      NonRec i rhs -> do
+        (new_subst, new_id) <- go_id acc_subst i
+        pure (new_subst, NonRec new_id $ substExpr subst0 rhs)
+      Rec bs -> do
+        let f s (i,rhs) = do
+              (ns,ni) <- go_id s i
+              pure (ns, (ni, substExpr subst0  rhs))
+        (new_subst, bs1) <- mapAccumLM f acc_subst bs
+        pure (new_subst, Rec bs1)
+    in mapAccumLM go (mkEmptySubst inscope_less_ours) $ getTopFloatBinds  $ floats1
+
+  let !floats2 = case sfLetFloats floats1 of
+        LetFloats _ ff -> let
+          lf = LetFloats (toOL new_binds) ff
+          in SimplFloats lf (sfJoinFloats floats1) (substInScope subst)
+
+  traceM  "simplScc:substSimplFloats:(subst0,subst1,floats2)" $ ppr (subst,floats2)
+
+  pure (floats2, setInScopeFromF env2 floats2)
+
+
+simplTopBinds :: Bool -> SimplEnv -> ([(Int, InBind)], M.Map Int [Int]) -> SimplM (SimplFloats, SimplEnv)
 -- See Note [The big picture]
-simplTopBinds env0 (binds0, g)
+simplTopBinds should_trace env0 (binds0, g)
   = do  {       -- Put all the top-level binders into scope at the start
                 -- so that if a rewrite rule has unexpectedly brought
                 -- anything into scope, then we don't get a complaint about that.
@@ -284,14 +301,15 @@ simplTopBinds env0 (binds0, g)
                 -- See note [Glomming] in "GHC.Core.Opt.OccurAnal".
         -- See Note [Bangs in the Simplifier]
         ; !env1 <- {-#SCC "simplTopBinds-simplRecBndrs" #-} simplRecBndrs env0 (bindersOfBinds (map snd binds0))
+        ; let my_binds = mkUniqSet [lookupRecBndr env1 x | x <- bindersOfBinds (map snd binds0)]
 
---        ; env_m_vars :: M.Map Int (MVar (SimplFloats, SimplEnv))
+--        ; env_m_vars :: M.Map Int (MVar (SimplFloats, SimplEnv, UniqSet Var))
         ; env_m_vars <- liftIO $ M.fromList <$> (sequence [(k,) <$> newEmptyMVar | (k,_) <- binds0])
 
 
         ; sem <- liftIO $ newQSem 8
-        ; SM' $ \te sc -> do
-            mapM_ (do_one sem env1 env_m_vars te sc) binds0
+        ; SM $ \te sc -> do
+            mapM_ (do_one sem (should_trace, env1, my_binds) env_m_vars te sc) binds0
             return ((), sc)
 
         ; let res_vars = M.elems env_m_vars
@@ -303,11 +321,22 @@ simplTopBinds env0 (binds0, g)
         ; _old_res <- {-#SCC "simplTopBinds-simpl_binds" #-} simpl_binds env1 (map snd binds0)
 
         ; let
-            env = combine_envs env1 envs
-            final_floats = foldl' addFloats (emptyFloats env1) floats
+            !env = combine_envs env1 envs
+            !(final_floats, _) = foldl' go_sfs (emptyFloats env, emptyUniqSet) floats where
+              go_sfs acc sf = foldl' go_bind acc $ getTopFloatBinds sf where
+                go_bind bind_acc@(floats_acc, seen_set_acc) b = let
+                  bob = bindersOfBinds [b]
+                  is_seen = (`elementOfUniqSet` seen_set_acc)
+                  f = liftA2 (,) Mon.All Mon.Any . is_seen
+                  (Mon.All all_seen, Mon.Any any_seen) = foldMap f  bob
+                  in case () of
+                  _ | all_seen -> bind_acc
+                    | any_seen -> pprPanic "simplTopBinds:seenSome" $ ppr b
+                    | otherwise -> (floats_acc `extendFloats` b, seen_set_acc `addListToUniqSet` bob)
+
 
         ; freeTick SimplifierDone
-        ; return (final_floats, setInScopeFromF env final_floats) }
+        ; return (final_floats, env ) }
   where
     combine_envs env0 envs =
       env0 { seInScope = foldr unionInScope (seInScope env0) (map seInScope envs)
@@ -316,41 +345,37 @@ simplTopBinds env0 (binds0, g)
     do_one sem env1 deps te sc (k, b) = do
       ---pprTraceM "forking" (ppr k)
       forkIO $ do
-        let ds = (filter (/= k) $ fromJust $ M.lookup k g)
-        --print (k, ds)
-        (_, envs) <- unzip <$> mapM readMVar (mapMaybe (\di -> M.lookup di deps) ds)
-        let my_var = fromJust (M.lookup k deps)
-        let env' = combine_envs env1 envs
+        rs <- for [x | di <- g M.! k, di /= k, Just x <- [M.lookup di deps]] readMVar
         bracket_ (waitQSem sem) (signalQSem sem) $ do
-          ((floats, env''), _) <- unSM (simpl_bind env' b) te sc
-          simplSubstLocals env' (floats,env'') >>= putMVar my_var
-
+          let my_mv = deps M.! k
+          (fst <$> unSM (simplScc env1 rs b) te sc) >>= putMVar my_mv
 
 
 
---    go :: M.Map Int (MVar SimplEnv) -> [Int] -> IO (MVar SimplEnv)
---    go m deps = let deps = map (\k -> M.lookup k m) deps
---                in _
+-- TODO we need to be threading SimplCount through as well
+type SimplR = (SimplFloats, SimplEnv)
+type ResimplEnv = (Bool, SimplEnv, UniqSet Var)
 
+    -- We need to track the zapped top-level binders, because
+    -- they should have their fragile IdInfo zapped (notably occurrence info)
+    -- That's why we run down binds and bndrs' simultaneously.
+    --
+simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)
+simpl_binds env []           = return (emptyFloats env, env)
+simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind
+                                  ; (floats, env2) <- simpl_binds env1 binds
+                                  -- See Note [Bangs in the Simplifier]
+                                  ; let !floats1 = float `addFloats` floats
+                                  ; -- TODO ^^^ should this be unionFloats?
+                                  ; return (floats1, env2) }
 
-        -- We need to track the zapped top-level binders, because
-        -- they should have their fragile IdInfo zapped (notably occurrence info)
-        -- That's why we run down binds and bndrs' simultaneously.
-        --
-    simpl_binds :: SimplEnv -> [InBind] -> SimplM (SimplFloats, SimplEnv)
-    simpl_binds env []           = return (emptyFloats env, env)
-    simpl_binds env (bind:binds) = do { (float,  env1) <- simpl_bind env bind
-                                      ; (floats, env2) <- simpl_binds env1 binds
-                                      -- See Note [Bangs in the Simplifier]
-                                      ; let !floats1 = float `addFloats` floats
-                                      ; -- TODO ^^^ should this be unionFloats?
-                                      ; return (floats1, env2) }
+simpl_bind :: SimplEnv -> InBind -> SimplM (SimplFloats, SimplEnv)
+simpl_bind env (Rec pairs)
+  = simplRecBind env TopLevel Nothing pairs
+simpl_bind env (NonRec b r)
+  = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) Nothing
+       ; simplRecOrTopPair env' TopLevel NonRecursive Nothing b b' r }
 
-    simpl_bind env (Rec pairs)
-      = simplRecBind env TopLevel Nothing pairs
-    simpl_bind env (NonRec b r)
-      = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) Nothing
-           ; simplRecOrTopPair env' TopLevel NonRecursive Nothing b b' r }
 
 {-
 ************************************************************************
@@ -4291,4 +4316,3 @@ for the RHS as well as the LHS, but that seems more conservative
 than necesary.  Allowing some inlining might, for example, eliminate
 a binding.
 -}
-
diff --git a/compiler/GHC/Core/Opt/Simplify/Env.hs b/compiler/GHC/Core/Opt/Simplify/Env.hs
index 68678b6d16..a17b7ac7fc 100644
--- a/compiler/GHC/Core/Opt/Simplify/Env.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Env.hs
@@ -40,7 +40,9 @@ module GHC.Core.Opt.Simplify.Env (
 
         -- * JoinFloats
         JoinFloat, JoinFloats, emptyJoinFloats,
-        wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts
+        wrapJoinFloats, wrapJoinFloatsX, unitJoinFloat, addJoinFlts,
+
+        subst_id_bndr, extendInScopeSetBind
     ) where
 
 #include "HsVersions.h"
@@ -847,6 +849,7 @@ subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
               old_id adjust_type
   = ASSERT2( not (isCoVar old_id), ppr old_id )
     (env { seInScope = new_in_scope,
+
            seIdSubst = new_subst }, new_id)
     -- It's important that both seInScope and seIdSubst are updated with
     -- the new_id, /after/ applying adjust_type. That's why adjust_type
diff --git a/compiler/GHC/Core/Opt/Simplify/Monad.hs b/compiler/GHC/Core/Opt/Simplify/Monad.hs
index 4ad12c3aab..bee0c3607e 100644
--- a/compiler/GHC/Core/Opt/Simplify/Monad.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Monad.hs
@@ -7,7 +7,7 @@
 
 module GHC.Core.Opt.Simplify.Monad (
         -- The monad
-        SimplM(unSM, SM'),
+        SimplM(unSM, SM),
         initSmpl, traceSmpl,
         getSimplRules, getFamEnvs, getOptCoercionOpts,
 
diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index 6353dcda6f..6a4db0e4cf 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -670,7 +670,7 @@ add_info env old_bndr top_level new_rhs new_bndr
 
    old_unfolding = unfoldingInfo old_info
    new_unfolding | isStableUnfolding old_unfolding
-                 = substUnfolding subst old_unfolding
+                 = substUnfolding False subst old_unfolding
                  | otherwise
                  = unfolding_from_rhs
 
diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs
index 1c7d138574..c50841b7d2 100644
--- a/compiler/GHC/Core/Subst.hs
+++ b/compiler/GHC/Core/Subst.hs
@@ -31,6 +31,7 @@ module GHC.Core.Subst (
         -- ** Substituting and cloning binders
         substBndr, substBndrs, substRecBndrs, substTyVarBndr, substCoVarBndr,
         cloneBndr, cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs,
+        clone_id_hack
 
     ) where
 
@@ -485,7 +486,7 @@ substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
         -- The lazy-set is because we're in a loop here, with
         -- rec_subst, when dealing with a mutually-recursive group
     new_id = maybeModifyIdInfo mb_new_info id2
-    mb_new_info = substIdInfo rec_subst id2 (idInfo id2)
+    mb_new_info = substIdInfo False rec_subst id2 (idInfo id2)
         -- NB: unfolding info may be zapped
 
         -- Extend the substitution if the unique has changed
@@ -535,19 +536,21 @@ cloneRecIdBndrs subst us ids
 
 -- Just like substIdBndr, except that it always makes a new unique
 -- It is given the unique to use
-clone_id    :: Subst                    -- Substitution for the IdInfo
+clone_id_hack    :: Bool -> Subst                    -- Substitution for the IdInfo
             -> Subst -> (Id, Unique)    -- Substitution and Id to transform
             -> (Subst, Id)              -- Transformed pair
 
-clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq)
+clone_id_hack hack rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq)
   = (Subst (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id)
   where
     id1     = setVarUnique old_id uniq
     id2     = substIdType subst id1
-    new_id  = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2
+    new_id  = maybeModifyIdInfo (substIdInfo hack rec_subst id2 (idInfo old_id)) id2
     (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id))
                         | otherwise      = (extendVarEnv idvs old_id (Var new_id), cvs)
 
+
+clone_id = clone_id_hack False
 {-
 ************************************************************************
 *                                                                      *
@@ -612,11 +615,11 @@ substIdType subst@(Subst _ _ tv_env cv_env) id
 
 ------------------
 -- | Substitute into some 'IdInfo' with regard to the supplied new 'Id'.
-substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
-substIdInfo subst new_id info
+substIdInfo :: Bool -> Subst -> Id -> IdInfo -> Maybe IdInfo
+substIdInfo hack subst new_id info
   | nothing_to_do = Nothing
   | otherwise     = Just (info `setRuleInfo`      substRuleInfo subst new_id old_rules
-                               `setUnfoldingInfo` substUnfolding subst old_unf)
+                               `setUnfoldingInfo` substUnfolding hack subst old_unf)
   where
     old_rules     = ruleInfo info
     old_unf       = unfoldingInfo info
@@ -627,23 +630,24 @@ substIdInfo subst new_id info
 -- NB: substUnfolding /discards/ any unfolding without
 --     without a Stable source.  This is usually what we want,
 --     but it may be a bit unexpected
-substUnfolding, substUnfoldingSC :: Subst -> Unfolding -> Unfolding
+substUnfolding, substUnfoldingSC :: Bool -> Subst -> Unfolding -> Unfolding
         -- Seq'ing on the returned Unfolding is enough to cause
         -- all the substitutions to happen completely
 
-substUnfoldingSC subst unf       -- Short-cut version
+substUnfoldingSC hack subst unf       -- Short-cut version
   | isEmptySubst subst = unf
-  | otherwise          = substUnfolding subst unf
+  | otherwise          = substUnfolding hack subst unf
 
-substUnfolding subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
+substUnfolding _hack subst df@(DFunUnfolding { df_bndrs = bndrs, df_args = args })
   = df { df_bndrs = bndrs', df_args = args' }
   where
     (subst',bndrs') = substBndrs subst bndrs
     args'           = map (substExpr subst') args
 
-substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
+substUnfolding hack subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
         -- Retain an InlineRule!
   | not (isStableSource src)  -- Zap an unstable unfolding, to save substitution work
+  && not hack
   = NoUnfolding
   | otherwise                 -- But keep a stable one!
   = seqExpr new_tmpl `seq`
@@ -651,7 +655,7 @@ substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src })
   where
     new_tmpl = substExpr subst tmpl
 
-substUnfolding _ unf = unf      -- NoUnfolding, OtherCon
+substUnfolding _ _ unf = unf      -- NoUnfolding, OtherCon
 
 ------------------
 substIdOcc :: Subst -> Id -> Id