DmdAnal: Improve handling of precise exceptions

This patch does two things: Fix possible unsoundness in what was called
the "IO hack" and implement part 2.1 of the "fixing precise exceptions"
plan in
https://gitlab.haskell.org/ghc/ghc/wikis/fixing-precise-exceptions,
which, in combination with !2956, supersedes !3014 and !2525.

**IO hack**

The "IO hack" (which is a fallback to preserve precise exceptions
semantics and thus soundness, rather than some smart thing that
increases precision) is called `exprMayThrowPreciseException` now.
I came up with two testcases exemplifying possible unsoundness (if
twisted enough) in the old approach:

- `T13380d`: Demonstrating unsoundness of the "IO hack" when resorting
             to manual state token threading and direct use of primops.
             More details below.
- `T13380e`: Demonstrating unsoundness of the "IO hack" when we have
             Nested CPR. Not currently relevant, as we don't have Nested
             CPR yet.
- `T13380f`: Demonstrating unsoundness of the "IO hack" for safe FFI
             calls.

Basically, the IO hack assumed that precise exceptions can only be
thrown from a case scrutinee of type `(# State# RealWorld, _ #)`. I
couldn't come up with a program using the `IO` abstraction that violates
this assumption. But it's easy to do so via manual state token threading
and direct use of primops, see `T13380d`. Also similar code might be
generated by Nested CPR in the (hopefully not too) distant future, see
`T13380e`. Hence, we now have a more careful test in `forcesRealWorld`
that passes `T13380{d,e}` (and will hopefully be robust to Nested CPR).

**Precise exceptions**

In #13380 and #17676 we saw that we didn't preserve precise exception
semantics in demand analysis. We fixed that with minimal changes in
!2956, but that was terribly unprincipled.

That unprincipledness resulted in a loss of precision, which is tracked
by these new test cases:

- `T13380b`: Regression in dead code elimination, because !2956 was too
             syntactic about `raiseIO#`
- `T13380c`: No need to apply the "IO hack" when the IO action may not
             throw a precise exception (and the existing IO hack doesn't
             detect that)

Fixing both issues in !3014 turned out to be too complicated and had
the potential to regress in the future. Hence we decided to only fix
`T13380b` and augment the `Divergence` lattice with a new middle-layer
element, `ExnOrDiv`, which means either `Diverges` (, throws an
imprecise exception) or throws a *precise* exception.

See the wiki page on Step 2.1 for more implementational details:
https://gitlab.haskell.org/ghc/ghc/wikis/fixing-precise-exceptions#dead-code-elimination-for-raiseio-with-isdeadenddiv-introducing-exnordiv-step-21

15 files changed, 167 insertions, 130 deletions

diff --git a/compiler/GHC/Core/Arity.hs b/compiler/GHC/Core/Arity.hs
index 53e47d9746..935fd7a67b 100644
--- a/compiler/GHC/Core/Arity.hs
+++ b/compiler/GHC/Core/Arity.hs
@@ -759,8 +759,8 @@ arityType _ (Var v)
   , not $ isTopSig strict_sig
   , (ds, res) <- splitStrictSig strict_sig
   , let arity = length ds
-  = if isBotDiv res then ABot arity
-                    else ATop (take arity one_shots)
+  = if isDeadEndDiv res then ABot arity
+                        else ATop (take arity one_shots)
   | otherwise
   = ATop (take (idArity v) one_shots)
   where
@@ -787,7 +787,7 @@ arityType env (App fun arg )
         -- The difference is observable using 'seq'
         --
 arityType env (Case scrut _ _ alts)
-  | exprIsBottom scrut || null alts
+  | exprIsDeadEnd scrut || null alts
   = ABot 0     -- Do not eta expand
                -- See Note [Dealing with bottom (1)]
   | otherwise
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index b1f0e8eece..872a081f47 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -64,7 +64,7 @@ import GHC.Utils.Misc
 import GHC.Core.InstEnv      ( instanceDFunId )
 import GHC.Core.Coercion.Opt ( checkAxInstCo )
 import GHC.Core.Arity        ( typeArity )
-import GHC.Types.Demand ( splitStrictSig, isBotDiv )
+import GHC.Types.Demand ( splitStrictSig, isDeadEndDiv )
 
 import GHC.Driver.Types
 import GHC.Driver.Session
@@ -651,7 +651,7 @@ lintLetBind top_lvl rec_flag binder rhs rhs_ty
            ppr binder)
 
        ; case splitStrictSig (idStrictness binder) of
