.gitlab-ci.yml

@@ -681,6 +681,25 @@ nightly-x86_64-linux-deb9-integer-simple:
     TEST_ENV: "x86_64-linux-deb9-integer-simple"
     TEST_TYPE: slowtest
 
+.build-x86_64-linux-deb9-tsan:
+  extends: .validate-linux-hadrian
+  stage: full-build
+  variables:
+    TEST_ENV: "x86_64-linux-deb9-tsan"
+    BUILD_FLAVOUR: "thread-sanitizer"
+    TSAN_OPTIONS: "suppressions=$CI_PROJECT_DIR/rts/.tsan-suppressions"
+    # Haddock is large enough to make TSAN choke without massive quantities of
+    # memory.
+    HADRIAN_ARGS: "--docs=none"
+
+nightly-x86_64-linux-deb9-tsan:
+  <<: *nightly
+  extends: .build-x86_64-linux-deb9-tsan
+
+validate-x86_64-linux-deb9-tsan:
+  extends: .build-x86_64-linux-deb9-tsan
+  when: manual
+
 validate-x86_64-linux-deb9-dwarf:
   extends: .build-x86_64-linux-deb9
   stage: full-build

compiler/GHC.hs

@@ -621,12 +621,6 @@ checkBrokenTablesNextToCode' dflags
 -- read), and prepares the compilers knowledge about packages.  It can
 -- be called again to load new packages: just add new package flags to
 -- (packageFlags dflags).
---
--- Returns a list of new packages that may need to be linked in using
--- the dynamic linker (see 'linkPackages') as a result of new package
--- flags.  If you are not doing linking or doing static linking, you
--- can ignore the list of packages returned.
---
 setSessionDynFlags :: GhcMonad m => DynFlags -> m ()
 setSessionDynFlags dflags0 = do
   dflags1 <- checkNewDynFlags dflags0

compiler/GHC/Builtin/primops.txt.pp

@@ -2079,39 +2079,47 @@ primop  WriteOffAddrOp_Word64 "writeWord64OffAddr#" GenPrimOp
    with has_side_effects = True
         can_fail         = True
 
-primop  InterlockedExchange_Addr "atomicExchangeAddr#" GenPrimOp
+primop  InterlockedExchange_Addr "atomicExchangeAddrAddr#" GenPrimOp
    Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
    {The atomic exchange operation. Atomically exchanges the value at the first address
     with the Addr# given as second argument. Implies a read barrier.}
    with has_side_effects = True
+        can_fail         = True
 
-primop  InterlockedExchange_Int "atomicExchangeInt#" GenPrimOp
-   Addr# -> Int# -> State# s -> (# State# s, Int# #)
+primop  InterlockedExchange_Word "atomicExchangeWordAddr#" GenPrimOp
+   Addr# -> Word# -> State# s -> (# State# s, Word# #)
    {The atomic exchange operation. Atomically exchanges the value at the address
     with the given value. Returns the old value. Implies a read barrier.}
    with has_side_effects = True
+        can_fail         = True
 
-primop  AtomicCompareExchange_Int "atomicCasInt#" GenPrimOp
-   Addr# -> Int# -> Int# -> State# s -> (# State# s, Int# #)
+primop  CasAddrOp_Addr "atomicCasAddrAddr#" GenPrimOp
+   Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
    { Compare and swap on a word-sized memory location.
 
-     Use as atomicCasInt# location expected desired
+     Use as: \s -> atomicCasAddrAddr# location expected desired s
 
-     This version always returns the old value read. This follows the normal protocol for CAS operations (and matches the underlying instruction on most architectures).
+     This version always returns the old value read. This follows the normal
+     protocol for CAS operations (and matches the underlying instruction on
+     most architectures).
 
      Implies a full memory barrier.}
    with has_side_effects = True
+        can_fail         = True
 
-primop  AtomicCompareExchange_Addr "atomicCasAddr#" GenPrimOp
-   Addr# -> Addr# -> Addr# -> State# s -> (# State# s, Addr# #)
-   { Compare and swap on a word-sized memory location.
+primop  CasAddrOp_Word "atomicCasWordAddr#" GenPrimOp
+   Addr# -> Word# -> Word# -> State# s -> (# State# s, Word# #)
+   { Compare and swap on a word-sized and aligned memory location.
 
-     Use as atomicCasAddr# location expected desired
+     Use as: \s -> atomicCasWordAddr# location expected desired s
 
-     This version always returns the old value read. This follows the normal protocol for CAS operations (and matches the underlying instruction on most architectures).
+     This version always returns the old value read. This follows the normal
+     protocol for CAS operations (and matches the underlying instruction on
+     most architectures).
 
      Implies a full memory barrier.}
    with has_side_effects = True
+        can_fail         = True
 
 ------------------------------------------------------------------------
 section "Mutable variables"
@@ -2214,7 +2222,7 @@ section "Exceptions"
 --          DEFAULT -> case ma of MVar a -> ...
 --          0#      -> maskAsyncExceptions# (\st -> case ma of MVar a -> ...)
 -- The outer case just decides whether to mask exceptions, but we don't want
--- thereby to hide the strictness in 'ma'!  Hence the use of strictApply1Dmd
+-- thereby to hide the strictness in 'ma'!  Hence the use of strictOnceApply1Dmd
 -- in mask and unmask. But catch really is lazy in its first argument, see
 -- #11555. So for IO actions 'ma' we often use a wrapper around it that is
 -- head-strict in 'ma': GHC.IO.catchException.
@@ -2260,7 +2268,7 @@ primop  MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp
         (State# RealWorld -> (# State# RealWorld, a #))
      -> (State# RealWorld -> (# State# RealWorld, a #))
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv }
+   strictness  = { \ _arity -> mkClosedStrictSig [strictOnceApply1Dmd,topDmd] topDiv }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -2269,7 +2277,7 @@ primop  MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp
         (State# RealWorld -> (# State# RealWorld, a #))
      -> (State# RealWorld -> (# State# RealWorld, a #))
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv }
+   strictness  = { \ _arity -> mkClosedStrictSig [strictOnceApply1Dmd,topDmd] topDiv }
    out_of_line = True
    has_side_effects = True
 
@@ -2277,7 +2285,7 @@ primop  UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp
         (State# RealWorld -> (# State# RealWorld, a #))
      -> (State# RealWorld -> (# State# RealWorld, a #))
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv }
+   strictness  = { \ _arity -> mkClosedStrictSig [strictOnceApply1Dmd,topDmd] topDiv }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -2298,7 +2306,7 @@ primop  AtomicallyOp "atomically#" GenPrimOp
       (State# RealWorld -> (# State# RealWorld, a #) )
    -> State# RealWorld -> (# State# RealWorld, a #)
    with
-   strictness  = { \ _arity -> mkClosedStrictSig [strictApply1Dmd,topDmd] topDiv }
+   strictness  = { \ _arity -> mkClosedStrictSig [strictManyApply1Dmd,topDmd] topDiv }
                  -- See Note [Strictness for mask/unmask/catch]
    out_of_line = True
    has_side_effects = True
@@ -3450,8 +3458,7 @@ primop PrefetchAddrOp3 "prefetchAddr3#" GenPrimOp
 
 primop PrefetchValueOp3 "prefetchValue3#" GenPrimOp
    a -> State# s -> State# s
-   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topDiv }
-        has_side_effects =  True
+   with has_side_effects =  True
 ----
 
 primop PrefetchByteArrayOp2 "prefetchByteArray2#" GenPrimOp
@@ -3468,8 +3475,7 @@ primop PrefetchAddrOp2 "prefetchAddr2#" GenPrimOp
 
 primop PrefetchValueOp2 "prefetchValue2#" GenPrimOp
    a ->  State# s -> State# s
-   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topDiv }
-        has_side_effects =  True
+   with has_side_effects =  True
 ----
 
 primop PrefetchByteArrayOp1 "prefetchByteArray1#" GenPrimOp
@@ -3486,8 +3492,7 @@ primop PrefetchAddrOp1 "prefetchAddr1#" GenPrimOp
 
 primop PrefetchValueOp1 "prefetchValue1#" GenPrimOp
    a -> State# s -> State# s
-   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topDiv }
-        has_side_effects =  True
+   with has_side_effects =  True
 ----
 
 primop PrefetchByteArrayOp0 "prefetchByteArray0#" GenPrimOp
@@ -3504,8 +3509,7 @@ primop PrefetchAddrOp0 "prefetchAddr0#" GenPrimOp
 
 primop PrefetchValueOp0 "prefetchValue0#" GenPrimOp
    a -> State# s -> State# s
-   with strictness  = { \ _arity -> mkClosedStrictSig [botDmd, topDmd] topDiv }
-        has_side_effects =  True
+   with has_side_effects =  True
 
 ------------------------------------------------------------------------
 ---                                                                  ---

compiler/GHC/CmmToAsm/X86/CodeGen.hs

@@ -1052,7 +1052,9 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps
     --------------------
     add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
     add_code rep x (CmmLit (CmmInt y _))
-        | is32BitInteger y = add_int rep x y
+        | is32BitInteger y
+        , rep /= W8 -- LEA doesn't support byte size (#18614)
+        = add_int rep x y
     add_code rep x y = trivialCode rep (ADD format) (Just (ADD format)) x y
       where format = intFormat rep
     -- TODO: There are other interesting patterns we want to replace
@@ -1061,7 +1063,9 @@ getRegister' _ is32Bit (CmmMachOp mop [x, y]) = -- dyadic MachOps
     --------------------
     sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register
     sub_code rep x (CmmLit (CmmInt y _))
-        | is32BitInteger (-y) = add_int rep x (-y)
+        | is32BitInteger (-y)
+        , rep /= W8 -- LEA doesn't support byte size (#18614)
+        = add_int rep x (-y)
     sub_code rep x y = trivialCode rep (SUB (intFormat rep)) Nothing x y
 
     -- our three-operand add instruction:
@@ -1824,6 +1828,35 @@ I386: First, we have to ensure that the condition
 codes are set according to the supplied comparison operation.
 -}
 
+{-  Note [64-bit integer comparisons on 32-bit]
+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+    When doing these comparisons there are 2 kinds of
+    comparisons.
+
+    * Comparison for equality (or lack thereof)
+
+    We use xor to check if high/low bits are
+    equal. Then combine the results using or and
+    perform a single conditional jump based on the
+    result.
+
+    * Other comparisons:
+
+    We map all other comparisons to the >= operation.
+    Why? Because it's easy to encode it with a single
+    conditional jump.
+
+    We do this by first computing [r1_lo - r2_lo]
+    and use the carry flag to compute
+    [r1_high - r2_high - CF].
+
+    At which point if r1 >= r2 then the result will be
+    positive. Otherwise negative so we can branch on this
+    condition.
+
+-}
+
 
 genCondBranch
     :: BlockId      -- the source of the jump
@@ -1841,22 +1874,63 @@ genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr
                -> NatM InstrBlock
 
 -- 64-bit integer comparisons on 32-bit
+-- See Note [64-bit integer comparisons on 32-bit]
 genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])
   | is32Bit, Just W64 <- maybeIntComparison mop = do
