compiler: Write .o files atomically. See #14533
[ghc.git] / compiler / main / TidyPgm.hs
index 63f4c26..e9f3f85 100644 (file)
@@ -4,7 +4,7 @@
 \section{Tidying up Core}
 -}
 
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP, ViewPatterns #-}
 
 module TidyPgm (
        mkBootModDetailsTc, tidyProgram, globaliseAndTidyId
@@ -12,6 +12,8 @@ module TidyPgm (
 
 #include "HsVersions.h"
 
+import GhcPrelude
+
 import TcRnTypes
 import DynFlags
 import CoreSyn
@@ -22,12 +24,14 @@ import CoreMonad
 import CorePrep
 import CoreUtils        (rhsIsStatic)
 import CoreStats        (coreBindsStats, CoreStats(..))
+import CoreSeq          (seqBinds)
 import CoreLint
 import Literal
 import Rules
 import PatSyn
 import ConLike
 import CoreArity        ( exprArity, exprBotStrictness_maybe )
+import StaticPtrTable
 import VarEnv
 import VarSet
 import Var
@@ -37,11 +41,12 @@ import IdInfo
 import InstEnv
 import FamInstEnv
 import Type             ( tidyTopType )
-import Demand           ( appIsBottom, isNopSig, isBottomingSig )
+import Demand           ( appIsBottom, isTopSig, isBottomingSig )
 import BasicTypes
 import Name hiding (varName)
 import NameSet
 import NameEnv
+import NameCache
 import Avail
 import IfaceEnv
 import TcEnv
@@ -54,9 +59,7 @@ import Packages( isDllName )
 import HscTypes
 import Maybes
 import UniqSupply
-import ErrUtils (Severity(..))
 import Outputable
-import SrcLoc
 import qualified ErrUtils as Err
 
 import Control.Monad
@@ -65,7 +68,7 @@ import Data.List        ( sortBy )
 import Data.IORef       ( atomicModifyIORef' )
 
 {-
-Constructing the TypeEnv, Instances, Rules, VectInfo from which the
+Constructing the TypeEnv, Instances, Rules from which the
 ModIface is constructed, and which goes on to subsequent modules in
 --make mode.
 
@@ -137,12 +140,15 @@ mkBootModDetailsTc hsc_env
                   tcg_tcs       = tcs,
                   tcg_patsyns   = pat_syns,
                   tcg_insts     = insts,
-                  tcg_fam_insts = fam_insts
+                  tcg_fam_insts = fam_insts,
+                  tcg_mod       = this_mod
                 }
-  = do  { let dflags = hsc_dflags hsc_env
-        ; showPassIO dflags CoreTidy
-
-        ; let { insts'     = map (tidyClsInstDFun globaliseAndTidyId) insts
+  = -- This timing isn't terribly useful since the result isn't forced, but
+    -- the message is useful to locating oneself in the compilation process.
+    Err.withTiming (pure dflags)
+                   (text "CoreTidy"<+>brackets (ppr this_mod))
+                   (const ()) $
+    do  { let { insts'     = map (tidyClsInstDFun globaliseAndTidyId) insts
               ; pat_syns'  = map (tidyPatSynIds   globaliseAndTidyId) pat_syns
               ; type_env1  = mkBootTypeEnv (availsToNameSet exports)
                                            (typeEnvIds type_env) tcs fam_insts
@@ -156,10 +162,11 @@ mkBootModDetailsTc hsc_env
                              , md_rules     = []
                              , md_anns      = []
                              , md_exports   = exports
-                             , md_vect_info = noVectInfo
+                             , md_complete_sigs = []
                              })
         }
   where
+    dflags = hsc_dflags hsc_env
 
 mkBootTypeEnv :: NameSet -> [Id] -> [TyCon] -> [FamInst] -> TypeEnv
 mkBootTypeEnv exports ids tcs fam_insts
@@ -177,8 +184,9 @@ mkBootTypeEnv exports ids tcs fam_insts
         -- Do make sure that we keep Ids that are already Global.
         -- When typechecking an .hs-boot file, the Ids come through as
         -- GlobalIds.
-    final_ids = [ if isLocalId id then globaliseAndTidyId id
-                                  else id
+    final_ids = [ (if isLocalId id then globaliseAndTidyId id
+                                   else id)
+                        `setIdUnfolding` BootUnfolding
                 | id <- ids
                 , keep_it id ]
 
@@ -190,7 +198,7 @@ mkBootTypeEnv exports ids tcs fam_insts
 
 
 globaliseAndTidyId :: Id -> Id
--- Takes an LocalId with an External Name,
+-- Takes a LocalId with an External Name,
 -- makes it into a GlobalId
 --     * unchanged Name (might be Internal or External)
 --     * unchanged details
@@ -209,18 +217,22 @@ globaliseAndTidyId id
 
 Plan B: include pragmas, make interfaces
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* Figure out which Ids are externally visible
+* Step 1: Figure out which Ids are externally visible
+          See Note [Choosing external Ids]
 
-* Tidy the bindings, externalising appropriate Ids
+* Step 2: Gather the externally visible rules, separately from
+          the top-level bindings.
+          See Note [Finding external rules]
+
+* Step 3: Tidy the bindings, externalising appropriate Ids
+          See Note [Tidy the top-level bindings]
 
 * Drop all Ids from the TypeEnv, and add all the External Ids from
   the bindings.  (This adds their IdInfo to the TypeEnv; and adds
   floated-out Ids that weren't even in the TypeEnv before.)
 
-Step 1: Figure out external Ids
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Note [choosing external names]
-
+Note [Choosing external Ids]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 See also the section "Interface stability" in the
 RecompilationAvoidance commentary:
   http://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance
@@ -229,9 +241,9 @@ First we figure out which Ids are "external" Ids.  An
 "external" Id is one that is visible from outside the compilation
 unit.  These are
   a) the user exported ones
-  b) ones mentioned in the unfoldings, workers,
-     rules of externally-visible ones ,
-     or vectorised versions of externally-visible ones
+  b) the ones bound to static forms
+  c) ones mentioned in the unfoldings, workers, or
+     rules of externally-visible ones
 
 While figuring out which Ids are external, we pick a "tidy" OccName
 for each one.  That is, we make its OccName distinct from the other
@@ -259,8 +271,8 @@ as the bindings themselves are deterministic (they sometimes aren't!),
 the order in which they are presented to the tidying phase does not
 affect the names we assign.
 
-Step 2: Tidy the program
-~~~~~~~~~~~~~~~~~~~~~~~~
+Note [Tidy the top-level bindings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Next we traverse the bindings top to bottom.  For each *top-level*
 binder
 
@@ -307,20 +319,22 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                               , mg_binds     = binds
                               , mg_patsyns   = patsyns
                               , mg_rules     = imp_rules
-                              , mg_vect_info = vect_info
                               , mg_anns      = anns
+                              , mg_complete_sigs = complete_sigs
                               , mg_deps      = deps
                               , mg_foreign   = foreign_stubs
+                              , mg_foreign_files = foreign_files
                               , mg_hpc_info  = hpc_info
                               , mg_modBreaks = modBreaks
                               })
 
-  = do  { let { dflags     = hsc_dflags hsc_env
-              ; omit_prags = gopt Opt_OmitInterfacePragmas dflags
+  = Err.withTiming (pure dflags)
+                   (text "CoreTidy"<+>brackets (ppr mod))
+                   (const ()) $
+    do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags
               ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags
               ; print_unqual = mkPrintUnqualified dflags rdr_env
               }
-        ; showPassIO dflags CoreTidy
 
         ; let { type_env = typeEnvFromEntities [] tcs fam_insts
 
@@ -331,7 +345,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
 
         ; (unfold_env, tidy_occ_env)
               <- chooseExternalIds hsc_env mod omit_prags expose_all
-                                   binds implicit_binds imp_rules (vectInfoVar vect_info)
+                                   binds implicit_binds imp_rules
         ; let { (trimmed_binds, trimmed_rules)
                     = findExternalRules omit_prags binds imp_rules unfold_env }
 
@@ -342,7 +356,7 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                                     isExternalName (idName id)]
               ; type_env1  = extendTypeEnvWithIds type_env final_ids
 
-              ; tidy_cls_insts = map (tidyClsInstDFun (lookup_aux_id tidy_type_env)) cls_insts
+              ; tidy_cls_insts = map (tidyClsInstDFun (tidyVarOcc tidy_env)) cls_insts
                 -- A DFunId will have a binding in tidy_binds, and so will now be in
                 -- tidy_type_env, replete with IdInfo.  Its name will be unchanged since
                 -- it was born, but we want Global, IdInfo-rich (or not) DFunId in the
@@ -353,21 +367,32 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
                 -- and indeed it does, but if omit_prags is on, ext_rules is
                 -- empty
 
-              ; tidy_vect_info = tidyVectInfo tidy_env vect_info
-
                 -- Tidy the Ids inside each PatSyn, very similarly to DFunIds
                 -- and then override the PatSyns in the type_env with the new tidy ones
                 -- This is really the only reason we keep mg_patsyns at all; otherwise
                 -- they could just stay in type_env
-              ; tidy_patsyns = map (tidyPatSynIds (lookup_aux_id tidy_type_env)) patsyns
+              ; tidy_patsyns = map (tidyPatSynIds (tidyVarOcc tidy_env)) patsyns
               ; type_env2    = extendTypeEnvWithPatSyns tidy_patsyns type_env1
 
               ; tidy_type_env = tidyTypeEnv omit_prags type_env2
+              }
+          -- See Note [Grand plan for static forms] in StaticPtrTable.
+        ; (spt_entries, tidy_binds') <-
+             sptCreateStaticBinds hsc_env mod tidy_binds
+        ; let { spt_init_code = sptModuleInitCode mod spt_entries
+              ; add_spt_init_code =
+                  case hscTarget dflags of
+                    -- If we are compiling for the interpreter we will insert
+                    -- any necessary SPT entries dynamically
+                    HscInterpreted -> id
+                    -- otherwise add a C stub to do so
+                    _              -> (`appendStubC` spt_init_code)
+              }
 
-              -- See Note [Injecting implicit bindings]
-              ; all_tidy_binds = implicit_binds ++ tidy_binds
+        ; let { -- See Note [Injecting implicit bindings]
+                all_tidy_binds = implicit_binds ++ tidy_binds'
 
-              -- get the TyCons to generate code for.  Careful!  We must use
+              -- Get the TyCons to generate code for.  Careful!  We must use
               -- the untidied TypeEnv here, because we need
               --  (a) implicit TyCons arising from types and classes defined
               --      in this module
@@ -385,46 +410,43 @@ tidyProgram hsc_env  (ModGuts { mg_module    = mod
         ; unless (dopt Opt_D_dump_simpl dflags) $
             Err.dumpIfSet_dyn dflags Opt_D_dump_rules
               (showSDoc dflags (ppr CoreTidy <+> text "rules"))
-              (pprRulesForUser tidy_rules)
+              (pprRulesForUser dflags tidy_rules)
 
           -- Print one-line size info
         ; let cs = coreBindsStats tidy_binds
-        ; when (dopt Opt_D_dump_core_stats dflags)
-               (log_action dflags dflags SevDump noSrcSpan defaultDumpStyle
-                          (text "Tidy size (terms,types,coercions)"
-                           <+> ppr (moduleName mod) <> colon
-                           <+> int (cs_tm cs)
-                           <+> int (cs_ty cs)
-                           <+> int (cs_co cs) ))
+        ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_stats "Core Stats"
+            (text "Tidy size (terms,types,coercions)"
+             <+> ppr (moduleName mod) <> colon
+             <+> int (cs_tm cs)
+             <+> int (cs_ty cs)
+             <+> int (cs_co cs) )
 
         ; return (CgGuts { cg_module   = mod,
                            cg_tycons   = alg_tycons,
                            cg_binds    = all_tidy_binds,
-                           cg_foreign  = foreign_stubs,
+                           cg_foreign  = add_spt_init_code foreign_stubs,
+                           cg_foreign_files = foreign_files,
                            cg_dep_pkgs = map fst $ dep_pkgs deps,
                            cg_hpc_info = hpc_info,
-                           cg_modBreaks = modBreaks },
+                           cg_modBreaks = modBreaks,
+                           cg_spt_entries = spt_entries },
 
                    ModDetails { md_types     = tidy_type_env,
                                 md_rules     = tidy_rules,
                                 md_insts     = tidy_cls_insts,
-                                md_vect_info = tidy_vect_info,
                                 md_fam_insts = fam_insts,
                                 md_exports   = exports,
-                                md_anns      = anns      -- are already tidy
+                                md_anns      = anns,      -- are already tidy
+                                md_complete_sigs = complete_sigs
                               })
         }
-
-lookup_aux_id :: TypeEnv -> Var -> Id
-lookup_aux_id type_env id
-  = case lookupTypeEnv type_env (idName id) of
-        Just (AnId id') -> id'
-        _other          -> pprPanic "lookup_aux_id" (ppr id)
+  where
+    dflags = hsc_dflags hsc_env
 
 tidyTypeEnv :: Bool       -- Compiling without -O, so omit prags
             -> TypeEnv -> TypeEnv
 
--- The competed type environment is gotten from
+-- The completed type environment is gotten from
 --      a) the types and classes defined here (plus implicit things)
 --      b) adding Ids with correct IdInfo, including unfoldings,
 --              gotten from the bindings
@@ -460,37 +482,6 @@ extendTypeEnvWithPatSyns :: [PatSyn] -> TypeEnv -> TypeEnv
 extendTypeEnvWithPatSyns tidy_patsyns type_env
   = extendTypeEnvList type_env [AConLike (PatSynCon ps) | ps <- tidy_patsyns ]
 
-tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo
-tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar          = vars
-                                         , vectInfoParallelVars = parallelVars
-                                         })
-  = info { vectInfoVar          = tidy_vars
-         , vectInfoParallelVars = tidy_parallelVars
-         }
-  where
-      -- we only export mappings whose domain and co-domain is exported (otherwise, the iface is
-      -- inconsistent)
-    tidy_vars = mkVarEnv [ (tidy_var, (tidy_var, tidy_var_v))
-                         | (var, var_v) <- varEnvElts vars
-                         , let tidy_var   = lookup_var var
-                               tidy_var_v = lookup_var var_v
-                         , isExternalId tidy_var   && isExportedId tidy_var
-                         , isExternalId tidy_var_v && isExportedId tidy_var_v
-                         , isDataConWorkId var || not (isImplicitId var)
-                         ]
-
-    tidy_parallelVars = mkVarSet [ tidy_var
-                                 | var <- varSetElems parallelVars
-                                 , let tidy_var = lookup_var var
-                                 , isExternalId tidy_var && isExportedId tidy_var
-                                 ]
-
-    lookup_var var = lookupWithDefaultVarEnv var_env var var
-
-    -- We need to make sure that all names getting into the iface version of 'VectInfo' are
-    -- external; otherwise, 'MkIface' will bomb out.
-    isExternalId = isExternalName . idName
-
 {-
 Note [Don't attempt to trim data types]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -535,7 +526,7 @@ constructed in an optimised form.  E.g. record selector for
 Then the unfolding looks like
         x = \t. case t of MkT x1 -> let x = I# x1 in x
 This generates bad code unless it's first simplified a bit.  That is
-why CoreUnfold.mkImplicitUnfolding uses simleExprOpt to do a bit of
+why CoreUnfold.mkImplicitUnfolding uses simpleOptExpr to do a bit of
 optimisation first.  (Only matters when the selector is used curried;
 eg map x ys.)  See Trac #2070.
 
@@ -560,7 +551,7 @@ Oh: two other reasons for injecting them late:
     the sense of chooseExternalIds); else the Ids mentioned in *their*
     RHSs will be treated as external and you get an interface file
     saying      a18 = <blah>
-    but nothing refererring to a18 (because the implicit Id is the
+    but nothing referring to a18 (because the implicit Id is the
     one that does, and implicit Ids don't appear in interface files).
 
   - More seriously, the tidied type-envt will include the implicit
@@ -591,7 +582,7 @@ get_defn id = NonRec id (unfoldingTemplate (realIdUnfolding id))
 *                                                                      *
 ************************************************************************
 
-See Note [Choosing external names].
+See Note [Choosing external Ids].
 -}
 
 type UnfoldEnv  = IdEnv (Name{-new name-}, Bool {-show unfolding-})
@@ -607,38 +598,35 @@ chooseExternalIds :: HscEnv
                   -> [CoreBind]
                   -> [CoreBind]
                   -> [CoreRule]
-                  -> VarEnv (Var, Var)
                   -> IO (UnfoldEnv, TidyOccEnv)
                   -- Step 1 from the notes above
 
-chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules vect_vars
+chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules
   = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env
        ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders
        ; tidy_internal internal_ids unfold_env1 occ_env1 }
  where
   nc_var = hsc_NC hsc_env
 
-  -- init_ext_ids is the intial list of Ids that should be
+  -- init_ext_ids is the initial list of Ids that should be
   -- externalised.  It serves as the starting point for finding a
   -- deterministic, tidy, renaming for all external Ids in this
   -- module.
   --
-  -- It is sorted, so that it has adeterministic order (i.e. it's the
+  -- It is sorted, so that it has a deterministic order (i.e. it's the
   -- same list every time this module is compiled), in contrast to the
   -- bindings, which are ordered non-deterministically.
   init_work_list = zip init_ext_ids init_ext_ids
-  init_ext_ids   = sortBy (compare `on` getOccName) $
-                   filter is_external binders
+  init_ext_ids   = sortBy (compare `on` getOccName) $ filter is_external binders
 
   -- An Id should be external if either (a) it is exported,
   -- (b) it appears in the RHS of a local rule for an imported Id, or
-  -- (c) it is the vectorised version of an imported Id
   -- See Note [Which rules to expose]
-  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars || id `elemVarSet` vect_var_vs
+  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars
+
   rule_rhs_vars  = mapUnionVarSet ruleRhsFreeVars imp_id_rules
-  vect_var_vs    = mkVarSet [var_v | (var, var_v) <- nameEnvElts vect_vars, isGlobalId var]
 
-  binders          = bindersOfBinds binds
+  binders          = map fst $ flattenBinds binds
   implicit_binders = bindersOfBinds implicit_binds
   binder_set       = mkVarSet binders
 
@@ -665,7 +653,7 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
   init_occ_env = initTidyOccEnv avoids
 
 
-  search :: [(Id,Id)]    -- The work-list: (external id, referrring id)
+  search :: [(Id,Id)]    -- The work-list: (external id, referring id)
                          -- Make a tidy, external Name for the external id,
                          --   add it to the UnfoldEnv, and do the same for the
                          --   transitive closure of Ids it refers to
@@ -686,9 +674,6 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
                 | omit_prags = ([], False)
                 | otherwise  = addExternal expose_all refined_id
 
-                -- add vectorised version if any exists
-          new_ids' = new_ids ++ maybeToList (fmap snd $ lookupVarEnv vect_vars idocc)
-
                 -- 'idocc' is an *occurrence*, but we need to see the
                 -- unfolding in the *definition*; so look up in binder_set
           refined_id = case lookupVarSet binder_set idocc of
@@ -699,7 +684,7 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
           referrer' | isExportedId refined_id = refined_id
                     | otherwise               = referrer
       --
-      search (zip new_ids' (repeat referrer') ++ rest) unfold_env' occ_env'
+      search (zip new_ids (repeat referrer') ++ rest) unfold_env' occ_env'
 
   tidy_internal :: [Id] -> UnfoldEnv -> TidyOccEnv
                 -> IO (UnfoldEnv, TidyOccEnv)
@@ -749,7 +734,7 @@ a VarSet, which is in a non-deterministic order when converted to a
 list.  Hence, here we define a free-variable finder that returns
 the free variables in the order that they are encountered.
 
-See Note [Choosing external names]
+See Note [Choosing external Ids]
 -}
 
 bndrFvsInOrder :: Bool -> Id -> [Id]
@@ -891,7 +876,7 @@ codegen time.  I found that binary sizes jumped by 6-10% when I
 started to specialise INLINE functions (again, Note [Inline
 specialisations] in Specialise).
 
-So it seeems better to drop the binding for f_spec, and the rule
+So it seems better to drop the binding for f_spec, and the rule
 itself, if the auto-generated rule is the *only* reason that it is
 being kept alive.
 
@@ -934,7 +919,7 @@ findExternalRules omit_prags binds imp_id_rules unfold_env
         -- local binder (on LHS or RHS) that we have now discarded.
         -- (NB: ruleFreeVars only includes LocalIds)
         --
-        -- LHS: we have alrady filtered out rules that mention internal Ids
+        -- LHS: we have already filtered out rules that mention internal Ids
         --     on LHS but that isn't enough because we might have by now
         --     discarded a binding with an external Id. (How?
         --     chooseExternalIds is a bit conservative.)
@@ -944,7 +929,7 @@ findExternalRules omit_prags binds imp_id_rules unfold_env
 
     expose_rule rule
         | omit_prags = False
-        | otherwise  = all is_external_id (varSetElems (ruleLhsFreeIds rule))
+        | otherwise  = all is_external_id (ruleLhsFreeIdsList rule)
                 -- Don't expose a rule whose LHS mentions a locally-defined
                 -- Id that is completely internal (i.e. not visible to an
                 -- importing module).  NB: ruleLhsFreeIds only returns LocalIds.
@@ -1104,44 +1089,51 @@ tidyTopBinds :: HscEnv
 
 tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds
   = do mkIntegerId <- lookupMkIntegerName dflags hsc_env
+       mkNaturalId <- lookupMkNaturalName dflags hsc_env
        integerSDataCon <- lookupIntegerSDataConName dflags hsc_env
-       let cvt_integer = cvtLitInteger dflags mkIntegerId integerSDataCon
-       return $ tidy cvt_integer init_env binds
+       naturalSDataCon <- lookupNaturalSDataConName dflags hsc_env
+       let cvt_literal nt i = case nt of
+             LitNumInteger -> Just (cvtLitInteger dflags mkIntegerId integerSDataCon i)
+             LitNumNatural -> Just (cvtLitNatural dflags mkNaturalId naturalSDataCon i)
+             _             -> Nothing
+           result      = tidy cvt_literal init_env binds
+       seqBinds (snd result) `seq` return result
+       -- This seqBinds avoids a spike in space usage (see #13564)
   where
     dflags = hsc_dflags hsc_env
 
     init_env = (init_occ_env, emptyVarEnv)
 
-    this_pkg = thisPackage dflags
-
     tidy _           env []     = (env, [])
-    tidy cvt_integer env (b:bs)
-        = let (env1, b')  = tidyTopBind dflags this_pkg this_mod
-                                        cvt_integer unfold_env env b
-              (env2, bs') = tidy cvt_integer env1 bs
+    tidy cvt_literal env (b:bs)
+        = let (env1, b')  = tidyTopBind dflags this_mod cvt_literal unfold_env
+                                        env b
+              (env2, bs') = tidy cvt_literal env1 bs
           in  (env2, b':bs')
 
 ------------------------
 tidyTopBind  :: DynFlags
-             -> UnitId
              -> Module
-             -> (Integer -> CoreExpr)
+             -> (LitNumType -> Integer -> Maybe CoreExpr)
              -> UnfoldEnv
              -> TidyEnv
              -> CoreBind
              -> (TidyEnv, CoreBind)
 
-tidyTopBind dflags this_pkg this_mod cvt_integer unfold_env
+tidyTopBind dflags this_mod cvt_literal unfold_env
             (occ_env,subst1) (NonRec bndr rhs)
   = (tidy_env2,  NonRec bndr' rhs')
   where
     Just (name',show_unfold) = lookupVarEnv unfold_env bndr
-    caf_info      = hasCafRefs dflags this_pkg this_mod (subst1, cvt_integer) (idArity bndr) rhs
-    (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' (bndr, rhs)
+    caf_info      = hasCafRefs dflags this_mod
+                               (subst1, cvt_literal)
+                               (idArity bndr) rhs
+    (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name'
+                                (bndr, rhs)
     subst2        = extendVarEnv subst1 bndr bndr'
     tidy_env2     = (occ_env, subst2)
 
-tidyTopBind dflags this_pkg this_mod cvt_integer unfold_env
+tidyTopBind dflags this_mod cvt_literal unfold_env
             (occ_env, subst1) (Rec prs)
   = (tidy_env2, Rec prs')
   where
@@ -1159,8 +1151,8 @@ tidyTopBind dflags this_pkg this_mod cvt_integer unfold_env
         -- the CafInfo for a recursive group says whether *any* rhs in
         -- the group may refer indirectly to a CAF (because then, they all do).
     caf_info
-        | or [ mayHaveCafRefs (hasCafRefs dflags this_pkg this_mod
-                                          (subst1, cvt_integer)
+        | or [ mayHaveCafRefs (hasCafRefs dflags this_mod
+                                          (subst1, cvt_literal)
                                           (idArity bndr) rhs)
              | (bndr,rhs) <- prs ] = MayHaveCafRefs
         | otherwise                = NoCafRefs
@@ -1212,6 +1204,8 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_
         `setCafInfo`        caf_info
         `setArityInfo`      arity
         `setStrictnessInfo` final_sig
+        `setUnfoldingInfo`  minimal_unfold_info  -- See note [Preserve evaluatedness]
+                                                 -- in CoreTidy
 
   | otherwise           -- Externally-visible Ids get the whole lot
   = vanillaIdInfo
@@ -1235,11 +1229,11 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_
     mb_bot_str = exprBotStrictness_maybe orig_rhs
 
     sig = strictnessInfo idinfo
-    final_sig | not $ isNopSig sig
-                 = WARN( _bottom_hidden sig , ppr name ) sig
-                 -- try a cheap-and-cheerful bottom analyser
-                 | Just (_, nsig) <- mb_bot_str = nsig
-                 | otherwise                    = sig
+    final_sig | not $ isTopSig sig
+              = WARN( _bottom_hidden sig , ppr name ) sig
+              -- try a cheap-and-cheerful bottom analyser
+              | Just (_, nsig) <- mb_bot_str = nsig
+              | otherwise                    = sig
 
     _bottom_hidden id_sig = case mb_bot_str of
                                   Nothing         -> False
@@ -1248,7 +1242,8 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_
     --------- Unfolding ------------
     unf_info = unfoldingInfo idinfo
     unfold_info | show_unfold = tidyUnfolding rhs_tidy_env unf_info unf_from_rhs
-                | otherwise   = noUnfolding
+                | otherwise   = minimal_unfold_info
+    minimal_unfold_info = zapUnfolding unf_info
     unf_from_rhs = mkTopUnfolding dflags is_bot tidy_rhs
     is_bot = isBottomingSig final_sig
     -- NB: do *not* expose the worker if show_unfold is off,
@@ -1265,6 +1260,7 @@ tidyTopIdInfo dflags rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_
     -- for bottoming functions), but we might still have a worker/wrapper
     -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.hs
 
+
     --------- Arity ------------
     -- Usually the Id will have an accurate arity on it, because
     -- the simplifier has just run, but not always.
@@ -1302,25 +1298,28 @@ We compute hasCafRefs here, because IdInfo is supposed to be finalised
 after TidyPgm.  But CorePrep does some transformations that affect CAF-hood.
 So we have to *predict* the result here, which is revolting.
 
-In particular CorePrep expands Integer literals.  So in the prediction code
-here we resort to applying the same expansion (cvt_integer). Ugh!
+In particular CorePrep expands Integer and Natural literals. So in the
+prediction code here we resort to applying the same expansion (cvt_literal).
+Ugh!
 -}
 
-type CafRefEnv = (VarEnv Id, Integer -> CoreExpr)
+type CafRefEnv = (VarEnv Id, LitNumType -> Integer -> Maybe CoreExpr)
   -- The env finds the Caf-ness of the Id
-  -- The Integer -> CoreExpr is the desugaring function for Integer literals
+  -- The LitNumType -> Integer -> CoreExpr is the desugaring functions for
+  -- Integer and Natural literals
   -- See Note [Disgusting computation of CafRefs]
 
-hasCafRefs :: DynFlags -> UnitId -> Module
+hasCafRefs :: DynFlags -> Module
            -> CafRefEnv -> Arity -> CoreExpr
            -> CafInfo
-hasCafRefs dflags this_pkg this_mod p@(_,cvt_integer) arity expr
+hasCafRefs dflags this_mod (subst, cvt_literal) arity expr
   | is_caf || mentions_cafs = MayHaveCafRefs
   | otherwise               = NoCafRefs
  where
-  mentions_cafs   = cafRefsE p expr
-  is_dynamic_name = isDllName dflags this_pkg this_mod
-  is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name cvt_integer expr)
+  mentions_cafs   = cafRefsE expr
+  is_dynamic_name = isDllName dflags this_mod
+  is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name
+                                         cvt_literal expr)
 
   -- NB. we pass in the arity of the expression, which is expected
   -- to be calculated by exprArity.  This is because exprArity
@@ -1328,34 +1327,36 @@ hasCafRefs dflags this_pkg this_mod p@(_,cvt_integer) arity expr
   -- CorePrep later on, and we don't want to duplicate that
   -- knowledge in rhsIsStatic below.
 
-cafRefsE :: CafRefEnv -> Expr a -> Bool
-cafRefsE p (Var id)            = cafRefsV p id
-cafRefsE p (Lit lit)           = cafRefsL p lit
-cafRefsE p (App f a)           = cafRefsE p f || cafRefsE p a
-cafRefsE p (Lam _ e)           = cafRefsE p e
-cafRefsE p (Let b e)           = cafRefsEs p (rhssOfBind b) || cafRefsE p e
-cafRefsE p (Case e _ _ alts)   = cafRefsE p e || cafRefsEs p (rhssOfAlts alts)
-cafRefsE p (Tick _n e)         = cafRefsE p e
-cafRefsE p (Cast e _co)        = cafRefsE p e
-cafRefsE _ (Type _)            = False
-cafRefsE _ (Coercion _)        = False
-
-cafRefsEs :: CafRefEnv -> [Expr a] -> Bool
-cafRefsEs _ []     = False
-cafRefsEs p (e:es) = cafRefsE p e || cafRefsEs p es
-
-cafRefsL :: CafRefEnv -> Literal -> Bool
--- Don't forget that mk_integer id might have Caf refs!
--- We first need to convert the Integer into its final form, to
--- see whether mkInteger is used.
-cafRefsL p@(_, cvt_integer) (LitInteger i _) = cafRefsE p (cvt_integer i)
-cafRefsL _                  _                = False
-
-cafRefsV :: CafRefEnv -> Id -> Bool
-cafRefsV (subst, _) id
-  | not (isLocalId id)                = mayHaveCafRefs (idCafInfo id)
-  | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id')
-  | otherwise                         = False
+  cafRefsE :: Expr a -> Bool
+  cafRefsE (Var id)            = cafRefsV id
+  cafRefsE (Lit lit)           = cafRefsL lit
+  cafRefsE (App f a)           = cafRefsE f || cafRefsE a
+  cafRefsE (Lam _ e)           = cafRefsE e
+  cafRefsE (Let b e)           = cafRefsEs (rhssOfBind b) || cafRefsE e
+  cafRefsE (Case e _ _ alts)   = cafRefsE e || cafRefsEs (rhssOfAlts alts)
+  cafRefsE (Tick _n e)         = cafRefsE e
+  cafRefsE (Cast e _co)        = cafRefsE e
+  cafRefsE (Type _)            = False
+  cafRefsE (Coercion _)        = False
+
+  cafRefsEs :: [Expr a] -> Bool
+  cafRefsEs []     = False
+  cafRefsEs (e:es) = cafRefsE e || cafRefsEs es
+
+  cafRefsL :: Literal -> Bool
+  -- Don't forget that mk_integer id might have Caf refs!
+  -- We first need to convert the Integer into its final form, to
+  -- see whether mkInteger is used. Same for LitNatural.
+  cafRefsL (LitNumber nt i _) = case cvt_literal nt i of
+    Just e  -> cafRefsE e
+    Nothing -> False
+  cafRefsL _                = False
+
+  cafRefsV :: Id -> Bool
+  cafRefsV id
+    | not (isLocalId id)                = mayHaveCafRefs (idCafInfo id)
+    | Just id' <- lookupVarEnv subst id = mayHaveCafRefs (idCafInfo id')
+    | otherwise                         = False
 
 
 {-
@@ -1400,7 +1401,7 @@ First, Template Haskell.  Consider (Trac #2386) this
           data T = Yay String
           makeOne = [| Yay "Yep" |]
 Notice that T is exported abstractly, but makeOne effectively exports it too!
-A module that splices in $(makeOne) will then look for a declartion of Yay,
+A module that splices in $(makeOne) will then look for a declaration of Yay,
 so it'd better be there.  Hence, brutally but simply, we switch off type
 constructor trimming if TH is enabled in this module.