-           (demands, result_info) | isBotDiv result_info ->
+           (demands, result_info) | isDeadEndDiv result_info ->
              checkL (demands `lengthAtLeast` idArity binder)
                (text "idArity" <+> ppr (idArity binder) <+>
                text "exceeds arity imposed by the strictness signature" <+>
@@ -986,7 +986,7 @@ used to check two things:
 * exprIsHNF is false: it would *seem* to be terribly wrong if
   the scrutinee was already in head normal form.
 
-* exprIsBottom is true: we should be able to see why GHC believes the
+* exprIsDeadEnd is true: we should be able to see why GHC believes the
   scrutinee is diverging for sure.
 
 It was already known that the second test was not entirely reliable.
@@ -1182,7 +1182,7 @@ lintCaseExpr scrut var alt_ty alts =
               , isAlgTyCon tycon
               , not (isAbstractTyCon tycon)
               , null (tyConDataCons tycon)
-              , not (exprIsBottom scrut)
+              , not (exprIsDeadEnd scrut)
               -> pprTrace "Lint warning: case binder's type has no constructors" (ppr var <+> ppr (idType var))
                         -- This can legitimately happen for type families
                       $ return ()
diff --git a/compiler/GHC/Core/Opt/CallArity.hs b/compiler/GHC/Core/Opt/CallArity.hs
index ef5bb94b23..250942e0f6 100644
--- a/compiler/GHC/Core/Opt/CallArity.hs
+++ b/compiler/GHC/Core/Opt/CallArity.hs
@@ -701,7 +701,7 @@ trimArity v a = minimum [a, max_arity_by_type, max_arity_by_strsig]
   where
     max_arity_by_type = length (typeArity (idType v))
     max_arity_by_strsig
-        | isBotDiv result_info = length demands
+        | isDeadEndDiv result_info = length demands
         | otherwise = a
 
     (demands, result_info) = splitStrictSig (idStrictness v)
diff --git a/compiler/GHC/Core/Opt/DmdAnal.hs b/compiler/GHC/Core/Opt/DmdAnal.hs
index 5d4e650564..b1fcc227ef 100644
--- a/compiler/GHC/Core/Opt/DmdAnal.hs
+++ b/compiler/GHC/Core/Opt/DmdAnal.hs
@@ -16,7 +16,7 @@ module GHC.Core.Opt.DmdAnal ( dmdAnalProgram ) where
 import GHC.Prelude
 
 import GHC.Driver.Session
-import GHC.Core.Opt.WorkWrap.Utils ( findTypeShape )
+import GHC.Core.Opt.WorkWrap.Utils
 import GHC.Types.Demand   -- All of it
 import GHC.Core
 import GHC.Core.Seq     ( seqBinds )
@@ -25,6 +25,7 @@ import GHC.Types.Var.Env
 import GHC.Types.Basic
 import Data.List        ( mapAccumL )
 import GHC.Core.DataCon
+import GHC.Types.ForeignCall ( isSafeForeignCall )
 import GHC.Types.Id
 import GHC.Types.Id.Info
 import GHC.Core.Utils
@@ -34,7 +35,7 @@ import GHC.Core.Coercion ( Coercion, coVarsOfCo )
 import GHC.Core.FamInstEnv
 import GHC.Utils.Misc
 import GHC.Data.Maybe         ( isJust )
-import GHC.Builtin.Types
+import GHC.Builtin.PrimOps
 import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
 import GHC.Utils.Error        ( dumpIfSet_dyn, DumpFormat (..) )
 import GHC.Types.Unique.Set
@@ -151,7 +152,7 @@ dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
                   dmdAnal' env d e
 
 dmdAnal' _ _ (Lit lit)     = (nopDmdType, Lit lit)
-dmdAnal' _ _ (Type ty)     = (nopDmdType, Type ty)      -- Doesn't happen, in fact
+dmdAnal' _ _ (Type ty)     = (nopDmdType, Type ty) -- Doesn't happen, in fact
 dmdAnal' _ _ (Coercion co)
   = (unitDmdType (coercionDmdEnv co), Coercion co)
 
@@ -222,8 +223,13 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])
         (alt_ty1, dmds)          = findBndrsDmds env rhs_ty bndrs
         (alt_ty2, case_bndr_dmd) = findBndrDmd env False alt_ty1 case_bndr
         id_dmds                  = addCaseBndrDmd case_bndr_dmd dmds
-        alt_ty3 | io_hack_reqd scrut dc bndrs = deferAfterIO alt_ty2
-                | otherwise                   = alt_ty2
+        fam_envs                 = ae_fam_envs env
+        alt_ty3
+          -- See Note [Precise exceptions and strictness analysis] in Demand
+          | exprMayThrowPreciseException fam_envs scrut
+          = deferAfterPreciseException alt_ty2
+          | otherwise
+          = alt_ty2
 
         -- Compute demand on the scrutinee
         -- See Note [Demand on scrutinee of a product case]
@@ -251,12 +257,20 @@ dmdAnal' env dmd (Case scrut case_bndr ty alts)
                                -- NB: Base case is botDmdType, for empty case alternatives
                                --     This is a unit for lubDmdType, and the right result
                                --     when there really are no alternatives