-  ChildCode64 code1 r1_lo <- iselExpr64 e1
-  ChildCode64 code2 r2_lo <- iselExpr64 e2
-  let r1_hi = getHiVRegFromLo r1_lo
-      r2_hi = getHiVRegFromLo r2_lo
-      cond = machOpToCond mop
-      Just cond' = maybeFlipCond cond
-  --TODO: Update CFG for x86
-  let code = code1 `appOL` code2 `appOL` toOL [
-        CMP II32 (OpReg r2_hi) (OpReg r1_hi),
-        JXX cond true,
-        JXX cond' false,
-        CMP II32 (OpReg r2_lo) (OpReg r1_lo),
-        JXX cond true] `appOL` genBranch false
-  return code
+
+  -- The resulting registers here are both the lower part of
+  -- the register as well as a way to get at the higher part.
+  ChildCode64 code1 r1 <- iselExpr64 e1
+  ChildCode64 code2 r2 <- iselExpr64 e2
+  let cond = machOpToCond mop :: Cond
+
+  let cmpCode = intComparison cond true false r1 r2
+  return $ code1 `appOL` code2 `appOL` cmpCode
+
+  where
+    intComparison :: Cond -> BlockId -> BlockId -> Reg -> Reg -> InstrBlock
+    intComparison cond true false r1_lo r2_lo =
+      case cond of
+        -- Impossible results of machOpToCond
+        ALWAYS  -> panic "impossible"
+        NEG     -> panic "impossible"
+        POS     -> panic "impossible"
+        CARRY   -> panic "impossible"
+        OFLO    -> panic "impossible"
+        PARITY  -> panic "impossible"
+        NOTPARITY -> panic "impossible"
+        -- Special case #1 x == y and x != y
+        EQQ -> cmpExact
+        NE  -> cmpExact
+        -- [x >= y]
+        GE  -> cmpGE
+        GEU -> cmpGE
+        -- [x >  y] <==> ![y >= x]
+        GTT -> intComparison GE  false true r2_lo r1_lo
+        GU  -> intComparison GEU false true r2_lo r1_lo
+        -- [x <= y] <==> [y >= x]
+        LE  -> intComparison GE  true false r2_lo r1_lo
+        LEU -> intComparison GEU true false r2_lo r1_lo
+        -- [x <  y] <==> ![x >= x]
+        LTT -> intComparison GE  false true r1_lo r2_lo
+        LU  -> intComparison GEU false true r1_lo r2_lo
+      where
+        r1_hi = getHiVRegFromLo r1_lo
+        r2_hi = getHiVRegFromLo r2_lo
+        cmpExact :: OrdList Instr
+        cmpExact =
+          toOL
+            [ XOR II32 (OpReg r2_hi) (OpReg r1_hi)
+            , XOR II32 (OpReg r2_lo) (OpReg r1_lo)
+            , OR  II32 (OpReg r1_hi)  (OpReg r1_lo)
+            , JXX cond true
+            , JXX ALWAYS false
+            ]
+        cmpGE = toOL
+            [ CMP II32 (OpReg r2_lo) (OpReg r1_lo)
+            , SBB II32 (OpReg r2_hi) (OpReg r1_hi)
+            , JXX cond true
+            , JXX ALWAYS false ]
 
 genCondBranch' _ bid id false bool = do
   CondCode is_float cond cond_code <- getCondCode bool

compiler/GHC/CmmToAsm/X86/Cond.hs

@@ -11,22 +11,22 @@ import GHC.Prelude
 
 data Cond
         = ALWAYS        -- What's really used? ToDo
-        | EQQ
-        | GE
-        | GEU
-        | GTT
-        | GU
-        | LE
-        | LEU
-        | LTT
-        | LU
-        | NE
-        | NEG
-        | POS
-        | CARRY
-        | OFLO
-        | PARITY
-        | NOTPARITY
+        | EQQ           -- je/jz -> zf = 1
+        | GE            -- jge
+        | GEU           -- ae
+        | GTT           -- jg
+        | GU            -- ja
+        | LE            -- jle
+        | LEU           -- jbe
+        | LTT           -- jl
+        | LU            -- jb
+        | NE            -- jne
+        | NEG           -- js
+        | POS           -- jns
+        | CARRY         -- jc
+        | OFLO          -- jo
+        | PARITY        -- jp
+        | NOTPARITY     -- jnp
         deriving Eq
 
 condToUnsigned :: Cond -> Cond

compiler/GHC/Core.hs

