+cseProgram = map cseCoreCompUnit

+

+cseCoreCompUnit :: CoreCompUnit -> CoreCompUnit

+cseCoreCompUnit (CoreCompUnit unit_binds unit_rules)

+  = CoreCompUnit binds' unit_rules

+    init_env = emptyCSEnv $

+               mkInScopeSetList (bindersOfBinds unit_binds)

+               -- Put all top-level binders in this compilation unit into

+               -- scope; it is possible to have forward references.

+               -- See Note [Glomming] in GHC.Core.Opt.OccurAnal.

+    (_env', binds') = mapAccumL (cseBind TopLevel) init_env unit_binds

+    initRuleEnv, getHomeRuleBase, getExternalRuleBase,

+    occurAnalysePgm, occurAnalyseExpr

+import GHC.Driver.Config.Core.Lint ( endPass, initLintConfig )

+import GHC.Core.SimpleOpt (simpleOptPgm, defaultSimpleOpts, so_inline, so_uf_opts)

+import GHC.Core.Lint    ( lintAnnots, lintCoreProgram', displayLintResults )

+import GHC.Core.Opt.Split        ( splitCompUnit, checkNameClashes )

+           [ runWhen split_core CoreMerge

+           , CoreCSE

+           , runWhen split_core CoreSplit

+           , simplify "post-final-cse"

+           ],

+  let extra_vars = interactiveInScope (hsc_IC hsc_env)

+                                 do { let split_res = map (splitCompUnit (mg_module guts) (mg_rules guts)) (mg_binds guts)

+                                          _ = checkNameClashes binds_before

+                                          _ = checkNameClashes binds_after

+                                    ; liftIO $ do

+                                        let warns_and_errs = lintCoreProgram'

+                                              (initLintConfig dflags extra_vars)

+                                              binds_after

+                                              (mg_rules guts)

+                                              True

+                                        displayLintResults logger

+                                          (text "CoreMerge after flattenCoreProgram")

+                                          (pprCoreProgram binds_after)

+                                          warns_and_errs

+                                    ; let minimal_things = defaultSimpleOpts

+                                              { so_inline = False

+                                              , so_uf_opts = unfoldingOpts dflags }

+                                          (binds_w_unfolds, rules_for_imps, occ_anald_binds) = simpleOptPgm

+                                              minimal_things

+                                              (mg_module guts)

+                                              binds_after

+                                              (mg_rules guts)

+                                          _ = checkNameClashes binds_w_unfolds

+                                    ; liftIO $

+                                        Logger.putDumpFileMaybe logger Opt_D_dump_split_core

+                                          "Core after re-attaching unfolds"

+                                          FormatCore

+                                          (pprCoreProgram occ_anald_binds)

+

+                                    ; return $ guts { mg_binds = binds_w_unfolds

+                                                    , mg_rules = rules_for_imps } }

+import GHC.Core.FVs (ruleFreeVars)

+import GHC.Types.Var.Set

+               , dyn_no_binds { dsd_binds = binds, dsd_rules = local_rules } )

+                -- Simplify each compilation unit independently

+           ((binds1, rules1), counts1) <-

+             simpl_comp_units simpl_env local_rules tagged_binds sz ;

+                       , dyn_no_binds { dsd_binds = binds1, dsd_rules = rules1 } )