-        res_ty               = alt_ty `bothDmdType` toBothDmdArg scrut_ty
+        fam_envs             = ae_fam_envs env
+        alt_ty2
+          -- See Note [Precise exceptions and strictness analysis] in Demand
+          | exprMayThrowPreciseException fam_envs scrut
+          = deferAfterPreciseException alt_ty
+          | otherwise
+          = alt_ty
+        res_ty               = alt_ty2 `bothDmdType` toBothDmdArg scrut_ty
+
     in
 --    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
 --                                   , text "scrut_ty" <+> ppr scrut_ty
 --                                   , text "alt_tys" <+> ppr alt_tys
---                                   , text "alt_ty" <+> ppr alt_ty
+--                                   , text "alt_ty2" <+> ppr alt_ty2
 --                                   , text "res_ty" <+> ppr res_ty ]) $
     (res_ty, Case scrut' case_bndr' ty alts')
 
@@ -314,16 +328,37 @@ dmdAnal' env dmd (Let (Rec pairs) body)
     body_ty2 `seq`
     (body_ty2,  Let (Rec pairs') body')
 
-io_hack_reqd :: CoreExpr -> DataCon -> [Var] -> Bool
--- See Note [IO hack in the demand analyser]
-io_hack_reqd scrut con bndrs
-  | (bndr:_) <- bndrs
-  , con == tupleDataCon Unboxed 2
-  , idType bndr `eqType` realWorldStatePrimTy
-  , (fun, _) <- collectArgs scrut
-  = case fun of
-      Var f -> not (isPrimOpId f)
-      _     -> True
+-- | A simple, syntactic analysis of whether an expression MAY throw a precise
+-- exception when evaluated. It's always sound to return 'True'.
+-- See Note [Which scrutinees may throw precise exceptions].
+exprMayThrowPreciseException :: FamInstEnvs -> CoreExpr -> Bool
+exprMayThrowPreciseException envs e
+  | not (forcesRealWorld envs (exprType e))
+  = False -- 1. in the Note
+  | (Var f, _) <- collectArgs e
+  , Just op    <- isPrimOpId_maybe f
+  , op /= RaiseIOOp
+  = False -- 2. in the Note
+  | (Var f, _) <- collectArgs e
+  , Just fcall <- isFCallId_maybe f
+  , not (isSafeForeignCall fcall)
+  = False -- 3. in the Note
+  | otherwise
+  = True  -- _. in the Note
+
+-- | Recognises types that are
+--    * @State# RealWorld@
+--    * Unboxed tuples with a @State# RealWorld@ field
+-- modulo coercions. This will detect 'IO' actions (even post Nested CPR! See
+-- T13380e) and user-written variants thereof by their type.
+forcesRealWorld :: FamInstEnvs -> Type -> Bool
+forcesRealWorld fam_envs ty
+  | ty `eqType` realWorldStatePrimTy
+  = True
+  | Just DataConAppContext{ dcac_dc = dc, dcac_arg_tys = field_tys }
+      <- deepSplitProductType_maybe fam_envs ty
+  , isUnboxedTupleCon dc
+  = any (\(ty,_) -> ty `eqType` realWorldStatePrimTy) field_tys
   | otherwise
   = False
 
@@ -340,49 +375,42 @@ dmdAnalAlt env dmd case_bndr (con,bndrs,rhs)
         id_dmds       = addCaseBndrDmd case_bndr_dmd dmds
   = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs'))
 
-
-{- Note [IO hack in the demand analyser]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-There's a hack here for I/O operations.  Consider
-
-     case foo x s of { (# s', r #) -> y }
-
-Is this strict in 'y'? Often not! If foo x s performs some observable action
-(including raising an exception with raiseIO#, modifying a mutable variable, or
-even ending the program normally), then we must not force 'y' (which may fail
-to terminate) until we have performed foo x s.
-
-Hackish solution: spot the IO-like situation and add a virtual branch,
-as if we had
-     case foo x s of
-        (# s, r #) -> y
-        other      -> return ()
-So the 'y' isn't necessarily going to be evaluated
-
-A more complete example (#148, #1592) where this shows up is:
-     do { let len = <expensive> ;
-        ; when (...) (exitWith ExitSuccess)
-        ; print len }
-
-However, consider
-  f x s = case getMaskingState# s of
-            (# s, r #) ->
-          case x of I# x2 -> ...
-
-Here it is terribly sad to make 'f' lazy in 's'.  After all,
-getMaskingState# is not going to diverge or throw an exception!  This
-situation actually arises in GHC.IO.Handle.Internals.wantReadableHandle
-(on an MVar not an Int), and made a material difference.
-
-So if the scrutinee is a primop call, we *don't* apply the
-state hack:
-  - If it is a simple, terminating one like getMaskingState,
-    applying the hack is over-conservative.
-  - If the primop is raise# then it returns bottom, so
-    the case alternatives are already discarded.
-  - If the primop can raise a non-IO exception, like
-    divide by zero or seg-fault (eg writing an array
-    out of bounds) then we don't mind evaluating 'x' first.
+{- Note [Which scrutinees may throw precise exceptions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This is the specification of 'exprMayThrowPreciseExceptions',
+which is important for Scenario 2 of
+Note [Precise exceptions and strictness analysis] in GHC.Types.Demand.
+
+For an expression @f a1 ... an :: ty@ we determine that
+  1. False  If ty is *not* @State# RealWorld@ or an unboxed tuple thereof.
+            This check is done by 'forcesRealWorld'.
+            (Why not simply unboxed pairs as above? This is motivated by
+            T13380{d,e}.)
+  2. False  If f is a PrimOp, and it is *not* raiseIO#
+  3. False  If f is an unsafe FFI call ('PlayRisky')
+  _. True   Otherwise "give up".
+
+It is sound to return False in those cases, because
+  1. We don't give any guarantees for unsafePerformIO, so no precise exceptions
+     from pure code.
+  2. raiseIO# is the only primop that may throw a precise exception.
+  3. Unsafe FFI calls may not interact with the RTS (to throw, for example).
+     See haddock on GHC.Types.ForeignCall.PlayRisky.
+
+We *need* to return False in those cases, because
+  1. We would lose too much strictness in pure code, all over the place.
+  2. We would lose strictness for primops like getMaskingState#, which
+     introduces a substantial regression in
+     GHC.IO.Handle.Internals.wantReadableHandle.
+  3. We would lose strictness for code like GHC.Fingerprint.fingerprintData,
+     where an intermittent FFI call to c_MD5Init would otherwise lose
+     strictness on the arguments len and buf, leading to regressions in T9203
+     (2%) and i386's haddock.base (5%). Tested by T13380f.
+
+In !3014 we tried a more sophisticated analysis by introducing ConOrDiv (nic)
+to the Divergence lattice, but in practice it turned out to be hard to untaint
+from 'topDiv' to 'conDiv', leading to bugs, performance regressions and
+complexity that didn't justify the single fixed testcase T13380c.
 
 Note [Demand on the scrutinee of a product case]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -453,27 +481,33 @@ dmdTransform :: AnalEnv         -- The strictness environment
         -- this function plus demand on its free variables
 
 dmdTransform env var dmd
-  | isDataConWorkId var                          -- Data constructor
+  -- Data constructors
+  | isDataConWorkId var
   = dmdTransformDataConSig (idArity var) dmd
-
+  -- Dictionary component selectors
   | gopt Opt_DmdTxDictSel (ae_dflags env),
-    Just _ <- isClassOpId_maybe var -- Dictionary component selector
+    Just _ <- isClassOpId_maybe var
   = dmdTransformDictSelSig (idStrictness var) dmd
-
-  | isGlobalId var                               -- Imported function
+  -- Imported functions
+  | isGlobalId var
   , let res = dmdTransformSig (idStrictness var) dmd
-  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])
+  = -- pprTrace "dmdTransform:import" (vcat [ppr var, ppr (idStrictness var), ppr dmd, ppr res])
     res
-
-  | Just (sig, top_lvl) <- lookupSigEnv env var  -- Local letrec bound thing
+  -- Top-level or local let-bound thing for which we use LetDown ('useLetUp').
+  -- In that case, we have a strictness signature to unleash in our AnalEnv.
+  | Just (sig, top_lvl) <- lookupSigEnv env var
   , let fn_ty = dmdTransformSig sig dmd
-  = -- pprTrace "dmdTransform" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
+  = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
     if isTopLevel top_lvl
-    then fn_ty   -- Don't record top level things
+    then fn_ty   -- Don't record demand on top-level things
     else addVarDmd fn_ty var (mkOnceUsedDmd dmd)
-
-  | otherwise                                    -- Local non-letrec-bound thing
-  = unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))
+  -- Everything else:
+  --   * Local let binders for which we use LetUp (cf. 'useLetUp')
+  --   * Lambda binders
+  --   * Case and constructor field binders
+  | otherwise
+  = -- pprTrace "dmdTransform:other" (vcat [ppr var, ppr sig, ppr dmd, ppr res]) $
+    unitDmdType (unitVarEnv var (mkOnceUsedDmd dmd))
 
 {-
 ************************************************************************
@@ -600,10 +634,9 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
       = mkRhsDmd env rhs_arity rhs
     (DmdType rhs_fv rhs_dmds rhs_div, rhs')
                    = dmdAnal env rhs_dmd rhs
-    -- TODO: Won't the following line unnecessarily trim down arity for join
-    --       points returning a lambda in a C(S) context?
-    sig            = mkStrictSigForArity rhs_arity (mkDmdType sig_fv rhs_dmds rhs_div)
-    id'            = setIdStrictness id sig
+    sig            = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)
+    id'            = -- pprTrace "dmdAnalRhsLetDown" (ppr id <+> ppr sig) $
+                     setIdStrictness id sig
         -- See Note [NOINLINE and strictness]
 
 
diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs
index 4d759a47bc..9398435ee5 100644
--- a/compiler/GHC/Core/Opt/FloatIn.hs
+++ b/compiler/GHC/Core/Opt/FloatIn.hs
@@ -407,12 +407,17 @@ floating in cases with a single alternative that may bind values.
 
 But there are wrinkles
 
-* Which unlifted cases do we float? See GHC.Builtin.PrimOps
-  Note [PrimOp can_fail and has_side_effects] which explains:
-   - We can float-in can_fail primops, but we can't float them out.
+* Which unlifted cases do we float?
+  See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps which
+  explains:
+   - We can float in can_fail primops (which concerns imprecise exceptions),
+     but we can't float them out.
    - But we can float a has_side_effects primop, but NOT inside a lambda,
-     so for now we don't float them at all.
-  Hence exprOkForSideEffects
+     so for now we don't float them at all. Hence exprOkForSideEffects.
+   - Throwing precise exceptions is a special case of the previous point: We
+     may /never/ float in a call to (something that ultimately calls)
+     'raiseIO#'.
+     See Note [Precise exceptions and strictness analysis] in GHC.Types.Demand.
 
 * Because we can float can-fail primops (array indexing, division) inwards
   but not outwards, we must be careful not to transform
diff --git a/compiler/GHC/Core/Opt/FloatOut.hs b/compiler/GHC/Core/Opt/FloatOut.hs
index 92a747424f..7bb7acafb0 100644
--- a/compiler/GHC/Core/Opt/FloatOut.hs
+++ b/compiler/GHC/Core/Opt/FloatOut.hs
@@ -20,7 +20,7 @@ import GHC.Core.Opt.Monad ( FloatOutSwitches(..) )
 
 import GHC.Driver.Session
 import GHC.Utils.Error   ( dumpIfSet_dyn, DumpFormat (..) )
-import GHC.Types.Id      ( Id, idArity, idType, isBottomingId,
+import GHC.Types.Id      ( Id, idArity, idType, isDeadEndId,
                            isJoinId, isJoinId_maybe )
 import GHC.Core.Opt.SetLevels
 import GHC.Types.Unique.Supply ( UniqSupply )
@@ -221,7 +221,7 @@ floatBind (NonRec (TB var _) rhs)
 
         -- A tiresome hack:
         -- see Note [Bottoming floats: eta expansion] in GHC.Core.Opt.SetLevels
-    let rhs'' | isBottomingId var = etaExpand (idArity var) rhs'
+    let rhs'' | isDeadEndId var   = etaExpand (idArity var) rhs'
               | otherwise         = rhs'
 
     in (fs, rhs_floats, [NonRec var rhs'']) }
diff --git a/compiler/GHC/Core/Opt/LiberateCase.hs b/compiler/GHC/Core/Opt/LiberateCase.hs
index 7a28abce20..211fc39920 100644
--- a/compiler/GHC/Core/Opt/LiberateCase.hs
+++ b/compiler/GHC/Core/Opt/LiberateCase.hs
@@ -158,8 +158,8 @@ libCaseBind env (Rec pairs)
                                    Let (Rec dup_pairs) (Var unitDataConId)
 
     ok_pair (id,_)
-        =  idArity id > 0          -- Note [Only functions!]
-        && not (isBottomingId id)  -- Note [Not bottoming ids]
+        =  idArity id > 0       -- Note [Only functions!]
+        && not (isDeadEndId id) -- Note [Not bottoming ids]
 
 {- Note [Not bottoming Ids]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/GHC/Core/Opt/SetLevels.hs b/compiler/GHC/Core/Opt/SetLevels.hs
index ed6f4c61fe..0a1395a432 100644
--- a/compiler/GHC/Core/Opt/SetLevels.hs
+++ b/compiler/GHC/Core/Opt/SetLevels.hs
@@ -87,7 +87,7 @@ import GHC.Types.Unique.Set   ( nonDetStrictFoldUniqSet )
 import GHC.Types.Unique.DSet  ( getUniqDSet )
 import GHC.Types.Var.Env
 import GHC.Types.Literal      ( litIsTrivial )
-import GHC.Types.Demand       ( StrictSig, Demand, isStrictDmd, splitStrictSig, increaseStrictSigArity )
+import GHC.Types.Demand       ( StrictSig, Demand, isStrictDmd, splitStrictSig, prependArgsStrictSig )
 import GHC.Types.Cpr          ( mkCprSig, botCpr )
 import GHC.Types.Name         ( getOccName, mkSystemVarName )
 import GHC.Types.Name.Occurrence ( occNameString )
@@ -293,7 +293,7 @@ lvlTopBind env (Rec pairs)
 lvl_top :: LevelEnv -> RecFlag -> Id -> CoreExpr -> LvlM LevelledExpr
 lvl_top env is_rec bndr rhs
   = lvlRhs env is_rec
-           (isBottomingId bndr)
+           (isDeadEndId bndr)
            Nothing  -- Not a join point
            (freeVars rhs)
 
@@ -943,7 +943,7 @@ Id, *immediately*, for three reasons:
     Lint complains unless the scrutinee of such a case is clearly bottom.
 
     This was reported in #11290.   But since the whole bottoming-float
-    thing is based on the cheap-and-cheerful exprIsBottom, I'm not sure
+    thing is based on the cheap-and-cheerful exprIsDeadEnd, I'm not sure
     that it'll nail all such cases.
 
 Note [Bottoming floats: eta expansion] c.f Note [Bottoming floats]
@@ -983,7 +983,7 @@ annotateBotStr id n_extra mb_str
   = case mb_str of
       Nothing           -> id
       Just (arity, sig) -> id `setIdArity`      (arity + n_extra)
-                              `setIdStrictness` (increaseStrictSigArity n_extra sig)
+                              `setIdStrictness` (prependArgsStrictSig n_extra sig)
                               `setIdCprInfo`    mkCprSig (arity + n_extra) botCpr
 
 notWorthFloating :: CoreExpr -> [Var] -> Bool
diff --git a/compiler/GHC/Core/Opt/Simplify.hs b/compiler/GHC/Core/Opt/Simplify.hs
index 340efd2c9c..154b15e9d8 100644
--- a/compiler/GHC/Core/Opt/Simplify.hs
+++ b/compiler/GHC/Core/Opt/Simplify.hs
@@ -3058,7 +3058,7 @@ altsWouldDup (alt:alts)
   | is_bot_alt alt = altsWouldDup alts
   | otherwise      = not (all is_bot_alt alts)
   where
-    is_bot_alt (_,_,rhs) = exprIsBottom rhs
+    is_bot_alt (_,_,rhs) = exprIsDeadEnd rhs
 
 -------------------------
 mkDupableCont :: SimplEnv -> SimplCont
@@ -3515,7 +3515,7 @@ mkLetUnfolding dflags top_lvl src id new_rhs
             --             we don't.)  The simple thing is always to have one.
   where
     is_top_lvl   = isTopLevel top_lvl
-    is_bottoming = isBottomingId id
+    is_bottoming = isDeadEndId id
 
 -------------------
 simplStableUnfolding :: SimplEnv -> TopLevelFlag
diff --git a/compiler/GHC/Core/Opt/Simplify/Utils.hs b/compiler/GHC/Core/Opt/Simplify/Utils.hs
index 14e1a08fe0..87948ff6c1 100644
--- a/compiler/GHC/Core/Opt/Simplify/Utils.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Utils.hs
@@ -58,7 +58,6 @@ import GHC.Types.Var
 import GHC.Types.Demand
 import GHC.Types.Var.Set
 import GHC.Types.Basic
-import GHC.Builtin.PrimOps
 import GHC.Core.Opt.Simplify.Monad
 import GHC.Core.Type     hiding( substTy )
 import GHC.Core.Coercion hiding( substCo )
@@ -499,11 +498,9 @@ mkArgInfo env fun rules n_val_args call_cont
                         -- interesting context.  This avoids substituting
                         -- top-level bindings for (say) strings into
                         -- calls to error.  But now we are more careful about
-                        -- inlining lone variables, so it's ok
-                        -- (see GHC.Core.Opt.Simplify.Utils.analyseCont)
-                        -- See Note [Precise exceptions and strictness analysis] in Demand.hs
-                        -- for the special case on raiseIO#
-                   if isBotDiv result_info || isPrimOpId_maybe fun == Just RaiseIOOp then
+                        -- inlining lone variables, so its ok
+                        -- (see GHC.Core.Op.Simplify.Utils.analyseCont)
+                   if isDeadEndDiv result_info then
                         map isStrictDmd demands         -- Finite => result is bottom
                    else
                         map isStrictDmd demands ++ vanilla_stricts
@@ -1145,7 +1142,7 @@ preInlineUnconditionally
 preInlineUnconditionally env top_lvl bndr rhs rhs_env
   | not pre_inline_unconditionally           = Nothing
   | not active                               = Nothing
-  | isTopLevel top_lvl && isBottomingId bndr = Nothing -- Note [Top-level bottoming Ids]
+  | isTopLevel top_lvl && isDeadEndId bndr   = Nothing -- Note [Top-level bottoming Ids]
   | isCoVar bndr                             = Nothing -- Note [Do not inline CoVars unconditionally]
   | isExitJoinId bndr                        = Nothing -- Note [Do not inline exit join points]
                                                        -- in module Exitify
@@ -1517,7 +1514,7 @@ tryEtaExpandRhs :: SimplMode -> OutId -> OutExpr
 tryEtaExpandRhs mode bndr rhs
   | Just join_arity <- isJoinId_maybe bndr
   = do { let (join_bndrs, join_body) = collectNBinders join_arity rhs
-       ; return (count isId join_bndrs, exprIsBottom join_body, rhs) }
+       ; return (count isId join_bndrs, exprIsDeadEnd join_body, rhs) }
          -- Note [Do not eta-expand join points]
          -- But do return the correct arity and bottom-ness, because
          -- these are used to set the bndr's IdInfo (#15517)
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index 780c115857..d2c431765b 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -1551,8 +1551,8 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
                               , ri_lam_body = body, ri_arg_occs = arg_occs })
                spec_info@(SI { si_specs = specs, si_n_specs = spec_count
                              , si_mb_unspec = mb_unspec })
-  | isBottomingId fn      -- Note [Do not specialise diverging functions]
-                          -- and do not generate specialisation seeds from its RHS
+  | isDeadEndId fn  -- Note [Do not specialise diverging functions]
+                    -- and do not generate specialisation seeds from its RHS
   = -- pprTrace "specialise bot" (ppr fn) $
     return (nullUsage, spec_info)
 
@@ -1713,10 +1713,10 @@ calcSpecStrictness :: Id                     -- The original function
                    -> StrictSig              -- Strictness of specialised thing
 -- See Note [Transfer strictness]
 calcSpecStrictness fn qvars pats
-  = mkClosedStrictSig spec_dmds topDiv
+  = mkClosedStrictSig spec_dmds div
   where
     spec_dmds = [ lookupVarEnv dmd_env qv `orElse` topDmd | qv <- qvars, isId qv ]
-    StrictSig (DmdType _ dmds _) = idStrictness fn
+    StrictSig (DmdType _ dmds div) = idStrictness fn
 
     dmd_env = go emptyVarEnv dmds pats
 
@@ -1776,10 +1776,10 @@ Note [Transfer strictness]
 We must transfer strictness information from the original function to
 the specialised one.  Suppose, for example
 
-  f has strictness     SS
+  f has strictness     SSx
         and a RULE     f (a:as) b = f_spec a as b
 
-Now we want f_spec to have strictness  LLS, otherwise we'll use call-by-need
+Now we want f_spec to have strictness  LLSx, otherwise we'll use call-by-need
 when calling f_spec instead of call-by-value.  And that can result in
 unbounded worsening in space (cf the classic foldl vs foldl')
 
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index 4c4c3dc5e7..5ea719ac5b 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -1228,7 +1228,10 @@ mk_absent_let dflags fam_envs arg
 
     abs_rhs      = mkAbsentErrorApp arg_ty msg
     msg          = showSDoc (gopt_set dflags Opt_SuppressUniques)
-                          (ppr arg <+> ppr (idType arg))
+                            (ppr arg <+> ppr (idType arg) <+> file_msg)
+    file_msg     = case outputFile dflags of
+                     Nothing -> empty
+                     Just f  -> text "in output file " <+> quotes (text f)
               -- We need to suppress uniques here because otherwise they'd
               -- end up in the generated code as strings. This is bad for
               -- determinism, because with different uniques the strings
diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs
index 3e55600461..e8a4e86af1 100644
--- a/compiler/GHC/Core/SimpleOpt.hs
+++ b/compiler/GHC/Core/SimpleOpt.hs
@@ -39,7 +39,7 @@ import GHC.Types.Var      ( isNonCoVarId )
 import GHC.Types.Var.Set
 import GHC.Types.Var.Env
 import GHC.Core.DataCon
-import GHC.Types.Demand( etaExpandStrictSig )
+import GHC.Types.Demand( etaConvertStrictSig )
 import GHC.Core.Coercion.Opt ( optCoercion )
 import GHC.Core.Type hiding ( substTy, extendTvSubst, extendCvSubst, extendTvSubstList
                             , isInScope, substTyVarBndr, cloneTyVarBndr )
@@ -767,7 +767,7 @@ joinPointBinding_maybe bndr rhs
   , let str_sig   = idStrictness bndr
         str_arity = count isId bndrs  -- Strictness demands are for Ids only
         join_bndr = bndr `asJoinId`        join_arity
-                         `setIdStrictness` etaExpandStrictSig str_arity str_sig
+                         `setIdStrictness` etaConvertStrictSig str_arity str_sig
   = Just (join_bndr, mkLams bndrs body)
 
   | otherwise
diff --git a/compiler/GHC/Core/Unfold.hs b/compiler/GHC/Core/Unfold.hs
index 42a8974b54..bf281e7246 100644
--- a/compiler/GHC/Core/Unfold.hs
+++ b/compiler/GHC/Core/Unfold.hs
@@ -53,7 +53,7 @@ import GHC.Core.SimpleOpt
 import GHC.Core.Arity   ( manifestArity )
 import GHC.Core.Utils
 import GHC.Types.Id
-import GHC.Types.Demand ( StrictSig, isBottomingSig )
+import GHC.Types.Demand ( StrictSig, isDeadEndSig )
 import GHC.Core.DataCon
 import GHC.Types.Literal
 import GHC.Builtin.PrimOps
@@ -86,7 +86,7 @@ mkFinalUnfolding :: DynFlags -> UnfoldingSource -> StrictSig -> CoreExpr -> Unfo
 mkFinalUnfolding dflags src strict_sig expr
   = mkUnfolding dflags src
                 True {- Top level -}
-                (isBottomingSig strict_sig)
+                (isDeadEndSig strict_sig)
                 expr
 
 mkCompulsoryUnfolding :: CoreExpr -> Unfolding
@@ -1150,7 +1150,7 @@ certainlyWillInline dflags fn_info
         --    See Note [certainlyWillInline: INLINABLE]
     do_cunf expr (UnfIfGoodArgs { ug_size = size, ug_args = args })
       | arityInfo fn_info > 0  -- See Note [certainlyWillInline: be careful of thunks]
-      , not (isBottomingSig (strictnessInfo fn_info))
+      , not (isDeadEndSig (strictnessInfo fn_info))
               -- Do not unconditionally inline a bottoming functions even if
               -- it seems smallish. We've carefully lifted it out to top level,
               -- so we don't want to re-inline it.
diff --git a/compiler/GHC/Core/Utils.hs b/compiler/GHC/Core/Utils.hs
index 6faf179489..b9f4a63eb5 100644
--- a/compiler/GHC/Core/Utils.hs
+++ b/compiler/GHC/Core/Utils.hs
@@ -23,7 +23,7 @@ module GHC.Core.Utils (
 
         -- * Properties of expressions
         exprType, coreAltType, coreAltsType, isExprLevPoly,
-        exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsBottom,
+        exprIsDupable, exprIsTrivial, getIdFromTrivialExpr, exprIsDeadEnd,
         getIdFromTrivialExpr_maybe,
         exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,
         exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
@@ -1031,21 +1031,21 @@ getIdFromTrivialExpr_maybe e
     go _       = Nothing
 
 {-
-exprIsBottom is a very cheap and cheerful function; it may return
+exprIsDeadEnd is a very cheap and cheerful function; it may return
 False for bottoming expressions, but it never costs much to ask.  See
 also GHC.Core.Arity.exprBotStrictness_maybe, but that's a bit more
 expensive.
 -}
 
-exprIsBottom :: CoreExpr -> Bool
+exprIsDeadEnd :: CoreExpr -> Bool
 -- See Note [Bottoming expressions]
-exprIsBottom e
+exprIsDeadEnd e
   | isEmptyTy (exprType e)
   = True
   | otherwise
   = go 0 e
   where
-    go n (Var v) = isBottomingId v &&  n >= idArity v
+    go n (Var v)                 = isDeadEndId v &&  n >= idArity v
     go n (App e a) | isTypeArg a = go n e
                    | otherwise   = go (n+1) e
     go n (Tick _ e)              = go n e
@@ -1059,7 +1059,7 @@ exprIsBottom e
 {- Note [Bottoming expressions]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 A bottoming expression is guaranteed to diverge, or raise an
-exception.  We can test for it in two different ways, and exprIsBottom
+exception.  We can test for it in two different ways, and exprIsDeadEnd
 checks for both of these situations:
 
 * Visibly-bottom computations.  For example
@@ -1353,7 +1353,6 @@ type CheapAppFun = Id -> Arity -> Bool
   -- but with minor variations:
   --    isWorkFreeApp
   --    isCheapApp
-  --    isExpandableApp
 
 isWorkFreeApp :: CheapAppFun
 isWorkFreeApp fn n_val_args
@@ -1369,7 +1368,7 @@ isWorkFreeApp fn n_val_args
 isCheapApp :: CheapAppFun
 isCheapApp fn n_val_args
   | isWorkFreeApp fn n_val_args = True
-  | isBottomingId fn            = True  -- See Note [isCheapApp: bottoming functions]
+  | isDeadEndId fn              = True  -- See Note [isCheapApp: bottoming functions]
   | otherwise
   = case idDetails fn of
       DataConWorkId {} -> True  -- Actually handled by isWorkFreeApp
@@ -1390,7 +1389,7 @@ isExpandableApp fn n_val_args
       RecSelId {}  -> n_val_args == 1  -- See Note [Record selection]
       ClassOpId {} -> n_val_args == 1
       PrimOpId {}  -> False
-      _ | isBottomingId fn   -> False
+      _ | isDeadEndId fn     -> False
           -- See Note [isExpandableApp: bottoming functions]
         | isConLikeId fn     -> True
         | all_args_are_preds -> True
@@ -2136,7 +2135,7 @@ diffExpr top env (Tick n1 e1)   (Tick n2 e2)
  -- generated names, which are allowed to differ.
 diffExpr _   _   (App (App (Var absent) _) _)
                  (App (App (Var absent2) _) _)
-  | isBottomingId absent && isBottomingId absent2 = []
+  | isDeadEndId absent && isDeadEndId absent2 = []
 diffExpr top env (App f1 a1)    (App f2 a2)
   = diffExpr top env f1 f2 ++ diffExpr top env a1 a2
 diffExpr top env (Lam b1 e1)  (Lam b2 e2)