@@ -27,8 +27,8 @@ module GHC.Core (
         mkLet, mkLets, mkLetNonRec, mkLetRec, mkLams,
         mkApps, mkTyApps, mkCoApps, mkVarApps, mkTyArg,
 
-        mkIntLit, mkIntLitInt,
-        mkWordLit, mkWordLitWord,
+        mkIntLit, mkIntLitWrap,
+        mkWordLit, mkWordLitWrap,
         mkWord64LitWord64, mkInt64LitInt64,
         mkCharLit, mkStringLit,
         mkFloatLit, mkFloatLitFloat,
@@ -1977,23 +1977,25 @@ mkTyArg ty
 
 -- | Create a machine integer literal expression of type @Int#@ from an @Integer@.
 -- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr'
-mkIntLit      :: Platform -> Integer -> Expr b
--- | Create a machine integer literal expression of type @Int#@ from an @Int@.
--- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr'
-mkIntLitInt   :: Platform -> Int     -> Expr b
+mkIntLit :: Platform -> Integer -> Expr b
+mkIntLit platform n = Lit (mkLitInt platform n)
 
-mkIntLit    platform n = Lit (mkLitInt platform n)
-mkIntLitInt platform n = Lit (mkLitInt platform (toInteger n))
+-- | Create a machine integer literal expression of type @Int#@ from an
+-- @Integer@, wrapping if necessary.
+-- If you want an expression of type @Int@ use 'GHC.Core.Make.mkIntExpr'
+mkIntLitWrap :: Platform -> Integer -> Expr b
+mkIntLitWrap platform n = Lit (mkLitIntWrap platform n)
 
 -- | Create a machine word literal expression of type  @Word#@ from an @Integer@.
 -- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr'
-mkWordLit     :: Platform -> Integer -> Expr b
--- | Create a machine word literal expression of type  @Word#@ from a @Word@.
--- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr'
-mkWordLitWord :: Platform -> Word -> Expr b
+mkWordLit :: Platform -> Integer -> Expr b
+mkWordLit platform w = Lit (mkLitWord platform w)
 
-mkWordLit     platform w = Lit (mkLitWord platform w)
-mkWordLitWord platform w = Lit (mkLitWord platform (toInteger w))
+-- | Create a machine word literal expression of type  @Word#@ from an
+-- @Integer@, wrapping if necessary.
+-- If you want an expression of type @Word@ use 'GHC.Core.Make.mkWordExpr'
+mkWordLitWrap :: Platform -> Integer -> Expr b
+mkWordLitWrap platform w = Lit (mkLitWordWrap platform w)
 
 mkWord64LitWord64 :: Word64 -> Expr b
 mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w))

compiler/GHC/Core/Coercion.hs

@@ -1190,7 +1190,7 @@ mkGReflLeftCo r ty co
 mkCoherenceLeftCo :: Role -> Type -> CoercionN -> Coercion -> Coercion
 mkCoherenceLeftCo r ty co co2
   | isGReflCo co = co2
-  | otherwise = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2
+  | otherwise    = (mkSymCo $ GRefl r ty (MCo co)) `mkTransCo` co2
 
 -- | Given @ty :: k1@, @co :: k1 ~ k2@, @co2:: ty' ~r ty@,
 -- produces @co' :: ty' ~r (ty |> co)
@@ -1199,7 +1199,7 @@ mkCoherenceLeftCo r ty co co2
 mkCoherenceRightCo :: Role -> Type -> CoercionN -> Coercion -> Coercion
 mkCoherenceRightCo r ty co co2
   | isGReflCo co = co2
-  | otherwise = co2 `mkTransCo` GRefl r ty (MCo co)
+  | otherwise    = co2 `mkTransCo` GRefl r ty (MCo co)
 
 -- | Given @co :: (a :: k) ~ (b :: k')@ produce @co' :: k ~ k'@.
 mkKindCo :: Coercion -> Coercion

compiler/GHC/Core/Lint.hs

@@ -19,8 +19,8 @@ module GHC.Core.Lint (
 
     -- ** Debug output
     endPass, endPassIO,
-    dumpPassResult,
-    GHC.Core.Lint.dumpIfSet,
+    displayLintResults, dumpPassResult,
+    dumpIfSet,
  ) where
 
 #include "HsVersions.h"
@@ -65,7 +65,8 @@ import GHC.Core.TyCon as TyCon
 import GHC.Core.Coercion.Axiom
 import GHC.Core.Unify
 import GHC.Types.Basic
-import GHC.Utils.Error as Err
+import GHC.Utils.Error hiding ( dumpIfSet )
+import qualified GHC.Utils.Error as Err
 import GHC.Data.List.SetOps
 import GHC.Builtin.Names
 import GHC.Utils.Outputable as Outputable
@@ -372,33 +373,38 @@ lintPassResult hsc_env pass binds
   | not (gopt Opt_DoCoreLinting dflags)
   = return ()
   | otherwise
-  = do { let (warns, errs) = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds
+  = do { let warns_and_errs = lintCoreBindings dflags pass (interactiveInScope hsc_env) binds
        ; Err.showPass dflags ("Core Linted result of " ++ showPpr dflags pass)
-       ; displayLintResults dflags pass warns errs binds  }
+       ; displayLintResults dflags (showLintWarnings pass) (ppr pass)
+                            (pprCoreBindings binds) warns_and_errs }
   where
     dflags = hsc_dflags hsc_env
 
-displayLintResults :: DynFlags -> CoreToDo
-                   -> Bag Err.MsgDoc -> Bag Err.MsgDoc -> CoreProgram
+displayLintResults :: DynFlags
+                   -> Bool -- ^ If 'True', display linter warnings.
+                           --   If 'False', ignore linter warnings.
+                   -> SDoc -- ^ The source of the linted program
+                   -> SDoc -- ^ The linted program, pretty-printed
+                   -> WarnsAndErrs
                    -> IO ()
-displayLintResults dflags pass warns errs binds
+displayLintResults dflags display_warnings pp_what pp_pgm (warns, errs)
   | not (isEmptyBag errs)
   = do { putLogMsg dflags NoReason Err.SevDump noSrcSpan
            $ withPprStyle defaultDumpStyle
-           (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
+           (vcat [ lint_banner "errors" pp_what, Err.pprMessageBag errs
                  , text "*** Offending Program ***"
-                 , pprCoreBindings binds
+                 , pp_pgm
                  , text "*** End of Offense ***" ])
        ; Err.ghcExit dflags 1 }
 
   | not (isEmptyBag warns)
   , not (hasNoDebugOutput dflags)
-  , showLintWarnings pass
+  , display_warnings
   -- If the Core linter encounters an error, output to stderr instead of
   -- stdout (#13342)
   = putLogMsg dflags NoReason Err.SevInfo noSrcSpan
       $ withPprStyle defaultDumpStyle
-        (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))
+        (lint_banner "warnings" pp_what $$ Err.pprMessageBag (mapBag ($$ blankLine) warns))
 
   | otherwise = return ()
 
@@ -413,29 +419,18 @@ showLintWarnings :: CoreToDo -> Bool
 showLintWarnings (CoreDoSimplify _ (SimplMode { sm_phase = InitialPhase })) = False
 showLintWarnings _ = True
 
-lintInteractiveExpr :: String -> HscEnv -> CoreExpr -> IO ()
+lintInteractiveExpr :: SDoc -- ^ The source of the linted expression
+                    -> HscEnv -> CoreExpr -> IO ()
 lintInteractiveExpr what hsc_env expr
   | not (gopt Opt_DoCoreLinting dflags)
   = return ()
   | Just err <- lintExpr dflags (interactiveInScope hsc_env) expr
-  = do { display_lint_err err
-       ; Err.ghcExit dflags 1 }
+  = displayLintResults dflags False what (pprCoreExpr expr) (emptyBag, err)
   | otherwise
   = return ()
   where
     dflags = hsc_dflags hsc_env
 
-    display_lint_err err
-      = do { putLogMsg dflags NoReason Err.SevDump
-               noSrcSpan
-               $ withPprStyle defaultDumpStyle
-               (vcat [ lint_banner "errors" (text what)
-                     , err
-                     , text "*** Offending Program ***"
-                     , pprCoreExpr expr
-                     , text "*** End of Offense ***" ])
-           ; Err.ghcExit dflags 1 }
-
 interactiveInScope :: HscEnv -> [Var]
 -- In GHCi we may lint expressions, or bindings arising from 'deriving'
 -- clauses, that mention variables bound in the interactive context.
@@ -464,7 +459,7 @@ interactiveInScope hsc_env
               -- where t is a RuntimeUnk (see TcType)
 
 -- | Type-check a 'CoreProgram'. See Note [Core Lint guarantee].
-lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> (Bag MsgDoc, Bag MsgDoc)
+lintCoreBindings :: DynFlags -> CoreToDo -> [Var] -> CoreProgram -> WarnsAndErrs
 --   Returns (warnings, errors)
 -- If you edit this function, you may need to update the GHC formalism
 -- See Note [GHC Formalism]
@@ -540,16 +535,16 @@ hence the `TopLevelFlag` on `tcPragExpr` in GHC.IfaceToCore.
 
 -}
 
-lintUnfolding :: Bool           -- True <=> is a compulsory unfolding
+lintUnfolding :: Bool               -- True <=> is a compulsory unfolding
               -> DynFlags
               -> SrcLoc
-              -> VarSet         -- Treat these as in scope
+              -> VarSet             -- Treat these as in scope
               -> CoreExpr
-              -> Maybe MsgDoc   -- Nothing => OK
+              -> Maybe (Bag MsgDoc) -- Nothing => OK
 
 lintUnfolding is_compulsory dflags locn var_set expr
   | isEmptyBag errs = Nothing
-  | otherwise       = Just (pprMessageBag errs)
+  | otherwise       = Just errs
   where
     vars = nonDetEltsUniqSet var_set
     (_warns, errs) = initL dflags (defaultLintFlags dflags) vars $
@@ -563,11 +558,11 @@ lintUnfolding is_compulsory dflags locn var_set expr
 lintExpr :: DynFlags
          -> [Var]               -- Treat these as in scope
          -> CoreExpr
-         -> Maybe MsgDoc        -- Nothing => OK
+         -> Maybe (Bag MsgDoc)  -- Nothing => OK
 
 lintExpr dflags vars expr
   | isEmptyBag errs = Nothing
-  | otherwise       = Just (pprMessageBag errs)
+  | otherwise       = Just errs
   where
     (_warns, errs) = initL dflags (defaultLintFlags dflags) vars linter
     linter = addLoc TopLevelBindings $
@@ -2326,13 +2321,15 @@ lintCoercion (HoleCo h)
 -}
 
 lintAxioms :: DynFlags
