(which is always substituted) with the tyvar-replete-with-unfolding, rather

   than merely extending the in-scope set as we do for Ids.

 Note [Core top-level string literals]

 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 As an exception to the usual rule that top-level binders must be lifted,

      cant_float_types

        | not (null tvs), any isTyCoVar float_bndrs

        = (pprTraceWhen (any isId float_bndrs)

          True

        | otherwise

        = False

                           , mkCast, exprType, exprIsHNF

                           , stripTicksTop, mkInScopeSetBndrs )

 import GHC.Core.FVs

 import GHC.Core.Opt.Arity( collectBindersPushingCo )

 import GHC.Core.Opt.Monad

 import GHC.Core.Opt.Simplify.Env ( SimplPhase(..), isActive )

                           , se_rules  = rule_env

                           , se_dflags = dflags }

              go (bind:binds) = do (bind', binds', uds') <- specBind TopLevel top_env bind $ \_ ->

                                                            go binds

              -- Specialise the bindings of this module

        ; (binds', uds) <- runSpecM (go binds)

        ; (spec_rules, spec_binds) <- specImports top_env uds

                       , mg_rules = spec_rules ++ local_rules }) }

 {-

 'specImports' returns a set of specialized bindings. However, these are lacking

 necessary floated dictionary bindings, which are returned by

 UsageDetails(ud_binds). These dictionaries need to be brought into scope with

 for instance, the 'specImports' call in 'specProgram'.

 specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls })

   | not $ gopt Opt_CrossModuleSpecialise (se_dflags top_env)

     -- See Note [Disabling cross-module specialisation]

   | otherwise

   = do { let env_w_dict_bndrs = top_env `bringFloatedDictsIntoScope` dict_binds

              -- Make a Rec: see Note [Glom the bindings if imported functions are specialised]

              --

              --   bindings for the needed dictionaries.

              --   See Note [Wrap bindings returned by specImports]

              --

        ; let (rules_for_locals, rules_for_imps) = partition isLocalRule spec_rules

              local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals

              final_binds

                | otherwise       = glomValBinds $

                                    map (mapBindBndrs (addRulesToId local_rule_base)) $

                                    spec_binds

 -- | Specialise a set of calls to imported bindings

 spec_imports :: SpecEnv          -- Passed in so that all top-level Ids are in scope

              -> [Id]             -- Stack of imported functions being specialised

                                  -- See Note [specImport call stack]

                                  -- See Note [Avoiding loops in specImports]

              -> CallDetails      -- Calls for imported things

              -> CoreM ( SpecEnv      -- Env contains the new rules

            ; return (env, rules1 ++ rules2, spec_binds1 ++ spec_binds2) }

 spec_import :: SpecEnv               -- Passed in so that all top-level Ids are in scope

             -> [Id]                  -- Stack of imported functions being specialised

                                      -- See Note [specImport call stack]

                                      -- See Note [Avoiding loops in specImports]

             -> CallInfoSet           -- Imported function and calls for it

             -> CoreM ( SpecEnv

                                     (dict_binds `thenFDBs` dict_binds1)

                                     new_calls

                            spec_binds2 ++ spec_binds1

        ; return (env, rules2 ++ rules1, final_binds) }

 Avoiding this recursive specialisation loop is one reason for the

 'callers' stack passed to specImports and specImport.

 ************************************************************************

 *                                                                      *

   = specExpr env body

   | otherwise

   = do { (body', uds) <- specExpr env body

 --------------

 specTickish :: SpecEnv -> CoreTickish -> CoreTickish

     (env_alt, case_bndr') = substBndr env case_bndr

     spec_alt (Alt con args rhs)

       = do { (rhs', uds) <- specExpr env_rhs rhs

         where

           (env_rhs, args') = substBndrs env_alt args

 ************************************************************************

 -}

   = -- pprTrace "brought into scope" (ppr dx_bndrs) $

     env {se_subst=subst'}

   where

                        -- top level binders in scope

          -> InBind

          -> (SpecEnv -> SpecM (body, UsageDetails))    -- Process the body

                   , body                -- Body

                   , UsageDetails)       -- And info to pass upstream

 -- Returned UsageDetails:

        ; let rhs_ty' = substTy env rhs_ty

              bind' = NonRec tv' (Type rhs_ty')

        ; if float_all then

          else

 specBind top_lvl env (NonRec fn rhs) do_body

   = do { (rhs', rhs_uds) <- specExpr env rhs

        ; let can_float_this_one = exprIsTopLevelBindable rhs (idType fn)

                  -- exprIsTopLevelBindable: see Note [Care with unlifted bindings]

              all_free_uds                    = free_uds `thenUDs` rhs_uds

              pairs = spec_defns ++ [(fn4, rhs')]

                         -- fn4 mentions the spec_defns in its rules,

                         -- so put the latter first

              -- See Note [From non-recursive to recursive]

              final_binds | not (isNilOL dump_dbs)

                          , not (null spec_defns)

                          | otherwise

        ; if float_all then

              -- Rather than discard the calls mentioning the bound variables

              -- we float this (dictionary) binding along with the others

          else

              -- No call in final_uds mentions bound variables,

              -- so we can just leave the binding here

 specBind top_lvl env (Rec pairs) do_body

                               <- specDefns rec_env uds2 (bndrs2 `zip` rhss)

                         ; return (bndrs3, spec_defns3 ++ spec_defns2, uds3) }

              final_bind = recWithDumpedDicts (spec_defns3 ++ zip bndrs3 rhss')

                                              dumped_dbs

        ; if float_all then

          else

 ---------------------------

                  already_covered = alreadyCovered env' rule_bndrs fn

                                                   rule_lhs_args is_active all_rules

            ; if not useful          -- No useful specialisation

            -- Make the RHS of the specialised function

            ; let spec_rhs_bndrs = spec_bndrs ++ inner_rhs_bndrs'

                  -- dx_binds comes from the arguments to the call,

                  -- and so can mention poly_qvars but no other local binders

                  spec_rhs = mkLams spec_rhs_bndrs           $

                  rule_rhs_args = spec_bndrs

                  -- Maybe add a void arg to the specialised function,

                  -- The wrap_unf_body applies the original unfolding to the specialised

                  -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)

                  simpl_opts = initSimpleOpts dflags

                  spec_unf = specUnfolding simpl_opts rule_rhs_args1 wrap_unf_body

                                           rule_lhs_args fn_unf

   ppr UnspecType    = text "UnspecType"

   ppr UnspecArg     = text "UnspecArg"

     foldr (unionFV . get) emptyFV args

   where

     get :: SpecArg -> FV

                 -- `$sf = \spec_bndrs. let { dx_binds } in <orig-rhs> spec_arg`

               , [OutBndr]    -- spec_bndrs: Binders for $sf, and args for the RHS

                              --             of the RULE. Subset of rule_bndrs.

               , [OutExpr]    -- spec_args:  Specialised arguments for unfolding

                              --             Same length as "Args for LHS of rule"

               )

 -- If we run out of binders, stop immediately

 -- See Note [Specialisation Must Preserve Sharing]

 -- We want to specialise on type 'T1', and so we must construct a substitution

 -- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding

 -- a wildcard binder to match the dictionary (See Note [Specialising Calls] for

 -- the nitty-gritty), as a LHS rule and unfolding details.

 specHeader subst (bndr:bndrs) (SpecDict dict_arg : args)

          -- It might turn into a dict binding (via bindAuxiliaryDict) which we

          -- then float, so we use cloneIdBndr to get a completely fresh binder

                  -- zapIdOccInfo: see Note [Zap occ info in rule binders]

          -- Extend the substitution to map bndr :-> dict_arg, for use in the RHS

               , bndr' : rule_bs, Var bndr' : rule_es

               , spec_bs,    dx', spec_dict : spec_args ) }

               , bndrs ++ spec_bs, dx, dummy_arg : spec_args ) }

 -- | Binds a dictionary argument to a fresh name, to preserve sharing

 bindAuxiliaryDict

   :: Subst

   -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression

 bindAuxiliaryDict subst orig_dict_id fresh_dict_id dict_arg

   -- If the dictionary argument is trivial,

   | exprIsTrivial dict_arg

   , let subst' = Core.extendSubst subst orig_dict_id dict_arg

   = -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_arg) $

   | otherwise  -- Non-trivial dictionary arg; make an auxiliary binding

   , let fresh_dict_id' = fresh_dict_id `addDictUnfolding` dict_arg

                     `Core.extendSubstInScope` fresh_dict_id'

                     -- Ensure the new unfolding is in the in-scope set

   = -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id') $

 addDictUnfolding :: Id -> CoreExpr -> Id

 -- Add unfolding for freshly-bound Ids: see Note [Make the new dictionaries interesting]

 ********************************************************************* -}

 data UsageDetails

          , ud_calls :: !CallDetails }

     -- Then 'calls' may *mention* 'bs',

     -- but there should be no calls *for* bs

                -- The order is important;

                -- in ds1 `appOL` ds2, bindings in ds2 can depend on those in ds1

                -- Caches a superset of the expression

                -- for later addition to an InScopeSet

 -- variables (both type variables and dictionaries). We need this set

 -- captured by a binder

 {- Note [Floated dictionary bindings]

 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 These all float above the binding for 'f', and now we can

 successfully specialise 'f'.

 non-dictionary bindings too.

 Note [Specialising polymorphic dictionaries]

         CIS wimwam (CI { ci_key = [@(ST s), dMST @s]

                        , ci_fvs = {dMST} })

       when we come to the /\s.  Instead, we simply let it continue to float

   NB to be fully kosher we should explicitly quantifying the CallInfo

   over 's', but we don't bother.  This would matter if there was an

 see Note [Which type variables to abstract over] in that module.

 -}

     = text "DB" <+> braces (sep [ text "fvs: " <+> ppr fvs

                                 , text "bind:" <+> ppr bind ])

                 [text "binds" <+> equals <+> ppr dbs,

                  text "calls" <+> equals <+> ppr calls]))

 emptyUDs :: UsageDetails

 emptyUDs = MkUD { ud_binds = emptyFDBs, ud_calls = emptyDVarEnv }

 ------------------------------------------------------------

 type CallDetails  = DIdEnv CallInfoSet

   = CI { ci_key  :: [SpecArg]   -- Arguments of the call

                                 -- See Note [The (CI-KEY) invariant]

                                 -- /not/ including the main id itself, of course

                                 --     See Note [Specialising polymorphic dictionaries]

     }

 ------------------------------------------------------------

   = MkUD {ud_binds = emptyFDBs,

           ud_calls = unitDVarEnv id $ CIS id $

   where

 mkCallUDs :: SpecEnv -> OutExpr -> [OutExpr] -> UsageDetails

 mkCallUDs env fun args

   | wantCallsFor env f    -- We want it, and...

   , not (null ci_key)     -- this call site has a useful specialisation

   = -- pprTrace "mkCallUDs: keeping" _trace_doc

   | otherwise  -- See also Note [Specialisations already covered]

   = -- pprTrace "mkCallUDs: discarding" _trace_doc

   = MkUD { ud_binds       = db1    `thenFDBs`   db2

          , ud_calls       = calls1 `unionCalls`  calls2 }

 -- In (dbs1 `thenFDBs` dbs2), dbs2 may mention dbs1 but not vice versa

 -----------------------------

 -- | Identify the free variables of a 'CoreBind'

 bind_fvs :: CoreBind -> VarSet

         --         whether a dictionary binding depends on an imported

         --         DFun in case we try to specialise that imported DFun

 -- pairs, into a single recursive binding.

 recWithDumpedDicts pairs dbs

   where

     (bindings, fvs) = foldr add ([], emptyVarSet)

                                 (dbs `snocOL` mkDB (Rec pairs))

       = case bind of

           NonRec b r -> ((b,r) : prs_acc, fvs')

           Rec prs1   -> (prs1 ++ prs_acc, fvs')

       where

         fvs' = fvs_acc `unionVarSet` fvs

 -- Add ud_binds to the tail end of the bindings in uds

   = foldr add binds dbs

   where

   = foldr add expr dbs

   where

 ----------------------