never executed always true always false
    1 
    2 {-# LANGUAGE DeriveFunctor #-}
    3 
    4 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
    5 {-# LANGUAGE NamedFieldPuns #-}
    6 
    7 {-
    8 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
    9 
   10 \section{Tidying up Core}
   11 -}
   12 
   13 module GHC.Iface.Tidy (
   14        mkBootModDetailsTc, tidyProgram
   15    ) where
   16 
   17 import GHC.Prelude
   18 
   19 import GHC.Driver.Session
   20 import GHC.Driver.Backend
   21 import GHC.Driver.Ppr
   22 import GHC.Driver.Env
   23 
   24 import GHC.Tc.Types
   25 import GHC.Tc.Utils.Env
   26 
   27 import GHC.Core
   28 import GHC.Core.Unfold
   29 import GHC.Core.Unfold.Make
   30 import GHC.Core.FVs
   31 import GHC.Core.Tidy
   32 import GHC.Core.Opt.Monad
   33 import GHC.Core.Stats   (coreBindsStats, CoreStats(..))
   34 import GHC.Core.Seq     (seqBinds)
   35 import GHC.Core.Lint
   36 import GHC.Core.Rules
   37 import GHC.Core.Opt.Arity   ( exprArity, exprBotStrictness_maybe )
   38 import GHC.Core.InstEnv
   39 import GHC.Core.Type     ( tidyTopType )
   40 import GHC.Core.DataCon
   41 import GHC.Core.TyCon
   42 import GHC.Core.Class
   43 
   44 import GHC.Iface.Tidy.StaticPtrTable
   45 import GHC.Iface.Env
   46 
   47 import GHC.Utils.Outputable
   48 import GHC.Utils.Misc( filterOut )
   49 import GHC.Utils.Panic
   50 import GHC.Utils.Trace
   51 import GHC.Utils.Logger as Logger
   52 import qualified GHC.Utils.Error as Err
   53 
   54 import GHC.Types.ForeignStubs
   55 import GHC.Types.Var.Env
   56 import GHC.Types.Var.Set
   57 import GHC.Types.Var
   58 import GHC.Types.Id
   59 import GHC.Types.Id.Make ( mkDictSelRhs )
   60 import GHC.Types.Id.Info
   61 import GHC.Types.Demand  ( appIsDeadEnd, isTopSig, isDeadEndSig )
   62 import GHC.Types.Cpr     ( mkCprSig, botCpr )
   63 import GHC.Types.Basic
   64 import GHC.Types.Name hiding (varName)
   65 import GHC.Types.Name.Set
   66 import GHC.Types.Name.Cache
   67 import GHC.Types.Name.Ppr
   68 import GHC.Types.Avail
   69 import GHC.Types.Tickish
   70 import GHC.Types.TypeEnv
   71 
   72 import GHC.Unit.Module
   73 import GHC.Unit.Module.ModGuts
   74 import GHC.Unit.Module.ModDetails
   75 import GHC.Unit.Module.Deps
   76 
   77 import GHC.Data.Maybe
   78 
   79 import Control.Monad
   80 import Data.Function
   81 import Data.List        ( sortBy, mapAccumL )
   82 import qualified Data.Set as S
   83 import GHC.Platform.Ways
   84 import GHC.Types.CostCentre
   85 
   86 {-
   87 Constructing the TypeEnv, Instances, Rules from which the
   88 ModIface is constructed, and which goes on to subsequent modules in
   89 --make mode.
   90 
   91 Most of the interface file is obtained simply by serialising the
   92 TypeEnv.  One important consequence is that if the *interface file*
   93 has pragma info if and only if the final TypeEnv does. This is not so
   94 important for *this* module, but it's essential for ghc --make:
   95 subsequent compilations must not see (e.g.) the arity if the interface
   96 file does not contain arity If they do, they'll exploit the arity;
   97 then the arity might change, but the iface file doesn't change =>
   98 recompilation does not happen => disaster.
   99 
  100 For data types, the final TypeEnv will have a TyThing for the TyCon,
  101 plus one for each DataCon; the interface file will contain just one
  102 data type declaration, but it is de-serialised back into a collection
  103 of TyThings.
  104 
  105 ************************************************************************
  106 *                                                                      *
  107                 Plan A: simpleTidyPgm
  108 *                                                                      *
  109 ************************************************************************
  110 
  111 
  112 Plan A: mkBootModDetails: omit pragmas, make interfaces small
  113 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  114 * Ignore the bindings
  115 
  116 * Drop all WiredIn things from the TypeEnv
  117         (we never want them in interface files)
  118 
  119 * Retain all TyCons and Classes in the TypeEnv, to avoid
  120         having to find which ones are mentioned in the
  121         types of exported Ids
  122 
  123 * Trim off the constructors of non-exported TyCons, both
  124         from the TyCon and from the TypeEnv
  125 
  126 * Drop non-exported Ids from the TypeEnv
  127 
  128 * Tidy the types of the DFunIds of Instances,
  129   make them into GlobalIds, (they already have External Names)
  130   and add them to the TypeEnv
  131 
  132 * Tidy the types of the (exported) Ids in the TypeEnv,
  133   make them into GlobalIds (they already have External Names)
  134 
  135 * Drop rules altogether
  136 
  137 * Tidy the bindings, to ensure that the Arity
  138   information is correct for each top-level binder; the
  139   code generator needs it. And to ensure that local names have
  140   distinct OccNames in case of object-file splitting
  141 
  142 * If this an hsig file, drop the instances altogether too (they'll
  143   get pulled in by the implicit module import.
  144 -}
  145 
  146 -- This is Plan A: make a small type env when typechecking only,
  147 -- or when compiling a hs-boot file, or simply when not using -O
  148 --
  149 -- We don't look at the bindings at all -- there aren't any
  150 -- for hs-boot files
  151 
  152 mkBootModDetailsTc :: Logger -> TcGblEnv -> IO ModDetails
  153 mkBootModDetailsTc logger
  154         TcGblEnv{ tcg_exports          = exports,
  155                   tcg_type_env         = type_env, -- just for the Ids
  156                   tcg_tcs              = tcs,
  157                   tcg_patsyns          = pat_syns,
  158                   tcg_insts            = insts,
  159                   tcg_fam_insts        = fam_insts,
  160                   tcg_complete_matches = complete_matches,
  161                   tcg_mod              = this_mod
  162                 }
  163   = -- This timing isn't terribly useful since the result isn't forced, but
  164     -- the message is useful to locating oneself in the compilation process.
  165     Err.withTiming logger
  166                    (text "CoreTidy"<+>brackets (ppr this_mod))
  167                    (const ()) $
  168     return (ModDetails { md_types            = type_env'
  169                        , md_insts            = insts'
  170                        , md_fam_insts        = fam_insts
  171                        , md_rules            = []
  172                        , md_anns             = []
  173                        , md_exports          = exports
  174                        , md_complete_matches = complete_matches
  175                        })
  176   where
  177     -- Find the LocalIds in the type env that are exported
  178     -- Make them into GlobalIds, and tidy their types
  179     --
  180     -- It's very important to remove the non-exported ones
  181     -- because we don't tidy the OccNames, and if we don't remove
  182     -- the non-exported ones we'll get many things with the
  183     -- same name in the interface file, giving chaos.
  184     --
  185     -- Do make sure that we keep Ids that are already Global.
  186     -- When typechecking an .hs-boot file, the Ids come through as
  187     -- GlobalIds.
  188     final_ids = [ globaliseAndTidyBootId id
  189                 | id <- typeEnvIds type_env
  190                 , keep_it id ]
  191 
  192     final_tcs  = filterOut isWiredIn tcs
  193                  -- See Note [Drop wired-in things]
  194     type_env'  = typeEnvFromEntities final_ids final_tcs pat_syns fam_insts
  195     insts'     = mkFinalClsInsts type_env' insts
  196 
  197     -- Default methods have their export flag set (isExportedId),
  198     -- but everything else doesn't (yet), because this is
  199     -- pre-desugaring, so we must test against the exports too.
  200     keep_it id | isWiredInName id_name           = False
  201                  -- See Note [Drop wired-in things]
  202                | isExportedId id                 = True
  203                | id_name `elemNameSet` exp_names = True
  204                | otherwise                       = False
  205                where
  206                  id_name = idName id
  207 
  208     exp_names = availsToNameSet exports
  209 
  210 lookupFinalId :: TypeEnv -> Id -> Id
  211 lookupFinalId type_env id
  212   = case lookupTypeEnv type_env (idName id) of
  213       Just (AnId id') -> id'
  214       _ -> pprPanic "lookup_final_id" (ppr id)
  215 
  216 mkFinalClsInsts :: TypeEnv -> [ClsInst] -> [ClsInst]
  217 mkFinalClsInsts env = map (updateClsInstDFun (lookupFinalId env))
  218 
  219 globaliseAndTidyBootId :: Id -> Id
  220 -- For a LocalId with an External Name,
  221 -- makes it into a GlobalId
  222 --     * unchanged Name (might be Internal or External)
  223 --     * unchanged details
  224 --     * VanillaIdInfo (makes a conservative assumption about arity)
  225 --     * BootUnfolding (see Note [Inlining and hs-boot files] in GHC.CoreToIface)
  226 globaliseAndTidyBootId id
  227   = updateIdTypeAndMult tidyTopType (globaliseId id)
  228                    `setIdUnfolding` BootUnfolding
  229 
  230 {-
  231 ************************************************************************
  232 *                                                                      *
  233         Plan B: tidy bindings, make TypeEnv full of IdInfo
  234 *                                                                      *
  235 ************************************************************************
  236 
  237 Plan B: include pragmas, make interfaces
  238 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  239 * Step 1: Figure out which Ids are externally visible
  240           See Note [Choosing external Ids]
  241 
  242 * Step 2: Gather the externally visible rules, separately from
  243           the top-level bindings.
  244           See Note [Finding external rules]
  245 
  246 * Step 3: Tidy the bindings, externalising appropriate Ids
  247           See Note [Tidy the top-level bindings]
  248 
  249 * Drop all Ids from the TypeEnv, and add all the External Ids from
  250   the bindings.  (This adds their IdInfo to the TypeEnv; and adds
  251   floated-out Ids that weren't even in the TypeEnv before.)
  252 
  253 Note [Choosing external Ids]
  254 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  255 See also the section "Interface stability" in the
  256 recompilation-avoidance commentary:
  257   https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/recompilation-avoidance
  258 
  259 First we figure out which Ids are "external" Ids.  An
  260 "external" Id is one that is visible from outside the compilation
  261 unit.  These are
  262   a) the user exported ones
  263   b) the ones bound to static forms
  264   c) ones mentioned in the unfoldings, workers, or
  265      rules of externally-visible ones
  266 
  267 While figuring out which Ids are external, we pick a "tidy" OccName
  268 for each one.  That is, we make its OccName distinct from the other
  269 external OccNames in this module, so that in interface files and
  270 object code we can refer to it unambiguously by its OccName.  The
  271 OccName for each binder is prefixed by the name of the exported Id
  272 that references it; e.g. if "f" references "x" in its unfolding, then
  273 "x" is renamed to "f_x".  This helps distinguish the different "x"s
  274 from each other, and means that if "f" is later removed, things that
  275 depend on the other "x"s will not need to be recompiled.  Of course,
  276 if there are multiple "f_x"s, then we have to disambiguate somehow; we
  277 use "f_x0", "f_x1" etc.
  278 
  279 As far as possible we should assign names in a deterministic fashion.
  280 Each time this module is compiled with the same options, we should end
  281 up with the same set of external names with the same types.  That is,
  282 the ABI hash in the interface should not change.  This turns out to be
  283 quite tricky, since the order of the bindings going into the tidy
  284 phase is already non-deterministic, as it is based on the ordering of
  285 Uniques, which are assigned unpredictably.
  286 
  287 To name things in a stable way, we do a depth-first-search of the
  288 bindings, starting from the exports sorted by name.  This way, as long
  289 as the bindings themselves are deterministic (they sometimes aren't!),
  290 the order in which they are presented to the tidying phase does not
  291 affect the names we assign.
  292 
  293 Note [Tidy the top-level bindings]
  294 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  295 Next we traverse the bindings top to bottom.  For each *top-level*
  296 binder
  297 
  298  1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal,
  299     reflecting the fact that from now on we regard it as a global,
  300     not local, Id
  301 
  302  2. Give it a system-wide Unique.
  303     [Even non-exported things need system-wide Uniques because the
  304     byte-code generator builds a single Name->BCO symbol table.]
  305 
  306     We use the NameCache kept in the HscEnv as the
  307     source of such system-wide uniques.
  308 
  309     For external Ids, use the original-name cache in the NameCache
  310     to ensure that the unique assigned is the same as the Id had
  311     in any previous compilation run.
  312 
  313  3. Rename top-level Ids according to the names we chose in step 1.
  314     If it's an external Id, make it have a External Name, otherwise
  315     make it have an Internal Name.  This is used by the code generator
  316     to decide whether to make the label externally visible
  317 
  318  4. Give it its UTTERLY FINAL IdInfo; in ptic,
  319         * its unfolding, if it should have one
  320 
  321         * its arity, computed from the number of visible lambdas
  322 
  323 
  324 Finally, substitute these new top-level binders consistently
  325 throughout, including in unfoldings.  We also tidy binders in
  326 RHSs, so that they print nicely in interfaces.
  327 
  328 Note [Always expose compulsory unfoldings]
  329 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  330 We must make absolutely sure that unsafeCoerce# is inlined. You might
  331 think that giving it a compulsory unfolding is enough. However,
  332 unsafeCoerce# is put in an interface file just like any other definition.
  333 So, unless we take special precuations
  334 - If we compiled Unsafe.Coerce with -O0, we might not put the unfolding
  335   into the interface file.
  336 - If we compile a module M, that imports Unsafe.Coerce, with -O0 we might
  337   not read the unfolding out of the interface file.
  338 
  339 So we need to take care, to ensure that Compulsory unfoldings are written
  340 and read.  That makes sense: they are compulsory, after all. There are
  341 three places this is actioned:
  342 
  343 * GHC.Iface.Tidy.addExternal.  Export end: expose compulsory
  344   unfoldings, even with -O0.
  345 
  346 * GHC.IfaceToCore.tcIdInfo.  Import end: when reading in from
  347   interface file, even with -O0 (fignore-interface-pragmas.)  we must
  348   load a compulsory unfolding
  349 -}
  350 
  351 tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
  352 tidyProgram hsc_env  (ModGuts { mg_module           = mod
  353                               , mg_exports          = exports
  354                               , mg_rdr_env          = rdr_env
  355                               , mg_tcs              = tcs
  356                               , mg_insts            = cls_insts
  357                               , mg_fam_insts        = fam_insts
  358                               , mg_binds            = binds
  359                               , mg_patsyns          = patsyns
  360                               , mg_rules            = imp_rules
  361                               , mg_anns             = anns
  362                               , mg_complete_matches = complete_matches
  363                               , mg_deps             = deps
  364                               , mg_foreign          = foreign_stubs
  365                               , mg_foreign_files    = foreign_files
  366                               , mg_hpc_info         = hpc_info
  367                               , mg_modBreaks        = modBreaks
  368                               })
  369 
  370   = Err.withTiming logger
  371                    (text "CoreTidy"<+>brackets (ppr mod))
  372                    (const ()) $
  373     do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags
  374               ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags
  375               ; print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env
  376               ; implicit_binds = concatMap getImplicitBinds tcs
  377               }
  378 
  379         ; (unfold_env, tidy_occ_env)
  380               <- chooseExternalIds hsc_env mod omit_prags expose_all
  381                                    binds implicit_binds imp_rules
  382         ; let { (trimmed_binds, trimmed_rules)
  383                     = findExternalRules omit_prags binds imp_rules unfold_env }
  384 
  385         ; let uf_opts = unfoldingOpts dflags
  386         ; (tidy_env, tidy_binds)
  387                  <- tidyTopBinds uf_opts unfold_env tidy_occ_env trimmed_binds
  388 
  389           -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
  390         ; (spt_entries, tidy_binds') <-
  391              sptCreateStaticBinds hsc_env mod tidy_binds
  392         ; let { platform = targetPlatform (hsc_dflags hsc_env)
  393               ; spt_init_code = sptModuleInitCode platform mod spt_entries
  394               ; add_spt_init_code =
  395                   case backend dflags of
  396                     -- If we are compiling for the interpreter we will insert
  397                     -- any necessary SPT entries dynamically
  398                     Interpreter -> id
  399                     -- otherwise add a C stub to do so
  400                     _              -> (`appendStubC` spt_init_code)
  401 
  402               -- The completed type environment is gotten from
  403               --      a) the types and classes defined here (plus implicit things)
  404               --      b) adding Ids with correct IdInfo, including unfoldings,
  405               --              gotten from the bindings
  406               -- From (b) we keep only those Ids with External names;
  407               --          the CoreTidy pass makes sure these are all and only
  408               --          the externally-accessible ones
  409               -- This truncates the type environment to include only the
  410               -- exported Ids and things needed from them, which saves space
  411               --
  412               -- See Note [Don't attempt to trim data types]
  413               ; final_ids  = [ trimId omit_prags id
  414                              | id <- bindersOfBinds tidy_binds
  415                              , isExternalName (idName id)
  416                              , not (isWiredIn id)
  417                              ]   -- See Note [Drop wired-in things]
  418 
  419               ; final_tcs      = filterOut isWiredIn tcs
  420                                  -- See Note [Drop wired-in things]
  421               ; tidy_type_env  = typeEnvFromEntities final_ids final_tcs patsyns fam_insts
  422               ; tidy_cls_insts = mkFinalClsInsts tidy_type_env cls_insts
  423               ; tidy_rules     = tidyRules tidy_env trimmed_rules
  424 
  425               ; -- See Note [Injecting implicit bindings]
  426                 all_tidy_binds = implicit_binds ++ tidy_binds'
  427 
  428               -- Get the TyCons to generate code for.  Careful!  We must use
  429               -- the untidied TyCons here, because we need
  430               --  (a) implicit TyCons arising from types and classes defined
  431               --      in this module
  432               --  (b) wired-in TyCons, which are normally removed from the
  433               --      TypeEnv we put in the ModDetails
  434               --  (c) Constructors even if they are not exported (the
  435               --      tidied TypeEnv has trimmed these away)
  436               ; alg_tycons = filter isAlgTyCon tcs
  437 
  438 
  439               ; local_ccs
  440                   | ways dflags `hasWay` WayProf
  441                         = collectCostCentres mod all_tidy_binds tidy_rules
  442                   | otherwise
  443                         = S.empty
  444               }
  445 
  446         ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules
  447 
  448           -- If the endPass didn't print the rules, but ddump-rules is
  449           -- on, print now
  450         ; unless (logHasDumpFlag logger Opt_D_dump_simpl) $
  451             Logger.putDumpFileMaybe logger Opt_D_dump_rules
  452               (showSDoc dflags (ppr CoreTidy <+> text "rules"))
  453               FormatText
  454               (pprRulesForUser tidy_rules)
  455 
  456           -- Print one-line size info
  457         ; let cs = coreBindsStats tidy_binds
  458         ; Logger.putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats"
  459             FormatText
  460             (text "Tidy size (terms,types,coercions)"
  461              <+> ppr (moduleName mod) <> colon
  462              <+> int (cs_tm cs)
  463              <+> int (cs_ty cs)
  464              <+> int (cs_co cs) )
  465 
  466         ; return (CgGuts { cg_module   = mod,
  467                            cg_tycons   = alg_tycons,
  468                            cg_binds    = all_tidy_binds,
  469                            cg_ccs      = S.toList local_ccs,
  470                            cg_foreign  = add_spt_init_code foreign_stubs,
  471                            cg_foreign_files = foreign_files,
  472                            cg_dep_pkgs = dep_direct_pkgs deps,
  473                            cg_hpc_info = hpc_info,
  474                            cg_modBreaks = modBreaks,
  475                            cg_spt_entries = spt_entries },
  476 
  477                    ModDetails { md_types            = tidy_type_env,
  478                                 md_rules            = tidy_rules,
  479                                 md_insts            = tidy_cls_insts,
  480                                 md_fam_insts        = fam_insts,
  481                                 md_exports          = exports,
  482                                 md_anns             = anns,      -- are already tidy
  483                                 md_complete_matches = complete_matches
  484                               })
  485         }
  486   where
  487     dflags = hsc_dflags hsc_env
  488     logger = hsc_logger hsc_env
  489 
  490 
  491 ------------------------------------------------------------------------------
  492 -- Collecting cost centres
  493 -- ---------------------------------------------------------------------------
  494 
  495 -- | Collect cost centres defined in the current module, including those in
  496 -- unfoldings.
  497 collectCostCentres :: Module -> CoreProgram -> [CoreRule] -> S.Set CostCentre
  498 collectCostCentres mod_name binds rules
  499   = foldl' go_bind (go_rules S.empty) binds
  500   where
  501     go cs e = case e of
  502       Var{} -> cs
  503       Lit{} -> cs
  504       App e1 e2 -> go (go cs e1) e2
  505       Lam _ e -> go cs e
  506       Let b e -> go (go_bind cs b) e
  507       Case scrt _ _ alts -> go_alts (go cs scrt) alts
  508       Cast e _ -> go cs e
  509       Tick (ProfNote cc _ _) e ->
  510         go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e
  511       Tick _ e -> go cs e
  512       Type{} -> cs
  513       Coercion{} -> cs
  514 
  515     go_alts = foldl' (\cs (Alt _con _bndrs e) -> go cs e)
  516 
  517     go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre
  518     go_bind cs (NonRec b e) =
  519       go (do_binder cs b) e
  520     go_bind cs (Rec bs) =
  521       foldl' (\cs' (b, e) -> go (do_binder cs' b) e) cs bs
  522 
  523     do_binder cs b = maybe cs (go cs) (get_unf b)
  524 
  525 
  526     -- Unfoldings may have cost centres that in the original definion are
  527     -- optimized away, see #5889.
  528     get_unf = maybeUnfoldingTemplate . realIdUnfolding
  529 
  530     -- Have to look at the RHS of rules as well, as these may contain ticks which
  531     -- don't appear anywhere else. See #19894
  532     go_rules cs = foldl' go cs (mapMaybe get_rhs rules)
  533 
  534     get_rhs Rule { ru_rhs } = Just ru_rhs
  535     get_rhs BuiltinRule {} = Nothing
  536 
  537 --------------------------
  538 trimId :: Bool -> Id -> Id
  539 -- With -O0 we now trim off the arity, one-shot-ness, strictness
  540 -- etc which tidyTopIdInfo retains for the benefit of the code generator
  541 -- but which we don't want in the interface file or ModIface for
  542 -- downstream compilations
  543 trimId omit_prags id
  544   | omit_prags, not (isImplicitId id)
  545   = id `setIdInfo`      vanillaIdInfo
  546        `setIdUnfolding` idUnfolding id
  547        -- We respect the final unfolding chosen by tidyTopIdInfo.
  548        -- We have already trimmed it if we don't want it for -O0;
  549        -- see also Note [Always expose compulsory unfoldings]
  550 
  551   | otherwise   -- No trimming
  552   = id
  553 
  554 {- Note [Drop wired-in things]
  555 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  556 We never put wired-in TyCons or Ids in an interface file.
  557 They are wired-in, so the compiler knows about them already.
  558 
  559 Note [Don't attempt to trim data types]
  560 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  561 For some time GHC tried to avoid exporting the data constructors
  562 of a data type if it wasn't strictly necessary to do so; see #835.
  563 But "strictly necessary" accumulated a longer and longer list
  564 of exceptions, and finally I gave up the battle:
  565 
  566     commit 9a20e540754fc2af74c2e7392f2786a81d8d5f11
  567     Author: Simon Peyton Jones <simonpj@microsoft.com>
  568     Date:   Thu Dec 6 16:03:16 2012 +0000
  569 
  570     Stop attempting to "trim" data types in interface files
  571 
  572     Without -O, we previously tried to make interface files smaller
  573     by not including the data constructors of data types.  But
  574     there are a lot of exceptions, notably when Template Haskell is
  575     involved or, more recently, DataKinds.
  576 
  577     However #7445 shows that even without TemplateHaskell, using
  578     the Data class and invoking Language.Haskell.TH.Quote.dataToExpQ
  579     is enough to require us to expose the data constructors.
  580 
  581     So I've given up on this "optimisation" -- it's probably not
  582     important anyway.  Now I'm simply not attempting to trim off
  583     the data constructors.  The gain in simplicity is worth the
  584     modest cost in interface file growth, which is limited to the
  585     bits reqd to describe those data constructors.
  586 
  587 ************************************************************************
  588 *                                                                      *
  589         Implicit bindings
  590 *                                                                      *
  591 ************************************************************************
  592 
  593 Note [Injecting implicit bindings]
  594 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  595 We inject the implicit bindings right at the end, in GHC.Core.Tidy.
  596 Some of these bindings, notably record selectors, are not
  597 constructed in an optimised form.  E.g. record selector for
  598         data T = MkT { x :: {-# UNPACK #-} !Int }
  599 Then the unfolding looks like
  600         x = \t. case t of MkT x1 -> let x = I# x1 in x
  601 This generates bad code unless it's first simplified a bit.  That is
  602 why GHC.Core.Unfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of
  603 optimisation first.  (Only matters when the selector is used curried;
  604 eg map x ys.)  See #2070.
  605 
  606 [Oct 09: in fact, record selectors are no longer implicit Ids at all,
  607 because we really do want to optimise them properly. They are treated
  608 much like any other Id.  But doing "light" optimisation on an implicit
  609 Id still makes sense.]
  610 
  611 At one time I tried injecting the implicit bindings *early*, at the
  612 beginning of SimplCore.  But that gave rise to real difficulty,
  613 because GlobalIds are supposed to have *fixed* IdInfo, but the
  614 simplifier and other core-to-core passes mess with IdInfo all the
  615 time.  The straw that broke the camels back was when a class selector
  616 got the wrong arity -- ie the simplifier gave it arity 2, whereas
  617 importing modules were expecting it to have arity 1 (#2844).
  618 It's much safer just to inject them right at the end, after tidying.
  619 
  620 Oh: two other reasons for injecting them late:
  621 
  622   - If implicit Ids are already in the bindings when we start tidying,
  623     we'd have to be careful not to treat them as external Ids (in
  624     the sense of chooseExternalIds); else the Ids mentioned in *their*
  625     RHSs will be treated as external and you get an interface file
  626     saying      a18 = <blah>
  627     but nothing referring to a18 (because the implicit Id is the
  628     one that does, and implicit Ids don't appear in interface files).
  629 
  630   - More seriously, the tidied type-envt will include the implicit
  631     Id replete with a18 in its unfolding; but we won't take account
  632     of a18 when computing a fingerprint for the class; result chaos.
  633 
  634 There is one sort of implicit binding that is injected still later,
  635 namely those for data constructor workers. Reason (I think): it's
  636 really just a code generation trick.... binding itself makes no sense.
  637 See Note [Data constructor workers] in "GHC.CoreToStg.Prep".
  638 -}
  639 
  640 getImplicitBinds :: TyCon -> [CoreBind]
  641 getImplicitBinds tc = cls_binds ++ getTyConImplicitBinds tc
  642   where
  643     cls_binds = maybe [] getClassImplicitBinds (tyConClass_maybe tc)
  644 
  645 getTyConImplicitBinds :: TyCon -> [CoreBind]
  646 getTyConImplicitBinds tc
  647   | isNewTyCon tc = []  -- See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make
  648   | otherwise     = map get_defn (mapMaybe dataConWrapId_maybe (tyConDataCons tc))
  649 
  650 getClassImplicitBinds :: Class -> [CoreBind]
  651 getClassImplicitBinds cls
  652   = [ NonRec op (mkDictSelRhs cls val_index)
  653     | (op, val_index) <- classAllSelIds cls `zip` [0..] ]
  654 
  655 get_defn :: Id -> CoreBind
  656 get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))
  657 
  658 {-
  659 ************************************************************************
  660 *                                                                      *
  661 \subsection{Step 1: finding externals}
  662 *                                                                      *
  663 ************************************************************************
  664 
  665 See Note [Choosing external Ids].
  666 -}
  667 
  668 type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})
  669   -- Maps each top-level Id to its new Name (the Id is tidied in step 2)
  670   -- The Unique is unchanged.  If the new Name is external, it will be
  671   -- visible in the interface file.
  672   --
  673   -- Bool => expose unfolding or not.
  674 
  675 chooseExternalIds :: HscEnv
  676                   -> Module
  677                   -> Bool -> Bool
  678                   -> [CoreBind]
  679                   -> [CoreBind]
  680                   -> [CoreRule]
  681                   -> IO (UnfoldEnv, TidyOccEnv)
  682                   -- Step 1 from the notes above
  683 
  684 chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules
  685   = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env
  686        ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders
  687        ; tidy_internal internal_ids unfold_env1 occ_env1 }
  688  where
  689   name_cache = hsc_NC hsc_env
  690 
  691   -- init_ext_ids is the initial list of Ids that should be
  692   -- externalised.  It serves as the starting point for finding a
  693   -- deterministic, tidy, renaming for all external Ids in this
  694   -- module.
  695   --
  696   -- It is sorted, so that it has a deterministic order (i.e. it's the
  697   -- same list every time this module is compiled), in contrast to the
  698   -- bindings, which are ordered non-deterministically.
  699   init_work_list = zip init_ext_ids init_ext_ids
  700   init_ext_ids   = sortBy (compare `on` getOccName) $ filter is_external binders
  701 
  702   -- An Id should be external if either (a) it is exported,
  703   -- (b) it appears in the RHS of a local rule for an imported Id, or
  704   -- See Note [Which rules to expose]
  705   is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars
  706 
  707   rule_rhs_vars
  708     -- No rules are exposed when omit_prags is enabled see #19836
  709     -- imp_id_rules are the RULES in /this/ module for /imported/ Ids
  710     -- If omit_prags is True, these rules won't be put in the interface file.
  711     -- But if omit_prags is False, so imp_id_rules are in the interface file for
  712     -- this module, then the local-defined Ids they use must be made external.
  713     | omit_prags = emptyVarSet
  714     | otherwise = mapUnionVarSet ruleRhsFreeVars imp_id_rules
  715 
  716   binders          = map fst $ flattenBinds binds
  717   implicit_binders = bindersOfBinds implicit_binds
  718   binder_set       = mkVarSet binders
  719 
  720   avoids   = [getOccName name | bndr <- binders ++ implicit_binders,
  721                                 let name = idName bndr,
  722                                 isExternalName name ]
  723                 -- In computing our "avoids" list, we must include
  724                 --      all implicit Ids
  725                 --      all things with global names (assigned once and for
  726                 --                                      all by the renamer)
  727                 -- since their names are "taken".
  728                 -- The type environment is a convenient source of such things.
  729                 -- In particular, the set of binders doesn't include
  730                 -- implicit Ids at this stage.
  731 
  732         -- We also make sure to avoid any exported binders.  Consider
  733         --      f{-u1-} = 1     -- Local decl
  734         --      ...
  735         --      f{-u2-} = 2     -- Exported decl
  736         --
  737         -- The second exported decl must 'get' the name 'f', so we
  738         -- have to put 'f' in the avoids list before we get to the first
  739         -- decl.  tidyTopId then does a no-op on exported binders.
  740   init_occ_env = initTidyOccEnv avoids
  741 
  742 
  743   search :: [(Id,Id)]    -- The work-list: (external id, referring id)
  744                          -- Make a tidy, external Name for the external id,
  745                          --   add it to the UnfoldEnv, and do the same for the
  746                          --   transitive closure of Ids it refers to
  747                          -- The referring id is used to generate a tidy
  748                          ---  name for the external id
  749          -> UnfoldEnv    -- id -> (new Name, show_unfold)
  750          -> TidyOccEnv   -- occ env for choosing new Names
  751          -> IO (UnfoldEnv, TidyOccEnv)
  752 
  753   search [] unfold_env occ_env = return (unfold_env, occ_env)
  754 
  755   search ((idocc,referrer) : rest) unfold_env occ_env
  756     | idocc `elemVarEnv` unfold_env = search rest unfold_env occ_env
  757     | otherwise = do
  758       (occ_env', name') <- tidyTopName mod name_cache (Just referrer) occ_env idocc
  759       let
  760           (new_ids, show_unfold) = addExternal omit_prags expose_all refined_id
  761 
  762                 -- 'idocc' is an *occurrence*, but we need to see the
  763                 -- unfolding in the *definition*; so look up in binder_set
  764           refined_id = case lookupVarSet binder_set idocc of
  765                          Just id -> id
  766                          Nothing -> warnPprTrace True (ppr idocc) idocc
  767 
  768           unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)
  769           referrer' | isExportedId refined_id = refined_id
  770                     | otherwise               = referrer
  771       --
  772       search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env'
  773 
  774   tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv
  775                 -> IO (UnfoldEnv, TidyOccEnv)
  776   tidy_internal []       unfold_env occ_env = return (unfold_env,occ_env)
  777   tidy_internal (id:ids) unfold_env occ_env = do
  778       (occ_env', name') <- tidyTopName mod name_cache Nothing occ_env id
  779       let unfold_env' = extendVarEnv unfold_env id (name',False)
  780       tidy_internal ids unfold_env' occ_env'
  781 
  782 addExternal :: Bool -> Bool -> Id -> ([Id], Bool)
  783 addExternal omit_prags expose_all id
  784   | omit_prags
  785   , not (isCompulsoryUnfolding unfolding)
  786   = ([], False)  -- See Note [Always expose compulsory unfoldings]
  787                  -- in GHC.HsToCore
  788 
  789   | otherwise
  790   = (new_needed_ids, show_unfold)
  791 
  792   where
  793     new_needed_ids = bndrFvsInOrder show_unfold id
  794     idinfo         = idInfo id
  795     unfolding      = realUnfoldingInfo idinfo
  796     show_unfold    = show_unfolding unfolding
  797     never_active   = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo))
  798     loop_breaker   = isStrongLoopBreaker (occInfo idinfo)
  799     bottoming_fn   = isDeadEndSig (dmdSigInfo idinfo)
  800 
  801         -- Stuff to do with the Id's unfolding
  802         -- We leave the unfolding there even if there is a worker
  803         -- In GHCi the unfolding is used by importers
  804 
  805     show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })
  806        =  expose_all         -- 'expose_all' says to expose all
  807                              -- unfoldings willy-nilly
  808 
  809        || isStableSource src     -- Always expose things whose
  810                                  -- source is an inline rule
  811 
  812        || not dont_inline
  813        where
  814          dont_inline
  815             | never_active = True   -- Will never inline
  816             | loop_breaker = True   -- Ditto
  817             | otherwise    = case guidance of
  818                                 UnfWhen {}       -> False
  819                                 UnfIfGoodArgs {} -> bottoming_fn
  820                                 UnfNever {}      -> True
  821          -- bottoming_fn: don't inline bottoming functions, unless the
  822          -- RHS is very small or trivial (UnfWhen), in which case we
  823          -- may as well do so For example, a cast might cancel with
  824          -- the call site.
  825 
  826     show_unfolding (DFunUnfolding {}) = True
  827     show_unfolding _                  = False
  828 
  829 {-
  830 ************************************************************************
  831 *                                                                      *
  832                Deterministic free variables
  833 *                                                                      *
  834 ************************************************************************
  835 
  836 We want a deterministic free-variable list.  exprFreeVars gives us
  837 a VarSet, which is in a non-deterministic order when converted to a
  838 list.  Hence, here we define a free-variable finder that returns
  839 the free variables in the order that they are encountered.
  840 
  841 See Note [Choosing external Ids]
  842 -}
  843 
  844 bndrFvsInOrder :: Bool -> Id -> [Id]
  845 bndrFvsInOrder show_unfold id
  846   = run (dffvLetBndr show_unfold id)
  847 
  848 run :: DFFV () -> [Id]
  849 run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of
  850                  ((_,ids),_) -> ids
  851 
  852 newtype DFFV a
  853   = DFFV (VarSet              -- Envt: non-top-level things that are in scope
  854                               -- we don't want to record these as free vars
  855       -> (VarSet, [Var])      -- Input State: (set, list) of free vars so far
  856       -> ((VarSet,[Var]),a))  -- Output state
  857     deriving (Functor)
  858 
  859 instance Applicative DFFV where
  860     pure a = DFFV $ \_ st -> (st, a)
  861     (<*>) = ap
  862 
  863 instance Monad DFFV where
  864   (DFFV m) >>= k = DFFV $ \env st ->
  865     case m env st of
  866        (st',a) -> case k a of
  867                      DFFV f -> f env st'
  868 
  869 extendScope :: Var -> DFFV a -> DFFV a
  870 extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st)
  871 
  872 extendScopeList :: [Var] -> DFFV a -> DFFV a
  873 extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st)
  874 
  875 insert :: Var -> DFFV ()
  876 insert v = DFFV $ \ env (set, ids) ->
  877            let keep_me = isLocalId v &&
  878                          not (v `elemVarSet` env) &&
  879                            not (v `elemVarSet` set)
  880            in if keep_me
  881               then ((extendVarSet set v, v:ids), ())
  882               else ((set,                ids),   ())
  883 
  884 
  885 dffvExpr :: CoreExpr -> DFFV ()
  886 dffvExpr (Var v)              = insert v
  887 dffvExpr (App e1 e2)          = dffvExpr e1 >> dffvExpr e2
  888 dffvExpr (Lam v e)            = extendScope v (dffvExpr e)
  889 dffvExpr (Tick (Breakpoint _ _ ids) e) = mapM_ insert ids >> dffvExpr e
  890 dffvExpr (Tick _other e)    = dffvExpr e
  891 dffvExpr (Cast e _)           = dffvExpr e
  892 dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e)
  893 dffvExpr (Let (Rec prs) e)    = extendScopeList (map fst prs) $
  894                                 (mapM_ dffvBind prs >> dffvExpr e)
  895 dffvExpr (Case e b _ as)      = dffvExpr e >> extendScope b (mapM_ dffvAlt as)
  896 dffvExpr _other               = return ()
  897 
  898 dffvAlt :: CoreAlt -> DFFV ()
  899 dffvAlt (Alt _ xs r) = extendScopeList xs (dffvExpr r)
  900 
  901 dffvBind :: (Id, CoreExpr) -> DFFV ()
  902 dffvBind(x,r)
  903   | not (isId x) = dffvExpr r
  904   | otherwise    = dffvLetBndr False x >> dffvExpr r
  905                 -- Pass False because we are doing the RHS right here
  906                 -- If you say True you'll get *exponential* behaviour!
  907 
  908 dffvLetBndr :: Bool -> Id -> DFFV ()
  909 -- Gather the free vars of the RULES and unfolding of a binder
  910 -- We always get the free vars of a *stable* unfolding, but
  911 -- for a *vanilla* one (InlineRhs), the flag controls what happens:
  912 --   True <=> get fvs of even a *vanilla* unfolding
  913 --   False <=> ignore an InlineRhs
  914 -- For nested bindings (call from dffvBind) we always say "False" because
  915 --       we are taking the fvs of the RHS anyway
  916 -- For top-level bindings (call from addExternal, via bndrFvsInOrder)
  917 --       we say "True" if we are exposing that unfolding
  918 dffvLetBndr vanilla_unfold id
  919   = do { go_unf (realUnfoldingInfo idinfo)
  920        ; mapM_ go_rule (ruleInfoRules (ruleInfo idinfo)) }
  921   where
  922     idinfo = idInfo id
  923 
  924     go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
  925        = case src of
  926            InlineRhs | vanilla_unfold -> dffvExpr rhs
  927                      | otherwise      -> return ()
  928            _                          -> dffvExpr rhs
  929 
  930     go_unf (DFunUnfolding { df_bndrs = bndrs, df_args = args })
  931              = extendScopeList bndrs $ mapM_ dffvExpr args
  932     go_unf _ = return ()
  933 
  934     go_rule (BuiltinRule {}) = return ()
  935     go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs })
  936       = extendScopeList bndrs (dffvExpr rhs)
  937 
  938 {-
  939 ************************************************************************
  940 *                                                                      *
  941                findExternalRules
  942 *                                                                      *
  943 ************************************************************************
  944 
  945 Note [Finding external rules]
  946 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  947 The complete rules are gotten by combining
  948    a) local rules for imported Ids
  949    b) rules embedded in the top-level Ids
  950 
  951 There are two complications:
  952   * Note [Which rules to expose]
  953   * Note [Trimming auto-rules]
  954 
  955 Note [Which rules to expose]
  956 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  957 The function 'expose_rule' filters out rules that mention, on the LHS,
  958 Ids that aren't externally visible; these rules can't fire in a client
  959 module.
  960 
  961 The externally-visible binders are computed (by chooseExternalIds)
  962 assuming that all orphan rules are externalised (see init_ext_ids in
  963 function 'search'). So in fact it's a bit conservative and we may
  964 export more than we need.  (It's a sort of mutual recursion.)
  965 
  966 Note [Trimming auto-rules]
  967 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
  968 Second, with auto-specialisation we may specialise local or imported
  969 dfuns or INLINE functions, and then later inline them.  That may leave
  970 behind something like
  971    RULE "foo" forall d. f @ Int d = f_spec
  972 where f is either local or imported, and there is no remaining
  973 reference to f_spec except from the RULE.
  974 
  975 Now that RULE *might* be useful to an importing module, but that is
  976 purely speculative, and meanwhile the code is taking up space and
  977 codegen time.  I found that binary sizes jumped by 6-10% when I
  978 started to specialise INLINE functions (again, Note [Inline
  979 specialisations] in GHC.Core.Opt.Specialise).
  980 
  981 So it seems better to drop the binding for f_spec, and the rule
  982 itself, if the auto-generated rule is the *only* reason that it is
  983 being kept alive.
  984 
  985 (The RULE still might have been useful in the past; that is, it was
  986 the right thing to have generated it in the first place.  See Note
  987 [Inline specialisations] in GHC.Core.Opt.Specialise. But now it has
  988 served its purpose, and can be discarded.)
  989 
  990 So findExternalRules does this:
  991   * Remove all bindings that are kept alive *only* by isAutoRule rules
  992       (this is done in trim_binds)
  993   * Remove all auto rules that mention bindings that have been removed
  994       (this is done by filtering by keep_rule)
  995 
  996 NB: if a binding is kept alive for some *other* reason (e.g. f_spec is
  997 called in the final code), we keep the rule too.
  998 
  999 This stuff is the only reason for the ru_auto field in a Rule.
 1000 -}
 1001 
 1002 findExternalRules :: Bool       -- Omit pragmas
 1003                   -> [CoreBind]
 1004                   -> [CoreRule] -- Local rules for imported fns
 1005                   -> UnfoldEnv  -- Ids that are exported, so we need their rules
 1006                   -> ([CoreBind], [CoreRule])
 1007 -- See Note [Finding external rules]
 1008 findExternalRules omit_prags binds imp_id_rules unfold_env
 1009   = (trimmed_binds, filter keep_rule all_rules)
 1010   where
 1011     imp_rules         = filter expose_rule imp_id_rules
 1012     imp_user_rule_fvs = mapUnionVarSet user_rule_rhs_fvs imp_rules
 1013 
 1014     user_rule_rhs_fvs rule | isAutoRule rule = emptyVarSet
 1015                            | otherwise       = ruleRhsFreeVars rule
 1016 
 1017     (trimmed_binds, local_bndrs, _, all_rules) = trim_binds binds
 1018 
 1019     keep_rule rule = ruleFreeVars rule `subVarSet` local_bndrs
 1020         -- Remove rules that make no sense, because they mention a
 1021         -- local binder (on LHS or RHS) that we have now discarded.
 1022         -- (NB: ruleFreeVars only includes LocalIds)
 1023         --
 1024         -- LHS: we have already filtered out rules that mention internal Ids
 1025         --     on LHS but that isn't enough because we might have by now
 1026         --     discarded a binding with an external Id. (How?
 1027         --     chooseExternalIds is a bit conservative.)
 1028         --
 1029         -- RHS: the auto rules that might mention a binder that has
 1030         --      been discarded; see Note [Trimming auto-rules]
 1031 
 1032     expose_rule rule
 1033         | omit_prags = False
 1034         | otherwise  = all is_external_id (ruleLhsFreeIdsList rule)
 1035                 -- Don't expose a rule whose LHS mentions a locally-defined
 1036                 -- Id that is completely internal (i.e. not visible to an
 1037                 -- importing module).  NB: ruleLhsFreeIds only returns LocalIds.
 1038                 -- See Note [Which rules to expose]
 1039 
 1040     is_external_id id = case lookupVarEnv unfold_env id of
 1041                           Just (name, _) -> isExternalName name
 1042                           Nothing        -> False
 1043 
 1044     trim_binds :: [CoreBind]
 1045                -> ( [CoreBind]   -- Trimmed bindings
 1046                   , VarSet       -- Binders of those bindings
 1047                   , VarSet       -- Free vars of those bindings + rhs of user rules
 1048                                  -- (we don't bother to delete the binders)
 1049                   , [CoreRule])  -- All rules, imported + from the bindings
 1050     -- This function removes unnecessary bindings, and gathers up rules from
 1051     -- the bindings we keep.  See Note [Trimming auto-rules]
 1052     trim_binds []  -- Base case, start with imp_user_rule_fvs
 1053        = ([], emptyVarSet, imp_user_rule_fvs, imp_rules)
 1054 
 1055     trim_binds (bind:binds)
 1056        | any needed bndrs    -- Keep binding
 1057        = ( bind : binds', bndr_set', needed_fvs', local_rules ++ rules )
 1058        | otherwise           -- Discard binding altogether
 1059        = stuff
 1060        where
 1061          stuff@(binds', bndr_set, needed_fvs, rules)
 1062                        = trim_binds binds
 1063          needed bndr   = isExportedId bndr || bndr `elemVarSet` needed_fvs
 1064 
 1065          bndrs         = bindersOf  bind
 1066          rhss          = rhssOfBind bind
 1067          bndr_set'     = bndr_set `extendVarSetList` bndrs
 1068 
 1069          needed_fvs'   = needed_fvs                                   `unionVarSet`
 1070                          mapUnionVarSet idUnfoldingVars   bndrs       `unionVarSet`
 1071                               -- Ignore type variables in the type of bndrs
 1072                          mapUnionVarSet exprFreeVars      rhss        `unionVarSet`
 1073                          mapUnionVarSet user_rule_rhs_fvs local_rules
 1074             -- In needed_fvs', we don't bother to delete binders from the fv set
 1075 
 1076          local_rules  = [ rule
 1077                         | id <- bndrs
 1078                         , is_external_id id   -- Only collect rules for external Ids
 1079                         , rule <- idCoreRules id
 1080                         , expose_rule rule ]  -- and ones that can fire in a client
 1081 
 1082 {-
 1083 ************************************************************************
 1084 *                                                                      *
 1085                tidyTopName
 1086 *                                                                      *
 1087 ************************************************************************
 1088 
 1089 This is where we set names to local/global based on whether they really are
 1090 externally visible (see comment at the top of this module).  If the name
 1091 was previously local, we have to give it a unique occurrence name if
 1092 we intend to externalise it.
 1093 -}
 1094 
 1095 tidyTopName :: Module -> NameCache -> Maybe Id -> TidyOccEnv
 1096             -> Id -> IO (TidyOccEnv, Name)
 1097 tidyTopName mod name_cache maybe_ref occ_env id
 1098   | global && internal = return (occ_env, localiseName name)
 1099 
 1100   | global && external = return (occ_env, name)
 1101         -- Global names are assumed to have been allocated by the renamer,
 1102         -- so they already have the "right" unique
 1103         -- And it's a system-wide unique too
 1104 
 1105   -- Now we get to the real reason that all this is in the IO Monad:
 1106   -- we have to update the name cache in a nice atomic fashion
 1107 
 1108   | local  && internal = do uniq <- takeUniqFromNameCache name_cache
 1109                             let new_local_name = mkInternalName uniq occ' loc
 1110                             return (occ_env', new_local_name)
 1111         -- Even local, internal names must get a unique occurrence, because
 1112         -- if we do -split-objs we externalise the name later, in the code generator
 1113         --
 1114         -- Similarly, we must make sure it has a system-wide Unique, because
 1115         -- the byte-code generator builds a system-wide Name->BCO symbol table
 1116 
 1117   | local  && external = do new_external_name <- allocateGlobalBinder name_cache mod occ' loc
 1118                             return (occ_env', new_external_name)
 1119         -- If we want to externalise a currently-local name, check
 1120         -- whether we have already assigned a unique for it.
 1121         -- If so, use it; if not, extend the table.
 1122         -- All this is done by allocateGlobalBinder.
 1123         -- This is needed when *re*-compiling a module in GHCi; we must
 1124         -- use the same name for externally-visible things as we did before.
 1125 
 1126   | otherwise = panic "tidyTopName"
 1127   where
 1128     name        = idName id
 1129     external    = isJust maybe_ref
 1130     global      = isExternalName name
 1131     local       = not global
 1132     internal    = not external
 1133     loc         = nameSrcSpan name
 1134 
 1135     old_occ     = nameOccName name
 1136     new_occ | Just ref <- maybe_ref
 1137             , ref /= id
 1138             = mkOccName (occNameSpace old_occ) $
 1139                    let
 1140                        ref_str = occNameString (getOccName ref)
 1141                        occ_str = occNameString old_occ
 1142                    in
 1143                    case occ_str of
 1144                      '$':'w':_ -> occ_str
 1145                         -- workers: the worker for a function already
 1146                         -- includes the occname for its parent, so there's
 1147                         -- no need to prepend the referrer.
 1148                      _other | isSystemName name -> ref_str
 1149                             | otherwise         -> ref_str ++ '_' : occ_str
 1150                         -- If this name was system-generated, then don't bother
 1151                         -- to retain its OccName, just use the referrer.  These
 1152                         -- system-generated names will become "f1", "f2", etc. for
 1153                         -- a referrer "f".
 1154             | otherwise = old_occ
 1155 
 1156     (occ_env', occ') = tidyOccName occ_env new_occ
 1157 
 1158 
 1159 {-
 1160 ************************************************************************
 1161 *                                                                      *
 1162 \subsection{Step 2: top-level tidying}
 1163 *                                                                      *
 1164 ************************************************************************
 1165 -}
 1166 
 1167 -- TopTidyEnv: when tidying we need to know
 1168 --   * name_cache: The NameCache, containing a unique supply and any pre-ordained Names.
 1169 --        These may have arisen because the
 1170 --        renamer read in an interface file mentioning M.$wf, say,
 1171 --        and assigned it unique r77.  If, on this compilation, we've
 1172 --        invented an Id whose name is $wf (but with a different unique)
 1173 --        we want to rename it to have unique r77, so that we can do easy
 1174 --        comparisons with stuff from the interface file
 1175 --
 1176 --   * occ_env: The TidyOccEnv, which tells us which local occurrences
 1177 --     are 'used'
 1178 --
 1179 --   * subst_env: A Var->Var mapping that substitutes the new Var for the old
 1180 
 1181 tidyTopBinds :: UnfoldingOpts
 1182              -> UnfoldEnv
 1183              -> TidyOccEnv
 1184              -> CoreProgram
 1185              -> IO (TidyEnv, CoreProgram)
 1186 
 1187 tidyTopBinds uf_opts unfold_env init_occ_env binds
 1188   = do let result = tidy init_env binds
 1189        seqBinds (snd result) `seq` return result
 1190        -- This seqBinds avoids a spike in space usage (see #13564)
 1191   where
 1192     init_env = (init_occ_env, emptyVarEnv)
 1193 
 1194     tidy = mapAccumL (tidyTopBind uf_opts unfold_env)
 1195 
 1196 ------------------------
 1197 tidyTopBind  :: UnfoldingOpts
 1198              -> UnfoldEnv
 1199              -> TidyEnv
 1200              -> CoreBind
 1201              -> (TidyEnv, CoreBind)
 1202 
 1203 tidyTopBind uf_opts unfold_env
 1204             (occ_env,subst1) (NonRec bndr rhs)
 1205   = (tidy_env2,  NonRec bndr' rhs')
 1206   where
 1207     Just (name',show_unfold) = lookupVarEnv unfold_env bndr
 1208     (bndr', rhs') = tidyTopPair uf_opts show_unfold tidy_env2 name' (bndr, rhs)
 1209     subst2        = extendVarEnv subst1 bndr bndr'
 1210     tidy_env2     = (occ_env, subst2)
 1211 
 1212 tidyTopBind uf_opts unfold_env (occ_env, subst1) (Rec prs)
 1213   = (tidy_env2, Rec prs')
 1214   where
 1215     prs' = [ tidyTopPair uf_opts show_unfold tidy_env2 name' (id,rhs)
 1216            | (id,rhs) <- prs,
 1217              let (name',show_unfold) =
 1218                     expectJust "tidyTopBind" $ lookupVarEnv unfold_env id
 1219            ]
 1220 
 1221     subst2    = extendVarEnvList subst1 (bndrs `zip` map fst prs')
 1222     tidy_env2 = (occ_env, subst2)
 1223 
 1224     bndrs = map fst prs
 1225 
 1226 -----------------------------------------------------------
 1227 tidyTopPair :: UnfoldingOpts
 1228             -> Bool  -- show unfolding
 1229             -> TidyEnv  -- The TidyEnv is used to tidy the IdInfo
 1230                         -- It is knot-tied: don't look at it!
 1231             -> Name             -- New name
 1232             -> (Id, CoreExpr)   -- Binder and RHS before tidying
 1233             -> (Id, CoreExpr)
 1234         -- This function is the heart of Step 2
 1235         -- The rec_tidy_env is the one to use for the IdInfo
 1236         -- It's necessary because when we are dealing with a recursive
 1237         -- group, a variable late in the group might be mentioned
 1238         -- in the IdInfo of one early in the group
 1239 
 1240 tidyTopPair uf_opts show_unfold rhs_tidy_env name' (bndr, rhs)
 1241   = (bndr1, rhs1)
 1242   where
 1243     bndr1    = mkGlobalId details name' ty' idinfo'
 1244     details  = idDetails bndr   -- Preserve the IdDetails
 1245     ty'      = tidyTopType (idType bndr)
 1246     rhs1     = tidyExpr rhs_tidy_env rhs
 1247     idinfo'  = tidyTopIdInfo uf_opts rhs_tidy_env name' rhs rhs1 (idInfo bndr)
 1248                              show_unfold
 1249 
 1250 -- tidyTopIdInfo creates the final IdInfo for top-level
 1251 -- binders.  The delicate piece:
 1252 --
 1253 --  * Arity.  After CoreTidy, this arity must not change any more.
 1254 --      Indeed, CorePrep must eta expand where necessary to make
 1255 --      the manifest arity equal to the claimed arity.
 1256 --
 1257 tidyTopIdInfo :: UnfoldingOpts -> TidyEnv -> Name -> CoreExpr -> CoreExpr
 1258               -> IdInfo -> Bool -> IdInfo
 1259 tidyTopIdInfo uf_opts rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold
 1260   | not is_external     -- For internal Ids (not externally visible)
 1261   = vanillaIdInfo       -- we only need enough info for code generation
 1262                         -- Arity and strictness info are enough;
 1263                         --      c.f. GHC.Core.Tidy.tidyLetBndr
 1264         `setArityInfo`      arity
 1265         `setDmdSigInfo` final_sig
 1266         `setCprSigInfo`        final_cpr
 1267         `setUnfoldingInfo`  minimal_unfold_info  -- See note [Preserve evaluatedness]
 1268                                                  -- in GHC.Core.Tidy
 1269 
 1270   | otherwise           -- Externally-visible Ids get the whole lot
 1271   = vanillaIdInfo
 1272         `setArityInfo`         arity
 1273         `setDmdSigInfo`    final_sig
 1274         `setCprSigInfo`           final_cpr
 1275         `setOccInfo`           robust_occ_info
 1276         `setInlinePragInfo`    (inlinePragInfo idinfo)
 1277         `setUnfoldingInfo`     unfold_info
 1278                 -- NB: we throw away the Rules
 1279                 -- They have already been extracted by findExternalRules
 1280   where
 1281     is_external = isExternalName name
 1282 
 1283     --------- OccInfo ------------
 1284     robust_occ_info = zapFragileOcc (occInfo idinfo)
 1285     -- It's important to keep loop-breaker information
 1286     -- when we are doing -fexpose-all-unfoldings
 1287 
 1288     --------- Strictness ------------
 1289     mb_bot_str = exprBotStrictness_maybe orig_rhs
 1290 
 1291     sig = dmdSigInfo idinfo
 1292     final_sig | not $ isTopSig sig
 1293               = warnPprTrace (_bottom_hidden sig) (ppr name) sig
 1294               -- try a cheap-and-cheerful bottom analyser
 1295               | Just (_, nsig) <- mb_bot_str = nsig
 1296               | otherwise                    = sig
 1297 
 1298     cpr = cprSigInfo idinfo
 1299     final_cpr | Just _ <- mb_bot_str
 1300               = mkCprSig arity botCpr
 1301               | otherwise
 1302               = cpr
 1303 
 1304     _bottom_hidden id_sig = case mb_bot_str of
 1305                                   Nothing         -> False
 1306                                   Just (arity, _) -> not (appIsDeadEnd id_sig arity)
 1307 
 1308     --------- Unfolding ------------
 1309     unf_info = realUnfoldingInfo idinfo
 1310     unfold_info
 1311       | isCompulsoryUnfolding unf_info || show_unfold
 1312       = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
 1313       | otherwise
 1314       = minimal_unfold_info
 1315     minimal_unfold_info = zapUnfolding unf_info
 1316     unf_from_rhs = mkFinalUnfolding uf_opts InlineRhs final_sig tidy_rhs
 1317     -- NB: do *not* expose the worker if show_unfold is off,
 1318     --     because that means this thing is a loop breaker or
 1319     --     marked NOINLINE or something like that
 1320     -- This is important: if you expose the worker for a loop-breaker
 1321     -- then you can make the simplifier go into an infinite loop, because
 1322     -- in effect the unfolding is exposed.  See #1709
 1323     --
 1324     -- You might think that if show_unfold is False, then the thing should
 1325     -- not be w/w'd in the first place.  But a legitimate reason is this:
 1326     --    the function returns bottom
 1327     -- In this case, show_unfold will be false (we don't expose unfoldings
 1328     -- for bottoming functions), but we might still have a worker/wrapper
 1329     -- split (see Note [Worker/wrapper for bottoming functions] in
 1330     -- GHC.Core.Opt.WorkWrap)
 1331 
 1332 
 1333     --------- Arity ------------
 1334     -- Usually the Id will have an accurate arity on it, because
 1335     -- the simplifier has just run, but not always.
 1336     -- One case I found was when the last thing the simplifier
 1337     -- did was to let-bind a non-atomic argument and then float
 1338     -- it to the top level. So it seems more robust just to
 1339     -- fix it here.
 1340     arity = exprArity orig_rhs
 1341 
 1342 {-
 1343 ************************************************************************
 1344 *                                                                      *
 1345                   Old, dead, type-trimming code
 1346 *                                                                      *
 1347 ************************************************************************
 1348 
 1349 We used to try to "trim off" the constructors of data types that are
 1350 not exported, to reduce the size of interface files, at least without
 1351 -O.  But that is not always possible: see the old Note [When we can't
 1352 trim types] below for exceptions.
 1353 
 1354 Then (#7445) I realised that the TH problem arises for any data type
 1355 that we have deriving( Data ), because we can invoke
 1356    Language.Haskell.TH.Quote.dataToExpQ
 1357 to get a TH Exp representation of a value built from that data type.
 1358 You don't even need {-# LANGUAGE TemplateHaskell #-}.
 1359 
 1360 At this point I give up. The pain of trimming constructors just
 1361 doesn't seem worth the gain.  So I've dumped all the code, and am just
 1362 leaving it here at the end of the module in case something like this
 1363 is ever resurrected.
 1364 
 1365 
 1366 Note [When we can't trim types]
 1367 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1368 The basic idea of type trimming is to export algebraic data types
 1369 abstractly (without their data constructors) when compiling without
 1370 -O, unless of course they are explicitly exported by the user.
 1371 
 1372 We always export synonyms, because they can be mentioned in the type
 1373 of an exported Id.  We could do a full dependency analysis starting
 1374 from the explicit exports, but that's quite painful, and not done for
 1375 now.
 1376 
 1377 But there are some times we can't do that, indicated by the 'no_trim_types' flag.
 1378 
 1379 First, Template Haskell.  Consider (#2386) this
 1380         module M(T, makeOne) where
 1381           data T = Yay String
 1382           makeOne = [| Yay "Yep" |]
 1383 Notice that T is exported abstractly, but makeOne effectively exports it too!
 1384 A module that splices in $(makeOne) will then look for a declaration of Yay,
 1385 so it'd better be there.  Hence, brutally but simply, we switch off type
 1386 constructor trimming if TH is enabled in this module.
 1387 
 1388 Second, data kinds.  Consider (#5912)
 1389      {-# LANGUAGE DataKinds #-}
 1390      module M() where
 1391      data UnaryTypeC a = UnaryDataC a
 1392      type Bug = 'UnaryDataC
 1393 We always export synonyms, so Bug is exposed, and that means that
 1394 UnaryTypeC must be too, even though it's not explicitly exported.  In
 1395 effect, DataKinds means that we'd need to do a full dependency analysis
 1396 to see what data constructors are mentioned.  But we don't do that yet.
 1397 
 1398 In these two cases we just switch off type trimming altogether.
 1399 
 1400 mustExposeTyCon :: Bool         -- Type-trimming flag
 1401                 -> NameSet      -- Exports
 1402                 -> TyCon        -- The tycon
 1403                 -> Bool         -- Can its rep be hidden?
 1404 -- We are compiling without -O, and thus trying to write as little as
 1405 -- possible into the interface file.  But we must expose the details of
 1406 -- any data types whose constructors or fields are exported
 1407 mustExposeTyCon no_trim_types exports tc
 1408   | no_trim_types               -- See Note [When we can't trim types]
 1409   = True
 1410 
 1411   | not (isAlgTyCon tc)         -- Always expose synonyms (otherwise we'd have to
 1412                                 -- figure out whether it was mentioned in the type
 1413                                 -- of any other exported thing)
 1414   = True
 1415 
 1416   | isEnumerationTyCon tc       -- For an enumeration, exposing the constructors
 1417   = True                        -- won't lead to the need for further exposure
 1418 
 1419   | isFamilyTyCon tc            -- Open type family
 1420   = True
 1421 
 1422   -- Below here we just have data/newtype decls or family instances
 1423 
 1424   | null data_cons              -- Ditto if there are no data constructors
 1425   = True                        -- (NB: empty data types do not count as enumerations
 1426                                 -- see Note [Enumeration types] in GHC.Core.TyCon
 1427 
 1428   | any exported_con data_cons  -- Expose rep if any datacon or field is exported
 1429   = True
 1430 
 1431   | isNewTyCon tc && isFFITy (snd (newTyConRhs tc))
 1432   = True   -- Expose the rep for newtypes if the rep is an FFI type.
 1433            -- For a very annoying reason.  'Foreign import' is meant to
 1434            -- be able to look through newtypes transparently, but it
 1435            -- can only do that if it can "see" the newtype representation
 1436 
 1437   | otherwise
 1438   = False
 1439   where
 1440     data_cons = tyConDataCons tc
 1441     exported_con con = any (`elemNameSet` exports)
 1442                            (dataConName con : dataConFieldLabels con)
 1443 -}