+           -> SDoc -- ^ The source of the linted axioms
            -> [CoAxiom Branched]
-           -> WarnsAndErrs
-lintAxioms dflags axioms
-  = initL dflags (defaultLintFlags dflags) [] $
-    do { mapM_ lint_axiom axioms
-       ; let axiom_groups = groupWith coAxiomTyCon axioms
-       ; mapM_ lint_axiom_group axiom_groups }
+           -> IO ()
+lintAxioms dflags what axioms =
+  displayLintResults dflags True what (vcat $ map pprCoAxiom axioms) $
+  initL dflags (defaultLintFlags dflags) [] $
+  do { mapM_ lint_axiom axioms
+     ; let axiom_groups = groupWith coAxiomTyCon axioms
+     ; mapM_ lint_axiom_group axiom_groups }
 
 lint_axiom :: CoAxiom Branched -> LintM ()
 lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches

compiler/GHC/Core/Make.hs

@@ -13,7 +13,7 @@ module GHC.Core.Make (
         sortQuantVars, castBottomExpr,
 
         -- * Constructing boxed literals
-        mkWordExpr, mkWordExprWord,
+        mkWordExpr,
         mkIntExpr, mkIntExprInt, mkUncheckedIntExpr,
         mkIntegerExpr, mkNaturalExpr,
         mkFloatExpr, mkDoubleExpr,
@@ -263,16 +263,12 @@ mkUncheckedIntExpr i = mkCoreConApps intDataCon  [Lit (mkLitIntUnchecked i)]
 
 -- | Create a 'CoreExpr' which will evaluate to the given @Int@
 mkIntExprInt :: Platform -> Int -> CoreExpr         -- Result = I# i :: Int
-mkIntExprInt platform i = mkCoreConApps intDataCon  [mkIntLitInt platform i]
+mkIntExprInt platform i = mkCoreConApps intDataCon  [mkIntLit platform (fromIntegral i)]
 
 -- | Create a 'CoreExpr' which will evaluate to the a @Word@ with the given value
 mkWordExpr :: Platform -> Integer -> CoreExpr
 mkWordExpr platform w = mkCoreConApps wordDataCon [mkWordLit platform w]
 
--- | Create a 'CoreExpr' which will evaluate to the given @Word@
-mkWordExprWord :: Platform -> Word -> CoreExpr
-mkWordExprWord platform w = mkCoreConApps wordDataCon [mkWordLitWord platform w]
-
 -- | Create a 'CoreExpr' which will evaluate to the given @Integer@
 mkIntegerExpr  :: Integer -> CoreExpr  -- Result :: Integer
 mkIntegerExpr i = Lit (mkLitInteger i)

compiler/GHC/Core/Opt/ConstantFold.hs

@@ -1348,10 +1348,10 @@ builtinBignumRules _ =
       , rule_IntegerFromLitNum  "Int64# -> Integer"   integerFromInt64Name
       , rule_IntegerFromLitNum  "Word64# -> Integer"  integerFromWord64Name
       , rule_IntegerFromLitNum  "Natural -> Integer"  integerFromNaturalName
-      , rule_convert            "Integer -> Word#"    integerToWordName       mkWordLitWord
-      , rule_convert            "Integer -> Int#"     integerToIntName        mkIntLitInt
-      , rule_convert            "Integer -> Word64#"  integerToWord64Name     (\_ -> mkWord64LitWord64)
-      , rule_convert            "Integer -> Int64#"   integerToInt64Name      (\_ -> mkInt64LitInt64)
+      , rule_convert            "Integer -> Word#"    integerToWordName       mkWordLitWrap
+      , rule_convert            "Integer -> Int#"     integerToIntName        mkIntLitWrap
+      , rule_convert            "Integer -> Word64#"  integerToWord64Name     (\_ -> mkWord64LitWord64 . fromInteger)
+      , rule_convert            "Integer -> Int64#"   integerToInt64Name      (\_ -> mkInt64LitInt64 . fromInteger)
       , rule_binopi             "integerAdd"          integerAddName          (+)
       , rule_binopi             "integerSub"          integerSubName          (-)
       , rule_binopi             "integerMul"          integerMulName          (*)
@@ -1366,9 +1366,9 @@ builtinBignumRules _ =
       , rule_unop               "integerSignum"       integerSignumName       signum
       , rule_binop_Ordering     "integerCompare"      integerCompareName      compare
       , rule_encodeFloat        "integerEncodeFloat"  integerEncodeFloatName  mkFloatLitFloat
-      , rule_convert            "integerToFloat"      integerToFloatName      (\_ -> mkFloatLitFloat)
+      , rule_convert            "integerToFloat"      integerToFloatName      (\_ -> mkFloatLitFloat . fromInteger)
       , rule_encodeFloat        "integerEncodeDouble" integerEncodeDoubleName mkDoubleLitDouble
-      , rule_convert            "integerToDouble"     integerToDoubleName     (\_ -> mkDoubleLitDouble)
+      , rule_convert            "integerToDouble"     integerToDoubleName     (\_ -> mkDoubleLitDouble . fromInteger)
       , rule_binopi             "integerGcd"          integerGcdName          gcd
       , rule_binopi             "integerLcm"          integerLcmName          lcm
       , rule_binopi             "integerAnd"          integerAndName          (.&.)
@@ -1659,12 +1659,11 @@ match_integerBit _ _ _ _ = Nothing
 
 
 -------------------------------------------------
-match_Integer_convert :: Num a
-                      => (Platform -> a -> Expr CoreBndr)
+match_Integer_convert :: (Platform -> Integer -> Expr CoreBndr)
                       -> RuleFun
 match_Integer_convert convert env id_unf _ [xl]
   | Just (LitNumber LitNumInteger x) <- exprIsLiteral_maybe id_unf xl
-  = Just (convert (roPlatform env) (fromInteger x))
+  = Just (convert (roPlatform env) x)
 match_Integer_convert _ _ _ _ _ = Nothing
 
 match_Integer_unop :: (Integer -> Integer) -> RuleFun

compiler/GHC/Core/Opt/CprAnal.hs

@@ -319,7 +319,7 @@ cprAnalBind top_lvl env id rhs
     -- See Note [CPR for thunks]
     stays_thunk = is_thunk && not_strict
     is_thunk    = not (exprIsHNF rhs) && not (isJoinId id)
-    not_strict  = not (isStrictDmd (idDemandInfo id))
+    not_strict  = not (isStrUsedDmd (idDemandInfo id))
     -- See Note [CPR for sum types]
     (_, ret_ty) = splitPiTys (idType id)
     not_a_prod  = isNothing (deepSplitProductType_maybe (ae_fam_envs env) ret_ty)

compiler/GHC/Core/Opt/DmdAnal.hs

@@ -44,6 +44,8 @@ import GHC.Builtin.PrimOps
 import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
 import GHC.Types.Unique.Set
 
+-- import GHC.Driver.Ppr
+
 {-
 ************************************************************************
 *                                                                      *
@@ -143,21 +145,20 @@ dmdTransformThunkDmd e
 dmdAnalStar :: AnalEnv
             -> Demand   -- This one takes a *Demand*
             -> CoreExpr -- Should obey the let/app invariant
-            -> (BothDmdArg, CoreExpr)
-dmdAnalStar env dmd e
-  | (dmd_shell, cd) <- toCleanDmd dmd
-  , (dmd_ty, e')    <- dmdAnal env cd e
+            -> (PlusDmdArg, CoreExpr)
+dmdAnalStar env (n :* cd) e
+  | (dmd_ty, e')    <- dmdAnal env cd e
   = ASSERT2( not (isUnliftedType (exprType e)) || exprOkForSpeculation e, ppr e )
     -- The argument 'e' should satisfy the let/app invariant
     -- See Note [Analysing with absent demand] in GHC.Types.Demand
-    (postProcessDmdType dmd_shell dmd_ty, e')
+    (toPlusDmdArg $ multDmdType n dmd_ty, e')
 
 -- Main Demand Analsysis machinery
 dmdAnal, dmdAnal' :: AnalEnv
-        -> CleanDemand         -- The main one takes a *CleanDemand*
+        -> SubDemand         -- The main one takes a *SubDemand*
         -> CoreExpr -> (DmdType, CoreExpr)
 
--- The CleanDemand is always strict and not absent
+-- The SubDemand is always strict and not absent
 --    See Note [Ensure demand is strict]
 
 dmdAnal env d e = -- pprTrace "dmdAnal" (ppr d <+> ppr e) $
@@ -172,7 +173,7 @@ dmdAnal' env dmd (Var var)
   = (dmdTransform env var dmd, Var var)
 
 dmdAnal' env dmd (Cast e co)
-  = (dmd_ty `bothDmdType` mkBothDmdArg (coercionDmdEnv co), Cast e' co)
+  = (dmd_ty `plusDmdType` mkPlusDmdArg (coercionDmdEnv co), Cast e' co)
   where
     (dmd_ty, e') = dmdAnal env dmd e
 
@@ -206,7 +207,7 @@ dmdAnal' env dmd (App fun arg)
 --         , text "arg dmd_ty =" <+> ppr arg_ty
 --         , text "res dmd_ty =" <+> ppr res_ty
 --         , text "overall res dmd_ty =" <+> ppr (res_ty `bothDmdType` arg_ty) ])
-    (res_ty `bothDmdType` arg_ty, App fun' arg')
+    (res_ty `plusDmdType` arg_ty, App fun' arg')
 
 dmdAnal' env dmd (Lam var body)
   | isTyVar var
@@ -216,13 +217,13 @@ dmdAnal' env dmd (Lam var body)
     (body_ty, Lam var body')
 
   | otherwise
-  = let (body_dmd, defer_and_use) = peelCallDmd dmd
+  = let (n, body_dmd)    = peelCallDmd dmd
           -- body_dmd: a demand to analyze the body
 
         (body_ty, body') = dmdAnal env body_dmd body
         (lam_ty, var')   = annotateLamIdBndr env notArgOfDfun body_ty var
     in
-    (postProcessUnsat defer_and_use lam_ty, Lam var' body')
+    (multDmdType n lam_ty, Lam var' body')
 
 dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])
   -- Only one alternative with a product constructor
@@ -243,9 +244,9 @@ dmdAnal' env dmd (Case scrut case_bndr ty [(DataAlt dc, bndrs, rhs)])
 
         -- Compute demand on the scrutinee
         -- See Note [Demand on scrutinee of a product case]
-        scrut_dmd          = mkProdDmd id_dmds
+        scrut_dmd          = mkProd id_dmds
         (scrut_ty, scrut') = dmdAnal env scrut_dmd scrut
-        res_ty             = alt_ty3 `bothDmdType` toBothDmdArg scrut_ty
+        res_ty             = alt_ty3 `plusDmdType` toPlusDmdArg scrut_ty
         case_bndr'         = setIdDemandInfo case_bndr case_bndr_dmd
         bndrs'             = setBndrsDemandInfo bndrs id_dmds
     in
@@ -274,7 +275,7 @@ dmdAnal' env dmd (Case scrut case_bndr ty alts)
           = deferAfterPreciseException alt_ty
           | otherwise
           = alt_ty
-        res_ty               = alt_ty2 `bothDmdType` toBothDmdArg scrut_ty
+        res_ty               = alt_ty2 `plusDmdType` toPlusDmdArg scrut_ty
 
     in
 --    pprTrace "dmdAnal:Case2" (vcat [ text "scrut" <+> ppr scrut
@@ -304,7 +305,7 @@ dmdAnal' env dmd (Let (NonRec id rhs) body)
     id'                = setIdDemandInfo id id_dmd
 
     (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs
-    final_ty           = body_ty' `bothDmdType` rhs_ty
+    final_ty           = body_ty' `plusDmdType` rhs_ty
 
 dmdAnal' env dmd (Let (NonRec id rhs) body)
   = (body_ty2, Let (NonRec id2 rhs') body')
@@ -373,7 +374,7 @@ forcesRealWorld fam_envs ty
   | otherwise
   = False
 
-dmdAnalAlt :: AnalEnv -> CleanDemand -> Id -> Alt Var -> (DmdType, Alt Var)
+dmdAnalAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> (DmdType, Alt Var)
 dmdAnalAlt env dmd case_bndr (con,bndrs,rhs)
   | null bndrs    -- Literals, DEFAULT, and nullary constructors
   , (rhs_ty, rhs') <- dmdAnal env dmd rhs
@@ -386,8 +387,68 @@ dmdAnalAlt env dmd case_bndr (con,bndrs,rhs)
         id_dmds       = addCaseBndrDmd case_bndr_dmd dmds
   = (alt_ty, (con, setBndrsDemandInfo bndrs id_dmds, rhs'))
 
-{- Note [Which scrutinees may throw precise exceptions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+{-
+Note [Analysing with absent demand]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Suppose we analyse an expression with demand A.  The "A" means
+"absent", so this expression will never be needed.  What should happen?
+There are several wrinkles:
+
+* We *do* want to analyse the expression regardless.
+  Reason: Note [Always analyse in virgin pass]
+
+  But we can post-process the results to ignore all the usage
+  demands coming back. This is done by multDmdType.
+
+* In a previous incarnation of GHC we needed to be extra careful in the
+  case of an *unlifted type*, because unlifted values are evaluated
+  even if they are not used.  Example (see #9254):
+     f :: (() -> (# Int#, () #)) -> ()
+          -- Strictness signature is
+          --    <CS(S(A,SU))>
+          -- I.e. calls k, but discards first component of result
+     f k = case k () of (# _, r #) -> r
+
+     g :: Int -> ()
+     g y = f (\n -> (# case y of I# y2 -> y2, n #))
+
+  Here f's strictness signature says (correctly) that it calls its
+  argument function and ignores the first component of its result.
+  This is correct in the sense that it'd be fine to (say) modify the
+  function so that always returned 0# in the first component.
+
+  But in function g, we *will* evaluate the 'case y of ...', because
+  it has type Int#.  So 'y' will be evaluated.  So we must record this
+  usage of 'y', else 'g' will say 'y' is absent, and will w/w so that
+  'y' is bound to an aBSENT_ERROR thunk.
+
+  However, the argument of toSubDmd always satisfies the let/app
+  invariant; so if it is unlifted it is also okForSpeculation, and so
+  can be evaluated in a short finite time -- and that rules out nasty
+  cases like the one above.  (I'm not quite sure why this was a
+  problem in an earlier version of GHC, but it isn't now.)
+
+Note [Always analyse in virgin pass]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Tricky point: make sure that we analyse in the 'virgin' pass. Consider
+   rec { f acc x True  = f (...rec { g y = ...g... }...)
+         f acc x False = acc }
+In the virgin pass for 'f' we'll give 'f' a very strict (bottom) type.
+That might mean that we analyse the sub-expression containing the
+E = "...rec g..." stuff in a bottom demand.  Suppose we *didn't analyse*
+E, but just returned botType.
+
+Then in the *next* (non-virgin) iteration for 'f', we might analyse E
+in a weaker demand, and that will trigger doing a fixpoint iteration
+for g.  But *because it's not the virgin pass* we won't start g's
+iteration at bottom.  Disaster.  (This happened in $sfibToList' of
+nofib/spectral/fibheaps.)
+
+So in the virgin pass we make sure that we do analyse the expression
+at least once, to initialise its signatures.
+
+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.
@@ -436,7 +497,7 @@ worker, so the worker will rebuild
      x = (a, absent-error)
 and that'll crash.
 
-Note [Aggregated demand for cardinality]
+Note [Aggregated demand for cardinality] -- TODO: This Note should be named [LetUp vs. LetDown] and probably predates said separation
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 We use different strategies for strictness and usage/cardinality to
 "unleash" demands captured on free variables by bindings. Let us
@@ -486,7 +547,7 @@ strict in |y|.
 
 dmdTransform :: AnalEnv         -- The strictness environment
              -> Id              -- The function
-             -> CleanDemand     -- The demand on the function
+             -> SubDemand     -- The demand on the function
              -> DmdType         -- The demand type of the function in this context
         -- Returned DmdEnv includes the demand on
         -- this function plus demand on its free variables
@@ -499,7 +560,8 @@ dmdTransform env var dmd
   -- Used to be controlled by a flag.
   -- See #18429 for some perf measurements.
   | Just _ <- isClassOpId_maybe var
-  = dmdTransformDictSelSig (idStrictness var) dmd
+  = -- pprTrace "dmdTransform:DictSel" (ppr var $$ ppr dmd) $
+    dmdTransformDictSelSig (idStrictness var) dmd
   -- Imported functions
   | isGlobalId var
   , let res = dmdTransformSig (idStrictness var) dmd
@@ -512,14 +574,14 @@ dmdTransform env var dmd
   = -- pprTrace "dmdTransform:LetDown" (vcat [ppr var, ppr sig, ppr dmd, ppr fn_ty]) $
     if isTopLevel top_lvl
     then fn_ty   -- Don't record demand on top-level things
-    else addVarDmd fn_ty var (mkOnceUsedDmd dmd)
+    else addVarDmd fn_ty var (C_11 :* 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))
+    unitDmdType (unitVarEnv var (C_11 :* dmd))
 
 {- *********************************************************************
 *                                                                      *
@@ -541,14 +603,15 @@ dmdTransform env var dmd
 -- This is the LetDown rule in the paper “Higher-Order Cardinality Analysis”.
 dmdAnalRhsLetDown
   :: Maybe [Id]   -- Just bs <=> recursive, Nothing <=> non-recursive
-  -> AnalEnv -> CleanDemand
+  -> AnalEnv -> SubDemand
   -> Id -> CoreExpr
   -> (DmdEnv, StrictSig, CoreExpr)
 -- Process the RHS of the binding, add the strictness signature
 -- to the Id, and augment the environment with the signature as well.
 -- See Note [NOINLINE and strictness]
 dmdAnalRhsLetDown rec_flag env let_dmd id rhs
-  = (lazy_fv, sig, rhs')
+  = -- pprTrace "dmdAnalRhsLetDown" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $
+    (lazy_fv, sig, rhs')
   where
     rhs_arity = idArity id
     rhs_dmd -- See Note [Demand analysis for join points]
@@ -567,31 +630,40 @@ dmdAnalRhsLetDown rec_flag env let_dmd id rhs
     sig = mkStrictSigForArity rhs_arity (DmdType sig_fv rhs_dmds rhs_div)
 
     -- See Note [Aggregated demand for cardinality]
+    -- TODO: That Note doesn't explain the following lines at all. The reason
+    --       is really much different: When we have a recursive function, we'd
+    --       have to also consider the free vars of the strictness signature
+    --       when checking whether we found a fixed-point. That is expensive; we
+    --       only want to check whether argument demands of the sig changed.
+    --       reuseEnv makes it so that the FV results are stable as long as the
+    --       last argument demands were. Strictness won't change. But used-once
+    --       might turn into used-many even if the signature was stable and we'd
+    --       have to do an additional iteration. reuseEnv makes sure that we
+    --       never get used-once info for FVs of recursive functions.
     rhs_fv1 = case rec_flag of
                 Just bs -> reuseEnv (delVarEnvList rhs_fv bs)
                 Nothing -> rhs_fv
 
     rhs_fv2 = rhs_fv1 `keepAliveDmdEnv` extra_fvs
-
-    -- See Note [Lazy and unleashable free variables]
-    (lazy_fv, sig_fv) = partitionVarEnv isWeakDmd rhs_fv2
-
     -- Find the RHS free vars of the unfoldings and RULES
     -- See Note [Absence analysis for stable unfoldings and RULES]
     extra_fvs = foldr (unionVarSet . ruleRhsFreeIds) unf_fvs $
                 idCoreRules id
 
+    -- See Note [Lazy and unleashable free variables]
+    (lazy_fv, sig_fv) = partitionVarEnv isWeakDmd rhs_fv2
+
     unf = realIdUnfolding id
     unf_fvs | isStableUnfolding unf
             , Just unf_body <- maybeUnfoldingTemplate unf
             = exprFreeIds unf_body
             | otherwise = emptyVarSet
 
--- | @mkRhsDmd env rhs_arity rhs@ creates a 'CleanDemand' for
+-- | @mkRhsDmd env rhs_arity rhs@ creates a 'SubDemand' for
 -- unleashing on the given function's @rhs@, by creating
 -- a call demand of @rhs_arity@
 -- See Historical Note [Product demands for function body]
-mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> CleanDemand
+mkRhsDmd :: AnalEnv -> Arity -> CoreExpr -> SubDemand
 mkRhsDmd _env rhs_arity _rhs = mkCallDmds rhs_arity cleanEvalDmd
 
 -- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines
@@ -759,57 +831,6 @@ coercion into the binding, leading to an arity decrease:
 With the CoreLint check, we would have to zap `go`'s perfectly viable strictness
 signature.
 
-Note [What are demand signatures?]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Demand analysis interprets expressions in the abstract domain of demand
-transformers. Given an incoming demand we put an expression under, its abstract
-transformer gives us back a demand type denoting how other things (like
-arguments and free vars) were used when the expression was evaluated.
-Here's an example:
-
-  f x y =
-    if x + expensive
-      then \z -> z + y * ...
-      else \z -> z * ...
-
-The abstract transformer (let's call it F_e) of the if expression (let's call it
-e) would transform an incoming head demand <S,HU> into a demand type like
-{x-><S,1*U>,y-><L,U>}<L,U>. In pictures:
-
-     Demand ---F_e---> DmdType
-     <S,HU>            {x-><S,1*U>,y-><L,U>}<L,U>
-
-Let's assume that the demand transformers we compute for an expression are
-correct wrt. to some concrete semantics for Core. How do demand signatures fit
-in? They are strange beasts, given that they come with strict rules when to
-it's sound to unleash them.
-
-Fortunately, we can formalise the rules with Galois connections. Consider
-f's strictness signature, {}<S,1*U><L,U>. It's a single-point approximation of
-the actual abstract transformer of f's RHS for arity 2. So, what happens is that
-we abstract *once more* from the abstract domain we already are in, replacing
-the incoming Demand by a simple lattice with two elements denoting incoming
-arity: A_2 = {<2, >=2} (where '<2' is the top element and >=2 the bottom
-element). Here's the diagram:
-
-     A_2 -----f_f----> DmdType
-      ^                   |
-      | α               γ |
-      |                   v
-     Demand ---F_f---> DmdType
-
-With
-  α(C1(C1(_))) = >=2 -- example for usage demands, but similar for strictness
-  α(_)         =  <2
-  γ(ty)        =  ty
-and F_f being the abstract transformer of f's RHS and f_f being the abstracted
-abstract transformer computable from our demand signature simply by
-
-  f_f(>=2) = {}<S,1*U><L,U>
-  f_f(<2)  = postProcessUnsat {}<S,1*U><L,U>
-
-where postProcessUnsat makes a proper top element out of the given demand type.
-
 Note [Demand analysis for trivial right-hand sides]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider
@@ -899,7 +920,7 @@ deleted the special case.
 -- Recursive bindings
 dmdFix :: TopLevelFlag
        -> AnalEnv                            -- Does not include bindings for this binding
-       -> CleanDemand
+       -> SubDemand
        -> [(Id,CoreExpr)]
        -> (AnalEnv, DmdEnv, [(Id,CoreExpr)]) -- Binders annotated with strictness info
 
@@ -954,10 +975,11 @@ dmdFix top_lvl env let_dmd orig_pairs
                 -- so this can significantly reduce the number of iterations needed
 
         my_downRhs (env, lazy_fv) (id,rhs)
-          = ((env', lazy_fv'), (id', rhs'))
+          = -- pprTrace "my_downRhs" (ppr id $$ ppr (idStrictness id) $$ ppr sig) $
+            ((env', lazy_fv'), (id', rhs'))
           where
             (lazy_fv1, sig, rhs') = dmdAnalRhsLetDown (Just bndrs) env let_dmd id rhs
-            lazy_fv'              = plusVarEnv_C bothDmd lazy_fv lazy_fv1
+            lazy_fv'              = plusVarEnv_C plusDmd lazy_fv lazy_fv1
             env'                  = extendAnalEnv top_lvl env id sig
             id'                   = setIdStrictness id sig
 
@@ -1043,11 +1065,11 @@ coercionDmdEnv co = mapVarEnv (const topDmd) (getUniqSet $ coVarsOfCo co)
 
 addVarDmd :: DmdType -> Var -> Demand -> DmdType
 addVarDmd (DmdType fv ds res) var dmd
-  = DmdType (extendVarEnv_C bothDmd fv var dmd) ds res
+  = DmdType (extendVarEnv_C plusDmd fv var dmd) ds res
 
 addLazyFVs :: DmdType -> DmdEnv -> DmdType
 addLazyFVs dmd_ty lazy_fvs
-  = dmd_ty `bothDmdType` mkBothDmdArg lazy_fvs
+  = dmd_ty `plusDmdType` mkPlusDmdArg lazy_fvs
         -- Using bothDmdType (rather than just both'ing the envs)
         -- is vital.  Consider
         --      let f = \x -> (x,y)
@@ -1109,13 +1131,13 @@ annotateLamIdBndr env arg_of_dfun dmd_ty id
 -- For lambdas we add the demand to the argument demands
 -- Only called for Ids
   = ASSERT( isId id )
-    -- pprTrace "annLamBndr" (vcat [ppr id, ppr _dmd_ty]) $
+    -- pprTrace "annLamBndr" (vcat [ppr id, ppr dmd_ty, ppr final_ty]) $
     (final_ty, setIdDemandInfo id dmd)
   where
       -- Watch out!  See note [Lambda-bound unfoldings]
     final_ty = case maybeUnfoldingTemplate (idUnfolding id) of
                  Nothing  -> main_ty
-                 Just unf -> main_ty `bothDmdType` unf_ty
+                 Just unf -> main_ty `plusDmdType` unf_ty
                           where
                              (unf_ty, _) = dmdAnalStar env dmd unf
 
@@ -1314,7 +1336,8 @@ findBndrsDmds env dmd_ty bndrs
 findBndrDmd :: AnalEnv -> Bool -> DmdType -> Id -> (DmdType, Demand)
 -- See Note [Trimming a demand to a type]
 findBndrDmd env arg_of_dfun dmd_ty id
-  = (dmd_ty', dmd')
+  = -- pprTrace "findBndrDmd" (ppr id $$ ppr dmd_ty $$ ppr starting_dmd $$ ppr dmd') $
+    (dmd_ty', dmd')
   where
     dmd' = strictify $
            trimToType starting_dmd (findTypeShape fam_envs id_ty)

compiler/GHC/Core/Opt/Pipeline.hs

@@ -67,7 +67,6 @@ import GHC.Types.Id.Info
 import GHC.Types.Basic
 import GHC.Types.Var.Set
 import GHC.Types.Var.Env
-import GHC.Types.Demand
 import GHC.Types.Unique.Supply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
 import GHC.Types.Unique.FM
 import GHC.Types.Name.Ppr
@@ -1096,6 +1095,6 @@ dmdAnal dflags fam_envs binds = do
                }
       binds_plus_dmds = dmdAnalProgram opts fam_envs binds
   Err.dumpIfSet_dyn dflags Opt_D_dump_str_signatures "Strictness signatures" FormatText $
-    dumpIdInfoOfProgram (pprIfaceStrictSig . strictnessInfo) binds_plus_dmds
+    dumpIdInfoOfProgram (ppr . strictnessInfo) binds_plus_dmds
   -- See Note [Stamp out space leaks in demand analysis] in GHC.Core.Opt.DmdAnal
   seqBinds binds_plus_dmds `seq` return binds_plus_dmds

compiler/GHC/Core/Opt/SetLevels.hs

@@ -103,7 +103,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, prependArgsStrictSig )
+import GHC.Types.Demand       ( StrictSig, Demand, isStrUsedDmd, splitStrictSig, prependArgsStrictSig )
 import GHC.Types.Cpr          ( mkCprSig, botCpr )
 import GHC.Types.Name         ( getOccName, mkSystemVarName )
 import GHC.Types.Name.Occurrence ( occNameString )
@@ -469,7 +469,7 @@ lvlApp env orig_expr ((_,AnnVar fn), args)
     lvl_arg :: [Demand] -> CoreExprWithFVs -> LvlM ([Demand], LevelledExpr)
     lvl_arg strs arg | (str1 : strs') <- strs
                      , is_val_arg arg
-                     = do { arg' <- lvlMFE env (isStrictDmd str1) arg
+                     = do { arg' <- lvlMFE env (isStrUsedDmd str1) arg
                           ; return (strs', arg') }
                      | otherwise
                      = do { arg' <- lvlMFE env False arg

compiler/GHC/Core/Opt/Simplify.hs

@@ -41,7 +41,7 @@ import GHC.Core.Opt.Monad ( Tick(..), SimplMode(..) )
 import GHC.Core
 import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
 import GHC.Builtin.Names( runRWKey )
-import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrictDmd
+import GHC.Types.Demand ( StrictSig(..), Demand, dmdTypeDepth, isStrUsedDmd
                         , mkClosedStrictSig, topDmd, seqDmd, botDiv )
 import GHC.Types.Cpr    ( mkCprSig, botCpr )
 import GHC.Core.Ppr     ( pprCoreExpr )
@@ -2481,7 +2481,7 @@ There have been various earlier versions of this patch:
 
     scrut_is_demanded_var :: CoreExpr -> Bool
     scrut_is_demanded_var (Cast s _) = scrut_is_demanded_var s
-    scrut_is_demanded_var (Var _)    = isStrictDmd (idDemandInfo case_bndr)
+    scrut_is_demanded_var (Var _)    = isStrUsedDmd (idDemandInfo case_bndr)
     scrut_is_demanded_var _          = False
 
   This only fired if the scrutinee was a /variable/, which seems
@@ -2709,7 +2709,7 @@ doCaseToLet scrut case_bndr
 
   | otherwise  -- Scrut has a lifted type
   = exprIsHNF scrut
-    || isStrictDmd (idDemandInfo case_bndr)
+    || isStrUsedDmd (idDemandInfo case_bndr)
     -- See Note [Case-to-let for strictly-used binders]
 
 --------------------------------------------------

compiler/GHC/Core/Opt/Simplify/Utils.hs

@@ -329,7 +329,7 @@ addCastTo ai co = ai { ai_args = CastBy co : ai_args ai }
 isStrictArgInfo :: ArgInfo -> Bool
 -- True if the function is strict in the next argument
 isStrictArgInfo (ArgInfo { ai_dmds = dmds })
-  | dmd:_ <- dmds = isStrictDmd dmd
+  | dmd:_ <- dmds = isStrUsedDmd dmd
   | otherwise     = False
 
 argInfoAppArgs :: [ArgSpec] -> [OutExpr]
@@ -582,7 +582,7 @@ mkArgInfo env fun rules n_val_args call_cont
       | Just (_, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty        -- Add strict-type info
       , dmd : rest_dmds <- dmds
       , let dmd' = case isLiftedType_maybe arg_ty of
-                       Just False -> strictenDmd dmd
+                       Just False -> strictifyDmd dmd
                        _          -> dmd
       = dmd' : add_type_strictness fun_ty' rest_dmds
           -- If the type is levity-polymorphic, we can't know whether it's

compiler/GHC/Core/Opt/SpecConstr.hs

@@ -1724,11 +1724,12 @@ calcSpecStrictness fn qvars pats
     go env _      _                = env
 
     go_one :: DmdEnv -> Demand -> CoreExpr -> DmdEnv
-    go_one env d   (Var v) = extendVarEnv_C bothDmd env v d
-    go_one env d e
-           | Just ds <- splitProdDmd_maybe d  -- NB: d does not have to be strict
-           , (Var _, args) <- collectArgs e = go env ds args
-    go_one env _         _ = env
+    go_one env d               (Var v) = extendVarEnv_C plusDmd env v d
+    go_one env (_n :* cd) e -- NB: _n does not have to be strict
+      | (Var _, args) <- collectArgs e
+      , Just ds <- viewProd (length args) cd
+      = go env ds args
+    go_one env _               _       = env
 
 {-
 Note [spec_usg includes rhs_usg]

compiler/GHC/Core/Opt/WorkWrap/Utils.hs

@@ -610,7 +610,7 @@ wantToUnbox :: FamInstEnvs -> Bool -> Type -> Demand -> Maybe ([Demand], DataCon
 wantToUnbox fam_envs has_inlineable_prag ty dmd =
   case deepSplitProductType_maybe fam_envs ty of
     Just dcac@DataConAppContext{ dcac_arg_tys = con_arg_tys }
-      | isStrictDmd dmd
+      | isStrUsedDmd dmd
       -- See Note [Unpacking arguments with product and polymorphic demands]
       , Just cs <- split_prod_dmd_arity dmd (length con_arg_tys)
       -- See Note [Do not unpack class dictionaries]
@@ -621,12 +621,11 @@ wantToUnbox fam_envs has_inlineable_prag ty dmd =
     _ -> Nothing
   where
     split_prod_dmd_arity dmd arty
-      -- For seqDmd, splitProdDmd_maybe will return Nothing (because how would
-      -- it know the arity?), but it should behave like <S, U(AAAA)>, for some
+      -- For seqDmd, it should behave like <S(AAAA)>, for some
       -- suitable arity
-      | isSeqDmd dmd = Just (replicate arty absDmd)
-      -- Otherwise splitProdDmd_maybe does the job
-      | otherwise    = splitProdDmd_maybe dmd
+      | isSeqDmd dmd        = Just (replicate arty absDmd)
+      | _ :* Prod ds <- dmd = Just ds
+      | otherwise           = Nothing
 
 unbox_one :: DynFlags -> FamInstEnvs -> Var
           -> [Demand]

compiler/GHC/CoreToStg.hs

@@ -46,7 +46,7 @@ import GHC.Driver.Session
 import GHC.Platform.Ways
 import GHC.Driver.Ppr
 import GHC.Types.ForeignCall
-import GHC.Types.Demand    ( isUsedOnce )
+import GHC.Types.Demand    ( isUsedOnceDmd )
 import GHC.Builtin.PrimOps ( PrimCall(..) )
 import GHC.Types.SrcLoc    ( mkGeneralSrcSpan )
 import GHC.Builtin.Names   ( unsafeEqualityProofName )
@@ -714,8 +714,8 @@ mkTopStgRhs dflags this_mod ccs bndr rhs
   where
     unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs
 
-    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
-             | otherwise                      = Updatable
+    upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry
+             | otherwise                         = Updatable
 
     -- CAF cost centres generated for -fcaf-all
     caf_cc = mkAutoCC bndr modl
@@ -756,8 +756,8 @@ mkStgRhs bndr rhs
   where
     unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs
 
-    upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry
-             | otherwise                      = Updatable
+    upd_flag | isUsedOnceDmd (idDemandInfo bndr) = SingleEntry
+             | otherwise                         = Updatable
 
   {-
     SDM: disabled.  Eval/Apply can't handle functions with arity zero very

compiler/GHC/CoreToStg/Prep.hs

@@ -1359,7 +1359,7 @@ mkFloat dmd is_unlifted bndr rhs
                    -- See Note [Pin demand info on floats]
   where
     is_hnf    = exprIsHNF rhs
-    is_strict = isStrictDmd dmd
+    is_strict = isStrUsedDmd dmd
 
 emptyFloats :: Floats
 emptyFloats = Floats OkToSpec nilOL
@@ -1446,7 +1446,7 @@ canFloat (Floats ok_to_spec fs) rhs
 wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
 wantFloatNested is_rec dmd is_unlifted floats rhs
   =  isEmptyFloats floats
-  || isStrictDmd dmd
+  || isStrUsedDmd dmd
   || is_unlifted
   || (allLazyNested is_rec floats && exprIsHNF rhs)
         -- Why the test for allLazyNested?