+           let { binds2 = {-# SCC "ZapInd" #-}

+                          [ CoreCompUnit (shortOutIndirections unit_binds) unit_rules'

+                          | CoreCompUnit unit_binds unit_rules' <- binds1 ] } ;

+             binds2 rules1 ;

+             lintPassResult logger pass_result_cfg binds2 rules1 ;

+           do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1

+    -- Keep top-level in-scope sets per-unit until CoreMerge.

+    simpl_comp_units

+      :: SimplEnv

+      -> [CoreRule]

+      -> CoreProgram

+      -> Int

+      -> IO ((CoreProgram, [CoreRule]), SimplCount)

+    simpl_comp_units simpl_env rules0 units0 sz = go rules0 [] zero_counts units0

+      where

+        zero_counts = zeroSimplCount $ logHasDumpFlag logger Opt_D_dump_simpl_stats

+

+        go !rules acc !counts [] = return ((reverse acc, rules), counts)

+        go !rules acc !counts (CoreCompUnit unit_binds unit_rules' : rest) = do

+          let unit_bndrs = mkVarSet (bindersOfBinds unit_binds)

+              (visible_rules, hidden_rules) = partitionVisibleImpRules unit_bndrs rules

+              !base_rule_env = updLocalRules hpt_rule_env (visible_rules ++ unit_rules')

+              read_eps_rules = eps_rule_base <$> ueEPS unit_env

+              read_rule_env = updExternalPackageRules base_rule_env <$> read_eps_rules

+

+          ((unit1, visible_rules1), counts1) <-

+            initSmpl logger read_rule_env top_env_cfg sz $ do

+              (floats, env1) <- {-# SCC "SimplTopBindsUnit" #-}

+                                simplTopBinds simpl_env unit_binds

+

+              -- Apply substitutions from this unit to imported-head rules and

+              -- the unit's own rules. Keep each unit's local rules separate.

+              visible_rules1 <- simplImpRules env1 visible_rules

+              unit_rules1 <- simplImpRules env1 unit_rules'

+

+              let unit_binds1 = getTopFloatBinds floats

+              pure (CoreCompUnit unit_binds1 unit_rules1, visible_rules1)

+

+          let rules1 = visible_rules1 ++ hidden_rules

+          go rules1 (unit1 : acc) (counts `plusSimplCount` counts1) rest

+

+    partitionVisibleImpRules :: VarSet -> [CoreRule] -> ([CoreRule], [CoreRule])

+    partitionVisibleImpRules unit_bndrs = foldr go_rule ([], [])

+      where

+        go_rule rule (visible, hidden)

+          | rule_mentions_unit = (rule : visible, hidden)

+          | rule_has_local_fvs = (visible, rule : hidden)

+          | otherwise          = (rule : visible, hidden)

+          where

+            local_fvs = ruleFreeVars rule `intersectVarSet` all_local_bndrs

+            rule_has_local_fvs = not (isEmptyVarSet local_fvs)

+            rule_mentions_unit = not (isEmptyVarSet (local_fvs `intersectVarSet` unit_bndrs))

+

+    all_local_bndrs :: VarSet

+    all_local_bndrs = mkVarSet (bindersOfBinds (concatMap coreCompUnitBinds (dsd_binds dyn)))

+

+  let unit_env = initScCompUnitEnv env unit_binds

+  (_unit_usg, unit_binds', unit_warnings) <- scTopBinds unit_env unit_binds

+  (_units_usg, units', units_warnings) <- scTopCompUnits env units

+  -- Before CoreMerge, different compilation units may legitimately reuse the

+  -- same top-level Id/Unique, so we must not combine ScUsage across units.

+  return (nullUsage, CoreCompUnit unit_binds' unit_rules : units', unit_warnings ++ units_warnings)

+                       sc_subst       = mkEmptySubst emptyInScopeSet,

+

+initScCompUnitEnv :: ScEnv -> [InBind] -> ScEnv

+initScCompUnitEnv env unit_binds

+  = env { sc_subst = mkEmptySubst in_scope }

+    in_scope = emptyInScopeSet `extendInScopeSetBndrs` unit_binds

+      -- Account for top-level bindings that are not in dependency order;

+      -- see Note [Glomming] in GHC.Core.Opt.OccurAnal.

+      -- Crucially, only add binders from the current compilation unit.

+       -- At top level, we've already put the current compilation unit's

+       -- binders into scope; see initScCompUnitEnv.

+       -- At top level, we've already put the current compilation unit's

+       -- binders into scope; see initScCompUnitEnv.

+import GHC.Unit.Module.Deps ( Dependencies )

+        , ssi_deps   = mg_deps guts

+  , ssi_deps     :: !Dependencies

+  = do { hpt_rules <- getHomeRuleBase

+       ; eps_rules <- getExternalRuleBase

+       ; let rule_env = mkRuleEnv (ssi_module static) (ssi_deps static) [] [unit]

+                                  eps_rules hpt_rules

+             top_env = SE { se_subst = Core.mkEmptySubst in_scope

+                          , se_module = ssi_module static

+                          , se_rules  = rule_env

+                          , se_dflags = dflags }

+       ; (unit_binds', uds) <- runSpecM (go top_env unit_binds)

+    unit = CoreCompUnit unit_binds unit_rules

+    go _ []           = return ([], emptyUDs)

+    go env (bind:binds)

+      = do (bind', binds', uds') <- specBind TopLevel env bind $ \_ ->

+                                     go env binds

+           return (bind' ++ binds', uds')

+{-# LANGUAGE ViewPatterns #-}

+

+module GHC.Core.Opt.Split

+  ( splitCompUnit

+  , checkNameClashes

+  ) where

+

+import GHC.Prelude hiding ( head, init, last )

+

+import GHC.Core

+import GHC.Core.FVs

+import GHC.Core.Opt.OccurAnal (occurAnalyseCompUnit)

+

+import GHC.Data.Graph.Directed (SCC(..), Node(..), stronglyConnCompFromEdgedVerticesUniq)

+import GHC.Data.Maybe (orElse)

+

+import GHC.Types.Unique.Set

+import GHC.Types.Name (isExternalName, nameModule)

+import GHC.Types.Id (realIdUnfolding)

+import GHC.Types.Var.Set

+import GHC.Types.Var.Env

+import GHC.Types.Var

+

+import GHC.Utils.Outputable

+import GHC.Utils.Panic

+

+import GHC.Unit.Module (Module)

+

+import qualified Data.IntMap.Strict as IntMap

+import qualified Data.IntSet as IntSet

+import Data.List (find)

+

+{- Note [Splitting core programs]

+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

+splitCompUnit splits a single compilation unit into multiple.

+To do so we:

+

+Initially we run OccAnal on the compilation unit. I don't think it's strictly neccessary

+but it zaps fragile unfoldings which speeds up and gets rid of glomming.

+We will try getting rid of this later.

+

+We split imported rules into those which only concern imported rules and those mentioning

+local binders (called unit_rules).

+

+Rules mentioning local binders introduce edges between any local binders they mention.

+

+Next we build the graph nodes from binders:

+* Fully nodes have one key, the first Id the binder defines. Their node data is the binder itself.

+* Pseudo nodes for every id the binder defines (tail $ bindersOf bind) with no data.

+

+Now we introduce edges:

+  * For binders from the first id to all other defined ids and those it mentions as fv

+      let key = (head bindersOf bind)

+      let edges = map (\x -> (key, x)) bindersOf bind ++ map (\x -> (key, x)) (bindFreeVars bind)

+  * For rules if they mention local binders introduce edges between any local binders they mention.

+

+* All edges computed so far are directional. So we take all edges and also add their reversed version.

+

+* After this we split the graph into independent components.

+

+* As the last step we assign each unit rule to a unit from which it mentions variables

+-}

+

+data DepGraphNode

+  = BindNode

+  { depNodeKey  :: !Var

+  , depNodeBind :: CoreBind

+  }

+  | PseudoNode

+  { depNodeKey :: !Var }

+

+type Edge = (Var, Var)

+

+-- | Is the given variable defined in the given module.

+varFromModule :: Module -> Var -> Bool

+varFromModule _ var = isLocalId var

+

+maybeRuleEdges :: Module -> CoreRule -> Maybe [Edge]

+maybeRuleEdges this_module rule =

+  case local_fvs of

+    []  -> Nothing

+    [_] -> Just []

+    _   -> Just (zip local_fvs (drop 1 local_fvs))

+  where

+    local_fvs = filter (varFromModule this_module) (nonDetEltsUniqSet (ruleFreeVars rule))

+

+bindNode :: VarSet -> CoreBind -> ([DepGraphNode], [Edge])

+bindNode local_top_bndrs bind =

+  case bindersOf bind of

+    []       -> ([], [])

+    key:rest ->

+      let split_fvs = bindSplitFreeVars local_top_bndrs bind

+          intern_edges = map (\v -> (key, v)) rest

+          ext_edges = map (\v -> (key, v)) (nonDetEltsUniqSet split_fvs)

+          node = BindNode key bind

+          pseudo_nodes = map PseudoNode rest

+      in (node : pseudo_nodes, intern_edges ++ ext_edges)

+

+bindSplitFreeVars :: VarSet -> CoreBind -> VarSet

+bindSplitFreeVars local_top_bndrs bind =

+  close_over_imported_unfoldings (bindMentionedVars bind `unionVarSet` bindBndrInfoVars bind)

+  where

+    close_over_imported_unfoldings fvs = go emptyVarSet fvs

+

+    go !seen !fvs =

+      case pick_new_import (fvs `minusVarSet` seen) of

+        Nothing -> fvs

+        Just v  ->

+          let unfolding_fvs = unfoldingRefs v

+              local_unfolding_fvs = unfolding_fvs `intersectVarSet` local_top_bndrs

+          in go (extendVarSet seen v) (fvs `unionVarSet` local_unfolding_fvs `unionVarSet` unfolding_fvs)

+

+    pick_new_import vars =

+      find pickable (nonDetEltsUniqSet vars)

+

+    pickable v = isId v && not (v `elemVarSet` local_top_bndrs)

+

+    unfoldingRefs v =

+      case maybeUnfoldingTemplate (realIdUnfolding v) of

+        Just rhs -> exprSomeFreeVars (const True) rhs

+        Nothing  -> emptyVarSet

+

+bindMentionedVars :: CoreBind -> VarSet

+bindMentionedVars (NonRec _ rhs) = exprSomeFreeVars (const True) rhs

+bindMentionedVars (Rec prs)      = exprsSomeFreeVars (const True) (map snd prs)

+

+bindBndrInfoVars :: CoreBind -> VarSet

+bindBndrInfoVars bind =

+  mkVarSet $

+    concatMap (dVarSetElems . bndrRuleAndUnfoldingVarsDSet) (bindersOf bind)

+

+type Edges = IdEnv [Var]

+

+-- Split core binders takes directed edges treating them as undirected by adding the reverse edge internally.

+splitCoreBinders :: [DepGraphNode] -> [Edge] -> [(VarSet, [CoreBind])]

+splitCoreBinders nodes edges =

+  [ (mkVarSet (concatMap bindersOf binds), binds)

+  | comp_nodes <- map scc_payloads (stronglyConnCompFromEdgedVerticesUniq (map mk_graph_node nodes))

+  , let binds = [ b | BindNode { depNodeBind = b } <- comp_nodes ]

+  ]

+  where

+    key_set = mkVarSet (map depNodeKey nodes)