ghc-lib 0.20220401 → 0.20220501

raw patch · 88 files changed

+2923/−2028 lines, 88 filesdep ~ghc-lib-parserPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghc-lib-parser

API changes (from Hackage documentation)

Files

• compiler/GHC.hs +1/−1
• compiler/GHC/Builtin/Names/TH.hs +40/−38
• compiler/GHC/Cmm/InitFini.hs +6/−6
• compiler/GHC/CmmToAsm/X86/CodeGen.hs +112/−52
• compiler/GHC/CmmToAsm/X86/Instr.hs +4/−0
• compiler/GHC/Core/Opt/CSE.hs +2/−2
• compiler/GHC/Core/Opt/DmdAnal.hs +80/−31
• compiler/GHC/Core/Opt/FloatIn.hs +12/−24
• compiler/GHC/Core/Opt/Pipeline.hs +2/−2
• compiler/GHC/Core/Opt/SetLevels.hs +5/−5
• compiler/GHC/Core/Opt/Simplify.hs +238/−205
• compiler/GHC/Core/Opt/Simplify/Env.hs +35/−28
• compiler/GHC/Core/Opt/Simplify/Utils.hs +101/−31
• compiler/GHC/Core/Opt/SpecConstr.hs +2/−1
• compiler/GHC/Core/Opt/Specialise.hs +297/−287
• compiler/GHC/Core/Opt/WorkWrap/Utils.hs +1/−1
• compiler/GHC/CoreToStg.hs +5/−1
• compiler/GHC/Driver/Backpack.hs +4/−3
• compiler/GHC/Driver/CodeOutput.hs +9/−0
• compiler/GHC/Driver/Main.hs +7/−6
• compiler/GHC/Driver/Make.hs +119/−45
• compiler/GHC/Driver/Pipeline.hs +8/−9
• compiler/GHC/Driver/Pipeline/Execute.hs +48/−9
• compiler/GHC/Hs/Syn/Type.hs +1/−1
• compiler/GHC/HsToCore/Arrows.hs +159/−64
• compiler/GHC/HsToCore/Binds.hs +1/−3
• compiler/GHC/HsToCore/Coverage.hs +15/−15
• compiler/GHC/HsToCore/Expr.hs +9/−12
• compiler/GHC/HsToCore/Match.hs +27/−10
• compiler/GHC/HsToCore/Match.hs-boot +1/−1
• compiler/GHC/HsToCore/Pmc.hs +14/−13
• compiler/GHC/HsToCore/Pmc/Utils.hs +16/−14
• compiler/GHC/HsToCore/Quote.hs +9/−2
• compiler/GHC/HsToCore/Utils.hs +3/−6
• compiler/GHC/Iface/Ext/Ast.hs +3/−3
• compiler/GHC/IfaceToCore.hs +0/−1
• compiler/GHC/Linker/Loader.hs +8/−3
• compiler/GHC/Linker/Static.hs +5/−18
• compiler/GHC/Plugins.hs +1/−1
• compiler/GHC/Rename/Bind.hs +49/−10
• compiler/GHC/Rename/Env.hs +1/−3
• compiler/GHC/Rename/Expr.hs +8/−7
• compiler/GHC/Rename/HsType.hs +45/−35
• compiler/GHC/Rename/Module.hs +2/−0
• compiler/GHC/Settings/IO.hs +6/−3
• compiler/GHC/Stg/InferTags/Rewrite.hs +8/−2
• compiler/GHC/Stg/Lint.hs +26/−5
• compiler/GHC/Stg/Unarise.hs +24/−2
• compiler/GHC/StgToByteCode.hs +3/−1
• compiler/GHC/SysTools/Ar.hs +6/−5
• compiler/GHC/SysTools/Info.hs +2/−28
• compiler/GHC/SysTools/Tasks.hs +8/−26
• compiler/GHC/Tc/Deriv/Generate.hs +3/−3
• compiler/GHC/Tc/Deriv/Utils.hs +2/−2
• compiler/GHC/Tc/Errors.hs +168/−101
• compiler/GHC/Tc/Gen/App.hs +15/−8
• compiler/GHC/Tc/Gen/Arrow.hs +73/−77
• compiler/GHC/Tc/Gen/Bind.hs +3/−3
• compiler/GHC/Tc/Gen/Expr.hs +13/−15
• compiler/GHC/Tc/Gen/Head.hs +37/−38
• compiler/GHC/Tc/Gen/HsType.hs +18/−108
• compiler/GHC/Tc/Gen/Match.hs +38/−21
• compiler/GHC/Tc/Gen/Pat.hs +11/−8
• compiler/GHC/Tc/Gen/Rule.hs +15/−13
• compiler/GHC/Tc/Gen/Sig.hs +1/−1
• compiler/GHC/Tc/Instance/FunDeps.hs +4/−2
• compiler/GHC/Tc/Module.hs +2/−2
• compiler/GHC/Tc/Solver.hs +75/−34
• compiler/GHC/Tc/Solver/Canonical.hs +0/−48
• compiler/GHC/Tc/Solver/Interact.hs +2/−10
• compiler/GHC/Tc/Solver/Monad.hs +6/−8
• compiler/GHC/Tc/TyCl/Build.hs +1/−3
• compiler/GHC/Tc/TyCl/Instance.hs +1/−1
• compiler/GHC/Tc/TyCl/PatSyn.hs +6/−8
• compiler/GHC/Tc/Utils/Concrete.hs +353/−138
• compiler/GHC/Tc/Utils/Instantiate.hs +2/−2
• compiler/GHC/Tc/Utils/Monad.hs +14/−2
• compiler/GHC/Tc/Utils/TcMType.hs +115/−132
• compiler/GHC/Tc/Utils/Unify.hs +244/−56
• compiler/GHC/Tc/Utils/Unify.hs-boot +3/−3
• compiler/GHC/Tc/Utils/Zonk.hs +5/−6
• compiler/GHC/Tc/Validity.hs +39/−59
• compiler/GHC/ThToHs.hs +26/−19
• compiler/GHC/Types/TyThing/Ppr.hs +3/−1
• compiler/GHC/Unit/Finder.hs +10/−3
• ghc-lib.cabal +4/−4
• ghc-lib/stage0/lib/settings +7/−7
• ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +6/−1

@@ -1900,7 +1900,7 @@       Just envfile -> do         content <- readFile envfile         compilationProgressMsg logger (text "Loaded package environment from " <> text envfile)-        let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags+        let (_, dflags') = runCmdLineP (runEwM (setFlagsFromEnvFile envfile content)) dflags          return dflags'   where

@@ -54,7 +54,7 @@     -- Exp     varEName, conEName, litEName, appEName, appTypeEName, infixEName,     infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName,-    tupEName, unboxedTupEName, unboxedSumEName,+    lamCasesEName, tupEName, unboxedTupEName, unboxedSumEName,     condEName, multiIfEName, letEName, caseEName, doEName, mdoEName, compEName,     fromEName, fromThenEName, fromToEName, fromThenToEName,     listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,@@ -285,7 +285,7 @@  -- data Exp = ... varEName, conEName, litEName, appEName, appTypeEName, infixEName, infixAppName,-    sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,+    sectionLName, sectionRName, lamEName, lamCaseEName, lamCasesEName, tupEName,     unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,     caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,     labelEName, implicitParamVarEName, getFieldEName, projectionEName :: Name@@ -300,6 +300,7 @@ sectionRName          = libFun (fsLit "sectionR")          sectionRIdKey lamEName              = libFun (fsLit "lamE")              lamEIdKey lamCaseEName          = libFun (fsLit "lamCaseE")          lamCaseEIdKey+lamCasesEName         = libFun (fsLit "lamCasesE")         lamCasesEIdKey tupEName              = libFun (fsLit "tupE")              tupEIdKey unboxedTupEName       = libFun (fsLit "unboxedTupE")       unboxedTupEIdKey unboxedSumEName       = libFun (fsLit "unboxedSumE")       unboxedSumEIdKey@@ -813,8 +814,8 @@ -- data Exp = ... varEIdKey, conEIdKey, litEIdKey, appEIdKey, appTypeEIdKey, infixEIdKey,     infixAppIdKey, sectionLIdKey, sectionRIdKey, lamEIdKey, lamCaseEIdKey,-    tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey, multiIfEIdKey,-    letEIdKey, caseEIdKey, doEIdKey, compEIdKey,+    lamCasesEIdKey, tupEIdKey, unboxedTupEIdKey, unboxedSumEIdKey, condEIdKey,+    multiIfEIdKey, letEIdKey, caseEIdKey, doEIdKey, compEIdKey,     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,     unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey,@@ -830,52 +831,53 @@ sectionRIdKey          = mkPreludeMiscIdUnique 278 lamEIdKey              = mkPreludeMiscIdUnique 279 lamCaseEIdKey          = mkPreludeMiscIdUnique 280-tupEIdKey              = mkPreludeMiscIdUnique 281-unboxedTupEIdKey       = mkPreludeMiscIdUnique 282-unboxedSumEIdKey       = mkPreludeMiscIdUnique 283-condEIdKey             = mkPreludeMiscIdUnique 284-multiIfEIdKey          = mkPreludeMiscIdUnique 285-letEIdKey              = mkPreludeMiscIdUnique 286-caseEIdKey             = mkPreludeMiscIdUnique 287-doEIdKey               = mkPreludeMiscIdUnique 288-compEIdKey             = mkPreludeMiscIdUnique 289-fromEIdKey             = mkPreludeMiscIdUnique 290-fromThenEIdKey         = mkPreludeMiscIdUnique 291-fromToEIdKey           = mkPreludeMiscIdUnique 292-fromThenToEIdKey       = mkPreludeMiscIdUnique 293-listEIdKey             = mkPreludeMiscIdUnique 294-sigEIdKey              = mkPreludeMiscIdUnique 295-recConEIdKey           = mkPreludeMiscIdUnique 296-recUpdEIdKey           = mkPreludeMiscIdUnique 297-staticEIdKey           = mkPreludeMiscIdUnique 298-unboundVarEIdKey       = mkPreludeMiscIdUnique 299-labelEIdKey            = mkPreludeMiscIdUnique 300-implicitParamVarEIdKey = mkPreludeMiscIdUnique 301-mdoEIdKey              = mkPreludeMiscIdUnique 302-getFieldEIdKey         = mkPreludeMiscIdUnique 303-projectionEIdKey       = mkPreludeMiscIdUnique 304+lamCasesEIdKey         = mkPreludeMiscIdUnique 281+tupEIdKey              = mkPreludeMiscIdUnique 282+unboxedTupEIdKey       = mkPreludeMiscIdUnique 283+unboxedSumEIdKey       = mkPreludeMiscIdUnique 284+condEIdKey             = mkPreludeMiscIdUnique 285+multiIfEIdKey          = mkPreludeMiscIdUnique 286+letEIdKey              = mkPreludeMiscIdUnique 287+caseEIdKey             = mkPreludeMiscIdUnique 288+doEIdKey               = mkPreludeMiscIdUnique 289+compEIdKey             = mkPreludeMiscIdUnique 290+fromEIdKey             = mkPreludeMiscIdUnique 291+fromThenEIdKey         = mkPreludeMiscIdUnique 292+fromToEIdKey           = mkPreludeMiscIdUnique 293+fromThenToEIdKey       = mkPreludeMiscIdUnique 294+listEIdKey             = mkPreludeMiscIdUnique 295+sigEIdKey              = mkPreludeMiscIdUnique 296+recConEIdKey           = mkPreludeMiscIdUnique 297+recUpdEIdKey           = mkPreludeMiscIdUnique 298+staticEIdKey           = mkPreludeMiscIdUnique 299+unboundVarEIdKey       = mkPreludeMiscIdUnique 300+labelEIdKey            = mkPreludeMiscIdUnique 301+implicitParamVarEIdKey = mkPreludeMiscIdUnique 302+mdoEIdKey              = mkPreludeMiscIdUnique 303+getFieldEIdKey         = mkPreludeMiscIdUnique 304+projectionEIdKey       = mkPreludeMiscIdUnique 305  -- type FieldExp = ... fieldExpIdKey :: Unique-fieldExpIdKey       = mkPreludeMiscIdUnique 305+fieldExpIdKey       = mkPreludeMiscIdUnique 306  -- data Body = ... guardedBIdKey, normalBIdKey :: Unique-guardedBIdKey     = mkPreludeMiscIdUnique 306-normalBIdKey      = mkPreludeMiscIdUnique 307+guardedBIdKey     = mkPreludeMiscIdUnique 307+normalBIdKey      = mkPreludeMiscIdUnique 308  -- data Guard = ... normalGEIdKey, patGEIdKey :: Unique-normalGEIdKey     = mkPreludeMiscIdUnique 308-patGEIdKey        = mkPreludeMiscIdUnique 309+normalGEIdKey     = mkPreludeMiscIdUnique 309+patGEIdKey        = mkPreludeMiscIdUnique 310  -- data Stmt = ... bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique-bindSIdKey       = mkPreludeMiscIdUnique 310-letSIdKey        = mkPreludeMiscIdUnique 311-noBindSIdKey     = mkPreludeMiscIdUnique 312-parSIdKey        = mkPreludeMiscIdUnique 313-recSIdKey        = mkPreludeMiscIdUnique 314+bindSIdKey       = mkPreludeMiscIdUnique 311+letSIdKey        = mkPreludeMiscIdUnique 312+noBindSIdKey     = mkPreludeMiscIdUnique 313+parSIdKey        = mkPreludeMiscIdUnique 314+recSIdKey        = mkPreludeMiscIdUnique 315  -- data Dec = ... funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,

@@ -49,12 +49,12 @@  On Windows initializers/finalizers are a bit tricky due to the inability to merge objects (due to the lld linker's lack of `-r` support on Windows; see-#21068) since we instead must package foreign stubs into static archives.-However, the linker is free to not include any constituent objects of a static-library in the final object code if nothing depends upon them. Consequently, we-must ensure that the initializer list for a module is defined in the module's-object code, not its foreign stubs. This happens naturally with the plan laid-out above.+Note [Object merging] in GHC.Driver.Pipeline.Execute) since we instead must+package foreign stubs into static archives.  However, the linker is free to not+include any constituent objects of a static library in the final object code if+nothing depends upon them. Consequently, we must ensure that the initializer+list for a module is defined in the module's object code, not its foreign+stubs. This happens naturally with the plan laid out above.  Note that we maintain the invariant that at most one initializer and one finalizer CmmDecl will be emitted per module.

@@ -437,7 +437,26 @@     ... (tmp) ... -} +{-+Note [%rip-relative addressing on x86-64]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On x86-64 GHC produces code for use in the "small" or, when `-fPIC` is set,+"small PIC" code models defined by the x86-64 System V ABI (section 3.5.1 of+specification version 0.99). +In general the small code model would allow us to assume that code is located+between 0 and 2^31 - 1. However, this is not true on Windows which, due to+high-entropy ASLR, may place the executable image anywhere in 64-bit address+space. This is problematic since immediate operands in x86-64 are generally+32-bit sign-extended values (with the exception of the 64-bit MOVABS encoding).+Consequently, to avoid overflowing we use %rip-relative addressing universally.+Since %rip-relative addressing comes essentially for free and makes linking far+easier, we use it even on non-Windows platforms.++See also: the documentation for GCC's `-mcmodel=small` flag.+-}++ -- | Check whether an integer will fit in 32 bits. --      A CmmInt is intended to be truncated to the appropriate --      number of bits, so here we truncate it to Int64.  This is@@ -1139,6 +1158,22 @@     in         return (Any format code) +-- Handle symbol references with LEA and %rip-relative addressing.+-- See Note [%rip-relative addressing on x86-64].+getRegister' platform is32Bit (CmmLit lit)+  | is_label lit+  , not is32Bit+  = do let format = cmmTypeFormat (cmmLitType platform lit)+           imm = litToImm lit+           op = OpAddr (AddrBaseIndex EABaseRip EAIndexNone imm)+           code dst = unitOL (LEA format op (OpReg dst))+       return (Any format code)+  where+    is_label (CmmLabel {})        = True+    is_label (CmmLabelOff {})     = True+    is_label (CmmLabelDiffOff {}) = True+    is_label _                    = False+   -- optimisation for loading small literals on x86_64: take advantage   -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit   -- instruction forms are shorter.@@ -1156,7 +1191,7 @@         -- signed literals that fit in 32 bits, but we want unsigned         -- literals here.         -- note2: all labels are small, because we're assuming the-        -- small memory model (see gcc docs, -mcmodel=small).+        -- small memory model. See Note [%rip-relative addressing on x86-64].  getRegister' platform _ (CmmLit lit)   = do let format = cmmTypeFormat (cmmLitType platform lit)@@ -1253,7 +1288,7 @@       -- This is all just ridiculous, since it carefully undoes       -- what mangleIndexTree has just done.       CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]-         | is32BitLit is32Bit lit+         | is32BitLit platform lit          -- assert (rep == II32)???          -> do             (x_reg, x_code) <- getSomeReg x@@ -1261,7 +1296,7 @@             return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code)        CmmMachOp (MO_Add _rep) [x, CmmLit lit]-         | is32BitLit is32Bit lit+         | is32BitLit platform lit          -- assert (rep == II32)???          -> do             (x_reg, x_code) <- getSomeReg x@@ -1292,8 +1327,16 @@          | not (isLit y) -- we already handle valid literals above.          -> x86_complex_amode x y 0 0 +      -- Handle labels with %rip-relative addressing since in general the image+      -- may be loaded anywhere in the 64-bit address space (e.g. on Windows+      -- with high-entropy ASLR). See Note [%rip-relative addressing on x86-64].       CmmLit lit-         | is32BitLit is32Bit lit+         | not is32Bit+         , is_label lit+         -> return (Amode (AddrBaseIndex EABaseRip EAIndexNone (litToImm lit)) nilOL)++      CmmLit lit+         | is32BitLit platform lit          -> return (Amode (ImmAddr (litToImm lit) 0) nilOL)        -- Literal with offsets too big (> 32 bits) fails during the linking phase@@ -1313,7 +1356,11 @@       _ -> do         (reg,code) <- getSomeReg e         return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code)-+  where+    is_label (CmmLabel{}) = True+    is_label (CmmLabelOff{}) = True+    is_label (CmmLabelDiffOff{}) = True+    is_label _ = False   -- | Like 'getAmode', but on 32-bit use simple register addressing@@ -1362,9 +1409,8 @@     Amode addr code <- memConstant (mkAlignment $ widthInBytes w) lit     return (OpAddr addr, code)   else do-    is32Bit <- is32BitPlatform     platform <- getPlatform-    if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit))+    if is32BitLit platform lit && not (isFloatType (cmmLitType platform lit))     then return (OpImm (litToImm lit), nilOL)     else getNonClobberedOperand_generic (CmmLit lit) @@ -1421,9 +1467,8 @@       return (OpAddr addr, code)     else do -  is32Bit <- is32BitPlatform   platform <- getPlatform-  if is32BitLit is32Bit lit && not (isFloatType (cmmLitType platform lit))+  if is32BitLit platform lit && not (isFloatType (cmmLitType platform lit))     then return (OpImm (litToImm lit), nilOL)     else getOperand_generic (CmmLit lit) @@ -1444,9 +1489,10 @@     (reg, code) <- getSomeReg e     return (OpReg reg, code) -isOperand :: Bool -> CmmExpr -> Bool+isOperand :: Platform -> CmmExpr -> Bool isOperand _ (CmmLoad _ _ _) = True-isOperand is32Bit (CmmLit lit)  = is32BitLit is32Bit lit+isOperand platform (CmmLit lit)+                          = is32BitLit platform lit                           || isSuitableFloatingPointLit lit isOperand _ _            = False @@ -1517,21 +1563,28 @@     (reg, code) <- getNonClobberedReg e     return (OpReg reg, code) -is32BitLit :: Bool -> CmmLit -> Bool-is32BitLit is32Bit lit-   | not is32Bit = case lit of+is32BitLit :: Platform -> CmmLit -> Bool+is32BitLit platform _lit+   | target32Bit platform = True+is32BitLit platform lit =+   case lit of       CmmInt i W64              -> is32BitInteger i-      -- assume that labels are in the range 0-2^31-1: this assumes the-      -- small memory model (see gcc docs, -mcmodel=small).-      CmmLabel _                -> True+      -- Except on Windows, assume that labels are in the range 0-2^31-1: this+      -- assumes the small memory model. Note [%rip-relative addressing on+      -- x86-64].+      CmmLabel _                -> low_image       -- however we can't assume that label offsets are in this range       -- (see #15570)-      CmmLabelOff _ off         -> is32BitInteger (fromIntegral off)-      CmmLabelDiffOff _ _ off _ -> is32BitInteger (fromIntegral off)+      CmmLabelOff _ off         -> low_image && is32BitInteger (fromIntegral off)+      CmmLabelDiffOff _ _ off _ -> low_image && is32BitInteger (fromIntegral off)       _                         -> True-is32BitLit _ _ = True--+  where+    -- Is the executable image certain to be located below 4GB? As noted in+    -- Note [%rip-relative addressing on x86-64], this is not true on Windows.+    low_image =+      case platformOS platform of+        OSMinGW32 -> False   -- See Note [%rip-relative addressing on x86-64]+        _         -> True   -- Set up a condition code for a conditional branch.@@ -1584,14 +1637,14 @@ -- passed back up the tree.  condIntCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode-condIntCode cond x y = do is32Bit <- is32BitPlatform-                          condIntCode' is32Bit cond x y+condIntCode cond x y = do platform <- getPlatform+                          condIntCode' platform cond x y -condIntCode' :: Bool -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode+condIntCode' :: Platform -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode  -- memory vs immediate-condIntCode' is32Bit cond (CmmLoad x pk _) (CmmLit lit)- | is32BitLit is32Bit lit = do+condIntCode' platform cond (CmmLoad x pk _) (CmmLit lit)+ | is32BitLit platform lit = do     Amode x_addr x_code <- getAmode x     let         imm  = litToImm lit@@ -1602,8 +1655,8 @@  -- anything vs zero, using a mask -- TODO: Add some sanity checking!!!!-condIntCode' is32Bit cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk))-    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit is32Bit lit+condIntCode' platform cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk))+    | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit platform lit     = do       (x_reg, x_code) <- getSomeReg x       let@@ -1622,9 +1675,8 @@     return (CondCode False cond code)  -- anything vs operand-condIntCode' is32Bit cond x y- | isOperand is32Bit y = do-    platform <- getPlatform+condIntCode' platform cond x y+ | isOperand platform y = do     (x_reg, x_code) <- getNonClobberedReg x     (y_op,  y_code) <- getOperand y     let@@ -1633,9 +1685,8 @@     return (CondCode False cond code) -- operand vs. anything: invert the comparison so that we can use a -- single comparison instruction.- | isOperand is32Bit x+ | isOperand platform x  , Just revcond <- maybeFlipCond cond = do-    platform <- getPlatform     (y_reg, y_code) <- getNonClobberedReg y     (x_op,  x_code) <- getOperand x     let@@ -1644,8 +1695,7 @@     return (CondCode False revcond code)  -- anything vs anything-condIntCode' _ cond x y = do-  platform <- getPlatform+condIntCode' platform cond x y = do   (y_reg, y_code) <- getNonClobberedReg y   (x_op, x_code) <- getRegOrMem x   let@@ -1719,9 +1769,9 @@  -- general case assignMem_IntCode pk addr src = do-    is32Bit <- is32BitPlatform+    platform <- getPlatform     Amode addr code_addr <- getAmode addr-    (code_src, op_src)   <- get_op_RI is32Bit src+    (code_src, op_src)   <- get_op_RI platform src     let         code = code_src `appOL`                code_addr `snocOL`@@ -1733,8 +1783,8 @@     --     return code   where-    get_op_RI :: Bool -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator-    get_op_RI is32Bit (CmmLit lit) | is32BitLit is32Bit lit+    get_op_RI :: Platform -> CmmExpr -> NatM (InstrBlock,Operand)   -- code, operator+    get_op_RI platform (CmmLit lit) | is32BitLit platform lit       = return (nilOL, OpImm (litToImm lit))     get_op_RI _ op       = do (reg,code) <- getNonClobberedReg op@@ -2563,12 +2613,12 @@               -- pass the arg into the given register               reg_this_arg r                 -- "operand" args can be directly assigned into r-                | isOperand False arg = do+                | isOperand platform arg = do                     arg_code <- getAnyReg arg                     return (code, (acode `appOL` arg_code r))                 -- The last non-operand arg can be directly assigned after its                 -- computation without going into a temporary register-                | all (isOperand False) rest = do+                | all (isOperand platform) rest = do                     arg_code   <- getAnyReg arg                     return (code `appOL` arg_code r,acode) @@ -2864,11 +2914,21 @@   else do         (reg,e_code) <- getSomeReg indexExpr         lbl <- getNewLabelNat-        let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))-            code = e_code `appOL` toOL [-                    JMP_TBL op ids (Section ReadOnlyData lbl) lbl-                 ]-        return code+        let is32bit = target32Bit platform+        if is32bit+          then let op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg (platformWordSizeInBytes platform)) (ImmCLbl lbl))+                   jmp_code = JMP_TBL op ids (Section ReadOnlyData lbl) lbl+               in return $ e_code `appOL` unitOL jmp_code+          else do+            -- See Note [%rip-relative addressing on x86-64].+            tableReg <- getNewRegNat (intFormat (platformWordWidth platform))+            let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0))+                code = e_code `appOL` toOL+                    [ LEA (archWordFormat is32bit) (OpAddr (AddrBaseIndex EABaseRip EAIndexNone (ImmCLbl lbl))) (OpReg tableReg)+                    , MOV (archWordFormat is32bit) op (OpReg reg)+                    , JMP_TBL (OpReg reg) ids (Section ReadOnlyData lbl) lbl+                    ]+            return code   where     (offset, blockIds) = switchTargetsToTable targets     ids = map (fmap DestBlockId) blockIds@@ -3078,14 +3138,14 @@             -> Maybe (Operand -> Operand -> Instr)             -> CmmExpr -> CmmExpr -> NatM Register trivialCode width instr m a b-    = do is32Bit <- is32BitPlatform-         trivialCode' is32Bit width instr m a b+    = do platform <- getPlatform+         trivialCode' platform width instr m a b -trivialCode' :: Bool -> Width -> (Operand -> Operand -> Instr)+trivialCode' :: Platform -> Width -> (Operand -> Operand -> Instr)              -> Maybe (Operand -> Operand -> Instr)              -> CmmExpr -> CmmExpr -> NatM Register-trivialCode' is32Bit width _ (Just revinstr) (CmmLit lit_a) b-  | is32BitLit is32Bit lit_a = do+trivialCode' platform width _ (Just revinstr) (CmmLit lit_a) b+  | is32BitLit platform lit_a = do   b_code <- getAnyReg b   let        code dst

@@ -196,6 +196,10 @@          -- Moves.         | MOV         Format Operand Operand+             -- ^ N.B. when used with the 'II64' 'Format', the source+             -- operand is interpreted to be a 32-bit sign-extended value.+             -- True 64-bit operands need to be moved with @MOVABS@, which we+             -- currently don't use.         | CMOV   Cond Format Operand Reg         | MOVZxL      Format Operand Operand               -- ^ The format argument is the size of operand 1 (the number of bits we keep)

@@ -273,8 +273,8 @@    case x |> co of (y::Array# Int) { ... }  We do not want to extend the substitution with (y -> x |> co); since y-is of unlifted type, this would destroy the let/app invariant if (x |>-co) was not ok-for-speculation.+is of unlifted type, this would destroy the let-can-float invariant if+(x |> co) was not ok-for-speculation.  But surely (x |> co) is ok-for-speculation, because it's a trivial expression, and x's type is also unlifted, presumably.  Well, maybe

@@ -285,7 +285,7 @@      id_dmd'            = finaliseLetBoxity (ae_fam_envs env) (idType id) id_dmd     !id'               = setBindIdDemandInfo top_lvl id id_dmd'-    (rhs_ty, rhs')     = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd') rhs+    (rhs_ty, rhs')     = dmdAnalStar env id_dmd' rhs      -- See Note [Absence analysis for stable unfoldings and RULES]     rule_fvs           = bndrRuleAndUnfoldingIds id@@ -335,27 +335,33 @@         -- the vanilla call demand seem to be due to (b).  So we don't         -- bother to re-analyse the RHS. --- If e is complicated enough to become a thunk, its contents will be evaluated--- at most once, so oneify it.-dmdTransformThunkDmd :: CoreExpr -> Demand -> Demand-dmdTransformThunkDmd e-  | exprIsTrivial e = id-  | otherwise       = oneifyDmd+-- | Mimic the effect of 'GHC.Core.Prep.mkFloat', turning non-trivial argument+-- expressions/RHSs into a proper let-bound thunk (lifted) or a case (with+-- unlifted scrutinee).+anticipateANF :: CoreExpr -> Card -> Card+anticipateANF e n+  | exprIsTrivial e                               = n -- trivial expr won't have a binding+  | Just Unlifted <- typeLevity_maybe (exprType e)+  , not (isAbs n && exprOkForSpeculation e)       = case_bind n+  | otherwise                                     = let_bind  n+  where+    case_bind _ = C_11       -- evaluated exactly once+    let_bind    = oneifyCard -- evaluated at most once  -- Do not process absent demands -- Otherwise act like in a normal demand analysis -- See ↦* relation in the Cardinality Analysis paper dmdAnalStar :: AnalEnv             -> Demand   -- This one takes a *Demand*-            -> CoreExpr -- Should obey the let/app invariant+            -> CoreExpr             -> (PlusDmdArg, CoreExpr) dmdAnalStar env (n :* sd) e   -- NB: (:*) expands AbsDmd and BotDmd as needed-  -- See Note [Analysing with absent demand]   | WithDmdType dmd_ty e' <- dmdAnal env sd e-  = assertPpr (mightBeLiftedType (exprType e) || exprOkForSpeculation e) (ppr e)-    -- The argument 'e' should satisfy the let/app invariant-    (toPlusDmdArg $ multDmdType n dmd_ty, e')+  , n' <- anticipateANF e n+      -- See Note [Anticipating ANF in demand analysis]+      -- and Note [Analysing with absent demand]+  = (toPlusDmdArg $ multDmdType n' dmd_ty, e')  -- Main Demand Analsysis machinery dmdAnal, dmdAnal' :: AnalEnv@@ -398,7 +404,7 @@         call_dmd          = mkCalledOnceDmd dmd         WithDmdType fun_ty fun' = dmdAnal env call_dmd fun         (arg_dmd, res_ty) = splitDmdTy fun_ty-        (arg_ty, arg')    = dmdAnalStar env (dmdTransformThunkDmd arg arg_dmd) arg+        (arg_ty, arg')    = dmdAnalStar env arg_dmd arg     in --    pprTrace "dmdAnal:app" (vcat --         [ text "dmd =" <+> ppr dmd@@ -589,6 +595,45 @@     scrut_sd = case_sd `plusSubDmd` mkProd Unboxed fld_dmds  {-+Note [Anticipating ANF in demand analysis]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When analysing non-complex (e.g., trivial) thunks and complex function+arguments, we have to pretend that the expression is really in administrative+normal form (ANF), the conversion to which is done by CorePrep.++Consider+```+f x = let y = x |> co in y `seq` y `seq` ()+```+E.g., 'y' is a let-binding with a trivial RHS. That may occur if 'y' can't be+inlined, for example. Now, is 'x' used once? It may appear as if that is the+case, since its only occurrence is in 'y's memoised RHS. But actually, CorePrep+will *not* allocate a thunk for 'y', because it is trivial and could just+re-use the memoisation mechanism of 'x'! By saying that 'x' is used once it+becomes a single-entry thunk and a call to 'f' will evaluate it twice.+The same applies to trivial arguments, e.g., `f z` really evaluates `z` twice.++So, somewhat counter-intuitively, trivial arguments and let RHSs will *not* be+memoised. On the other hand, evaluation of non-trivial arguments and let RHSs+*will* be memoised. In fact, consider the effect of conversion to ANF on complex+function arguments (as done by 'GHC.Core.Prep.mkFloat'):+```+f2 (g2 x) ===> let y = g2 x in f2 y                   (if `y` is lifted)+f3 (g3 x) ===> case g3 x of y { __DEFAULT -> f3 y }   (if `y` is not lifted)+```+So if a lifted argument like `g2 x` is complex enough, it will be memoised.+Regardless how many times 'f2' evaluates its parameter, the argument will be+evaluated at most once to WHNF.+Similarly, when an unlifted argument like `g3 x` is complex enough, we will+evaluate it *exactly* once to WHNF, no matter how 'f3' evaluates its parameter.++Note that any evaluation beyond WHNF is not affected by memoisation. So this+Note affects the outer 'Card' of a 'Demand', but not its nested 'SubDemand'.+'anticipateANF' predicts the effect of case-binding and let-binding complex+arguments, as well as the lack of memoisation for trivial let RHSs.+In particular, this takes care of the gripes in+Note [Analysing with absent demand] relating to unlifted types.+ Note [Analysing with absent demand] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we analyse an expression with demand A.  The "A" means@@ -599,7 +644,8 @@   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.+  demands coming back. This is done by 'multDmdType' with the appropriate+  (absent) evaluation cardinality A or B.  * Nevertheless, which sub-demand should we pick for analysis?   Since the demand was absent, any would do. Worker/wrapper will replace@@ -610,33 +656,36 @@   be bottoming. Better pick 'seqSubDmd', so that we annotate many of those   nested bindings with A themselves. -* 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):+* Since we allow unlifted arguments that are not ok-for-speculation,+  we need to be extra careful in the following situation, because unlifted+  values are evaluated even if they are not used. Example from #9254:      f :: (() -> (# Int#, () #)) -> ()           -- Strictness signature is-          --    <CS(S(A,SU))>+          --    <1C1(P(A,1L))>           -- 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.+  Here, f's strictness signature says (correctly) that it calls its argument+  function and ignores the first component of its result. -  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.+  But in function g, we *will* evaluate the 'case y of ...', because it has type+  Int#. So in the program as written, 'y' will be evaluated. Hence 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 filler (see Note [Absent fillers]), leading+  to a crash when 'y' is evaluated. -  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.)+  Now, worker/wrapper could be smarter and replace `case y of I# y2 -> y2`+  with a suitable absent filler such as `RUBBISH[IntRep] @Int#`.+  But as long as worker/wrapper isn't equipped to do so, we must be cautious,+  and follow Note [Anticipating ANF in demand analysis]. That is, in+  'dmdAnalStar', we will set the evaluation cardinality to C_11, anticipating+  the case binding of the complex argument `case y of I# y2 -> y2`. This+  cardinlities' only effect is in the call to 'multDmdType', where it makes sure+  that the demand on the arg's free variable 'y' is not absent and strict, so+  that it is ultimately passed unboxed to 'g'.  Note [Always analyse in virgin pass] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -194,14 +194,11 @@     add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet)     add_arg (fun_ty, extra_fvs) (_, AnnType ty)       = (piResultTy fun_ty ty, extra_fvs)-     add_arg (fun_ty, extra_fvs) (arg_fvs, arg)-      | noFloatIntoArg arg arg_ty-      = (res_ty, extra_fvs `unionDVarSet` arg_fvs)+      | noFloatIntoArg arg+      = (funResultTy fun_ty, extra_fvs `unionDVarSet` arg_fvs)       | otherwise-      = (res_ty, extra_fvs)-      where-       (_, arg_ty, res_ty) = splitFunTy fun_ty+      = (funResultTy fun_ty, extra_fvs)  {- Note [Dead bindings] ~~~~~~~~~~~~~~~~~~~~~~~@@ -212,15 +209,6 @@ But, while this may be unusual it is not actually wrong, and it did once happen (#15696). -Note [Do not destroy the let/app invariant]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Watch out for-   f (x +# y)-We don't want to float bindings into here-   f (case ... of { x -> x +# y })-because that might destroy the let/app invariant, which requires-unlifted function arguments to be ok-for-speculation.- Note [Join points] ~~~~~~~~~~~~~~~~~~ Generally, we don't need to worry about join points - there are places we're@@ -588,14 +576,14 @@   | isJoinId bndr   = isRec is_rec -- Joins are one-shot iff non-recursive -  | otherwise-  = noFloatIntoArg rhs (idType bndr)+  | Just Unlifted <- typeLevity_maybe (idType bndr)+  = True  -- Preserve let-can-float invariant, see Note [noFloatInto considerations] -noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool-noFloatIntoArg expr expr_ty-  | Just Unlifted <- typeLevity_maybe expr_ty-  = True  -- See Note [Do not destroy the let/app invariant]+  | otherwise+  = noFloatIntoArg rhs +noFloatIntoArg :: CoreExprWithFVs' -> Bool+noFloatIntoArg expr    | AnnLam bndr e <- expr    , (bndrs, _) <- collectAnnBndrs e    =  noFloatIntoLam (bndr:bndrs)  -- Wrinkle 1 (a)@@ -610,11 +598,11 @@ {- Note [noFloatInto considerations] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When do we want to float bindings into-   - noFloatIntoRHs: the RHS of a let-binding+   - noFloatIntoRhs: the RHS of a let-binding    - noFloatIntoArg: the argument of a function application -Definitely don't float in if it has unlifted type; that-would destroy the let/app invariant.+Definitely don't float into RHS if it has unlifted type;+that would destroy the let-can-float invariant.  * Wrinkle 1: do not float in if      (a) any non-one-shot value lambdas

@@ -26,7 +26,7 @@ import GHC.Core.Utils   ( mkTicks, stripTicksTop, dumpIdInfoOfProgram ) import GHC.Core.Lint    ( endPass, lintPassResult, dumpPassResult,                           lintAnnots )-import GHC.Core.Opt.Simplify       ( simplTopBinds, simplExpr, simplRules )+import GHC.Core.Opt.Simplify       ( simplTopBinds, simplExpr, simplImpRules ) import GHC.Core.Opt.Simplify.Utils ( simplEnvForGHCi, activeRule, activeUnfolding ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Monad@@ -749,7 +749,7 @@                       -- for imported Ids.  Eg  RULE map my_f = blah                       -- If we have a substitution my_f :-> other_f, we'd better                       -- apply it to the rule to, or it'll never match-                  ; rules1 <- simplRules env1 Nothing rules Nothing+                  ; rules1 <- simplImpRules env1 rules                    ; return (getTopFloatBinds floats, rules1) } ; 

@@ -912,15 +912,15 @@ We don't want to float very cheap expressions by boxing and unboxing. But we use exprOkForSpeculation for the test, not exprIsCheap. Why?  Because it's important /not/ to transform-     f (a /# 3)+     let x = a /# 3 to-     f (case bx of I# a -> a /# 3)-and float bx = I# (a /# 3), because the application of f no-longer obeys the let/app invariant.  But (a /# 3) is ok-for-spec+     let x = case bx of I# a -> a /# 3+because the let binding no+longer obeys the let-can-float invariant.  But (a /# 3) is ok-for-spec due to a special hack that says division operators can't fail when the denominator is definitely non-zero.  And yet that same expression says False to exprIsCheap.  Simplest way to-guarantee the let/app invariant is to use the same function!+guarantee the let-can-float invariant is to use the same function!  If an expression is okay for speculation, we could also float it out *without* boxing and unboxing, since evaluating it early is okay.

@@ -6,9 +6,10 @@   {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiWayIf #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates -Wno-incomplete-uni-patterns #-}-module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplRules ) where+module GHC.Core.Opt.Simplify ( simplTopBinds, simplExpr, simplImpRules ) where  import GHC.Prelude @@ -71,6 +72,7 @@ import GHC.Utils.Trace import GHC.Utils.Monad  ( mapAccumLM, liftIO ) import GHC.Utils.Logger+import GHC.Utils.Misc  import Control.Monad @@ -236,10 +238,11 @@                                       ; return (floats1, env2) }      simpl_bind env (Rec pairs)-      = simplRecBind env TopLevel Nothing pairs+      = simplRecBind env (BC_Let TopLevel Recursive) pairs     simpl_bind env (NonRec b r)-      = do { (env', b') <- addBndrRules env b (lookupRecBndr env b) Nothing-           ; simplRecOrTopPair env' TopLevel NonRecursive Nothing b b' r }+      = do { let bind_cxt = BC_Let TopLevel NonRecursive+           ; (env', b') <- addBndrRules env b (lookupRecBndr env b) bind_cxt+           ; simplRecOrTopPair env' bind_cxt b b' r }  {- ************************************************************************@@ -252,10 +255,10 @@         * recursive bindings only -} -simplRecBind :: SimplEnv -> TopLevelFlag -> MaybeJoinCont+simplRecBind :: SimplEnv -> BindContext              -> [(InId, InExpr)]              -> SimplM (SimplFloats, SimplEnv)-simplRecBind env0 top_lvl mb_cont pairs0+simplRecBind env0 bind_cxt pairs0   = do  { (env_with_info, triples) <- mapAccumLM add_rules env0 pairs0         ; (rec_floats, env1) <- go env_with_info triples         ; return (mkRecFloats rec_floats, env1) }@@ -263,13 +266,13 @@     add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))         -- Add the (substituted) rules to the binder     add_rules env (bndr, rhs)-        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) mb_cont+        = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) bind_cxt              ; return (env', (bndr, bndr', rhs)) }      go env [] = return (emptyFloats env, env)      go env ((old_bndr, new_bndr, rhs) : pairs)-        = do { (float, env1) <- simplRecOrTopPair env top_lvl Recursive mb_cont+        = do { (float, env1) <- simplRecOrTopPair env bind_cxt                                                   old_bndr new_bndr rhs              ; (floats, env2) <- go env1 pairs              ; return (float `addFloats` floats, env2) }@@ -283,28 +286,26 @@ -}  simplRecOrTopPair :: SimplEnv-                  -> TopLevelFlag -> RecFlag -> MaybeJoinCont+                  -> BindContext                   -> InId -> OutBndr -> InExpr  -- Binder and rhs                   -> SimplM (SimplFloats, SimplEnv) -simplRecOrTopPair env top_lvl is_rec mb_cont old_bndr new_bndr rhs-  | Just env' <- preInlineUnconditionally env top_lvl old_bndr rhs env+simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs+  | Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt)+                                          old_bndr rhs env   = {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}     simplTrace env "SimplBindr:inline-uncond" (ppr old_bndr) $     do { tick (PreInlineUnconditionally old_bndr)        ; return ( emptyFloats env, env' ) } -  | Just cont <- mb_cont-  = {-#SCC "simplRecOrTopPair-join" #-}-    assert (isNotTopLevel top_lvl && isJoinId new_bndr )-    simplTrace env "SimplBind:join" (ppr old_bndr) $-    simplJoinBind env cont old_bndr new_bndr rhs env-   | otherwise-  = {-#SCC "simplRecOrTopPair-normal" #-}-    simplTrace env "SimplBind:normal" (ppr old_bndr) $-    simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env+  = case bind_cxt of+      BC_Join cont  -> simplTrace env "SimplBind:join" (ppr old_bndr) $+                       simplJoinBind env cont old_bndr new_bndr rhs env +      BC_Let top_lvl is_rec -> simplTrace env "SimplBind:normal" (ppr old_bndr) $+                               simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env+ simplTrace :: SimplEnv -> String -> SDoc -> a -> a simplTrace env herald doc thing_inside   | not (logHasDumpFlag logger Opt_D_verbose_core2core)@@ -323,8 +324,9 @@                                         -- Ids only, no TyVars               -> InExpr -> SimplEnv     -- The RHS and its environment               -> SimplM (SimplFloats, SimplEnv)+-- Precondition: the OutId is already in the InScopeSet of the incoming 'env' -- Precondition: not a JoinId--- Precondition: rhs obeys the let/app invariant+-- Precondition: rhs obeys the let-can-float invariant -- NOT used for JoinIds simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se   = assert (isId bndr )@@ -346,49 +348,39 @@                         --    f = /\a. \x. g a x                         -- should eta-reduce. -         ; (body_env, tvs') <- {-#SCC "simplBinders" #-} simplBinders rhs_env tvs                 -- See Note [Floating and type abstraction] in GHC.Core.Opt.Simplify.Utils          -- Simplify the RHS-        ; let rhs_cont = mkRhsStop (substTy body_env (exprType body))+        ; let rhs_cont = mkRhsStop (substTy body_env (exprType body)) (idDemandInfo bndr)         ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont -              -- Never float join-floats out of a non-join let-binding (which this is)-              -- So wrap the body in the join-floats right now-              -- Hence: body_floats1 consists only of let-floats-        ; let (body_floats1, body1) = wrapJoinFloatsX body_floats0 body0-         -- ANF-ise a constructor or PAP rhs-        -- We get at most one float per argument here-        ; let body_env1 = body_env `setInScopeFromF` body_floats1-              -- body_env1: add to in-scope set the binders from body_floats1-              -- so that prepareBinding knows what is in scope in body1-        ; (let_floats, body2) <- {-#SCC "prepareBinding" #-}-                                 prepareBinding body_env1 top_lvl bndr1 body1-        ; let body_floats2 = body_floats1 `addLetFloats` let_floats+        ; (body_floats2, body2) <- {-#SCC "prepareBinding" #-}+                                   prepareBinding env top_lvl is_rec+                                                  False  -- Not strict; this is simplLazyBind+                                                  bndr1 body_floats0 body0+          -- Subtle point: we do not need or want tvs' in the InScope set+          -- of body_floats2, so we pass in 'env' not 'body_env'.+          -- Don't want: if tvs' are in-scope in the scope of this let-binding, we may do+          -- more renaming than necessary => extra work (see !7777 and test T16577).+          -- Don't need: we wrap tvs' around the RHS anyway.          ; (rhs_floats, body3)-            <-  if not (doFloatFromRhs top_lvl is_rec False body_floats2 body2)-                then -- Do not float; abandon prepareBinding entirely and revert to body1-                     return (emptyFloats env, wrapFloats body_floats1 body1)--                else if null tvs then   -- Simple floating+            <-  if isEmptyFloats body_floats2 || null tvs then   -- Simple floating                      {-#SCC "simplLazyBind-simple-floating" #-}-                     do { tick LetFloatFromLet-                        ; return (body_floats2, body2) }+                     return (body_floats2, body2) -                else                    -- Do type-abstraction first+                else -- Non-empty floats, and non-empty tyvars: do type-abstraction first                      {-#SCC "simplLazyBind-type-abstraction-first" #-}-                     do { tick LetFloatFromLet-                        ; (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl+                     do { (poly_binds, body3) <- abstractFloats (seUnfoldingOpts env) top_lvl                                                                 tvs' body_floats2 body2                         ; let floats = foldl' extendFloats (emptyFloats env) poly_binds                         ; return (floats, body3) }          ; let env' = env `setInScopeFromF` rhs_floats         ; rhs' <- mkLam env' tvs' body3 rhs_cont-        ; (bind_float, env2) <- completeBind env' top_lvl Nothing bndr bndr1 rhs'+        ; (bind_float, env2) <- completeBind env' (BC_Let top_lvl is_rec) bndr bndr1 rhs'         ; return (rhs_floats `addFloats` bind_float, env2) }  --------------------------@@ -402,7 +394,7 @@ simplJoinBind env cont old_bndr new_bndr rhs rhs_se   = do  { let rhs_env = rhs_se `setInScopeFromE` env         ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont-        ; completeBind env NotTopLevel (Just cont) old_bndr new_bndr rhs' }+        ; completeBind env (BC_Join cont) old_bndr new_bndr rhs' }  -------------------------- simplNonRecX :: SimplEnv@@ -412,7 +404,7 @@ -- A specialised variant of simplNonRec used when the RHS is already -- simplified, notably in knownCon.  It uses case-binding where necessary. ----- Precondition: rhs satisfies the let/app invariant+-- Precondition: rhs satisfies the let-can-float invariant  simplNonRecX env bndr new_rhs   | assertPpr (not (isJoinId bndr)) (ppr bndr) $@@ -430,39 +422,24 @@            , extendIdSubst env bndr (DoneEx new_rhs Nothing))    | otherwise-  = do  { (env', bndr') <- simplBinder env bndr-        ; completeNonRecX NotTopLevel env' (isStrictId bndr') bndr bndr' new_rhs }-          -- NotTopLevel: simplNonRecX is only used for NotTopLevel things-          ---          -- isStrictId: use bndr' because the InId bndr might not have-          -- a fixed runtime representation, which isStrictId doesn't expect-          -- c.f. Note [Dark corner with representation polymorphism]+  = do  { (env1, new_bndr)   <- simplBinder env bndr+        ; let is_strict = isStrictId new_bndr+              -- isStrictId: use new_bndr because the InId bndr might not have+              -- a fixed runtime representation, which isStrictId doesn't expect+              -- c.f. Note [Dark corner with representation polymorphism] ----------------------------completeNonRecX :: TopLevelFlag -> SimplEnv-                -> Bool-                -> InId                 -- Old binder; not a JoinId-                -> OutId                -- New binder-                -> OutExpr              -- Simplified RHS-                -> SimplM (SimplFloats, SimplEnv)    -- The new binding is in the floats--- Precondition: rhs satisfies the let/app invariant---               See Note [Core let/app invariant] in GHC.Core+        ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict+                                               new_bndr (emptyFloats env) new_rhs+              -- NB: it makes a surprisingly big difference (5% in compiler allocation+              -- in T9630) to pass 'env' rather than 'env1'.  It's fine to pass 'env',+              -- because this is simplNonRecX, so bndr is not in scope in the RHS. -completeNonRecX top_lvl env is_strict old_bndr new_bndr new_rhs-  = assertPpr (not (isJoinId new_bndr)) (ppr new_bndr) $-    do  { (prepd_floats, prepd_rhs) <- prepareBinding env top_lvl new_bndr new_rhs-        ; let floats = emptyFloats env `addLetFloats` prepd_floats-        ; (rhs_floats, rhs2) <--                if doFloatFromRhs NotTopLevel NonRecursive is_strict floats prepd_rhs-                then    -- Add the floats to the main env-                     do { tick LetFloatFromLet-                        ; return (floats, prepd_rhs) }-                else    -- Do not float; abandon prepareBinding entirely and revert to new_rhs-                     return (emptyFloats env, new_rhs)+        ; (bind_float, env2) <- completeBind (env1 `setInScopeFromF` rhs_floats)+                                             (BC_Let NotTopLevel NonRecursive)+                                             bndr new_bndr rhs1+              -- Must pass env1 to completeBind in case simplBinder had to clone,+              -- and extended the substitution with [bndr :-> new_bndr] -        ; (bind_float, env2) <- completeBind (env `setInScopeFromF` rhs_floats)-                                             NotTopLevel Nothing-                                             old_bndr new_bndr rhs2         ; return (rhs_floats `addFloats` bind_float, env2) }  @@ -610,13 +587,13 @@ Note [Concrete types] in GHC.Tc.Utils.Concrete. -} -tryCastWorkerWrapper :: SimplEnv -> TopLevelFlag+tryCastWorkerWrapper :: SimplEnv -> BindContext                      -> InId -> OccInfo                      -> OutId -> OutExpr                      -> SimplM (SimplFloats, SimplEnv) -- See Note [Cast worker/wrapper]-tryCastWorkerWrapper env top_lvl old_bndr occ_info bndr (Cast rhs co)-  | not (isJoinId bndr) -- Not for join points+tryCastWorkerWrapper env bind_cxt old_bndr occ_info bndr (Cast rhs co)+  | BC_Let top_lvl is_rec <- bind_cxt  -- Not join points   , not (isDFunId bndr) -- nor DFuns; cast w/w is no help, and we can't transform                         --            a DFunUnfolding in mk_worker_unfolding   , not (exprIsTrivial rhs)        -- Not x = y |> co; Wrinkle 1@@ -626,34 +603,36 @@                                    -- See Note [Preserve RuntimeRep info in cast w/w]   , not (isOpaquePragma (idInlinePragma old_bndr)) -- Not for OPAQUE bindings                                                    -- See Note [OPAQUE pragma]-  = do  { (rhs_floats, work_rhs) <- prepareRhs env top_lvl occ_fs rhs-        ; uniq <- getUniqueM+  = do  { uniq <- getUniqueM         ; let work_name = mkSystemVarName uniq occ_fs               work_id   = mkLocalIdWithInfo work_name Many rhs_ty worker_info+              is_strict = isStrictId bndr -       ; work_unf <- mk_worker_unfolding work_id work_rhs-       ; let  work_id_w_unf = work_id `setIdUnfolding` work_unf-              floats   = emptyFloats env-                         `addLetFloats` rhs_floats-                         `addLetFloats` unitLetFloat (NonRec work_id_w_unf work_rhs)+        ; (rhs_floats, work_rhs) <- prepareBinding env top_lvl is_rec is_strict+                                                   work_id (emptyFloats env) rhs -              triv_rhs = Cast (Var work_id_w_unf) co+        ; work_unf <- mk_worker_unfolding top_lvl work_id work_rhs+        ; let  work_id_w_unf = work_id `setIdUnfolding` work_unf+               floats   = rhs_floats `addLetFloats`+                          unitLetFloat (NonRec work_id_w_unf work_rhs) -       ; if postInlineUnconditionally env top_lvl bndr occ_info triv_rhs-            -- Almost always True, because the RHS is trivial-            -- In that case we want to eliminate the binding fast-            -- We conservatively use postInlineUnconditionally so that we-            -- check all the right things-         then do { tick (PostInlineUnconditionally bndr)-                 ; return ( floats-                          , extendIdSubst (setInScopeFromF env floats) old_bndr $-                            DoneEx triv_rhs Nothing ) }+               triv_rhs = Cast (Var work_id_w_unf) co -         else do { wrap_unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs bndr triv_rhs-                 ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)-                               `setIdUnfolding`  wrap_unf-                       floats' = floats `extendFloats` NonRec bndr' triv_rhs-                 ; return ( floats', setInScopeFromF env floats' ) } }+        ; if postInlineUnconditionally env bind_cxt bndr occ_info triv_rhs+             -- Almost always True, because the RHS is trivial+             -- In that case we want to eliminate the binding fast+             -- We conservatively use postInlineUnconditionally so that we+             -- check all the right things+          then do { tick (PostInlineUnconditionally bndr)+                  ; return ( floats+                           , extendIdSubst (setInScopeFromF env floats) old_bndr $+                             DoneEx triv_rhs Nothing ) }++          else do { wrap_unf <- mkLetUnfolding (sm_uf_opts mode) top_lvl InlineRhs bndr triv_rhs+                  ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)+                                `setIdUnfolding`  wrap_unf+                        floats' = floats `extendFloats` NonRec bndr' triv_rhs+                  ; return ( floats', setInScopeFromF env floats' ) } }   where     mode   = getMode env     occ_fs = getOccFS bndr@@ -674,7 +653,7 @@     --   the next round of simplification will do the job     -- Non-stable case: use work_rhs     -- Wrinkle 3 of Note [Cast worker/wrapper]-    mk_worker_unfolding work_id work_rhs+    mk_worker_unfolding top_lvl work_id work_rhs       = case realUnfoldingInfo info of -- NB: the real one, even for loop-breakers            unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src })              | isStableSource src -> return (unf { uf_tmpl = mkCast unf_rhs (mkSymCo co) })@@ -705,12 +684,45 @@ *                                                                      * ********************************************************************* -} -prepareBinding :: SimplEnv -> TopLevelFlag-               -> OutId -> OutExpr-               -> SimplM (LetFloats, OutExpr)-prepareBinding env top_lvl bndr rhs-  = prepareRhs env top_lvl (getOccFS bndr) rhs+prepareBinding :: SimplEnv -> TopLevelFlag -> RecFlag -> Bool+               -> Id   -- Used only for its OccName; can be InId or OutId+               -> SimplFloats -> OutExpr+               -> SimplM (SimplFloats, OutExpr)+-- In (prepareBinding ... bndr floats rhs), the binding is really just+--    bndr = let floats in rhs+-- Maybe we can ANF-ise this binding and float out; e.g.+--    bndr = let a = f x in K a a (g x)+-- we could float out to give+--    a    = f x+--    tmp  = g x+--    bndr = K a a tmp+-- That's what prepareBinding does+-- Precondition: binder is not a JoinId+prepareBinding env top_lvl is_rec strict_bind bndr rhs_floats rhs+  = do { -- Never float join-floats out of a non-join let-binding (which this is)+         -- So wrap the body in the join-floats right now+         -- Hence: rhs_floats1 consists only of let-floats+         let (rhs_floats1, rhs1) = wrapJoinFloatsX rhs_floats rhs +         -- rhs_env: add to in-scope set the binders from rhs_floats+         -- so that prepareRhs knows what is in scope in rhs+       ; let rhs_env = env `setInScopeFromF` rhs_floats1++       -- Now ANF-ise the remaining rhs+       ; (anf_floats, rhs2) <- prepareRhs rhs_env top_lvl (getOccFS bndr) rhs1++       -- Finally, decide whether or not to float+       ; let all_floats = rhs_floats1 `addLetFloats` anf_floats+       ; if doFloatFromRhs top_lvl is_rec strict_bind all_floats rhs2+         then -- Float!+              do { tick LetFloatFromLet+                 ; return (all_floats, rhs2) }++         else -- Abandon floating altogether; revert to original rhs+              -- Since we have already built rhs1, we just need to add+              -- rhs_floats1 to it+              return (emptyFloats env, wrapFloats rhs_floats1 rhs1) }+ {- Note [prepareRhs] ~~~~~~~~~~~~~~~~~~~~ prepareRhs takes a putative RHS, checks whether it's a PAP or@@ -729,7 +741,8 @@ That's what the 'go' loop in prepareRhs does -} -prepareRhs :: SimplEnv -> TopLevelFlag+prepareRhs :: HasDebugCallStack+           => SimplEnv -> TopLevelFlag            -> FastString    -- Base for any new variables            -> OutExpr            -> SimplM (LetFloats, OutExpr)@@ -752,10 +765,11 @@              ; return (is_exp, floats, App rhs' (Type ty)) }     go n_val_args (App fun arg)         = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun-             ; case is_exp of-                False -> return (False, emptyLetFloats, App fun arg)-                True  -> do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg-                            ; return (True, floats1 `addLetFlts` floats2, App fun' arg') } }+             ; if is_exp+               then do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg+                       ; return (True, floats1 `addLetFlts` floats2, App fun' arg') }+               else return (False, emptyLetFloats, App fun arg)+             }     go n_val_args (Var fun)         = return (is_exp, emptyLetFloats, Var fun)         where@@ -783,16 +797,17 @@     go _ other         = return (False, emptyLetFloats, other) -makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)+makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec) makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd })   = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e        ; return (floats, arg { as_arg = e' }) } makeTrivialArg _ arg   = return (emptyLetFloats, arg)  -- CastBy, TyArg -makeTrivial :: SimplEnv -> TopLevelFlag -> Demand+makeTrivial :: HasDebugCallStack+            => SimplEnv -> TopLevelFlag -> Demand             -> FastString  -- ^ A "friendly name" to build the new binder from-            -> OutExpr     -- ^ This expression satisfies the let/app invariant+            -> OutExpr             -> SimplM (LetFloats, OutExpr) -- Binds the expression to a variable, if it's not trivial, returning the variable -- For the Demand argument, see Note [Keeping demand info in StrictArg Plan A]@@ -814,10 +829,11 @@     id_info = vanillaIdInfo `setDemandInfo` dmd     expr_ty = exprType expr -makeTrivialBinding :: SimplEnv -> TopLevelFlag+makeTrivialBinding :: HasDebugCallStack+                   => SimplEnv -> TopLevelFlag                    -> FastString  -- ^ a "friendly name" to build the new binder from                    -> IdInfo-                   -> OutExpr     -- ^ This expression satisfies the let/app invariant+                   -> OutExpr                    -> OutType     -- Type of the expression                    -> SimplM (LetFloats, OutId) makeTrivialBinding env top_lvl occ_fs info expr expr_ty@@ -892,6 +908,7 @@   - tries PostInlineUnconditionally   - add unfolding [this is the only place we add an unfolding]   - add arity+  - extend the InScopeSet of the SimplEnv  It does *not* attempt to do let-to-case.  Why?  Because it is used for   - top-level bindings (when let-to-case is impossible)@@ -902,18 +919,18 @@ -}  completeBind :: SimplEnv-             -> TopLevelFlag            -- Flag stuck into unfolding-             -> MaybeJoinCont           -- Required only for join point-             -> InId                    -- Old binder-             -> OutId -> OutExpr        -- New binder and RHS+             -> BindContext+             -> InId           -- Old binder+             -> OutId          -- New binder; can be a JoinId+             -> OutExpr        -- New RHS              -> SimplM (SimplFloats, SimplEnv) -- completeBind may choose to do its work --      * by extending the substitution (e.g. let x = y in ...) --      * or by adding to the floats in the envt -- -- Binder /can/ be a JoinId--- Precondition: rhs obeys the let/app invariant-completeBind env top_lvl mb_cont old_bndr new_bndr new_rhs+-- Precondition: rhs obeys the let-can-float invariant+completeBind env bind_cxt old_bndr new_bndr new_rhs  | isCoVar old_bndr  = case new_rhs of      Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co)@@ -930,13 +947,13 @@       ; (new_arity, eta_rhs) <- tryEtaExpandRhs env new_bndr new_rhs          -- Simplify the unfolding-      ; new_unfolding <- simplLetUnfolding env top_lvl mb_cont old_bndr+      ; new_unfolding <- simplLetUnfolding env bind_cxt old_bndr                          eta_rhs (idType new_bndr) new_arity old_unf        ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding         -- See Note [In-scope set as a substitution] -      ; if postInlineUnconditionally env top_lvl new_bndr_w_info occ_info eta_rhs+      ; if postInlineUnconditionally env bind_cxt new_bndr_w_info occ_info eta_rhs          then -- Inline and discard the binding              do  { tick (PostInlineUnconditionally old_bndr)@@ -951,7 +968,7 @@          else -- Keep the binding; do cast worker/wrapper              -- pprTrace "Binding" (ppr new_bndr <+> ppr new_unfolding) $-             tryCastWorkerWrapper env top_lvl old_bndr occ_info new_bndr_w_info eta_rhs }+             tryCastWorkerWrapper env bind_cxt old_bndr occ_info new_bndr_w_info eta_rhs }  addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId addLetBndrInfo new_bndr new_arity_type new_unf@@ -1466,14 +1483,10 @@        StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }         -> rebuildCall env (addValArgTo fun expr fun_ty ) cont-      StrictBind { sc_bndr = b, sc_body = body-                 , sc_env = se, sc_cont = cont }-        -> do { (floats1, env') <- simplNonRecX (se `setInScopeFromE` env) b expr-                                  -- expr satisfies let/app since it started life-                                  -- in a call to simplNonRecE-              ; (floats2, expr') <- simplLam env' body cont-              ; return (floats1 `addFloats` floats2, expr') } +      StrictBind { sc_bndr = b, sc_body = body, sc_env = se, sc_cont = cont }+        -> completeBindX (se `setInScopeFromE` env) b expr body cont+       ApplyToTy  { sc_arg_ty = ty, sc_cont = cont}         -> rebuild env (App expr (Type ty)) cont @@ -1482,6 +1495,27 @@         -> do { (_, _, arg') <- simplArg env dup_flag se arg               ; rebuild env (App expr arg') cont } +completeBindX :: SimplEnv+              -> InId -> OutExpr   -- Bind this Id to this (simplified) expression+                                   -- (the let-can-float invariant may not be satisfied)+              -> InExpr  -- In this lambda+              -> SimplCont         -- Consumed by this continuation+              -> SimplM (SimplFloats, OutExpr)+completeBindX env bndr rhs body cont+  | needsCaseBinding (idType bndr) rhs -- Enforcing the let-can-float-invariant+  = do { (env1, bndr1) <- simplNonRecBndr env bndr+       ; (floats, expr') <- simplLam env1 body cont+       -- Do not float floats past the Case binder below+       ; let expr'' = wrapFloats floats expr'+       ; let case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr'']+       ; return (emptyFloats env, case_expr) }++  | otherwise+  = do  { (floats1, env') <- simplNonRecX env bndr rhs+        ; (floats2, expr') <- simplLam env' body cont+        ; return (floats1 `addFloats` floats2, expr') }++ {- ************************************************************************ *                                                                      *@@ -1634,12 +1668,10 @@                                     , sc_cont = cont, sc_dup = dup })   | isSimplified dup  -- Don't re-simplify if we've simplified it once                       -- See Note [Avoiding exponential behaviour]-  = do  { tick (BetaReduction bndr)-        ; (floats1, env') <- simplNonRecX env bndr arg-        ; (floats2, expr') <- simplLam env' body cont-        ; return (floats1 `addFloats` floats2, expr') }+  =  do { tick (BetaReduction bndr)+        ; completeBindX env bndr arg body cont } -  | otherwise+  | otherwise         -- See Note [Avoiding exponential behaviour]   = do  { tick (BetaReduction bndr)         ; simplNonRecE env bndr (arg, arg_se) body cont } @@ -1688,34 +1720,36 @@ --     cont< let b = rhs_se(rhs) in body > -- -- It deals with strict bindings, via the StrictBind continuation,--- which may abort the whole process+-- which may abort the whole process. ----- Precondition: rhs satisfies the let/app invariant---               Note [Core let/app invariant] in GHC.Core+-- The RHS may not satisfy the let-can-float invariant yet  simplNonRecE env bndr (rhs, rhs_se) body cont-  | assert (isId bndr && not (isJoinId bndr) ) True-  , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se-  = do { tick (PreInlineUnconditionally bndr)-       ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $-         simplLam env' body cont }+  = assert (isId bndr && not (isJoinId bndr) ) $+    do { (env1, bndr1) <- simplNonRecBndr env bndr+       ; let needs_case_binding = needsCaseBinding (idType bndr1) rhs+         -- See Note [Dark corner with representation polymorphism]+       ; if | not needs_case_binding+            , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se ->+            do { tick (PreInlineUnconditionally bndr)+               ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $+                 simplLam env' body cont } -  | otherwise-  = do { (env1, bndr1) <- simplNonRecBndr env bndr -       -- Deal with strict bindings-       -- See Note [Dark corner with representation polymorphism]-       ; if isStrictId bndr1 && sm_case_case (getMode env)-         then simplExprF (rhs_se `setInScopeFromE` env) rhs-                   (StrictBind { sc_bndr = bndr, sc_body = body-                               , sc_env = env, sc_cont = cont, sc_dup = NoDup })+             -- Deal with strict bindings+             -- See Note [Dark corner with representation polymorphism]+            | isStrictId bndr1 && sm_case_case (getMode env)+            || needs_case_binding ->+            simplExprF (rhs_se `setInScopeFromE` env) rhs+                       (StrictBind { sc_bndr = bndr, sc_body = body+                                   , sc_env = env, sc_cont = cont, sc_dup = NoDup }) -       -- Deal with lazy bindings-         else do-       { (env2, bndr2) <- addBndrRules env1 bndr bndr1 Nothing-       ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se-       ; (floats2, expr') <- simplLam env3 body cont-       ; return (floats1 `addFloats` floats2, expr') } }+            -- Deal with lazy bindings+            | otherwise ->+            do { (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)+               ; (floats1, env3)  <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se+               ; (floats2, expr') <- simplLam env3 body cont+               ; return (floats1 `addFloats` floats2, expr') } }  ------------------ simplRecE :: SimplEnv@@ -1726,20 +1760,21 @@  -- simplRecE is used for --  * non-top-level recursive lets in expressions+-- Precondition: not a join-point binding simplRecE env pairs body cont   = do  { let bndrs = map fst pairs         ; massert (all (not . isJoinId) bndrs)         ; env1 <- simplRecBndrs env bndrs                 -- NB: bndrs' don't have unfoldings or rules                 -- We add them as we go down-        ; (floats1, env2) <- simplRecBind env1 NotTopLevel Nothing pairs+        ; (floats1, env2)  <- simplRecBind env1 (BC_Let NotTopLevel Recursive) pairs         ; (floats2, expr') <- simplExprF env2 body cont         ; return (floats1 `addFloats` floats2, expr') }  {- Note [Dark corner with representation polymorphism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In `simplNonRecE`, the call to `isStrictId` will fail if the binder-does not have a fixed runtime representation, e.g. if it is of kind (TYPE r).+In `simplNonRecE`, the call to `needsCaseBinding` or to `isStrictId` will fail+if the binder does not have a fixed runtime representation, e.g. if it is of kind (TYPE r). So we are careful to call `isStrictId` on the OutId, not the InId, in case we have      ((\(r::RuntimeRep) \(x::TYPE r). blah) Lifted arg) That will lead to `simplNonRecE env (x::TYPE r) arg`, and we can't tell@@ -1760,8 +1795,8 @@ One way in which we can get exponential behaviour is if we simplify a big expression, and the re-simplify it -- and then this happens in a deeply-nested way.  So we must be jolly careful about re-simplifying-an expression.  That is why completeNonRecX does not try-preInlineUnconditionally.+an expression.  That is why simplNonRecX does not try+preInlineUnconditionally (unlike simplNonRecE).  Example:   f BIG, where f has a RULE@@ -1812,11 +1847,6 @@ of a SpecConstr-generated RULE for a join point. -} -type MaybeJoinCont = Maybe SimplCont-  -- Nothing => Not a join point-  -- Just k  => This is a join binding with continuation k-  -- See Note [Rules and unfolding for join points]- simplNonRecJoinPoint :: SimplEnv -> InId -> InExpr                      -> InExpr -> SimplCont                      -> SimplM (SimplFloats, OutExpr)@@ -1833,7 +1863,7 @@         ; let mult   = contHoleScaling cont               res_ty = contResultType cont         ; (env1, bndr1)    <- simplNonRecJoinBndr env bndr mult res_ty-        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (Just cont)+        ; (env2, bndr2)    <- addBndrRules env1 bndr bndr1 (BC_Join cont)         ; (floats1, env3)  <- simplJoinBind env2 cont bndr bndr2 rhs env         ; (floats2, body') <- simplExprF env3 body cont         ; return (floats1 `addFloats` floats2, body') }@@ -1851,7 +1881,7 @@        ; env1 <- simplRecJoinBndrs env bndrs mult res_ty                -- NB: bndrs' don't have unfoldings or rules                -- We add them as we go down-       ; (floats1, env2)  <- simplRecBind env1 NotTopLevel (Just cont) pairs+       ; (floats1, env2)  <- simplRecBind env1 (BC_Join cont) pairs        ; (floats2, body') <- simplExprF env2 body cont        ; return (floats1 `addFloats` floats2, body') } @@ -2175,7 +2205,7 @@         -- have to be very careful about bogus strictness through         -- floating a demanded let.   = do  { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg-                             (mkLazyArgStop arg_ty (lazyArgContext fun_info))+                             (mkLazyArgStop arg_ty fun_info)         ; rebuildCall env (addValArgTo fun_info  arg' fun_ty) cont }   where     arg_ty = funArgTy fun_ty@@ -2560,7 +2590,7 @@ We treat the unlifted and lifted cases separately:  * Unlifted case: 'e' satisfies exprOkForSpeculation-  (ok-for-spec is needed to satisfy the let/app invariant).+  (ok-for-spec is needed to satisfy the let-can-float invariant).   This turns     case a +# b of r -> ...r...   into           let r = a +# b in ...r...   and thence     .....(a +# b)....@@ -2641,7 +2671,7 @@     case_bndr_evald_next _               = False    This patch was part of fixing #7542. See also-  Note [Eta reduction of an eval'd function] in GHC.Core.Utils.)+  Note [Eta reduction soundness], criterion (E) in GHC.Core.Utils.)   Further notes about case elimination@@ -2772,7 +2802,7 @@       assert (null bs) $       do { (floats1, env') <- simplNonRecX env case_bndr case_bndr_rhs              -- scrut is a constructor application,-             -- hence satisfies let/app invariant+             -- hence satisfies let-can-float invariant          ; (floats2, expr') <- simplExprF env' rhs cont          ; case wfloats of              [] -> return (floats1 `addFloats` floats2, expr')@@ -3210,11 +3240,11 @@ even though it'll be over-ridden in every case alternative with a more informative unfolding.  Why?  Because suppose a later, less clever, pass simply replaces all occurrences of the case binder with the binder itself;-then Lint may complain about the let/app invariant.  Example+then Lint may complain about the let-can-float invariant.  Example     case e of b { DEFAULT -> let v = reallyUnsafePtrEquality# b y in ....                 ; K       -> blah } -The let/app invariant requires that y is evaluated in the call to+The let-can-float invariant requires that y is evaluated in the call to reallyUnsafePtrEquality#, which it is.  But we still want that to be true if we propagate binders to occurrences. @@ -3319,7 +3349,7 @@              -- it via postInlineUnconditionally.              -- Nevertheless we must keep it if the case-binder is alive,              -- because it may be used in the con_app.  See Note [knownCon occ info]-           ; (floats1, env2) <- simplNonRecX env' b' arg  -- arg satisfies let/app invariant+           ; (floats1, env2) <- simplNonRecX env' b' arg  -- arg satisfies let-can-float invariant            ; (floats2, env3)  <- bind_args env2 bs' args            ; return (floats1 `addFloats` floats2, env3) } @@ -4000,20 +4030,20 @@ ************************************************************************ -} -simplLetUnfolding :: SimplEnv-> TopLevelFlag-                  -> MaybeJoinCont+simplLetUnfolding :: SimplEnv+                  -> BindContext                   -> InId                   -> OutExpr -> OutType -> ArityType                   -> Unfolding -> SimplM Unfolding-simplLetUnfolding env top_lvl cont_mb id new_rhs rhs_ty arity unf+simplLetUnfolding env bind_cxt id new_rhs rhs_ty arity unf   | isStableUnfolding unf-  = simplStableUnfolding env top_lvl cont_mb id rhs_ty arity unf+  = simplStableUnfolding env bind_cxt id rhs_ty arity unf   | isExitJoinId id   = return noUnfolding -- See Note [Do not inline exit join points] in GHC.Core.Opt.Exitify   | otherwise   = -- Otherwise, we end up retaining all the SimpleEnv     let !opts = seUnfoldingOpts env-    in mkLetUnfolding opts top_lvl InlineRhs id new_rhs+    in mkLetUnfolding opts (bindContextLevel bind_cxt) InlineRhs id new_rhs  ------------------- mkLetUnfolding :: UnfoldingOpts -> TopLevelFlag -> UnfoldingSource@@ -4034,15 +4064,14 @@     !is_bottoming = isDeadEndId id  --------------------simplStableUnfolding :: SimplEnv -> TopLevelFlag-                     -> MaybeJoinCont  -- Just k => a join point with continuation k+simplStableUnfolding :: SimplEnv -> BindContext                      -> InId                      -> OutType                      -> ArityType      -- Used to eta expand, but only for non-join-points                      -> Unfolding                      ->SimplM Unfolding -- Note [Setting the new unfolding]-simplStableUnfolding env top_lvl mb_cont id rhs_ty id_arity unf+simplStableUnfolding env bind_cxt id rhs_ty id_arity unf   = case unf of       NoUnfolding   -> return unf       BootUnfolding -> return unf@@ -4055,11 +4084,11 @@        CoreUnfolding { uf_tmpl = expr, uf_src = src, uf_guidance = guide }         | isStableSource src-        -> do { expr' <- case mb_cont of-                           Just cont -> -- Binder is a join point-                                        -- See Note [Rules and unfolding for join points]-                                        simplJoinRhs unf_env id expr cont-                           Nothing   -> -- Binder is not a join point+        -> do { expr' <- case bind_cxt of+                           BC_Join cont -> -- Binder is a join point+                                           -- See Note [Rules and unfolding for join points]+                                           simplJoinRhs unf_env id expr cont+                           BC_Let {} -> -- Binder is not a join point                                         do { expr' <- simplExprC unf_env expr (mkBoringStop rhs_ty)                                            ; return (eta_expand expr') }               ; case guide of@@ -4101,6 +4130,7 @@     uf_opts    = seUnfoldingOpts env     -- Forcing this can save about 0.5MB of max residency and the result     -- is small and easy to compute so might as well force it.+    top_lvl     = bindContextLevel bind_cxt     !is_top_lvl = isTopLevel top_lvl     act        = idInlineActivation id     unf_env    = updMode (updModeForStableUnfoldings act) env@@ -4144,7 +4174,7 @@  * Don't eta-expand join points; see Note [Do not eta-expand join points]   in GHC.Core.Opt.Simplify.Utils.  We uphold this because the join-point-  case (mb_cont = Just _) doesn't use eta_expand.+  case (bind_cxt = BC_Join _) doesn't use eta_expand.  Note [Force bottoming field] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -4185,23 +4215,27 @@ -}  addBndrRules :: SimplEnv -> InBndr -> OutBndr-             -> MaybeJoinCont   -- Just k for a join point binder-                                -- Nothing otherwise+             -> BindContext              -> SimplM (SimplEnv, OutBndr) -- Rules are added back into the bin-addBndrRules env in_id out_id mb_cont+addBndrRules env in_id out_id bind_cxt   | null old_rules   = return (env, out_id)   | otherwise-  = do { new_rules <- simplRules env (Just out_id) old_rules mb_cont+  = do { new_rules <- simplRules env (Just out_id) old_rules bind_cxt        ; let final_id  = out_id `setIdSpecialisation` mkRuleInfo new_rules        ; return (modifyInScope env final_id, final_id) }   where     old_rules = ruleInfoRules (idSpecialisation in_id) +simplImpRules :: SimplEnv -> [CoreRule] -> SimplM [CoreRule]+-- Simplify local rules for imported Ids+simplImpRules env rules+  = simplRules env Nothing rules (BC_Let TopLevel NonRecursive)+ simplRules :: SimplEnv -> Maybe OutId -> [CoreRule]-           -> MaybeJoinCont -> SimplM [CoreRule]-simplRules env mb_new_id rules mb_cont+           -> BindContext -> SimplM [CoreRule]+simplRules env mb_new_id rules bind_cxt   = mapM simpl_rule rules   where     simpl_rule rule@(BuiltinRule {})@@ -4212,9 +4246,9 @@                           , ru_act = act })       = do { (env', bndrs') <- simplBinders env bndrs            ; let rhs_ty = substTy env' (exprType rhs)-                 rhs_cont = case mb_cont of  -- See Note [Rules and unfolding for join points]-                                Nothing   -> mkBoringStop rhs_ty-                                Just cont -> assertPpr join_ok bad_join_msg cont+                 rhs_cont = case bind_cxt of  -- See Note [Rules and unfolding for join points]+                                BC_Let {}    -> mkBoringStop rhs_ty+                                BC_Join cont -> assertPpr join_ok bad_join_msg cont                  lhs_env = updMode updModeForRules env'                  rhs_env = updMode (updModeForStableUnfoldings act) env'                            -- See Note [Simplifying the RHS of a RULE]@@ -4247,4 +4281,3 @@ than necesary.  Allowing some inlining might, for example, eliminate a binding. -}-

@@ -29,7 +29,7 @@         substCo, substCoVar,          -- * Floats-        SimplFloats(..), emptyFloats, mkRecFloats,+        SimplFloats(..), emptyFloats, isEmptyFloats, mkRecFloats,         mkFloatBind, addLetFloats, addJoinFloats, addFloats,         extendFloats, wrapFloats,         doFloatFromRhs, getTopFloatBinds,@@ -56,7 +56,7 @@ import GHC.Types.Var.Set import GHC.Data.OrdList import GHC.Types.Id as Id-import GHC.Core.Make            ( mkWildValBinder )+import GHC.Core.Make            ( mkWildValBinder, mkCoreLet ) import GHC.Driver.Session       ( DynFlags ) import GHC.Builtin.Types import GHC.Core.TyCo.Rep        ( TyCoBinder(..) )@@ -139,6 +139,13 @@                 , sfJoinFloats = emptyJoinFloats                 , sfInScope    = seInScope env } +isEmptyFloats :: SimplFloats -> Bool+-- Precondition: used only when sfJoinFloats is empty+isEmptyFloats (SimplFloats { sfLetFloats  = LetFloats fs _+                           , sfJoinFloats = js })+  = assertPpr (isNilOL js) (ppr js ) $+    isNilOL fs+ pprSimplEnv :: SimplEnv -> SDoc -- Used for debugging; selective pprSimplEnv env@@ -429,7 +436,8 @@ ~~~~~~~~~~~~~~~~ The LetFloats is a bunch of bindings, classified by a FloatFlag. -* All of them satisfy the let/app invariant+The `FloatFlag` contains summary information about the bindings, see the data+type declaration of `FloatFlag`  Examples @@ -440,10 +448,8 @@   NonRec x# (y +# 3)    FltOkSpec   -- Unboxed, but ok-for-spec'n    NonRec x* (f y)       FltCareful  -- Strict binding; might fail or diverge--Can't happen:-  NonRec x# (a /# b)    -- Might fail; does not satisfy let/app-  NonRec x# (f y)       -- Might diverge; does not satisfy let/app+  NonRec x# (a /# b)    FltCareful  -- Might fail; does not satisfy let-can-float invariant+  NonRec x# (f y)       FltCareful  -- Might diverge; does not satisfy let-can-float invariant -}  data LetFloats = LetFloats (OrdList OutBind) FloatFlag@@ -455,19 +461,22 @@ data FloatFlag   = FltLifted   -- All bindings are lifted and lazy *or*                 --     consist of a single primitive string literal-                --  Hence ok to float to top level, or recursive+                -- Hence ok to float to top level, or recursive+                -- NB: consequence: all bindings satisfy let-can-float invariant    | FltOkSpec   -- All bindings are FltLifted *or*                 --      strict (perhaps because unlifted,                 --      perhaps because of a strict binder),                 --        *and* ok-for-speculation-                --  Hence ok to float out of the RHS-                --  of a lazy non-recursive let binding-                --  (but not to top level, or into a rec group)+                -- Hence ok to float out of the RHS+                -- of a lazy non-recursive let binding+                -- (but not to top level, or into a rec group)+                -- NB: consequence: all bindings satisfy let-can-float invariant    | FltCareful  -- At least one binding is strict (or unlifted)                 --      and not guaranteed cheap-                --      Do not float these bindings out of a lazy let+                -- Do not float these bindings out of a lazy let!+                -- NB: some bindings may not satisfy let-can-float  instance Outputable LetFloats where   ppr (LetFloats binds ff) = ppr ff $$ ppr (fromOL binds)@@ -485,7 +494,7 @@  doFloatFromRhs :: TopLevelFlag -> RecFlag -> Bool -> SimplFloats -> OutExpr -> Bool -- If you change this function look also at FloatIn.noFloatFromRhs-doFloatFromRhs lvl rec str (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs+doFloatFromRhs lvl rec strict_bind (SimplFloats { sfLetFloats = LetFloats fs ff }) rhs   =  not (isNilOL fs) && want_to_float && can_float   where      want_to_float = isTopLevel lvl || exprIsCheap rhs || exprIsExpandable rhs@@ -493,7 +502,7 @@      can_float = case ff of                    FltLifted  -> True                    FltOkSpec  -> isNotTopLevel lvl && isNonRec rec-                   FltCareful -> isNotTopLevel lvl && isNonRec rec && str+                   FltCareful -> isNotTopLevel lvl && isNonRec rec && strict_bind  {- Note [Float when cheap or expandable]@@ -513,7 +522,7 @@ emptyJoinFloats :: JoinFloats emptyJoinFloats = nilOL -unitLetFloat :: OutBind -> LetFloats+unitLetFloat :: HasDebugCallStack => OutBind -> LetFloats -- This key function constructs a singleton float with the right form unitLetFloat bind = assert (all (not . isJoinId) (bindersOf bind)) $                     LetFloats (unitOL bind) (flag bind)@@ -525,11 +534,7 @@           -- String literals can be floated freely.           -- See Note [Core top-level string literals] in GHC.Core.       | exprOkForSpeculation rhs = FltOkSpec  -- Unlifted, and lifted but ok-for-spec (eg HNF)-      | otherwise                = assertPpr (not (isUnliftedType (idType bndr))) (ppr bndr)-                                   -- NB: binders always have a fixed RuntimeRep, so calling-                                   -- isUnliftedType is OK here-                                   FltCareful-      -- Unlifted binders can only be let-bound if exprOkForSpeculation holds+      | otherwise                = FltCareful  unitJoinFloat :: OutBind -> JoinFloats unitJoinFloat bind = assert (all isJoinId (bindersOf bind)) $@@ -634,13 +639,15 @@               | otherwise   = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))  wrapFloats :: SimplFloats -> OutExpr -> OutExpr--- Wrap the floats around the expression; they should all--- satisfy the let/app invariant, so mkLets should do the job just fine-wrapFloats (SimplFloats { sfLetFloats  = LetFloats bs _+-- Wrap the floats around the expression+wrapFloats (SimplFloats { sfLetFloats  = LetFloats bs flag                         , sfJoinFloats = jbs }) body-  = foldrOL Let (wrapJoinFloats jbs body) bs+  = foldrOL mk_let (wrapJoinFloats jbs body) bs      -- Note: Always safe to put the joins on the inside      -- since the values can't refer to them+  where+    mk_let | FltCareful <- flag = mkCoreLet -- need to enforce let-can-float-invariant+           | otherwise          = Let       -- let-can-float invariant hold  wrapJoinFloatsX :: SimplFloats -> OutExpr -> (SimplFloats, OutExpr) -- Wrap the sfJoinFloats of the env around the expression,@@ -899,10 +906,10 @@         f = \x -> f x to         f = f-which technically is not sound.   This is very much a corner case, so-I'm not worried about it.  Another idea is to ensure that f's arity-never decreases; its arity started as 1, and we should never eta-reduce-below that.+which technically is not sound.  We take care of that in point (3) of+Note [Eta reduction makes sense].+Another idea is to ensure that f's arity never decreases; its arity started as+1, and we should never eta-reduce below that.   Note [Robust OccInfo]

@@ -16,6 +16,9 @@         getUnfoldingInRuleMatch,         simplEnvForGHCi, updModeForStableUnfoldings, updModeForRules, +        -- The BindContext type+        BindContext(..), bindContextLevel,+         -- The continuation type         SimplCont(..), DupFlag(..), StaticEnv,         isSimplified, contIsStop,@@ -82,9 +85,28 @@ import Control.Monad    ( when ) import Data.List        ( sortBy ) -{--************************************************************************+{- ********************************************************************* *                                                                      *+                The BindContext type+*                                                                      *+********************************************************************* -}++-- What sort of binding is this? A let-binding or a join-binding?+data BindContext+  = BC_Let                 -- A regular let-binding+      TopLevelFlag RecFlag++  | BC_Join                -- A join point with continuation k+      SimplCont            -- See Note [Rules and unfolding for join points]+                           -- in GHC.Core.Opt.Simplify++bindContextLevel :: BindContext -> TopLevelFlag+bindContextLevel (BC_Let top_lvl _) = top_lvl+bindContextLevel (BC_Join {})       = NotTopLevel+++{- *********************************************************************+*                                                                      *                 The SimplCont and DupFlag types *                                                                      * ************************************************************************@@ -111,17 +133,25 @@ -}  data SimplCont-  = Stop                -- Stop[e] = e-        OutType         -- Type of the <hole>-        CallCtxt        -- Tells if there is something interesting about-                        --          the context, and hence the inliner+  = Stop                -- ^ Stop[e] = e+        OutType         -- ^ Type of the <hole>+        CallCtxt        -- ^ Tells if there is something interesting about+                        --          the syntactic context, and hence the inliner                         --          should be a bit keener (see interestingCallContext)                         -- Specifically:                         --     This is an argument of a function that has RULES                         --     Inlining the call might allow the rule to fire                         -- Never ValAppCxt (use ApplyToVal instead)                         -- or CaseCtxt (use Select instead)+        SubDemand       -- ^ The evaluation context of e. Tells how e is evaluated.+                        -- This fuels eta-expansion or eta-reduction without looking+                        -- at lambda bodies, for example.+                        --+                        -- See Note [Eta reduction based on evaluation context]+                        -- The evaluation context for other SimplConts can be+                        -- reconstructed with 'contEvalContext' +   | CastIt              -- (CastIt co K)[e] = K[ e `cast` co ]         OutCoercion             -- The coercion simplified                                 -- Invariant: never an identity coercion@@ -223,7 +253,10 @@   ppr Simplified = text "simpl"  instance Outputable SimplCont where-  ppr (Stop ty interesting) = text "Stop" <> brackets (ppr interesting) <+> ppr ty+  ppr (Stop ty interesting eval_sd)+    = text "Stop" <> brackets (sep $ punctuate comma pps) <+> ppr ty+    where+      pps = [ppr interesting] ++ [ppr eval_sd | eval_sd /= topSubDmd]   ppr (CastIt co cont  )    = (text "CastIt" <+> pprOptCo co) $$ ppr cont   ppr (TickIt t cont)       = (text "TickIt" <+> ppr t) $$ ppr cont   ppr (ApplyToTy  { sc_arg_ty = ty, sc_cont = cont })@@ -391,13 +424,15 @@ -}  mkBoringStop :: OutType -> SimplCont-mkBoringStop ty = Stop ty BoringCtxt+mkBoringStop ty = Stop ty BoringCtxt topSubDmd -mkRhsStop :: OutType -> SimplCont       -- See Note [RHS of lets] in GHC.Core.Unfold-mkRhsStop ty = Stop ty RhsCtxt+mkRhsStop :: OutType -> Demand -> SimplCont       -- See Note [RHS of lets] in GHC.Core.Unfold+mkRhsStop ty bndr_dmd = Stop ty RhsCtxt (subDemandIfEvaluated bndr_dmd) -mkLazyArgStop :: OutType -> CallCtxt -> SimplCont-mkLazyArgStop ty cci = Stop ty cci+mkLazyArgStop :: OutType -> ArgInfo -> SimplCont+mkLazyArgStop ty fun_info = Stop ty (lazyArgContext fun_info) arg_sd+  where+    arg_sd = subDemandIfEvaluated (head (ai_dmds fun_info))  ------------------- contIsRhsOrArg :: SimplCont -> Bool@@ -407,9 +442,9 @@ contIsRhsOrArg _               = False  contIsRhs :: SimplCont -> Bool-contIsRhs (Stop _ RhsCtxt) = True-contIsRhs (CastIt _ k)     = contIsRhs k   -- For f = e |> co, treat e as Rhs context-contIsRhs _                = False+contIsRhs (Stop _ RhsCtxt _) = True+contIsRhs (CastIt _ k)       = contIsRhs k   -- For f = e |> co, treat e as Rhs context+contIsRhs _                  = False  ------------------- contIsStop :: SimplCont -> Bool@@ -436,7 +471,7 @@  ------------------- contResultType :: SimplCont -> OutType-contResultType (Stop ty _)                  = ty+contResultType (Stop ty _ _)                = ty contResultType (CastIt _ k)                 = contResultType k contResultType (StrictBind { sc_cont = k }) = contResultType k contResultType (StrictArg { sc_cont = k })  = contResultType k@@ -446,7 +481,7 @@ contResultType (TickIt _ k)                 = contResultType k  contHoleType :: SimplCont -> OutType-contHoleType (Stop ty _)                      = ty+contHoleType (Stop ty _ _)                    = ty contHoleType (TickIt _ k)                     = contHoleType k contHoleType (CastIt co _)                    = coercionLKind co contHoleType (StrictBind { sc_bndr = b, sc_dup = dup, sc_env = se })@@ -467,7 +502,7 @@ -- should be scaled if it commutes with E. This appears, in particular, in the -- case-of-case transformation. contHoleScaling :: SimplCont -> Mult-contHoleScaling (Stop _ _) = One+contHoleScaling (Stop _ _ _) = One contHoleScaling (CastIt _ k) = contHoleScaling k contHoleScaling (StrictBind { sc_bndr = id, sc_cont = k })   = idMult id `mkMultMul` contHoleScaling k@@ -512,6 +547,35 @@                    -- Do *not* use short-cutting substitution here                    -- because we want to get as much IdInfo as possible +-- | Describes how the 'SimplCont' will evaluate the hole as a 'SubDemand'.+-- This can be more insightful than the limited syntactic context that+-- 'SimplCont' provides, because the 'Stop' constructor might carry a useful+-- 'SubDemand'.+-- For example, when simplifying the argument `e` in `f e` and `f` has the+-- demand signature `<MP(S,A)>`, this function will give you back `P(S,A)` when+-- simplifying `e`.+--+-- PRECONDITION: Don't call with 'ApplyToVal'. We haven't thoroughly thought+-- about what to do then and no call sites so far seem to care.+contEvalContext :: SimplCont -> SubDemand+contEvalContext k = case k of+  (Stop _ _ sd)              -> sd+  (TickIt _ k)               -> contEvalContext k+  (CastIt _ k)               -> contEvalContext k+  ApplyToTy{sc_cont=k}       -> contEvalContext k+    --  ApplyToVal{sc_cont=k}      -> mkCalledOnceDmd $ contEvalContext k+    -- Not 100% sure that's correct, . Here's an example:+    --   f (e x) and f :: <SCS(C1(L))>+    -- then what is the evaluation context of 'e' when we simplify it? E.g.,+    --   simpl e (ApplyToVal x $ Stop "CS(C1(L))")+    -- then it *should* be "C1(CS(C1(L))", so perhaps correct after all.+    -- But for now we just panic:+  ApplyToVal{}               -> pprPanic "contEvalContext" (ppr k)+  StrictArg{sc_fun=fun_info} -> subDemandIfEvaluated (head (ai_dmds fun_info))+  StrictBind{sc_bndr=bndr}   -> subDemandIfEvaluated (idDemandInfo bndr)+  Select{}                   -> topSubDmd+    -- Perhaps reconstruct the demand on the scrutinee by looking at field+    -- and case binder dmds, see addCaseBndrDmd. No priority right now.  ------------------- mkArgInfo :: SimplEnv@@ -530,7 +594,7 @@             , ai_discs = vanilla_discounts }   | otherwise   = ArgInfo { ai_fun   = fun-            , ai_args = []+            , ai_args  = []             , ai_rules = fun_rules             , ai_encl  = interestingArgContext rules call_cont             , ai_dmds  = add_type_strictness (idType fun) arg_dmds@@ -727,7 +791,7 @@      interesting (StrictArg { sc_fun = fun }) = strictArgContext fun     interesting (StrictBind {})              = BoringCtxt-    interesting (Stop _ cci)                 = cci+    interesting (Stop _ cci _)               = cci     interesting (TickIt _ k)                 = interesting k     interesting (ApplyToTy { sc_cont = k })  = interesting k     interesting (CastIt _ k)                 = interesting k@@ -778,8 +842,8 @@     go (StrictArg { sc_fun = fun }) = ai_encl fun     go (StrictBind {})              = False      -- ??     go (CastIt _ c)                 = go c-    go (Stop _ RuleArgCtxt)         = True-    go (Stop _ _)                   = False+    go (Stop _ RuleArgCtxt _)       = True+    go (Stop _ _ _)                 = False     go (TickIt _ c)                 = go c  {- Note [Interesting arguments]@@ -1268,8 +1332,8 @@     :: SimplEnv -> TopLevelFlag -> InId     -> InExpr -> StaticEnv  -- These two go together     -> Maybe SimplEnv       -- Returned env has extended substitution--- Precondition: rhs satisfies the let/app invariant--- See Note [Core let/app invariant] in GHC.Core+-- Precondition: rhs satisfies the let-can-float invariant+-- See Note [Core let-can-float invariant] in GHC.Core -- Reason: we don't want to inline single uses, or discard dead bindings, --         for unlifted, side-effect-ful bindings preInlineUnconditionally env top_lvl bndr rhs rhs_env@@ -1389,23 +1453,24 @@ -}  postInlineUnconditionally-    :: SimplEnv -> TopLevelFlag+    :: SimplEnv -> BindContext     -> OutId            -- The binder (*not* a CoVar), including its unfolding     -> OccInfo          -- From the InId     -> OutExpr     -> Bool--- Precondition: rhs satisfies the let/app invariant--- See Note [Core let/app invariant] in GHC.Core+-- Precondition: rhs satisfies the let-can-float invariant+-- See Note [Core let-can-float invariant] in GHC.Core -- Reason: we don't want to inline single uses, or discard dead bindings, --         for unlifted, side-effect-ful bindings-postInlineUnconditionally env top_lvl bndr occ_info rhs+postInlineUnconditionally env bind_cxt bndr occ_info rhs   | not active                  = False   | isWeakLoopBreaker occ_info  = False -- If it's a loop-breaker of any kind, don't inline                                         -- because it might be referred to "earlier"   | isStableUnfolding unfolding = False -- Note [Stable unfoldings and postInlineUnconditionally]-  | isTopLevel top_lvl          = False -- Note [Top level and postInlineUnconditionally]+  | isTopLevel (bindContextLevel bind_cxt)+                                = False -- Note [Top level and postInlineUnconditionally]   | exprIsTrivial rhs           = True-  | isJoinId bndr                       -- See point (1) of Note [Duplicating join points]+  | BC_Join {} <- bind_cxt              -- See point (1) of Note [Duplicating join points]   , not (phase == FinalPhase)   = False -- in Simplify.hs   | otherwise   = case occ_info of@@ -1588,6 +1653,10 @@   where     mode = getMode env +    -- See Note [Eta reduction based on evaluation context]+    -- NB: cont is never ApplyToVal, otherwise contEvalContext panics+    eval_sd = contEvalContext cont+     mkLam' :: DynFlags -> [OutBndr] -> OutExpr -> SimplM OutExpr     mkLam' dflags bndrs body@(Lam {})       = mkLam' dflags (bndrs ++ bndrs1) body1@@ -1610,7 +1679,8 @@      mkLam' dflags bndrs body       | gopt Opt_DoEtaReduction dflags-      , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce bndrs body+      -- , pprTrace "try eta" (ppr bndrs $$ ppr body $$ ppr cont $$ ppr eval_sd) True+      , Just etad_lam <- {-# SCC "tryee" #-} tryEtaReduce bndrs body eval_sd       = do { tick (EtaReduction (head bndrs))            ; return etad_lam } 

@@ -956,7 +956,8 @@  extendScInScope :: ScEnv -> [Var] -> ScEnv         -- Bring the quantified variables into scope-extendScInScope env qvars = env { sc_subst = extendInScopeList (sc_subst env) qvars }+extendScInScope env qvars+  = env { sc_subst = extendSubstInScopeList (sc_subst env) qvars }          -- Extend the substitution extendScSubst :: ScEnv -> Var -> OutExpr -> ScEnv

@@ -28,8 +28,6 @@ import qualified GHC.Core.Subst as Core import GHC.Core.Unfold.Make import GHC.Core-import GHC.Core.Make      ( mkLitRubbish )-import GHC.Core.Unify     ( tcMatchTy ) import GHC.Core.Rules import GHC.Core.Utils     ( exprIsTrivial, getIdFromTrivialExpr_maybe                           , mkCast, exprType )@@ -67,6 +65,7 @@ import GHC.Unit.Module( Module ) import GHC.Unit.Module.ModGuts import GHC.Unit.External+import GHC.Core.Unfold  {- ************************************************************************@@ -688,18 +687,18 @@                                  -- See Note [specImport call stack]              -> RuleBase         -- Rules from this module and the home package                                  -- (but not external packages, which can change)-             -> Bag DictBind     -- Dict bindings, used /only/ for filterCalls+             -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls                                  -- See Note [Avoiding loops in specImports]              -> CallDetails      -- Calls for imported things              -> CoreM ( [CoreRule]   -- New rules                       , [CoreBind] ) -- Specialised bindings spec_imports top_env callers rule_base dict_binds calls   = do { let import_calls = dVarEnvElts calls-       -- ; debugTraceMsg (text "specImports {" <+>-       --                  vcat [ text "calls:" <+> ppr import_calls-       --                       , text "dict_binds:" <+> ppr dict_binds ])+--       ; debugTraceMsg (text "specImports {" <+>+--                         vcat [ text "calls:" <+> ppr import_calls+--                              , text "dict_binds:" <+> ppr dict_binds ])        ; (rules, spec_binds) <- go rule_base import_calls-       -- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls)+--       ; debugTraceMsg (text "End specImports }" <+> ppr import_calls)         ; return (rules, spec_binds) }   where@@ -708,7 +707,7 @@     go rb (cis : other_calls)       = do { -- debugTraceMsg (text "specImport {" <+> ppr cis)            ; (rules1, spec_binds1) <- spec_import top_env callers rb dict_binds cis-           -- ; debugTraceMsg (text "specImport }" <+> ppr cis)+           ; -- debugTraceMsg (text "specImport }" <+> ppr cis)             ; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls            ; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }@@ -717,7 +716,7 @@             -> [Id]                  -- Stack of imported functions being specialised                                      -- See Note [specImport call stack]             -> RuleBase              -- Rules from this module-            -> Bag DictBind          -- Dict bindings, used /only/ for filterCalls+            -> FloatedDictBinds      -- Dict bindings, used /only/ for filterCalls                                      -- See Note [Avoiding loops in specImports]             -> CallInfoSet           -- Imported function and calls for it             -> CoreM ( [CoreRule]    -- New rules@@ -741,20 +740,22 @@        ; vis_orphs <- getVisibleOrphanMods        ; let rules_for_fn = getRules (RuleEnv [rb, eps_rule_base eps] vis_orphs) fn +       ; -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs])        ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })-            <- -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) >>-                (runSpecM $ specCalls True top_env rules_for_fn good_calls fn rhs)+            <- runSpecM $ specCalls True top_env dict_binds+                             rules_for_fn good_calls fn rhs+        ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]              -- After the rules kick in we may get recursion, but              -- we rely on a global GlomBinds to sort that out later              -- See Note [Glom the bindings if imported functions are specialised]                -- Now specialise any cascaded calls-       -- ; debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1))+       ; -- debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1))        ; (rules2, spec_binds2) <- spec_imports top_env                                                (fn:callers)                                                (extendRuleBaseList rb rules1)-                                               (dict_binds `unionBags` dict_binds1)+                                               (dict_binds `thenFDBs` dict_binds1)                                                new_calls         ; let final_binds = wrapDictBinds dict_binds1 $@@ -775,10 +776,6 @@ canSpecImport :: DynFlags -> Id -> Maybe CoreExpr -- See Note [Specialise imported INLINABLE things] canSpecImport dflags fn-  | isDataConWrapId fn-  = Nothing   -- Don't specialise data-con wrappers, even if they-              -- have dict args; there is no benefit.-   | CoreUnfolding { uf_src = src, uf_tmpl = rhs } <- unf   , isStableSource src   = Just rhs   -- By default, specialise only imported things that have a stable@@ -1116,16 +1113,12 @@  ---------------- Applications might generate a call instance -------------------- specExpr env expr@(App {})-  = go expr []-  where-    go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg-                               (fun', uds_app) <- go fun (arg':args)-                               return (App fun' arg', uds_arg `plusUDs` uds_app)--    go (Var f)       args = case specVar env f of-                                Var f' -> return (Var f', mkCallUDs env f' args)-                                e'     -> return (e', emptyUDs) -- I don't expect this!-    go other         _    = specExpr env other+  = do { let (fun_in, args_in) = collectArgs expr+       ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in+       ; let (fun_in', args_out') = rewriteClassOps env fun_in args_out+       ; (fun_out', uds_fun) <- specExpr env fun_in'+       ; let uds_call = mkCallUDs env fun_out' args_out'+       ; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) }  ---------------- Lambda/case require dumping of usage details -------------------- specExpr env e@(Lam {})@@ -1141,7 +1134,7 @@        ; (scrut'', case_bndr', alts', alts_uds)              <- specCase env scrut' case_bndr alts        ; return (Case scrut'' case_bndr' (substTy env ty) alts'-                , scrut_uds `plusUDs` alts_uds) }+                , scrut_uds `thenUDs` alts_uds) }  ---------------- Finally, let is the interesting case -------------------- specExpr env (Let bind body)@@ -1152,11 +1145,23 @@        ; (body', body_uds) <- specExpr body_env body          -- Deal with the bindings-      ; (binds', uds) <- specBind rhs_env bind' body_uds+       ; (binds', uds) <- specBind rhs_env bind' body_uds -        -- All done-      ; return (foldr Let body' binds', uds) }+         -- All done+       ; return (foldr Let body' binds', uds) } +-- See Note [Specialisation modulo dictionary selectors]+-- and Note [ClassOp/DFun selection]+rewriteClassOps :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr])+rewriteClassOps env (Var f) args+  | isClassOpId f -- If we see `op_sel $fCInt`, we rewrite to `$copInt`+  , Just (rule, expr) <- specLookupRule env f args (idCoreRules f)+  , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target]+  -- , pprTrace "class op rewritten" (ppr f <+> ppr args $$ ppr expr <+> ppr rest_args) True+  , (fun, args) <- collectArgs expr+  = rewriteClassOps env fun (args++rest_args)+rewriteClassOps _ fun args = (fun, args)+ -------------- specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails) -- The binders have been substituted, but the body has not@@ -1214,7 +1219,7 @@                              | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ]              flt_binds     = scrut_bind : sc_binds              (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds-             all_uds = flt_binds `addDictBinds` free_uds+             all_uds = flt_binds `consDictBinds` free_uds              alt'    = Alt con args' (wrapDictBindsE dumped_dbs rhs')        ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }   where@@ -1290,6 +1295,13 @@ ************************************************************************ -} +bringFloatedDictsIntoScope :: SpecEnv -> FloatedDictBinds -> SpecEnv+bringFloatedDictsIntoScope env (FDB { fdb_bndrs = dx_bndrs })+  = -- pprTrace "brought into scope" (ppr dx_bndrs) $+    env {se_subst=subst'}+  where+   subst' = se_subst env `Core.extendSubstInScopeSet` dx_bndrs+ specBind :: SpecEnv                     -- Use this for RHSs          -> CoreBind                    -- Binders are already cloned by cloneBindSM,                                         -- but RHSs are un-processed@@ -1302,18 +1314,18 @@ specBind rhs_env (NonRec fn rhs) body_uds   = do { (rhs', rhs_uds) <- specExpr rhs_env rhs -        ; let zapped_fn = zapIdDemandInfo fn+       ; let zapped_fn = zapIdDemandInfo fn               -- We zap the demand info because the binding may float,               -- which would invaidate the demand info (see #17810 for example).               -- Destroying demand info is not terrible; specialisation is               -- always followed soon by demand analysis.-      ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds zapped_fn rhs+       ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds zapped_fn rhs         ; let pairs = spec_defns ++ [(fn', rhs')]                         -- fn' mentions the spec_defns in its rules,                         -- so put the latter first -             combined_uds = body_uds1 `plusUDs` rhs_uds+             combined_uds = body_uds1 `thenUDs` rhs_uds               (free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds @@ -1341,7 +1353,7 @@        -- Note [Specialising a recursive group]   = do { let (bndrs,rhss) = unzip pairs        ; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss-       ; let scope_uds = body_uds `plusUDs` rhs_uds+       ; let scope_uds = body_uds `thenUDs` rhs_uds                        -- Includes binds and calls arising from rhss         ; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs@@ -1381,8 +1393,8 @@ specDefns _env uds []   = return ([], [], uds) specDefns env uds ((bndr,rhs):pairs)-  = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs-       ; (bndr1, spec_defns2, uds2)  <- specDefn env uds1 bndr rhs+  = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds  pairs+       ; (bndr1, spec_defns2, uds2)  <- specDefn  env uds1 bndr rhs        ; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }  ---------------------------@@ -1396,12 +1408,15 @@ specDefn env body_uds fn rhs   = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds              rules_for_me = idCoreRules fn-       ; (rules, spec_defns, spec_uds) <- specCalls False env rules_for_me-                                                    calls_for_me fn rhs+             dict_binds   = ud_binds body_uds++       ; (rules, spec_defns, spec_uds) <- specCalls False env dict_binds+                                               rules_for_me calls_for_me fn rhs+        ; return ( fn `addIdSpecialisations` rules                 , spec_defns-                , body_uds_without_me `plusUDs` spec_uds) }-                -- It's important that the `plusUDs` is this way+                , body_uds_without_me `thenUDs` spec_uds) }+                -- It's important that the `thenUDs` is this way                 -- round, because body_uds_without_me may bind                 -- dictionaries that are used in calls_for_me passed                 -- to specDefn.  So the dictionary bindings in@@ -1412,6 +1427,7 @@ specCalls :: Bool              -- True  =>  specialising imported fn                                -- False =>  specialising local fn           -> SpecEnv+          -> FloatedDictBinds  -- Just so that we can extend the in-scope set           -> [CoreRule]        -- Existing RULES for the fn           -> [CallInfo]           -> OutId -> InExpr@@ -1425,7 +1441,7 @@                 , [(Id,CoreExpr)]  -- Specialised definition                 , UsageDetails )   -- Usage details from specialised RHSs -specCalls spec_imp env existing_rules calls_for_me fn rhs+specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs         -- The first case is the interesting one   |  notNull calls_for_me               -- And there are some calls to specialise   && not (isNeverActive (idInlineActivation fn))@@ -1441,14 +1457,14 @@ --      See Note [Inline specialisations] for why we do not --      switch off specialisation for inline functions -  = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $+  = -- pprTrace "specCalls: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $     foldlM spec_call ([], [], emptyUDs) calls_for_me    | otherwise   -- No calls or RHS doesn't fit our preconceptions   = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me)           "Missed specialisation opportunity" (ppr fn $$ _trace_doc) $           -- Note [Specialisation shape]-    -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $+    -- pprTrace "specCalls: none" (ppr fn <+> ppr calls_for_me) $     return ([], [], emptyUDs)   where     _trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ]@@ -1461,7 +1477,6 @@     is_local  = isLocalId fn     is_dfun   = isDFunId fn     dflags    = se_dflags env-    ropts     = initRuleOpts dflags     this_mod  = se_module env         -- Figure out whether the function has an INLINE pragma         -- See Note [Inline specialisations]@@ -1469,13 +1484,12 @@     (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs                             -- See Note [Account for casts in binding] -    in_scope = Core.substInScope (se_subst env)+    -- Bring into scope the binders from the floated dicts+    env_with_dict_bndrs = bringFloatedDictsIntoScope env dict_binds -    already_covered :: RuleOpts -> [CoreRule] -> [CoreExpr] -> Bool-    already_covered ropts new_rules args      -- Note [Specialisations already covered]-       = isJust (lookupRule ropts (in_scope, realIdUnfolding)-                            (const True) fn args-                            (new_rules ++ existing_rules))+    already_covered :: [CoreRule] -> [CoreExpr] -> Bool+    already_covered new_rules args      -- Note [Specialisations already covered]+       = isJust (specLookupRule env fn args (new_rules ++ existing_rules))          -- NB: we look both in the new_rules (generated by this invocation          --     of specCalls), and in existing_rules (passed in to specCalls) @@ -1491,9 +1505,11 @@                                -- See Note [Specialising DFuns]            ; ( useful, rhs_env2, leftover_bndrs              , rule_bndrs, rule_lhs_args-             , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args+             , spec_bndrs1, dx_binds, spec_args) <- specHeader env_with_dict_bndrs+                                                               rhs_bndrs all_call_args ---           ; pprTrace "spec_call" (vcat [ text "call info: " <+> ppr _ci+--           ; pprTrace "spec_call" (vcat [ text "fun:       " <+> ppr fn+--                                        , text "call info: " <+> ppr _ci --                                        , text "useful:    " <+> ppr useful --                                        , text "rule_bndrs:" <+> ppr rule_bndrs --                                        , text "lhs_args:  " <+> ppr rule_lhs_args@@ -1501,25 +1517,18 @@ --                                        , text "spec_args: " <+> ppr spec_args --                                        , text "dx_binds:  " <+> ppr dx_binds --                                        , text "rhs_env2:  " <+> ppr (se_subst rhs_env2)+--                                        , text "leftover_bndrs:" <+> pprIds leftover_bndrs --                                        , ppr dx_binds ]) $ --             return ()             ; if not useful  -- No useful specialisation-                || already_covered ropts rules_acc rule_lhs_args+                || already_covered rules_acc rule_lhs_args              then return spec_acc              else         do { -- Run the specialiser on the specialised RHS              -- The "1" suffix is before we maybe add the void arg-           ; (rhs_body', rhs_uds) <- specExpr rhs_env2 rhs_body-                -- Add the { d1' = dx1; d2' = dx2 } usage stuff-                -- to the rhs_uds; see Note [Specialising Calls]-           ; let rhs_uds_w_dx = foldr consDictBind rhs_uds dx_binds-                 spec_rhs_bndrs  = spec_bndrs1 ++ leftover_bndrs-                 (spec_uds, dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds_w_dx-                 spec_rhs1 = mkLams spec_rhs_bndrs $-                             wrapDictBindsE dumped_dbs rhs_body'--                 spec_fn_ty1 = exprType spec_rhs1+           ; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs1 ++ leftover_bndrs) rhs_body+           ; let spec_fn_ty1 = exprType spec_rhs1                   -- Maybe add a void arg to the specialised function,                  -- to avoid unlifted bindings@@ -1572,6 +1581,10 @@                       Just join_arity -> etaExpandToJoinPointRule join_arity rule_wout_eta                       Nothing -> rule_wout_eta +                -- Add the { d1' = dx1; d2' = dx2 } usage stuff+                -- See Note [Specialising Calls]+                spec_uds = foldr consDictBind rhs_uds dx_binds+                 simpl_opts = initSimpleOpts dflags                  --------------------------------------@@ -1586,12 +1599,9 @@                   = (inl_prag { inl_inline = NoUserInlinePrag }, noUnfolding)                    | otherwise-                  = (inl_prag, specUnfolding simpl_opts spec_bndrs spec_unf_body+                  = (inl_prag, specUnfolding simpl_opts spec_bndrs (`mkApps` spec_args)                                              rule_lhs_args fn_unf) -                spec_unf_body body = wrapDictBindsE dumped_dbs $-                                     body `mkApps` spec_args-                 --------------------------------------                 -- Adding arity information just propagates it a bit faster                 --      See Note [Arity decrease] in GHC.Core.Opt.Simplify@@ -1612,9 +1622,19 @@            ; -- pprTrace "spec_call: rule" _rule_trace_doc              return ( spec_rule                  : rules_acc                     , (spec_f_w_arity, spec_rhs) : pairs_acc-                    , spec_uds           `plusUDs` uds_acc+                    , spec_uds           `thenUDs` uds_acc                     ) } } +-- Convenience function for invoking lookupRule from Specialise+specLookupRule :: SpecEnv -> Id -> [CoreExpr] -> [CoreRule] -> Maybe (CoreRule, CoreExpr)+specLookupRule env fn args rules+  = lookupRule ropts (in_scope, realIdUnfolding) (const True) fn args rules+  where+    dflags   = se_dflags env+    in_scope = Core.substInScope (se_subst env)+    ropts    = initRuleOpts dflags++ {- Note [Specialising DFuns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ DFuns have a special sort of unfolding (DFunUnfolding), and these are@@ -1750,27 +1770,64 @@     {-# RULE "SPEC f @Int" forall x. f @Int x $dShow = $sf #-}  This doesn’t save us much, since the arg would be removed later by-worker/wrapper, anyway, but it’s easy to do.--Wrinkles--* Note that we only drop dead arguments if:-    1. We don’t specialise on them.-    2. They come before an argument we do specialise on.-  Doing the latter would require eta-expanding the RULE, which could-  make it match less often, so it’s not worth it. Doing the former could-  be more useful --- it would stop us from generating pointless-  specialisations --- but it’s more involved to implement and unclear if-  it actually provides much benefit in practice.+worker/wrapper, anyway, but it’s easy to do. Note, however, that we+only drop dead arguments if: -* If the function has a stable unfolding, specHeader has to come up with-  arguments to pass to that stable unfolding, when building the stable-  unfolding of the specialised function: this is the last field in specHeader's-  big result tuple.+  1. We don’t specialise on them.+  2. They come before an argument we do specialise on.    The right thing to do is to produce a LitRubbish; it should rapidly   disappear.  Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let. +Note [Specialisation modulo dictionary selectors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In #19644, we discovered that the ClassOp/DFun rules from+Note [ClassOp/DFun selection] inhibit transitive specialisation.+Example, inspired by T17966:++  class C a where+    m :: Show b => a -> b -> String+    dummy :: a -> () -- Force a datatype dictionary representation++  instance C Int where+    m a b = show a ++ show b+    dummy _ = ()++  f :: (C a, Show b) => a -> b -> String+  f a b = m a b ++ "!"+  {-# INLINABLE[0] f #-}++  main = putStrLn (f (42::Int) (True::Bool))++Here, we specialise `f` at `Int` and `Bool`, giving++  $dC = $fCInt+  $dShow = GHC.Show.$fShowBool+  $sf (a::Int) (b::Bool) =+        ... (m @Int $dC @Bool $dShow a b) ...++Here `m` is just a DictSel, so there is (apparently) nothing to specialise!+However, the next Simplifier run will expose the rewritten instance method:++  ... $fCInt_$cm @Bool $fShowBool a b ...++where $fCInt_$cm is the instance method for `m` in `instance C Int`:++   $fCInt_$cm :: forall b. Show b => Int -> b -> String+   $fCInt_$cm b d x y = show @Int $dShowInt x ++ show @b d y++We want to specialise this! How? By doing the the method-selection rewrite in+the Specialiser. Hence++1. In the App case of 'specExpr', try to apply the ClassOp/DFun rule on the+   head of the application, repeatedly, via 'rewriteClassOps'.+2. Attach an unfolding to freshly-bound dictionary ids such as `$dC` and+   `$dShow` in `bindAuxiliaryDict`, so that we can exploit the unfolding+   in 'rewriteClassOps' to do the ClassOp/DFun rewrite.++NB: Without (2), (1) would be pointless, because 'lookupRule' wouldn't be able+to look into the RHS of `$dC` to see the DFun.+ Note [Zap occ info in rule binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we generate a specialisation RULE, we need to drop occurrence@@ -2195,11 +2252,11 @@   ppr (SpecDict d) = text "SpecDict" <+> ppr d   ppr UnspecArg    = text "UnspecArg" -specArgFreeIds :: SpecArg -> IdSet-specArgFreeIds (SpecType {}) = emptyVarSet-specArgFreeIds (SpecDict dx) = exprFreeIds dx-specArgFreeIds UnspecType    = emptyVarSet-specArgFreeIds UnspecArg     = emptyVarSet+specArgFreeVars :: SpecArg -> VarSet+specArgFreeVars (SpecType ty) = tyCoVarsOfType ty+specArgFreeVars (SpecDict dx) = exprFreeVars dx+specArgFreeVars UnspecType    = emptyVarSet+specArgFreeVars UnspecArg     = emptyVarSet  isSpecDict :: SpecArg -> Bool isSpecDict (SpecDict {}) = True@@ -2269,30 +2326,24 @@               , [OutBndr]    -- Binders for $sf               , [DictBind]   -- Auxiliary dictionary bindings               , [OutExpr]    -- Specialised arguments for unfolding-                             -- Same length as "Args for LHS of rule"+                             -- Same length as "args for LHS of rule"               )  -- We want to specialise on type 'T1', and so we must construct a substitution -- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding -- details.-specHeader env (bndr : bndrs) (SpecType ty : args)-  = do { let in_scope = Core.substInScope (se_subst env)-             qvars    = scopedSort $-                        filterOut (`elemInScopeSet` in_scope) $-                        tyCoVarsOfTypeList ty-             (env1, qvars') = substBndrs env qvars-             ty'            = substTy env1 ty-             env2           = extendTvSubstList env1 [(bndr, ty')]-       ; (useful, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)-            <- specHeader env2 bndrs args+specHeader env (bndr : bndrs) (SpecType t : args)+  = do { let env' = extendTvSubstList env [(bndr, t)]+       ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)+            <- specHeader env' bndrs args        ; pure ( useful-              , env3+              , env''               , leftover_bndrs-              , qvars' ++ rule_bs-              , Type ty' : rule_es-              , qvars' ++ bs'+              , rule_bs+              , Type t : rule_es+              , bs'               , dx-              , Type ty' : spec_args+              , Type t : spec_args               )        } @@ -2319,12 +2370,12 @@ -- a wildcard binder to match the dictionary (See Note [Specialising Calls] for -- the nitty-gritty), as a LHS rule and unfolding details. specHeader env (bndr : bndrs) (SpecDict d : args)-  = do { bndr' <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]-       ; let (env', dx_bind, spec_dict) = bindAuxiliaryDict env bndr bndr' d-       ; (_, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)-             <- specHeader env' bndrs args+  = do { (env1, bndr') <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]+       ; let (env2, dx_bind, spec_dict) = bindAuxiliaryDict env1 bndr bndr' d+       ; (_, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)+             <- specHeader env2 bndrs args        ; pure ( True      -- Ha!  A useful specialisation!-              , env''+              , env3               , leftover_bndrs               -- See Note [Evidence foralls]               , exprFreeIdsList (varToCoreExpr bndr') ++ rule_bs@@ -2348,28 +2399,16 @@          let (env', bndr') = substBndr env (zapIdOccInfo bndr)        ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)              <- specHeader env' bndrs args--       ; let bndr_ty = idType bndr'--             -- See Note [Drop dead args from specialisations]-             -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let-             (mb_spec_bndr, spec_arg)-                | isDeadBinder bndr-                , Just lit_expr <- mkLitRubbish bndr_ty-                = (Nothing, lit_expr)-                | otherwise-                = (Just bndr', varToCoreExpr bndr')-        ; pure ( useful               , env''               , leftover_bndrs               , bndr' : rule_bs               , varToCoreExpr bndr' : rule_es-              , case mb_spec_bndr of-                  Just b' -> b' : bs'-                  Nothing -> bs'+              , if isDeadBinder bndr+                  then bs' -- see Note [Drop dead args from specialisations]+                  else bndr' : bs'               , dx-              , spec_arg : spec_args+              , varToCoreExpr bndr' : spec_args               )        } @@ -2390,9 +2429,9 @@ bindAuxiliaryDict   :: SpecEnv   -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression-  -> ( SpecEnv        -- Substitute for orig_dict_id+  -> ( SpecEnv        -- Substitutes for orig_dict_id      , Maybe DictBind -- Auxiliary dict binding, if any-     , OutExpr)        -- Witnessing expression (always trivial)+     , OutExpr)       -- Witnessing expression (always trivial) bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting })                   orig_dict_id fresh_dict_id dict_expr @@ -2400,18 +2439,23 @@   -- don’t bother creating a new dict binding; just substitute   | Just dict_id <- getIdFromTrivialExpr_maybe dict_expr   = let env' = env { se_subst = Core.extendSubst subst orig_dict_id dict_expr-                                `Core.extendInScope` dict_id                           -- See Note [Keep the old dictionaries interesting]                    , se_interesting = interesting `extendVarSet` dict_id }-    in (env', Nothing, dict_expr)+    in -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_id) $+       (env', Nothing, dict_expr)    | otherwise  -- Non-trivial dictionary arg; make an auxiliary binding-  = let dict_bind = mkDB (NonRec fresh_dict_id dict_expr)-        env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id)-                                `Core.extendInScope` fresh_dict_id+  = let dict_unf       = mkSimpleUnfolding defaultUnfoldingOpts dict_expr+        fresh_dict_id' = fresh_dict_id `setIdUnfolding` dict_unf+          -- See Note [Specialisation modulo dictionary selectors] for the unfolding+        dict_bind = mkDB (NonRec fresh_dict_id' dict_expr)+        env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id')+                                `Core.extendSubstInScope` fresh_dict_id'+                                -- Ensure the new unfolding is in the in-scope set                       -- See Note [Make the new dictionaries interesting]-                   , se_interesting = interesting `extendVarSet` fresh_dict_id }-    in (env', Just dict_bind, Var fresh_dict_id)+                   , se_interesting = interesting `extendVarSet` fresh_dict_id' }+    in -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id' $$ ppr dict_expr $$ ppr (exprFreeVarsList dict_expr)) $+       (env', Just dict_bind, Var fresh_dict_id')  {- Note [Make the new dictionaries interesting]@@ -2473,24 +2517,34 @@ ********************************************************************* -}  data UsageDetails-  = MkUD {-      ud_binds :: !(Bag DictBind),-               -- See Note [Floated dictionary bindings]+  = MkUD { ud_binds :: !FloatedDictBinds+         , ud_calls :: !CallDetails }+    -- INVARIANT: suppose bs = fdb_bndrs ud_binds+    -- Then 'calls' may *mention* 'bs',+    -- but there should be no calls *for* bs++data FloatedDictBinds  -- See Note [Floated dictionary bindings]+  = FDB { fdb_binds :: !(Bag DictBind)                -- The order is important;-               -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1+               -- in ds1 `unionBags` ds2, bindings in ds2 can depend on those in ds1                -- (Remember, Bags preserve order in GHC.) -      ud_calls :: !CallDetails--      -- INVARIANT: suppose bs = bindersOf ud_binds-      -- Then 'calls' may *mention* 'bs',-      -- but there should be no calls *for* bs-    }+        , fdb_bndrs :: !IdSet+    }          -- ^ The binders of 'fdb_binds'.+               -- Caches a superset of the expression+               --   `mkVarSet (bindersOfDictBinds fdb_binds))`+               -- for later addition to an InScopeSet  -- | A 'DictBind' is a binding along with a cached set containing its free -- variables (both type variables and dictionaries) data DictBind = DB { db_bind :: CoreBind, db_fvs :: VarSet } +bindersOfDictBind :: DictBind -> [Id]+bindersOfDictBind = bindersOf . db_bind++bindersOfDictBinds :: Foldable f => f DictBind -> [Id]+bindersOfDictBinds = bindersOfBinds . foldr ((:) . db_bind) []+ {- Note [Floated dictionary bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We float out dictionary bindings for the reasons described under@@ -2516,66 +2570,12 @@  So the DictBinds in (ud_binds :: Bag DictBind) may contain non-dictionary bindings too.--Note [Specialising polymorphic dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    class M a where { foo :: a -> Int }--    instance M (ST s) where ...-    -- dMST :: forall s. M (ST s)--    wimwam :: forall a. M a => a -> Int-    wimwam = /\a \(d::M a). body--    f :: ST s -> Int-    f = /\s \(x::ST s). wimwam @(ST s) (dMST @s) dx + 1--We'd like to specialise wimwam at (ST s), thus-    $swimwam :: forall s. ST s -> Int-    $swimwam = /\s. body[ST s/a, (dMST @s)/d]--    RULE forall s (d :: M (ST s)).-         wimwam @(ST s) d = $swimwam @s--Here are the moving parts:--* We must /not/ dump the CallInfo-    CIS wimwam (CI { ci_key = [@(ST s), dMST @s]-                   , ci_fvs = {dMST} })-  when we come to the /\s.  Instead, we simply let it continue to float-  upwards. Hence ci_fvs is an IdSet, listing the /Ids/ that-  are free in the call, but not the /TyVars/.  Hence using specArgFreeIds-  in singleCall.--  NB to be fully kosher we should explicitly quantifying the CallInfo-  over 's', but we don't bother.  This would matter if there was an-  enclosing binding of the same 's', which I don't expect to happen.--* Whe we come to specialise the call, we must remember to quantify-  over 's'.  That is done in the SpecType case of specHeader, where-  we add 's' (called qvars) to the binders of the RULE and the specialised-  function.--* If we have f :: forall m. Monoid m => blah, and two calls-     (f @(Endo b)      (d :: Monoid (Endo b))-     (f @(Endo (c->c)) (d :: Monoid (Endo (c->c)))-  we want to generate a specialisation only for the first.  The second-  is just a substitution instance of the first, with no greater specialisation.-  Hence the call to `remove_dups` in `filterCalls`.--All this arose in #13873, in the unexpected form that a SPECIALISE-pragma made the program slower!  The reason was that the specialised-function $sinsertWith arising from the pragma looked rather like `f`-above, and failed to specialise a call in its body like wimwam.-Without the pragma, the original call to `insertWith` was completely-monomorphic, and specialised in one go. -}  instance Outputable DictBind where   ppr (DB { db_bind = bind, db_fvs = fvs })-    = text "DB" <+> braces (sep [ text "bind:" <+> ppr bind-                                , text "fvs: " <+> ppr fvs ])+    = text "DB" <+> braces (sep [ text "fvs: " <+> ppr fvs+                                , text "bind:" <+> ppr bind ])  instance Outputable UsageDetails where   ppr (MkUD { ud_binds = dbs, ud_calls = calls })@@ -2583,9 +2583,16 @@                 [text "binds" <+> equals <+> ppr dbs,                  text "calls" <+> equals <+> ppr calls])) +instance Outputable FloatedDictBinds where+  ppr (FDB { fdb_binds = binds }) = ppr binds+ emptyUDs :: UsageDetails-emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv }+emptyUDs = MkUD { ud_binds = emptyFDBs, ud_calls = emptyDVarEnv } ++emptyFDBs :: FloatedDictBinds+emptyFDBs = FDB { fdb_binds = emptyBag, fdb_bndrs = emptyVarSet }+ ------------------------------------------------------------ type CallDetails  = DIdEnv CallInfoSet   -- The order of specialized binds and rules depends on how we linearize@@ -2603,7 +2610,6 @@        , ci_fvs  :: IdSet       -- Free Ids of the ci_key call                                 -- _not_ including the main id itself, of course                                 -- NB: excluding tyvars:-                                --     See Note [Specialising polymorphic dictionaries]     }  type DictExpr = CoreExpr@@ -2653,12 +2659,12 @@ ------------------------------------------------------------ singleCall :: Id -> [SpecArg] -> UsageDetails singleCall id args-  = MkUD {ud_binds = emptyBag,+  = MkUD {ud_binds = emptyFDBs,           ud_calls = unitDVarEnv id $ CIS id $                      unitBag (CI { ci_key  = args -- used to be tys                                  , ci_fvs  = call_fvs }) }   where-    call_fvs = foldr (unionVarSet . specArgFreeIds) emptyVarSet args+    call_fvs = foldr (unionVarSet . specArgFreeVars) emptyVarSet args         -- The type args (tys) are guaranteed to be part of the dictionary         -- types, because they are just the constrained types,         -- and the dictionary is therefore sure to be bound@@ -2669,13 +2675,15 @@         --         -- We don't include the 'id' itself. -mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails-mkCallUDs env f args-  = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ])-    res-  where-    res = mkCallUDs' env f args+mkCallUDs :: SpecEnv -> OutExpr -> [OutExpr] -> UsageDetails+mkCallUDs env fun args+  | Var f <- fun+  = -- pprTraceWith "mkCallUDs" (\res -> vcat [ ppr f, ppr args, ppr res ]) $+    mkCallUDs' env f args+  | otherwise+  = emptyUDs +mkCallUDs' :: SpecEnv -> Id -> [OutExpr] -> UsageDetails mkCallUDs' env f args   | wantCallsFor env f    -- We want it, and...   , not (null ci_key)     -- this call site has a useful specialisation@@ -2699,7 +2707,7 @@              -- which broadens its applicability, since rules only              -- fire when saturated -    mk_spec_arg :: CoreExpr -> TyCoBinder -> SpecArg+    mk_spec_arg :: OutExpr -> TyCoBinder -> SpecArg     mk_spec_arg arg (Named bndr)       |  binderVar bndr `elemVarSet` constrained_tyvars       = case arg of@@ -2711,7 +2719,7 @@     -- we decide on a case by case basis if we want to specialise     -- on this argument; if so, SpecDict, if not UnspecArg     mk_spec_arg arg (Anon InvisArg pred)-      | not (isIPLikePred (scaledThing pred))+      | typeDeterminesValue (scaledThing pred)               -- See Note [Type determines value]       , interestingDict env arg               -- See Note [Interesting dictionary arguments]@@ -2781,8 +2789,13 @@ 1.2% for bspt, but mostly 0.0!  Average 0.1% increase in binary size. -} +typeDeterminesValue :: Type -> Bool+-- See Note [Type determines value]+typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty)+ interestingDict :: SpecEnv -> CoreExpr -> Bool--- A dictionary argument is interesting if it has *some* structure+-- A dictionary argument is interesting if it has *some* structure,+-- see Note [Interesting dictionary arguments] -- NB: "dictionary" arguments include constraints of all sorts, --     including equality constraints; hence the Coercion case interestingDict env (Var v) =  hasSomeUnfolding (idUnfolding v)@@ -2796,12 +2809,20 @@ interestingDict env (Cast e _)            = interestingDict env e interestingDict _ _                       = True -plusUDs :: UsageDetails -> UsageDetails -> UsageDetails-plusUDs (MkUD {ud_binds = db1, ud_calls = calls1})+thenUDs :: UsageDetails -> UsageDetails -> UsageDetails+thenUDs (MkUD {ud_binds = db1, ud_calls = calls1})         (MkUD {ud_binds = db2, ud_calls = calls2})-  = MkUD { ud_binds = db1    `unionBags`   db2-         , ud_calls = calls1 `unionCalls`  calls2 }+  = MkUD { ud_binds       = db1    `thenFDBs`   db2+         , ud_calls       = calls1 `unionCalls`  calls2 } +thenFDBs :: FloatedDictBinds -> FloatedDictBinds -> FloatedDictBinds+-- Combine FloatedDictBinds+-- In (dbs1 `thenFDBs` dbs2), dbs2 may mention dbs1 but not vice versa+thenFDBs (FDB { fdb_binds = dbs1, fdb_bndrs = bs1 })+         (FDB { fdb_binds = dbs2, fdb_bndrs = bs2 })+  = FDB { fdb_binds = dbs1 `unionBags` dbs2+        , fdb_bndrs = bs1  `unionVarSet` bs2 }+ ----------------------------- _dictBindBndrs :: Bag DictBind -> [Id] _dictBindBndrs dbs = foldr ((++) . bindersOf . db_bind) [] dbs@@ -2813,9 +2834,8 @@ -- | Identify the free variables of a 'CoreBind' bind_fvs :: CoreBind -> VarSet bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)-bind_fvs (Rec prs)         = foldl' delVarSet rhs_fvs bndrs+bind_fvs (Rec prs)         = rhs_fvs `delVarSetList` (map fst prs)                            where-                             bndrs = map fst prs                              rhs_fvs = unionVarSets (map pair_fvs prs)  pair_fvs :: (Id, CoreExpr) -> VarSet@@ -2840,7 +2860,8 @@ -- pairs, into a single recursive binding. recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind -> DictBind recWithDumpedDicts pairs dbs-  = DB { db_bind = Rec bindings, db_fvs = fvs }+  = DB { db_bind = Rec bindings+       , db_fvs = fvs `delVarSetList` map fst bindings }   where     (bindings, fvs) = foldr add ([], emptyVarSet)                                 (dbs `snocBag` mkDB (Rec pairs))@@ -2851,22 +2872,29 @@       where         fvs' = fvs_acc `unionVarSet` fvs +snocDictBind :: UsageDetails -> DictBind -> UsageDetails+snocDictBind uds@MkUD{ud_binds= FDB { fdb_binds = dbs, fdb_bndrs = bs }} db+  = uds { ud_binds = FDB { fdb_binds = dbs `snocBag` db+                         , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }+ snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails -- Add ud_binds to the tail end of the bindings in uds-snocDictBinds uds dbs-  = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs }+snocDictBinds uds@MkUD{ud_binds=FDB{ fdb_binds = binds, fdb_bndrs = bs }} dbs+  = uds { ud_binds = FDB { fdb_binds = binds `unionBags`        listToBag dbs+                         , fdb_bndrs = bs    `extendVarSetList` bindersOfDictBinds dbs } }  consDictBind :: DictBind -> UsageDetails -> UsageDetails-consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds }--addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails-addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds }+consDictBind db uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs=bs}}+  = uds { ud_binds = FDB { fdb_binds = db `consBag` binds+                         , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } } -snocDictBind :: UsageDetails -> DictBind -> UsageDetails-snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind }+consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails+consDictBinds dbs uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}}+  = uds { ud_binds = FDB{ fdb_binds = listToBag dbs `unionBags` binds+                        , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } } -wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]-wrapDictBinds dbs binds+wrapDictBinds :: FloatedDictBinds -> [CoreBind] -> [CoreBind]+wrapDictBinds (FDB { fdb_binds = dbs }) binds   = foldr add binds dbs   where     add (DB { db_bind = bind }) binds = bind : binds@@ -2885,7 +2913,7 @@   | otherwise  = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $                  (free_uds, dump_dbs)   where-    free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }+    free_uds = uds { ud_binds = free_dbs, ud_calls = free_calls }     bndr_set = mkVarSet bndrs     (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set     free_calls = deleteCallsMentioning dump_set $   -- Drop calls mentioning bndr_set on the floor@@ -2909,17 +2937,15 @@     float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls  callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo])-callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })+callsForMe fn uds@MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }   = -- pprTrace ("callsForMe")     --          (vcat [ppr fn,     --                 text "Orig dbs ="     <+> ppr (_dictBindBndrs orig_dbs),     --                 text "Orig calls ="   <+> ppr orig_calls,-    --                 text "Dep set ="      <+> ppr dep_set,     --                 text "Calls for me =" <+> ppr calls_for_me]) $     (uds_without_me, calls_for_me)   where-    uds_without_me = MkUD { ud_binds = orig_dbs-                          , ud_calls = delDVarEnv orig_calls fn }+    uds_without_me = uds { ud_calls = delDVarEnv orig_calls fn }     calls_for_me = case lookupDVarEnv orig_calls fn of                         Nothing -> []                         Just cis -> filterCalls cis orig_dbs@@ -2927,16 +2953,16 @@          -- refer to fn.  See Note [Avoiding loops (DFuns)]  -----------------------filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]--- Remove dominated calls (Note [Specialising polymorphic dictionaries])+filterCalls :: CallInfoSet -> FloatedDictBinds -> [CallInfo]+-- Remove dominated calls -- and loopy DFuns (Note [Avoiding loops (DFuns)])-filterCalls (CIS fn call_bag) dbs+filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs })   | isDFunId fn  -- Note [Avoiding loops (DFuns)] applies only to DFuns-  = filter ok_call de_dupd_calls+  = filter ok_call unfiltered_calls   | otherwise         -- Do not apply it to non-DFuns-  = de_dupd_calls  -- See Note [Avoiding loops (non-DFuns)]+  = unfiltered_calls  -- See Note [Avoiding loops (non-DFuns)]   where-    de_dupd_calls = remove_dups call_bag+    unfiltered_calls = bagToList call_bag      dump_set = foldl' go (unitVarSet fn) dbs       -- This dump-set could also be computed by splitDictBinds@@ -2950,42 +2976,24 @@      ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set -remove_dups :: Bag CallInfo -> [CallInfo]-remove_dups calls = foldr add [] calls-  where-    add :: CallInfo -> [CallInfo] -> [CallInfo]-    add ci [] = [ci]-    add ci1 (ci2:cis) | ci2 `beats_or_same` ci1 = ci2:cis-                      | ci1 `beats_or_same` ci2 = ci1:cis-                      | otherwise               = ci2 : add ci1 cis--beats_or_same :: CallInfo -> CallInfo -> Bool-beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 })-  = go args1 args2-  where-    go [] _ = True-    go (arg1:args1) (arg2:args2) = go_arg arg1 arg2 && go args1 args2-    go (_:_)        []           = False--    go_arg (SpecType ty1) (SpecType ty2) = isJust (tcMatchTy ty1 ty2)-    go_arg UnspecType     UnspecType     = True-    go_arg (SpecDict {})  (SpecDict {})  = True-    go_arg UnspecArg      UnspecArg      = True-    go_arg _              _              = False- -----------------------splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)+splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, Bag DictBind, IdSet) -- splitDictBinds dbs bndrs returns --   (free_dbs, dump_dbs, dump_set) -- where --   * dump_dbs depends, transitively on bndrs --   * free_dbs does not depend on bndrs --   * dump_set = bndrs `union` bndrs(dump_dbs)-splitDictBinds dbs bndr_set-   = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs+splitDictBinds (FDB { fdb_binds = dbs, fdb_bndrs = bs }) bndr_set+   = (FDB { fdb_binds = free_dbs+          , fdb_bndrs = bs `minusVarSet` dump_set }+     , dump_dbs, dump_set)+   where+    (free_dbs, dump_dbs, dump_set)+      = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs                 -- Important that it's foldl' not foldr;                 -- we're accumulating the set of dumped ids in dump_set-   where+     split_db (free_dbs, dump_dbs, dump_idset) db         | DB { db_bind = bind, db_fvs = fvs } <- db         , dump_idset `intersectsVarSet` fvs     -- Dump it@@ -2998,18 +3006,15 @@  ---------------------- deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails--- Remove calls mentioning any Id in bndrs--- NB: The call is allowed to mention TyVars in bndrs---     Note [Specialising polymorphic dictionaries]---     ci_fvs are just the free /Ids/-deleteCallsMentioning bndrs calls+-- Remove calls *mentioning* bs in any way+deleteCallsMentioning bs calls   = mapDVarEnv (ciSetFilter keep_call) calls   where-    keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bndrs+    keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bs  deleteCallsFor :: [Id] -> CallDetails -> CallDetails--- Remove calls *for* bndrs-deleteCallsFor bndrs calls = delDVarEnvList calls bndrs+-- Remove calls *for* bs+deleteCallsFor bs calls = delDVarEnvList calls bs  {- ************************************************************************@@ -3030,7 +3035,7 @@ mapAndCombineSM _ []     = return ([], emptyUDs) mapAndCombineSM f (x:xs) = do (y, uds1) <- f x                               (ys, uds2) <- mapAndCombineSM f xs-                              return (y:ys, uds1 `plusUDs` uds2)+                              return (y:ys, uds1 `thenUDs` uds2)  extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv extendTvSubstList env tv_binds@@ -3056,9 +3061,11 @@ cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs)   = do { us <- getUniqueSupplyM        ; let (subst', bndr') = Core.cloneIdBndr subst us bndr-             interesting' | interestingDict env rhs+             interesting' | typeDeterminesValue (idType bndr)+                          , interestingDict env rhs                           = interesting `extendVarSet` bndr'                           | otherwise = interesting+--       ; pprTrace "cloneBindSM" (ppr bndr <+> text ":->" <+> ppr bndr') return ()        ; return (env, env { se_subst = subst', se_interesting = interesting' }                 , NonRec bndr' rhs) } @@ -3067,16 +3074,19 @@        ; let (subst', bndrs') = Core.cloneRecIdBndrs subst us (map fst pairs)              env' = env { se_subst = subst'                         , se_interesting = interesting `extendVarSetList`-                                           [ v | (v,r) <- pairs, interestingDict env r ] }+                                           [ v | (v,r) <- pairs, typeDeterminesValue (idType v), interestingDict env r ] }        ; return (env', env', Rec (bndrs' `zip` map snd pairs)) } -newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr+newDictBndr :: SpecEnv -> CoreBndr -> SpecM (SpecEnv, CoreBndr) -- Make up completely fresh binders for the dictionaries -- Their bindings are going to float outwards-newDictBndr env b = do { uniq <- getUniqueM-                        ; let n   = idName b-                              ty' = substTy env (idType b)-                        ; return (mkUserLocal (nameOccName n) uniq Many ty' (getSrcSpan n)) }+newDictBndr env@(SE { se_subst = subst }) b+  = do { uniq <- getUniqueM+       ; let n    = idName b+             ty'  = Core.substTy subst (idType b)+             b'   = mkUserLocal (nameOccName n) uniq Many ty' (getSrcSpan n)+             env' = env { se_subst = subst `Core.extendSubstInScope` b' }+       ; pure (env', b') }  newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id     -- Give the new Id a similar occurrence name to the old one

@@ -1131,7 +1131,7 @@      of the form @TYPE rep@ where @rep@ is not (and doesn't contain) a variable.      Why? Because if we don't know its representation (e.g. size in memory,      register class), we don't know what or how much rubbish to emit in codegen.-     'typeMonoPrimRep_maybe' returns 'Nothing' in this case and we simply fall+     'mkLitRubbish' returns 'Nothing' in this case and we simply fall      back to passing the original parameter to the worker.       Note that currently this case should not occur, because binders always

@@ -402,7 +402,11 @@   = case app_head of       Var f -> coreToStgApp f args ticks -- Regular application       Lit l | isLitRubbish l             -- If there is LitRubbish at the head,-            -> return (StgLit l)         --    discard the arguments+                                         --    discard the arguments+                                         --    Recompute representation, because in+                                         --    '(RUBBISH[rep] x) :: (T :: TYPE rep2)'+                                         --    rep might not be equal to rep2+            -> return (StgLit $ LitRubbish $ getRuntimeRep (exprType expr))        _     -> pprPanic "coreToStgExpr - Invalid app head:" (ppr expr)     where

@@ -97,7 +97,7 @@     dflags0 <- getDynFlags     let dflags1 = dflags0     let parser_opts1 = initParserOpts dflags1-    src_opts <- liftIO $ getOptionsFromFile parser_opts1 src_filename+    (p_warns, src_opts) <- liftIO $ getOptionsFromFile parser_opts1 src_filename     (dflags, unhandled_flags, warns) <- liftIO $ parseDynamicFilePragma dflags1 src_opts     modifySession (hscSetFlags dflags)     logger <- getLogger -- Get the logger after having set the session flags,@@ -105,6 +105,7 @@                         -- Not doing so caused #20396.     -- Cribbed from: preprocessFile / GHC.Driver.Pipeline     liftIO $ checkProcessArgsResult unhandled_flags+    liftIO $ printOrThrowDiagnostics logger (initDiagOpts dflags) (GhcPsMessage <$> p_warns)     liftIO $ handleFlagWarnings logger (initDiagOpts dflags) warns     -- TODO: Preprocessing not implemented @@ -326,7 +327,7 @@         mod_graph <- hsunitModuleGraph False (unLoc lunit)          msg <- mkBackpackMsg-        (ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph+        ok <- load' noHomeCache LoadAllTargets (Just msg) mod_graph         when (failed ok) (liftIO $ exitWith (ExitFailure 1))          let hi_dir = expectJust (panic "hiDir Backpack") $ hiDir dflags@@ -415,7 +416,7 @@     withBkpExeSession deps_w_rns $ do         mod_graph <- hsunitModuleGraph True (unLoc lunit)         msg <- mkBackpackMsg-        (ok, _) <- load' [] LoadAllTargets (Just msg) mod_graph+        ok <- load' noHomeCache LoadAllTargets (Just msg) mod_graph         when (failed ok) (liftIO $ exitWith (ExitFailure 1))  -- | Register a new virtual unit database containing a single unit

@@ -224,6 +224,15 @@ ************************************************************************ -} +{-+Note [Packaging libffi headers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The C code emitted by GHC for libffi adjustors must depend upon the ffi_arg type,+defined in <ffi.h>. For this reason, we must ensure that <ffi.h> is available+in binary distributions. To do so, we install these headers as part of the+`rts` package.+-}+ outputForeignStubs     :: Logger     -> TmpFs

@@ -493,10 +493,11 @@              -- apply parse transformation of plugins             let applyPluginAction p opts-                  = uncurry (parsedResultAction p opts mod_summary)+                  = parsedResultAction p opts mod_summary             hsc_env <- getHscEnv-            (transformed, (warns, errs)) <--              withPlugins (hsc_plugins hsc_env) applyPluginAction (res, getPsMessages pst)+            (ParsedResult transformed (PsMessages warns errs)) <-+              withPlugins (hsc_plugins hsc_env) applyPluginAction+                (ParsedResult res (uncurry PsMessages $ getPsMessages pst))              logDiagnostics (GhcPsMessage <$> warns)             unless (isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs)@@ -1730,8 +1731,8 @@  ------------------------------ -hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO (Maybe FilePath)-hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do+hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)+hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hsc_env $ do     let dflags   = hsc_dflags hsc_env         logger   = hsc_logger hsc_env         hooks    = hsc_hooks hsc_env@@ -1742,7 +1743,7 @@         do_info_table = gopt Opt_InfoTableMap dflags         -- Make up a module name to give the NCG. We can't pass bottom here         -- lest we reproduce #11784.-        mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename+        mod_name = mkModuleName $ "Cmm$" ++ original_filename         cmm_mod = mkHomeModule home_unit mod_name     (cmm, ents) <- ioMsgMaybe                $ do

@@ -27,7 +27,7 @@ -- ----------------------------------------------------------------------------- module GHC.Driver.Make (         depanal, depanalE, depanalPartial, checkHomeUnitsClosed,-        load, loadWithCache, load', LoadHowMuch(..),+        load, loadWithCache, load', LoadHowMuch(..), HomeModInfoCache(..), noHomeCache, newHomeModInfoCache,         instantiationNodes,          downsweep,@@ -121,7 +121,7 @@ import qualified Data.Map as Map import qualified Data.Set as Set -import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )+import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask , forkIO ) import qualified GHC.Conc as CC import Control.Concurrent.MVar import Control.Monad@@ -264,7 +264,7 @@   where     iuids_to_check :: [InstantiatedUnit]     iuids_to_check =-      nubSort $ concatMap goUnitId (explicitUnits unit_state)+      nubSort $ concatMap (goUnitId . fst) (explicitUnits unit_state)      where       goUnitId uid =         [ recur@@ -409,6 +409,64 @@      -- ^ Load only the dependencies of the given module, but not the module      -- itself. +{-+Note [Caching HomeModInfo]+~~~~~~~~~~~~~~~~~~~~~~~~~~++API clients who call `load` like to cache the HomeModInfo in memory between+calls to this function. In the old days, this cache was a simple MVar which stored+a HomePackageTable. This was insufficient, as the interface files for boot modules+were not recorded in the cache. In the less old days, the cache was returned at the+end of load, and supplied at the start of load, however, this was not sufficient+because it didn't account for the possibility of exceptions such as SIGINT (#20780).++So now, in the current day, we have this HomeModInfoCache abstraction which+can incrementally be updated during the process of upsweep. This alllows us+to store interface files for boot modules in an exception-safe way.++When the final version of an interface file is completed then it is placed into+the cache. The contents of the cache is retrieved, and the cache cleared, by hmi_clearCache.++If a module is in a loop then the final version is the retypechecked version of+the inteface file which is created after the loop has concluded. For modules not+in a loop, the final interface file is just the normal one we create at the end+of compiling the module.++One slightly tricky part is keeping the cache up-to-date when performing parallel+upsweep. In order to do this we spawn a thread for each module which blocks on+the result variable and once unblocked adds the interface to the cache. This also+has the effect of writing the maximal number of modules into the cache as modules are not+inserted in the linearised order. In addition+to this we are careful to block the program continuing whilst there are still threads+waiting to write to the cache, lest we end up in situations where load is called+again before all threads have finished writing and old information will be placed into+the cache.++++-}+++-- Abstract interface to a cache of HomeModInfo+-- See Note [Caching HomeModInfo]+data HomeModInfoCache = HomeModInfoCache { hmi_clearCache :: IO [HomeModInfo]+                                         , hmi_addToCache :: HomeModInfo -> IO () }++noHomeCache :: Maybe HomeModInfoCache+noHomeCache = Nothing++newHomeModInfoCache :: IO HomeModInfoCache+newHomeModInfoCache = do+  ioref <- newIORef []+  return $+    HomeModInfoCache+      { hmi_clearCache = atomicModifyIORef' ioref (\c -> ([], c))+      , hmi_addToCache = \hmi -> atomicModifyIORef' ioref (\c -> (hmi:c, ()))+      }++++ -- | Try to load the program.  See 'LoadHowMuch' for the different modes. -- -- This function implements the core of GHC's @--make@ mode.  It preprocesses,@@ -425,7 +483,7 @@ -- All other errors are reported using the 'defaultWarnErrLogger'.  load :: GhcMonad f => LoadHowMuch -> f SuccessFlag-load how_much = fst <$> loadWithCache [] how_much+load how_much = loadWithCache noHomeCache how_much  mkBatchMsg :: HscEnv -> Messager mkBatchMsg hsc_env =@@ -434,7 +492,8 @@     then batchMultiMsg     else batchMsg -loadWithCache :: GhcMonad m => [HomeModInfo] -> LoadHowMuch -> m (SuccessFlag, [HomeModInfo])++loadWithCache :: GhcMonad m => Maybe HomeModInfoCache -> LoadHowMuch -> m SuccessFlag loadWithCache cache how_much = do     (errs, mod_graph) <- depanalE [] False                        -- #17459     msg <- mkBatchMsg <$> getSession@@ -460,41 +519,26 @@             $ concatMap ms_imps (               filter (\ms -> homeUnitId_ dflags == ms_unitid ms) (mgModSummaries mod_graph)) -        requestedArgs = mapMaybe packageArg (packageFlags dflags)+        used_args = Set.fromList $ map unitId loadedPackages -        unusedArgs-          = filter (\arg -> not $ any (matching us arg) loadedPackages)-                   requestedArgs+        resolve (u,mflag) = do+                  -- The units which we depend on via the command line explicitly+                  flag <- mflag+                  -- Which we can find the UnitInfo for (should be all of them)+                  ui <- lookupUnit us u+                  -- Which are not explicitly used+                  guard (Set.notMember (unitId ui) used_args)+                  return (unitId ui, unitPackageName ui, unitPackageVersion ui, flag) +        unusedArgs = mapMaybe resolve (explicitUnits us)+         warn = singleMessage $ mkPlainMsgEnvelope diag_opts noSrcSpan (DriverUnusedPackages unusedArgs)      in if null unusedArgs         then emptyMessages         else warn -    where-        packageArg (ExposePackage _ arg _) = Just arg-        packageArg _ = Nothing -        matchingStr :: String -> UnitInfo -> Bool-        matchingStr str p-                =  str == unitPackageIdString p-                || str == unitPackageNameString p--        matching :: UnitState -> PackageArg -> UnitInfo -> Bool-        matching _ (PackageArg str) p = matchingStr str p-        matching state (UnitIdArg uid) p = uid == realUnit state p--        -- For wired-in packages, we have to unwire their id,-        -- otherwise they won't match package flags-        realUnit :: UnitState -> UnitInfo -> Unit-        realUnit state-          = unwireUnit state-          . RealUnit-          . Definite-          . unitId-- -- | A ModuleGraphNode which also has a hs-boot file, and the list of nodes on any -- path from module to its boot file. data ModuleGraphNodeWithBootFile@@ -601,8 +645,8 @@ -- | Generalized version of 'load' which also supports a custom -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally -- produced by calling 'depanal'.-load' :: GhcMonad m => [HomeModInfo] -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m (SuccessFlag, [HomeModInfo])-load' cache how_much mHscMessage mod_graph = do+load' :: GhcMonad m => Maybe HomeModInfoCache -> LoadHowMuch -> Maybe Messager -> ModuleGraph -> m SuccessFlag+load' mhmi_cache how_much mHscMessage mod_graph = do     modifySession $ \hsc_env -> hsc_env { hsc_mod_graph = mod_graph }     guessOutputFile     hsc_env <- getSession@@ -636,7 +680,7 @@             | otherwise = do                     liftIO $ errorMsg logger                         (text "no such module:" <+> quotes (ppr (moduleUnit m) <> colon <> ppr (moduleName m)))-                    return (Failed, [])+                    return Failed      checkHowMuch how_much $ do @@ -657,6 +701,7 @@         build_plan = createBuildPlan mod_graph maybe_top_mod  +    cache <- liftIO $ maybe (return []) hmi_clearCache mhmi_cache     let         -- prune the HPT so everything is not retained when doing an         -- upsweep.@@ -683,10 +728,10 @@      setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env     hsc_env <- getSession-    (upsweep_ok, hsc_env1, new_cache) <- withDeferredDiagnostics $-      liftIO $ upsweep n_jobs hsc_env mHscMessage (toCache pruned_cache) build_plan+    (upsweep_ok, hsc_env1) <- withDeferredDiagnostics $+      liftIO $ upsweep n_jobs hsc_env mhmi_cache mHscMessage (toCache pruned_cache) build_plan     setSession hsc_env1-    fmap (, new_cache) $ case upsweep_ok of+    case upsweep_ok of       Failed -> loadFinish upsweep_ok       Succeeded -> do           liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")@@ -965,19 +1010,47 @@ -- if the module participates in a loop. This step also labels each node with a number for the output. -- See Note [Upsweep] for a high-level description. interpretBuildPlan :: HomeUnitGraph+                   -> Maybe HomeModInfoCache                    -> M.Map ModNodeKeyWithUid HomeModInfo                    -> [BuildPlan]                    -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle                          , [MakeAction] -- Actions we need to run in order to build everything                          , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end.-interpretBuildPlan hug old_hpt plan = do+interpretBuildPlan hug mhmi_cache old_hpt plan = do   hug_var <- newMVar hug   ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1 hug_var)-  return (mcycle, plans, collect_results (buildDep build_map))+  wait <- collect_results (buildDep build_map)+  return (mcycle, plans, wait)    where-    collect_results build_map = mapM (\(_doc, res_var) -> runMaybeT (waitResult res_var)) (M.elems build_map)+    collect_results build_map = do+      -- 1. On success, write the result to the cache, fork threads waiting for each result+      -- so that the cache can be updated out of order, before we wait at the end for everything to+      -- finish. We do this here rather than when we update the hug_var because we only ever+      -- want to add things to the cache which are externally visible+      -- (something which is hard to work out in the main loop).+      waits <- mapM (\(_doc, res_var) -> collect_result res_var) (M.elems build_map)+      -- 2. Block waiting for all to finish+      return (sequence waits) +    -- See Note [Caching HomeModInfo]+    collect_result res_var = case mhmi_cache of+      -- Avoid forking a new thread when there's no cache+      Nothing -> return (runMaybeT (waitResult res_var))+      Just hmi_cache -> do+        -- Barrier used to ensure that we write to the cache before execution+        -- continues.+        barrier <- newEmptyMVar+        forkIO (do+           r <- runMaybeT (waitResult res_var)+           case r of+             Just (Just hmi) -> do+               hmi_addToCache hmi_cache hmi+             _ -> do+               return ()+           putMVar barrier r)+        return (takeMVar barrier)+     n_mods = sum (map countMods plan)      buildLoop :: [BuildPlan]@@ -1072,12 +1145,13 @@ upsweep     :: Int -- ^ The number of workers we wish to run in parallel     -> HscEnv -- ^ The base HscEnv, which is augmented for each module+    -> Maybe HomeModInfoCache -- ^ A cache to incrementally write final interface files to     -> Maybe Messager     -> M.Map ModNodeKeyWithUid HomeModInfo     -> [BuildPlan]-    -> IO (SuccessFlag, HscEnv, [HomeModInfo])-upsweep n_jobs hsc_env mHscMessage old_hpt build_plan = do-    (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) old_hpt build_plan+    -> IO (SuccessFlag, HscEnv)+upsweep n_jobs hsc_env hmi_cache mHscMessage old_hpt build_plan = do+    (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) hmi_cache old_hpt build_plan     runPipelines n_jobs hsc_env mHscMessage pipelines     res <- collect_result @@ -1090,10 +1164,10 @@         Just mss -> do           let logger = hsc_logger hsc_env           liftIO $ fatalErrorMsg logger (cyclicModuleErr mss)-          return (Failed, hsc_env, completed)+          return (Failed, hsc_env)         Nothing  -> do           let success_flag = successIf (all isJust res)-          return (success_flag, hsc_env', completed)+          return (success_flag, hsc_env')  toCache :: [HomeModInfo] -> M.Map (ModNodeKeyWithUid) HomeModInfo toCache hmis = M.fromList ([(miKey $ hm_iface hmi, hmi) | hmi <- hmis])

@@ -663,13 +663,13 @@       use (T_Unlit pipe_env hsc_env input_fn)  -  (dflags1, warns1) <- use (T_FileArgs hsc_env unlit_fn)+  (dflags1, p_warns1, warns1) <- use (T_FileArgs hsc_env unlit_fn)   let hsc_env1 = hscSetFlags dflags1 hsc_env    (cpp_fn, hsc_env2)     <- runAfterFlag hsc_env1 (Cpp HsSrcFile) (xopt LangExt.Cpp) (unlit_fn, hsc_env1) $ do           cpp_fn <- use (T_Cpp pipe_env hsc_env1 unlit_fn)-          (dflags2, _) <- use (T_FileArgs hsc_env1 cpp_fn)+          (dflags2, _, _) <- use (T_FileArgs hsc_env1 cpp_fn)           let hsc_env2 = hscSetFlags dflags2 hsc_env1           return (cpp_fn, hsc_env2) @@ -677,15 +677,16 @@   pp_fn <- runAfterFlag hsc_env2 (HsPp HsSrcFile) (gopt Opt_Pp) cpp_fn $             use (T_HsPp pipe_env hsc_env2 input_fn cpp_fn) -  (dflags3, warns3)+  (dflags3, p_warns3, warns3)     <- if pp_fn == unlit_fn           -- Didn't run any preprocessors so don't need to reparse, would be nicer           -- if `T_FileArgs` recognised this.-          then return (dflags1, warns1)+          then return (dflags1, p_warns1, warns1)           else do             -- Reparse with original hsc_env so that we don't get duplicated options             use (T_FileArgs hsc_env pp_fn) +  liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3))   liftIO (handleFlagWarnings (hsc_logger hsc_env) (initDiagOpts dflags3) warns3)   return (dflags3, pp_fn) @@ -760,14 +761,12 @@       Nothing -> return mlinkable       Just o_fp -> do         unlinked_time <- liftIO (liftIO getCurrentTime)-        final_o <- use (T_MergeForeign pipe_env hsc_env o_fp fos)-        let !linkable = LM unlinked_time-                                    (ms_mod mod_sum)-                                    [DotO final_o]+        final_unlinked <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos)+        let !linkable = LM unlinked_time (ms_mod mod_sum) [final_unlinked]         return (Just linkable)   return (miface, final_linkable) -asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m FilePath+asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m ObjFile asPipeline use_cpp pipe_env hsc_env location input_fn = do   use (T_As use_cpp pipe_env hsc_env location input_fn) 

@@ -128,9 +128,9 @@   let dflags = hsc_dflags hsc_env   let next_phase = hscPostBackendPhase HsSrcFile (backend dflags)   output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env Nothing-  mstub <- hscCompileCmmFile hsc_env input_fn output_fn+  mstub <- hscCompileCmmFile hsc_env (src_filename pipe_env) input_fn output_fn   stub_o <- mapM (compileStub hsc_env) mstub-  let foreign_os = (maybeToList stub_o)+  let foreign_os = maybeToList stub_o   return (foreign_os, output_fn)  runPhase (T_Cc phase pipe_env hsc_env input_fn) = runCcPhase phase pipe_env hsc_env input_fn@@ -571,15 +571,15 @@      return output_fn -getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, [Warn]))+getFileArgs :: HscEnv -> FilePath -> IO ((DynFlags, Messages PsMessage, [Warn])) getFileArgs hsc_env input_fn = do   let dflags0 = hsc_dflags hsc_env       parser_opts = initParserOpts dflags0-  src_opts <- getOptionsFromFile parser_opts input_fn+  (warns0, src_opts) <- getOptionsFromFile parser_opts input_fn   (dflags1, unhandled_flags, warns)     <- parseDynamicFilePragma dflags0 src_opts   checkProcessArgsResult unhandled_flags-  return (dflags1, warns)+  return (dflags1, warns0, warns)  runCppPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath runCppPhase hsc_env input_fn output_fn = do@@ -996,7 +996,7 @@      -- MIN_VERSION macros     let uids = explicitUnits unit_state-        pkgs = catMaybes (map (lookupUnit unit_state) uids)+        pkgs = mapMaybe (lookupUnit unit_state . fst) uids     mb_macro_include <-         if not (null pkgs) && gopt Opt_VersionMacros dflags             then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h"@@ -1089,16 +1089,47 @@    suggests, this tells the linker to produce a bigobj-enabled COFF object, no a    PE executable. -We must enable bigobj output in a few places:+Previously when we used ld.bfd we had to enable bigobj output in a few places:   * When merging object files (GHC.Driver.Pipeline.Execute.joinObjectFiles)   * When assembling (GHC.Driver.Pipeline.runPhase (RealPhase As ...)) +However, this is no longer necessary with ld.lld, which detects that the+object is large on its own.+ Unfortunately the big object format is not supported on 32-bit targets so none of this can be used in that case.  +Note [Object merging]+~~~~~~~~~~~~~~~~~~~~~+On most platforms one can "merge" a set of relocatable object files into a new,+partiall-linked-but-still-relocatable object. In a typical UNIX-style linker,+this is accomplished with the `ld -r` command. We rely on this for two ends:++ * We rely on `ld -r` to squash together split sections, making GHCi loading+   more efficient. See Note [Merging object files for GHCi].++ * We use merging to combine a module's object code (e.g. produced by the NCG)+   with its foreign stubs (typically produced by a C compiler).++The command used for object linking is set using the -pgmlm and -optlm+command-line options.++Sadly, the LLD linker that we use on Windows does not support the `-r` flag+needed to support object merging (see #21068). For this reason on Windows we do+not support GHCi objects.  To deal with foreign stubs we build a static archive+of all of a module's object files instead merging them. Consequently, we can+end up producing `.o` files which are in fact static archives. However,+toolchains generally don't have a problem with this as they use file headers,+not the filename, to determine the nature of inputs.++Note that this has somewhat non-obvious consequences when producing+initializers and finalizers. See Note [Initializers and finalizers in Cmm]+in GHC.Cmm.InitFini for details.++ Note [Merging object files for GHCi] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHCi can usually loads standard linkable object files using GHC's linker@@ -1113,11 +1144,12 @@ gcc tends to do unpredictable things to our linker command line, we opt to invoke ld directly in this case, in contrast to our usual strategy of linking via gcc.- -} +-- | See Note [Object merging]. joinObjectFiles :: HscEnv -> [FilePath] -> FilePath -> IO ()-joinObjectFiles hsc_env o_files output_fn = do+joinObjectFiles hsc_env o_files output_fn+  | can_merge_objs = do   let toolSettings' = toolSettings dflags       ldIsGnuLd = toolSettings_ldIsGnuLd toolSettings'       ld_r args = GHC.SysTools.runMergeObjects (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (hsc_dflags hsc_env) (@@ -1147,7 +1179,14 @@                 GHC.SysTools.FileOption "" filelist]      else           ld_r (map (GHC.SysTools.FileOption "") o_files)++  | otherwise = do+  withAtomicRename output_fn $ \tmp_ar ->+      liftIO $ runAr logger dflags Nothing $ map Option $ ["qc" ++ dashL, tmp_ar] ++ o_files   where+    dashLSupported = sArSupportsDashL (settings dflags)+    dashL = if dashLSupported then "L" else ""+    can_merge_objs = isJust (pgm_lm (hsc_dflags hsc_env))     dflags = hsc_dflags hsc_env     tmpfs = hsc_tmpfs hsc_env     logger = hsc_logger hsc_env

@@ -99,7 +99,7 @@ hsExprType (HsOverLit _ lit) = overLitType lit hsExprType (HsLit _ lit) = hsLitType lit hsExprType (HsLam     _ (MG { mg_ext = match_group })) = matchGroupTcType match_group-hsExprType (HsLamCase _ (MG { mg_ext = match_group })) = matchGroupTcType match_group+hsExprType (HsLamCase _ _ (MG { mg_ext = match_group })) = matchGroupTcType match_group hsExprType (HsApp _ f _) = funResultTy $ lhsExprType f hsExprType (HsAppType x f _) = piResultTy (lhsExprType f) x hsExprType (OpApp v _ _ _) = dataConCantHappen v

@@ -1,5 +1,6 @@- {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE TupleSections #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -50,7 +51,9 @@ import GHC.Types.Var.Set import GHC.Types.SrcLoc import GHC.Data.List.SetOps( assocMaybe )+import Data.Foldable (toList) import Data.List (mapAccumL)+import Data.List.NonEmpty (NonEmpty(..), nonEmpty) import GHC.Utils.Misc import GHC.Types.Unique.DSet @@ -466,6 +469,8 @@         fvs_cond `unionDVarSet` fvs_then `unionDVarSet` fvs_else)  {-+Note [Desugaring HsCmdCase]+~~~~~~~~~~~~~~~~~~~~~~~~~~~ Case commands are treated in much the same way as if commands (see above) except that there are more alternatives.  For example @@ -492,74 +497,87 @@    bodies with |||. -} +dsCmd ids local_vars stack_ty res_ty (HsCmdCase _ exp match) env_ids = do+    stack_id <- newSysLocalDs Many stack_ty+    (match', core_choices)+      <- dsCases ids local_vars stack_id stack_ty res_ty match+    let MG{ mg_ext = MatchGroupTc _ sum_ty } = match'+        in_ty = envStackType env_ids stack_ty++    core_body <- dsExpr (HsCase noExtField exp match')++    core_matches <- matchEnvStack env_ids stack_id core_body+    return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,+            exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars)++{-+\cases and \case are desugared analogously to a case command (see above).+For example++        \cases {p1 q1 -> c1; p2 q2 -> c2; p3 q3 -> c3 }++is translated to++        premap (\ ((xs), (e1, (e2,stk))) -> cases e1 e2 of+                  p1 q1 -> (Left (Left (xs1), stk))+                  p2 q2 -> Left ((Right (xs2), stk))+                  p3 q3 -> Right ((xs3), stk))+        ((c1 ||| c2) ||| c3)++(cases...of is hypothetical notation that works like case...of but with+multiple scrutinees)++-} dsCmd ids local_vars stack_ty res_ty-      (HsCmdCase _ exp (MG { mg_alts = L l matches-                           , mg_ext = MatchGroupTc arg_tys _-                           , mg_origin = origin }))+      (HsCmdLamCase _ lc_variant match@MG { mg_ext = MatchGroupTc {mg_arg_tys = arg_tys} } )       env_ids = do-    stack_id <- newSysLocalDs Many stack_ty+    arg_ids <- newSysLocalsDs arg_tys -    -- Extract and desugar the leaf commands in the case, building tuple-    -- expressions that will (after tagging) replace these leaves+    let match_ctxt = ArrowLamCaseAlt lc_variant+        pat_vars = mkVarSet arg_ids+        local_vars' = pat_vars `unionVarSet` local_vars+        (pat_tys, stack_ty') = splitTypeAt (length arg_tys) stack_ty -    let-        leaves = concatMap leavesMatch matches-        make_branch (leaf, bound_vars) = do-            (core_leaf, _fvs, leaf_ids)-               <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty-                    res_ty leaf-            return ([mkHsEnvStackExpr leaf_ids stack_id],-                    envStackType leaf_ids stack_ty,-                    core_leaf)+    -- construct and desugar a case expression with multiple scrutinees+    (core_body, free_vars, env_ids') <- trimInput \env_ids -> do+      stack_id <- newSysLocalDs Many stack_ty'+      (match', core_choices)+        <- dsCases ids local_vars' stack_id stack_ty' res_ty match -    branches <- mapM make_branch leaves-    either_con <- dsLookupTyCon eitherTyConName-    left_con <- dsLookupDataCon leftDataConName-    right_con <- dsLookupDataCon rightDataConName-    let-        left_id  = mkConLikeTc (RealDataCon left_con)-        right_id = mkConLikeTc (RealDataCon right_con)-        left_expr  ty1 ty2 e = noLocA $ HsApp noComments-                           (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e-        right_expr ty1 ty2 e = noLocA $ HsApp noComments-                           (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e+      let MG{ mg_ext = MatchGroupTc _ sum_ty } = match'+          in_ty = envStackType env_ids stack_ty'+          discrims = map nlHsVar arg_ids+      (discrim_vars, matching_code)+        <- matchWrapper (ArrowMatchCtxt match_ctxt) (Just discrims) match'+      core_body <- flip (bind_vars discrim_vars) matching_code <$>+        traverse dsLExpr discrims -        -- Prefix each tuple with a distinct series of Left's and Right's,-        -- in a balanced way, keeping track of the types.+      core_matches <- matchEnvStack env_ids stack_id core_body+      return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,+              exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars') -        merge_branches :: ([LHsExpr GhcTc], Type, CoreExpr)-                      -> ([LHsExpr GhcTc], Type, CoreExpr)-                      -> ([LHsExpr GhcTc], Type, CoreExpr) -- AZ-        merge_branches (builds1, in_ty1, core_exp1)-                       (builds2, in_ty2, core_exp2)-          = (map (left_expr in_ty1 in_ty2) builds1 ++-                map (right_expr in_ty1 in_ty2) builds2,-             mkTyConApp either_con [in_ty1, in_ty2],-             do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)-        (leaves', sum_ty, core_choices) = foldb merge_branches branches+    param_ids <- mapM (newSysLocalDs Many) pat_tys+    stack_id' <- newSysLocalDs Many stack_ty' -        -- Replace the commands in the case with these tagged tuples,-        -- yielding a HsExpr Id we can feed to dsExpr.+    -- the expression is built from the inside out, so the actions+    -- are presented in reverse order -        (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches+    let -- build a new environment, plus what's left of the stack+        core_expr = buildEnvStack env_ids' stack_id'         in_ty = envStackType env_ids stack_ty--    core_body <- dsExpr (HsCase noExtField exp-                         (MG { mg_alts = L l matches'-                             , mg_ext = MatchGroupTc arg_tys sum_ty-                             , mg_origin = origin }))-        -- Note that we replace the HsCase result type by sum_ty,-        -- which is the type of matches'+        in_ty' = envStackType env_ids' stack_ty' -    core_matches <- matchEnvStack env_ids stack_id core_body-    return (do_premap ids in_ty sum_ty res_ty core_matches core_choices,-            exprFreeIdsDSet core_body `uniqDSetIntersectUniqSet` local_vars)+    -- bind the scrutinees to the parameters+    let match_code = bind_vars arg_ids (map Var param_ids) core_expr -dsCmd ids local_vars stack_ty res_ty-      (HsCmdLamCase _ mg@MG { mg_ext = MatchGroupTc [Scaled arg_mult arg_ty] _ }) env_ids = do-  arg_id <- newSysLocalDs arg_mult arg_ty-  let case_cmd  = noLocA $ HsCmdCase noExtField (nlHsVar arg_id) mg-  dsCmdLam ids local_vars stack_ty res_ty [nlVarPat arg_id] case_cmd env_ids+    -- match the parameters against the top of the old stack+    (stack_id, param_code) <- matchVarStack param_ids stack_id' match_code+    -- match the old environment and stack against the input+    select_code <- matchEnvStack env_ids stack_id param_code+    return (do_premap ids in_ty in_ty' res_ty select_code core_body,+            free_vars `uniqDSetMinusUniqSet` pat_vars)+    where+      bind_vars vars exprs expr = foldr (uncurry bindNonRec) expr $ zip vars exprs  -- D; ys |-a cmd : stk --> t -- ----------------------------------@@ -680,7 +698,7 @@         (core_cmd, free_vars) <- build_arrow env_ids         return (core_cmd, free_vars, dVarSetElems free_vars)) --- Desugaring for both HsCmdLam and HsCmdLamCase.+-- Desugaring for both HsCmdLam -- -- D; ys |-a cmd : stk t' -- -----------------------------------------------@@ -726,6 +744,82 @@     return (do_premap ids in_ty in_ty' res_ty select_code core_body,             free_vars `uniqDSetMinusUniqSet` pat_vars) +-- Used for case and \case(s)+-- See Note [Desugaring HsCmdCase]+dsCases :: DsCmdEnv                               -- arrow combinators+        -> IdSet                                  -- set of local vars available to this command+        -> Id                                     -- stack id+        -> Type                                   -- type of the stack (right-nested tuple)+        -> Type                                   -- return type of the command+        -> MatchGroup GhcTc (LHsCmd GhcTc)        -- match group to desugar+        -> DsM (MatchGroup GhcTc (LHsExpr GhcTc), -- match group with choice tree+                CoreExpr)                         -- desugared choices+dsCases ids local_vars stack_id stack_ty res_ty+        (MG { mg_alts = L l matches+            , mg_ext = MatchGroupTc arg_tys _+            , mg_origin = origin }) = do++  -- Extract and desugar the leaf commands in the case, building tuple+  -- expressions that will (after tagging) replace these leaves++  let leaves = concatMap leavesMatch matches+      make_branch (leaf, bound_vars) = do+          (core_leaf, _fvs, leaf_ids)+             <- dsfixCmd ids (bound_vars `unionVarSet` local_vars) stack_ty+                  res_ty leaf+          return ([mkHsEnvStackExpr leaf_ids stack_id],+                  envStackType leaf_ids stack_ty,+                  core_leaf)++  branches <- mapM make_branch leaves+  either_con <- dsLookupTyCon eitherTyConName+  left_con <- dsLookupDataCon leftDataConName+  right_con <- dsLookupDataCon rightDataConName+  void_ty <- mkTyConTy <$> dsLookupTyCon voidTyConName+  let+      left_id  = mkConLikeTc (RealDataCon left_con)+      right_id = mkConLikeTc (RealDataCon right_con)+      left_expr  ty1 ty2 e = noLocA $ HsApp noComments+                         (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) left_id ) e+      right_expr ty1 ty2 e = noLocA $ HsApp noComments+                         (noLocA $ mkHsWrap (mkWpTyApps [ty1, ty2]) right_id) e++      -- Prefix each tuple with a distinct series of Left's and Right's,+      -- in a balanced way, keeping track of the types.++      merge_branches :: ([LHsExpr GhcTc], Type, CoreExpr)+                    -> ([LHsExpr GhcTc], Type, CoreExpr)+                    -> ([LHsExpr GhcTc], Type, CoreExpr) -- AZ+      merge_branches (builds1, in_ty1, core_exp1)+                     (builds2, in_ty2, core_exp2)+        = (map (left_expr in_ty1 in_ty2) builds1 +++              map (right_expr in_ty1 in_ty2) builds2,+           mkTyConApp either_con [in_ty1, in_ty2],+           do_choice ids in_ty1 in_ty2 res_ty core_exp1 core_exp2)+  (leaves', sum_ty, core_choices) <- case nonEmpty branches of+    Just bs -> return $ foldb merge_branches bs+    -- when the case command has no alternatives, the sum type from+    -- Note [Desugaring HsCmdCase] becomes the empty sum type,+    -- i.e. Void. The choices then effectively become `arr absurd`,+    -- implemented as `arr \case {}`.+    Nothing -> ([], void_ty,) . do_arr ids void_ty res_ty <$>+      dsExpr (HsLamCase EpAnnNotUsed LamCase+        (MG { mg_alts = noLocA []+            , mg_ext = MatchGroupTc [Scaled Many void_ty] res_ty+            , mg_origin = Generated }))++      -- Replace the commands in the case with these tagged tuples,+      -- yielding a HsExpr Id we can feed to dsExpr.++  let (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches++  -- Note that we replace the MatchGroup result type by sum_ty,+  -- which is the type of matches'+  return (MG { mg_alts = L l matches'+             , mg_ext = MatchGroupTc arg_tys sum_ty+             , mg_origin = origin },+          core_choices)+ {- Translation of command judgements of the form @@ -1151,11 +1245,12 @@  -- Balanced fold of a non-empty list. -foldb :: (a -> a -> a) -> [a] -> a-foldb _ [] = error "foldb of empty list"-foldb _ [x] = x+foldb :: (a -> a -> a) -> NonEmpty a -> a+foldb _ (x:|[]) = x foldb f xs = foldb f (fold_pairs xs)   where-    fold_pairs [] = []-    fold_pairs [x] = [x]-    fold_pairs (x1:x2:xs) = f x1 x2:fold_pairs xs+    fold_pairs (x1:|x2:xs) = f x1 x2 :| keep_empty fold_pairs xs+    fold_pairs xs          = xs++    keep_empty :: (NonEmpty a -> NonEmpty a) -> [a] -> [a]+    keep_empty f = maybe [] (toList . f) . nonEmpty

@@ -164,9 +164,7 @@                           -- addTyCs: Add type evidence to the refinement type                           --            predicate of the coverage checker                           -- See Note [Long-distance information] in "GHC.HsToCore.Pmc"-                          matchWrapper-                           (mkPrefixFunRhs (L loc (idName fun)))-                           Nothing matches+                          matchWrapper (mkPrefixFunRhs (L loc (idName fun))) Nothing matches          ; core_wrap <- dsHsWrapper co_fn         ; let body' = mkOptTickBox tick body

@@ -536,19 +536,19 @@ addTickHsExpr e@(HsUnboundVar {})   = return e addTickHsExpr e@(HsRecSel _ (FieldOcc id _))   = do freeVar id; return e -addTickHsExpr e@(HsIPVar {})     = return e-addTickHsExpr e@(HsOverLit {})   = return e-addTickHsExpr e@(HsOverLabel{})  = return e-addTickHsExpr e@(HsLit {})       = return e-addTickHsExpr (HsLam x mg)       = liftM (HsLam x)-                                         (addTickMatchGroup True mg)-addTickHsExpr (HsLamCase x mgs)  = liftM (HsLamCase x)-                                         (addTickMatchGroup True mgs)-addTickHsExpr (HsApp x e1 e2)    = liftM2 (HsApp x) (addTickLHsExprNever e1)-                                                    (addTickLHsExpr      e2)-addTickHsExpr (HsAppType x e ty) = liftM3 HsAppType (return x)-                                                    (addTickLHsExprNever e)-                                                    (return ty)+addTickHsExpr e@(HsIPVar {})            = return e+addTickHsExpr e@(HsOverLit {})          = return e+addTickHsExpr e@(HsOverLabel{})         = return e+addTickHsExpr e@(HsLit {})              = return e+addTickHsExpr (HsLam x mg)              = liftM (HsLam x)+                                                (addTickMatchGroup True mg)+addTickHsExpr (HsLamCase x lc_variant mgs) = liftM (HsLamCase x lc_variant)+                                                   (addTickMatchGroup True mgs)+addTickHsExpr (HsApp x e1 e2)          = liftM2 (HsApp x) (addTickLHsExprNever e1)+                                                          (addTickLHsExpr      e2)+addTickHsExpr (HsAppType x e ty)       = liftM3 HsAppType (return x)+                                                          (addTickLHsExprNever e)+                                                          (return ty) addTickHsExpr (OpApp fix e1 e2 e3) =         liftM4 OpApp                 (return fix)@@ -891,8 +891,8 @@         liftM2 (HsCmdCase x)                 (addTickLHsExpr e)                 (addTickCmdMatchGroup mgs)-addTickHsCmd (HsCmdLamCase x mgs) =-        liftM (HsCmdLamCase x) (addTickCmdMatchGroup mgs)+addTickHsCmd (HsCmdLamCase x lc_variant mgs) =+        liftM (HsCmdLamCase x lc_variant) (addTickCmdMatchGroup mgs) addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =         liftM3 (HsCmdIf x cnd)                 (addBinTickLHsExpr (BinBox CondBinBox) e1)

@@ -195,8 +195,7 @@                         , fun_tick = tick }) body                -- Can't be a bang pattern (that looks like a PatBind)                -- so must be simply unboxed-  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))-                                     Nothing matches+  = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun)) Nothing matches        ; massert (null args) -- Functions aren't lifted        ; massert (isIdHsWrapper co_fn)        ; let rhs' = mkOptTickBox tick rhs@@ -300,11 +299,10 @@        ; dsSyntaxExpr neg_expr [expr'] }  dsExpr (HsLam _ a_Match)-  = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match+  = uncurry mkCoreLams <$> matchWrapper LambdaExpr Nothing a_Match -dsExpr (HsLamCase _ matches)-  = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches-       ; return $ Lam discrim_var matching_code }+dsExpr (HsLamCase _ lc_variant matches)+  = uncurry mkCoreLams <$> matchWrapper (LamCaseAlt lc_variant) Nothing matches  dsExpr e@(HsApp _ fun arg)   = do { fun' <- dsLExpr fun@@ -356,7 +354,7 @@  dsExpr (HsCase _ discrim matches)   = do { core_discrim <- dsLExpr discrim-       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches+       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just [discrim]) matches        ; return (bindNonRec discrim_var core_discrim matching_code) }  -- Pepe: The binds are in scope in the body but NOT in the binding group@@ -606,7 +604,7 @@         -- constructor arguments.         ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd         ; ([discrim_var], matching_code)-                <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates]+                <- matchWrapper RecUpd (Just [record_expr]) -- See Note [Scrutinee in Record updates]                                       (MG { mg_alts = noLocA alts                                           , mg_ext = MatchGroupTc [unrestricted in_ty] out_ty                                           , mg_origin = FromSource@@ -767,7 +765,7 @@ ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr ds_prag_expr (HsPragSCC _ _ cc) expr = do     dflags <- getDynFlags-    if sccProfilingEnabled dflags+    if sccProfilingEnabled dflags && gopt Opt_ProfManualCcs dflags       then do         mod_name <- getModule         count <- goptM Opt_ProfCountEntries@@ -1035,11 +1033,11 @@   | otherwise   = pprPanic "dsConLike" (ppr ps) -dsConLike :: ConLike -> [TcInvisTVBinder] -> [Scaled Type] -> DsM CoreExpr+dsConLike :: ConLike -> [TcTyVar] -> [Scaled Type] -> DsM CoreExpr -- This function desugars ConLikeTc -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head --     for what is going on here-dsConLike con tvbs tys+dsConLike con tvs tys   = do { ds_con <- dsHsConLike con        ; ids    <- newSysLocalsDs tys                    -- newSysLocalDs: /can/ be lev-poly; see@@ -1048,7 +1046,6 @@                  ds_con `mkTyApps` mkTyVarTys tvs                         `mkVarApps` drop_stupid ids) }   where-    tvs = binderVars tvbs      drop_stupid = dropList (conLikeStupidTheta con)     -- drop_stupid: see Note [Instantiating stupid theta]

@@ -708,15 +708,32 @@ \end{enumerate} -} +-- Note [matchWrapper scrutinees]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+-- There are three possible cases for matchWrapper's scrutinees argument:+--+-- 1. Nothing   Used for FunBind, HsLam, HsLamcase, where there is no explicit scrutinee+--              The MatchGroup may have matchGroupArity of 0 or more. Examples:+--                  f p1 q1 = ... -- matchGroupArity 2+--                  f p2 q2 = ...+--+--                  \cases | g1 -> ... -- matchGroupArity 0+--                         | g2 -> ...+--+-- 2. Just [e]  Used for HsCase, RecordUpd; exactly one scrutinee+--              The MatchGroup has matchGroupArity of exactly 1. Example:+--                  case e of p1 -> e1 -- matchGroupArity 1+--                            p2 -> e2+--+-- 3. Just es   Used for HsCmdLamCase; zero or more scrutinees+--              The MatchGroup has matchGroupArity of (length es). Example:+--                  \cases p1 q1 -> returnA -< ... -- matchGroupArity 2+--                         p2 q2 -> ...+ matchWrapper   :: HsMatchContext GhcRn              -- ^ For shadowing warning messages-  -> Maybe (LHsExpr GhcTc)             -- ^ Scrutinee. (Just scrut) for a case expr-                                       --      case scrut of { p1 -> e1 ... }-                                       --   (and in this case the MatchGroup will-                                       --    have all singleton patterns)-                                       --   Nothing for a function definition-                                       --      f p1 q1 = ...  -- No "scrutinee"-                                       --      f p2 q2 = ...  -- in this case+  -> Maybe [LHsExpr GhcTc]             -- ^ Scrutinee(s)+                                       -- see Note [matchWrapper scrutinees]   -> MatchGroup GhcTc (LHsExpr GhcTc)  -- ^ Matches being desugared   -> DsM ([Id], CoreExpr)              -- ^ Results (usually passed to 'match') @@ -744,7 +761,7 @@ JJQC 30-Nov-1997 -} -matchWrapper ctxt mb_scr (MG { mg_alts = L _ matches+matchWrapper ctxt scrs (MG { mg_alts = L _ matches                              , mg_ext = MatchGroupTc arg_tys rhs_ty                              , mg_origin = origin })   = do  { dflags <- getDynFlags@@ -762,7 +779,7 @@         -- @rhss_nablas@ is a flat list of covered Nablas for each RHS.         -- Each Match will split off one Nablas for its RHSs from this.         ; matches_nablas <- if isMatchContextPmChecked dflags origin ctxt-            then addHsScrutTmCs mb_scr new_vars $+            then addHsScrutTmCs (concat scrs) new_vars $                  -- See Note [Long-distance information]                  pmcMatches (DsMatchContext ctxt locn) new_vars matches             else pure (initNablasMatches matches)@@ -872,7 +889,7 @@        ; locn   <- getSrcSpanDs        -- Pattern match check warnings        ; when (isMatchContextPmChecked dflags FromSource ctx) $-           addCoreScrutTmCs mb_scrut [var] $+           addCoreScrutTmCs (maybeToList mb_scrut) [var] $            pmcPatBind (DsMatchContext ctx locn) var (unLoc pat)         ; let eqn_info = EqnInfo { eqn_pats = [unLoc (decideBangHood dflags pat)]

@@ -15,7 +15,7 @@  matchWrapper         :: HsMatchContext GhcRn-        -> Maybe (LHsExpr GhcTc)+        -> Maybe [LHsExpr GhcTc]         -> MatchGroup GhcTc (LHsExpr GhcTc)         -> DsM ([Id], CoreExpr) 

@@ -419,24 +419,25 @@               addPhiCtsNablas nablas (PhiTyCt . evVarPred <$> ev_vars))             m --- | Add equalities for the 'CoreExpr' scrutinee to the local 'DsM' environment--- when checking a case expression:+-- | Add equalities for the 'CoreExpr' scrutinees to the local 'DsM' environment,+-- e.g. when checking a case expression: --     case e of x { matches } -- When checking matches we record that (x ~ e) where x is the initial -- uncovered. All matches will have to satisfy this equality.-addCoreScrutTmCs :: Maybe CoreExpr -> [Id] -> DsM a -> DsM a-addCoreScrutTmCs Nothing    _   k = k-addCoreScrutTmCs (Just scr) [x] k =-  flip locallyExtendPmNablas k $ \nablas ->+-- This is also used for the Arrows \cases command, where these equalities have+-- to be added for multiple scrutinees rather than just one.+addCoreScrutTmCs :: [CoreExpr] -> [Id] -> DsM a -> DsM a+addCoreScrutTmCs []         _      k = k+addCoreScrutTmCs (scr:scrs) (x:xs) k =+  flip locallyExtendPmNablas (addCoreScrutTmCs scrs xs k) $ \nablas ->     addPhiCtsNablas nablas (unitBag (PhiCoreCt x scr))-addCoreScrutTmCs _   _   _ = panic "addCoreScrutTmCs: scrutinee, but more than one match id"+addCoreScrutTmCs _   _   _ = panic "addCoreScrutTmCs: numbers of scrutinees and match ids differ" --- | 'addCoreScrutTmCs', but desugars the 'LHsExpr' first.-addHsScrutTmCs :: Maybe (LHsExpr GhcTc) -> [Id] -> DsM a -> DsM a-addHsScrutTmCs Nothing    _    k = k-addHsScrutTmCs (Just scr) vars k = do-  scr_e <- dsLExpr scr-  addCoreScrutTmCs (Just scr_e) vars k+-- | 'addCoreScrutTmCs', but desugars the 'LHsExpr's first.+addHsScrutTmCs :: [LHsExpr GhcTc] -> [Id] -> DsM a -> DsM a+addHsScrutTmCs scrs vars k = do+  scr_es <- traverse dsLExpr scrs+  addCoreScrutTmCs scr_es vars k  {- Note [Long-distance information] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -82,26 +82,28 @@ -- via which 'WarningFlag' it's controlled. -- Returns 'Nothing' if check is not supported. exhaustiveWarningFlag :: HsMatchContext id -> Maybe WarningFlag-exhaustiveWarningFlag (FunRhs {})   = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag CaseAlt       = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag IfAlt         = Just Opt_WarnIncompletePatterns-exhaustiveWarningFlag LambdaExpr    = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag PatBindRhs    = Just Opt_WarnIncompleteUniPatterns-exhaustiveWarningFlag PatBindGuards = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag FunRhs{}           = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag CaseAlt            = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag LamCaseAlt{}       = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag IfAlt              = Just Opt_WarnIncompletePatterns+exhaustiveWarningFlag LambdaExpr         = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag PatBindRhs         = Just Opt_WarnIncompleteUniPatterns+exhaustiveWarningFlag PatBindGuards      = Just Opt_WarnIncompletePatterns exhaustiveWarningFlag (ArrowMatchCtxt c) = arrowMatchContextExhaustiveWarningFlag c-exhaustiveWarningFlag RecUpd        = Just Opt_WarnIncompletePatternsRecUpd-exhaustiveWarningFlag ThPatSplice   = Nothing-exhaustiveWarningFlag PatSyn        = Nothing-exhaustiveWarningFlag ThPatQuote    = Nothing+exhaustiveWarningFlag RecUpd             = Just Opt_WarnIncompletePatternsRecUpd+exhaustiveWarningFlag ThPatSplice        = Nothing+exhaustiveWarningFlag PatSyn             = Nothing+exhaustiveWarningFlag ThPatQuote         = Nothing -- Don't warn about incomplete patterns in list comprehensions, pattern guards -- etc. They are often *supposed* to be incomplete-exhaustiveWarningFlag (StmtCtxt {}) = Nothing+exhaustiveWarningFlag StmtCtxt{}         = Nothing  arrowMatchContextExhaustiveWarningFlag :: HsArrowMatchContext -> Maybe WarningFlag arrowMatchContextExhaustiveWarningFlag = \ case-  ProcExpr     -> Just Opt_WarnIncompleteUniPatterns-  ArrowCaseAlt -> Just Opt_WarnIncompletePatterns-  KappaExpr    -> Just Opt_WarnIncompleteUniPatterns+  ProcExpr          -> Just Opt_WarnIncompleteUniPatterns+  ArrowCaseAlt      -> Just Opt_WarnIncompletePatterns+  ArrowLamCaseAlt _ -> Just Opt_WarnIncompletePatterns+  KappaExpr         -> Just Opt_WarnIncompleteUniPatterns  -- | Check whether any part of pattern match checking is enabled for this -- 'HsMatchContext' (does not matter whether it is the redundancy check or the

@@ -1394,7 +1394,7 @@ repTy (HsSumTy _ tys)       = do tys1 <- repLTys tys                                  tcon <- repUnboxedSumTyCon (length tys)                                  repTapps tcon tys1-repTy (HsOpTy _ ty1 n ty2)  = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1)+repTy (HsOpTy _ prom ty1 n ty2) = repLTy ((nlHsTyVar prom (unLoc n) `nlHsAppTy` ty1)                                    `nlHsAppTy` ty2) repTy (HsParTy _ t)         = repLTy t repTy (HsStarTy _ _) =  repTStar@@ -1499,10 +1499,14 @@ repE (HsLit _ l)     = do { a <- repLiteral l;           repLit a } repE (HsLam _ (MG { mg_alts = (L _ [m]) })) = repLambda m repE e@(HsLam _ (MG { mg_alts = (L _ _) })) = pprPanic "repE: HsLam with multiple alternatives" (ppr e)-repE (HsLamCase _ (MG { mg_alts = (L _ ms) }))+repE (HsLamCase _ LamCase (MG { mg_alts = (L _ ms) }))                    = do { ms' <- mapM repMatchTup ms                         ; core_ms <- coreListM matchTyConName ms'                         ; repLamCase core_ms }+repE (HsLamCase _ LamCases (MG { mg_alts = (L _ ms) }))+                   = do { ms' <- mapM repClauseTup ms+                        ; core_ms <- coreListM matchTyConName ms'+                        ; repLamCases core_ms } repE (HsApp _ x y)   = do {a <- repLE x; b <- repLE y; repApp a b} repE (HsAppType _ e t) = do { a <- repLE e                             ; s <- repLTy (hswc_body t)@@ -2358,6 +2362,9 @@  repLamCase :: Core [(M TH.Match)] -> MetaM (Core (M TH.Exp)) repLamCase (MkC ms) = rep2 lamCaseEName [ms]++repLamCases :: Core [(M TH.Clause)] -> MetaM (Core (M TH.Exp))+repLamCases (MkC ms) = rep2 lamCasesEName [ms]  repTup :: Core [Maybe (M TH.Exp)] -> MetaM (Core (M TH.Exp)) repTup (MkC es) = rep2 tupEName [es]

@@ -1,4 +1,3 @@- {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-}@@ -472,14 +471,12 @@     Consider,        f x y = x `seq` (y `seq` (# x,y #)) -    The [Core let/app invariant] means that, other things being equal, because-    the argument to the outer 'seq' has an unlifted type, we'll use call-by-value thus:+    Because the argument to the outer 'seq' has an unlifted type, we'll use+    call-by-value, and compile it as if we had         f x y = case (y `seq` (# x,y #)) of v -> x `seq` v -    But that is bad for two reasons:-      (a) we now evaluate y before x, and-      (b) we can't bind v to an unboxed pair+    But that is bad, because we now evaluate y before x!      Seq is very, very special!  So we recognise it right here, and desugar to             case x of _ -> case y of _ -> (# x,y #)

@@ -1094,7 +1094,7 @@       HsLam _ mg ->         [ toHie mg         ]-      HsLamCase _ mg ->+      HsLamCase _ _ mg ->         [ toHie mg         ]       HsApp _ a b ->@@ -1415,7 +1415,7 @@         [ toHie expr         , toHie alts         ]-      HsCmdLamCase _ alts ->+      HsCmdLamCase _ _ alts ->         [ toHie alts         ]       HsCmdIf _ _ a b c ->@@ -1768,7 +1768,7 @@       HsSumTy _ tys ->         [ toHie tys         ]-      HsOpTy _ a op b ->+      HsOpTy _ _prom a op b ->         [ toHie a         , toHie $ C Use op         , toHie b

@@ -1662,7 +1662,6 @@     tcPrag info (HsDmdSig str)     = return (info `setDmdSigInfo` str)     tcPrag info (HsCprSig cpr)     = return (info `setCprSigInfo` cpr)     tcPrag info (HsInline prag)    = return (info `setInlinePragInfo` prag)-    tcPrag info HsLevity           = return (info `setNeverRepPoly` ty)     tcPrag info (HsLFInfo lf_info) = do       lf_info <- tcLFInfo lf_info       return (info `setLFInfo` lf_info)

@@ -622,12 +622,16 @@   checkNonStdWay :: DynFlags -> Interp -> SrcSpan -> IO (Maybe FilePath)-checkNonStdWay dflags interp srcspan+checkNonStdWay _dflags interp _srcspan   | ExternalInterp {} <- interpInstance interp = return Nothing     -- with -fexternal-interpreter we load the .o files, whatever way     -- they were built.  If they were built for a non-std way, then     -- we will use the appropriate variant of the iserv binary to load them. +-- #if-guard the following equations otherwise the pattern match checker will+-- complain that they are redundant.+#if defined(HAVE_INTERNAL_INTERPRETER)+checkNonStdWay dflags _interp srcspan   | hostFullWays == targetFullWays = return Nothing     -- Only if we are compiling with the same ways as GHC is built     -- with, can we dynamically load those object files. (see #3604)@@ -642,8 +646,8 @@                   "" -> ""                   tag -> tag ++ "_" -normalObjectSuffix :: String-normalObjectSuffix = phaseInputExt StopLn+    normalObjectSuffix :: String+    normalObjectSuffix = phaseInputExt StopLn  data Way' = Normal | Prof | Dyn @@ -677,6 +681,7 @@             Normal -> "the normal way"             Prof -> "with -prof"             Dyn -> "with -dynamic"+#endif  getLinkDeps :: HscEnv             -> LoaderState

@@ -1,6 +1,5 @@ module GHC.Linker.Static    ( linkBinary-   , linkBinary'    , linkStaticLib    ) where@@ -65,15 +64,12 @@ -}  linkBinary :: Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()-linkBinary = linkBinary' False--linkBinary' :: Bool -> Logger -> TmpFs -> DynFlags -> UnitEnv -> [FilePath] -> [UnitId] -> IO ()-linkBinary' staticLink logger tmpfs dflags unit_env o_files dep_units = do+linkBinary logger tmpfs dflags unit_env o_files dep_units = do     let platform   = ue_platform unit_env         unit_state = ue_units unit_env         toolSettings' = toolSettings dflags         verbFlags = getVerbFlags dflags-        output_fn = exeFileName platform staticLink (outputFile_ dflags)+        output_fn = exeFileName platform False (outputFile_ dflags)      -- get the full list of packages to link with, by combining the     -- explicit packages with the auto packages and all of their@@ -153,13 +149,7 @@      pkg_link_opts <- do         (package_hs_libs, extra_libs, other_flags) <- getUnitLinkOpts dflags unit_env dep_units-        return $ if staticLink-            then package_hs_libs -- If building an executable really means making a static-                                 -- library (e.g. iOS), then we only keep the -l options for-                                 -- HS packages, because libtool doesn't accept other options.-                                 -- In the case of iOS these need to be added by hand to the-                                 -- final link in Xcode.-            else other_flags ++ dead_strip+        return $ other_flags ++ dead_strip                   ++ pre_hs_libs ++ package_hs_libs ++ post_hs_libs                   ++ extra_libs                  -- -Wl,-u,<sym> contained in other_flags@@ -184,8 +174,7 @@       OSMinGW32 | gopt Opt_GenManifest dflags -> maybeCreateManifest logger tmpfs dflags output_fn       _                                       -> return [] -    let link dflags args | staticLink = GHC.SysTools.runLibtool logger dflags args-                         | platformOS platform == OSDarwin+    let link dflags args | platformOS platform == OSDarwin                             = do                                  GHC.SysTools.runLink logger tmpfs dflags args                                  GHC.Linker.MacOS.runInjectRPaths logger dflags pkg_lib_paths output_fn@@ -220,7 +209,6 @@                       -- on x86.                       ++ (if not (gopt Opt_CompactUnwind dflags) &&                              toolSettings_ldSupportsCompactUnwind toolSettings' &&-                             not staticLink &&                              (platformOS platform == OSDarwin) &&                              case platformArch platform of                                ArchX86     -> True@@ -238,8 +226,7 @@                       -- whether this is something we ought to fix, but                       -- for now this flags silences them.                       ++ (if platformOS   platform == OSDarwin &&-                             platformArch platform == ArchX86 &&-                             not staticLink+                             platformArch platform == ArchX86                           then ["-Wl,-read_only_relocs,suppress"]                           else []) 

@@ -88,7 +88,7 @@ import GHC.Core.Utils import GHC.Core.Make import GHC.Core.FVs-import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst )+import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst, extendSubstInScopeSet )        -- These names are also exported by Type  import GHC.Core.Rules

@@ -1189,15 +1189,43 @@     , Outputable (body GhcPs)     ) +-- Note [Empty MatchGroups]+-- ~~~~~~~~~~~~~~~~~~~~~~~~+-- In some cases, MatchGroups are allowed to be empty. Firstly, the+-- prerequisite is that -XEmptyCase is enabled. Then you have an empty+-- MatchGroup resulting either from a case-expression:+--+--     case e of {}+--+-- or from a \case-expression:+--+--     \case {}+--+-- NB: \cases {} is not allowed, since it's not clear how many patterns this+-- should match on.+--+-- The same applies in arrow notation commands: With -XEmptyCases, it is+-- allowed in case- and \case-commands, but not \cases.+--+-- Since the lambda expressions and empty function definitions are already+-- disallowed elsewhere, here, we only need to make sure we don't accept empty+-- \cases expressions or commands. In that case, or if we encounter an empty+-- MatchGroup but -XEmptyCases is disabled, we add an error.+ rnMatchGroup :: (Outputable (body GhcPs), AnnoBody body) => HsMatchContext GhcRn              -> (LocatedA (body GhcPs) -> RnM (LocatedA (body GhcRn), FreeVars))              -> MatchGroup GhcPs (LocatedA (body GhcPs))              -> RnM (MatchGroup GhcRn (LocatedA (body GhcRn)), FreeVars) rnMatchGroup ctxt rnBody (MG { mg_alts = L lm ms, mg_origin = origin })-  = do { empty_case_ok <- xoptM LangExt.EmptyCase-       ; when (null ms && not empty_case_ok) (addErr (emptyCaseErr ctxt))+         -- see Note [Empty MatchGroups]+  = do { whenM ((null ms &&) <$> mustn't_be_empty) (addErr (emptyCaseErr ctxt))        ; (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt rnBody) ms        ; return (mkMatchGroup origin (L lm new_ms), ms_fvs) }+  where+    mustn't_be_empty = case ctxt of+      LamCaseAlt LamCases -> return True+      ArrowMatchCtxt (ArrowLamCaseAlt LamCases) -> return True+      _ -> not <$> xoptM LangExt.EmptyCase  rnMatch :: AnnoBody body         => HsMatchContext GhcRn@@ -1222,17 +1250,28 @@                         , m_grhss = grhss'}, grhss_fvs ) }  emptyCaseErr :: HsMatchContext GhcRn -> TcRnMessage-emptyCaseErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $-  hang (text "Empty list of alternatives in" <+> pp_ctxt ctxt)-        2 (text "Use EmptyCase to allow this")+emptyCaseErr ctxt = TcRnUnknownMessage $ mkPlainError noHints $ message ctxt   where     pp_ctxt :: HsMatchContext GhcRn -> SDoc     pp_ctxt c = case c of-      CaseAlt       -> text "case expression"-      LambdaExpr    -> text "\\case expression"-      ArrowMatchCtxt ArrowCaseAlt -> text "case expression"-      ArrowMatchCtxt KappaExpr    -> text "kappa abstraction"-      _             -> text "(unexpected)" <+> pprMatchContextNoun c+      CaseAlt                                  -> text "case expression"+      LamCaseAlt LamCase                       -> text "\\case expression"+      ArrowMatchCtxt (ArrowLamCaseAlt LamCase) -> text "\\case command"+      ArrowMatchCtxt ArrowCaseAlt              -> text "case command"+      ArrowMatchCtxt KappaExpr                 -> text "kappa abstraction"+      _                                        -> text "(unexpected)"+                                                  <+> pprMatchContextNoun c++    message :: HsMatchContext GhcRn -> SDoc+    message (LamCaseAlt LamCases) = lcases_msg <+> text "expression"+    message (ArrowMatchCtxt (ArrowLamCaseAlt LamCases)) =+      lcases_msg <+> text "command"+    message ctxt =+      hang (text "Empty list of alternatives in" <+> pp_ctxt ctxt)+           2 (text "Use EmptyCase to allow this")++    lcases_msg =+      text "Empty list of alternatives is not allowed in \\cases"  {- ************************************************************************

@@ -1078,9 +1078,7 @@             then do { mb_demoted_name <- lookupOccRn_maybe demoted_rdr                     ; case mb_demoted_name of                         Nothing -> unboundNameX looking_for rdr_name star_is_type_hints-                        Just demoted_name ->-                          do { addDiagnostic $ TcRnUntickedPromotedConstructor demoted_name-                             ; return demoted_name } }+                        Just demoted_name -> return demoted_name }             else do { -- We need to check if a data constructor of this name is                       -- in scope to give good error messages. However, we do                       -- not want to give an additional error if the data

@@ -374,9 +374,9 @@   = do { (matches', fvMatch) <- rnMatchGroup LambdaExpr rnLExpr matches        ; return (HsLam x matches', fvMatch) } -rnExpr (HsLamCase x matches)-  = do { (matches', fvs_ms) <- rnMatchGroup CaseAlt rnLExpr matches-       ; return (HsLamCase x matches', fvs_ms) }+rnExpr (HsLamCase x lc_variant matches)+  = do { (matches', fvs_ms) <- rnMatchGroup (LamCaseAlt lc_variant) rnLExpr matches+       ; return (HsLamCase x lc_variant matches', fvs_ms) }  rnExpr (HsCase _ expr matches)   = do { (new_expr, e_fvs) <- rnLExpr expr@@ -810,9 +810,10 @@        ; return (HsCmdCase noExtField new_expr new_matches                 , e_fvs `plusFV` ms_fvs) } -rnCmd (HsCmdLamCase x matches)-  = do { (new_matches, ms_fvs) <- rnMatchGroup (ArrowMatchCtxt ArrowCaseAlt) rnLCmd matches-       ; return (HsCmdLamCase x new_matches, ms_fvs) }+rnCmd (HsCmdLamCase x lc_variant matches)+  = do { (new_matches, ms_fvs) <-+           rnMatchGroup (ArrowMatchCtxt $ ArrowLamCaseAlt lc_variant) rnLCmd matches+       ; return (HsCmdLamCase x lc_variant new_matches, ms_fvs) }  rnCmd (HsCmdIf _ _ p b1 b2)   = do { (p', fvP) <- rnLExpr p@@ -864,7 +865,7 @@  methodNamesCmd (HsCmdCase _ _ matches)   = methodNamesMatch matches `addOneFV` choiceAName-methodNamesCmd (HsCmdLamCase _ matches)+methodNamesCmd (HsCmdLamCase _ _ matches)   = methodNamesMatch matches `addOneFV` choiceAName  --methodNamesCmd _ = emptyFVs

@@ -61,6 +61,7 @@ import GHC.Tc.Utils.Monad import GHC.Types.Name.Reader import GHC.Builtin.Names+import GHC.Types.Hint ( UntickedPromotedThing(..) ) import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Types.Name.Set@@ -70,7 +71,7 @@ import GHC.Utils.Misc import GHC.Types.Fixity ( compareFixity, negateFixity                         , Fixity(..), FixityDirection(..), LexicalFixity(..) )-import GHC.Types.Basic  ( TypeOrKind(..) )+import GHC.Types.Basic  ( PromotionFlag(..), isPromoted, TypeOrKind(..) ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain@@ -626,15 +627,21 @@            -- Any type variable at the kind level is illegal without the use            -- of PolyKinds (see #14710)        ; name <- rnTyVar env rdr_name+       ; when (isDataConName name && not (isPromoted ip)) $+         -- NB: a prefix symbolic operator such as (:) is represented as HsTyVar.+            addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Prefix name)        ; return (HsTyVar noAnn ip (L loc name), unitFV name) } -rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)+rnHsTyKi env ty@(HsOpTy _ prom ty1 l_op ty2)   = setSrcSpan (getLocA l_op) $     do  { (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op+        ; let op_name = unLoc l_op'         ; fix   <- lookupTyFixityRn l_op'         ; (ty1', fvs2) <- rnLHsTyKi env ty1         ; (ty2', fvs3) <- rnLHsTyKi env ty2-        ; res_ty <- mkHsOpTyRn l_op' fix ty1' ty2'+        ; res_ty <- mkHsOpTyRn prom l_op' fix ty1' ty2'+        ; when (isDataConName op_name && not (isPromoted prom)) $+            addDiagnostic (TcRnUntickedPromotedThing $ UntickedConstructor Infix op_name)         ; return (res_ty, plusFVs [fvs1, fvs2, fvs3]) }  rnHsTyKi env (HsParTy _ ty)@@ -758,6 +765,8 @@   = do { data_kinds <- xoptM LangExt.DataKinds        ; unless data_kinds (addErr (dataKindsErr env ty))        ; (tys', fvs) <- mapFvRn (rnLHsTyKi env) tys+       ; unless (isPromoted ip) $+           addDiagnostic (TcRnUntickedPromotedThing $ UntickedExplicitList)        ; return (HsExplicitListTy noExtField ip tys', fvs) }  rnHsTyKi env ty@(HsExplicitTupleTy _ tys)@@ -1314,33 +1323,34 @@ -}  ------------------ Building (ty1 `op1` (ty21 `op2` ty22))-mkHsOpTyRn :: LocatedN Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn+-- Building (ty1 `op1` (ty2a `op2` ty2b))+mkHsOpTyRn :: PromotionFlag+           -> LocatedN Name -> Fixity -> LHsType GhcRn -> LHsType GhcRn            -> RnM (HsType GhcRn) -mkHsOpTyRn op1 fix1 ty1 (L loc2 (HsOpTy _ ty21 op2 ty22))+mkHsOpTyRn prom1 op1 fix1 ty1 (L loc2 (HsOpTy _ prom2 ty2a op2 ty2b))   = do  { fix2 <- lookupTyFixityRn op2-        ; mk_hs_op_ty op1 fix1 ty1 op2 fix2 ty21 ty22 loc2 }+        ; mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2 } -mkHsOpTyRn op1 _ ty1 ty2              -- Default case, no rearrangment-  = return (HsOpTy noExtField ty1 op1 ty2)+mkHsOpTyRn prom1 op1 _ ty1 ty2              -- Default case, no rearrangment+  = return (HsOpTy noAnn prom1 ty1 op1 ty2)  ----------------mk_hs_op_ty :: LocatedN Name -> Fixity -> LHsType GhcRn-            -> LocatedN Name -> Fixity -> LHsType GhcRn+mk_hs_op_ty :: PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn+            -> PromotionFlag -> LocatedN Name -> Fixity -> LHsType GhcRn             -> LHsType GhcRn -> SrcSpanAnnA             -> RnM (HsType GhcRn)-mk_hs_op_ty op1 fix1 ty1 op2 fix2 ty21 ty22 loc2+mk_hs_op_ty prom1 op1 fix1 ty1 prom2 op2 fix2 ty2a ty2b loc2   | nofix_error     = do { precParseErr (NormalOp (unLoc op1),fix1)                                         (NormalOp (unLoc op2),fix2)-                         ; return (ty1 `op1ty` (L loc2 (ty21 `op2ty` ty22))) }-  | associate_right = return (ty1 `op1ty` (L loc2 (ty21 `op2ty` ty22)))-  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22)-                           new_ty <- mkHsOpTyRn op1 fix1 ty1 ty21-                         ; return (noLocA new_ty `op2ty` ty22) }+                         ; return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b))) }+  | associate_right = return (ty1 `op1ty` (L loc2 (ty2a `op2ty` ty2b)))+  | otherwise       = do { -- Rearrange to ((ty1 `op1` ty2a) `op2` ty2b)+                           new_ty <- mkHsOpTyRn prom1 op1 fix1 ty1 ty2a+                         ; return (noLocA new_ty `op2ty` ty2b) }   where-    lhs `op1ty` rhs = HsOpTy noExtField lhs op1 rhs-    lhs `op2ty` rhs = HsOpTy noExtField lhs op2 rhs+    lhs `op1ty` rhs = HsOpTy noAnn prom1 lhs op1 rhs+    lhs `op2ty` rhs = HsOpTy noAnn prom2 lhs op2 rhs     (nofix_error, associate_right) = compareFixity fix1 fix2  @@ -1352,17 +1362,17 @@                                        -- be a NegApp)           -> RnM (HsExpr GhcRn) --- (e11 `op1` e12) `op2` e2-mkOpAppRn negation_handling e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2+-- (e1a `op1` e1b) `op2` e2+mkOpAppRn negation_handling e1@(L _ (OpApp fix1 e1a op1 e1b)) op2 fix2 e2   | nofix_error   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)        return (OpApp fix2 e1 op2 e2)    | associate_right = do-    new_e <- mkOpAppRn negation_handling e12 op2 fix2 e2-    return (OpApp fix1 e11 op1 (L loc' new_e))+    new_e <- mkOpAppRn negation_handling e1b op2 fix2 e2+    return (OpApp fix1 e1a op1 (L loc' new_e))   where-    loc'= combineLocsA e12 e2+    loc'= combineLocsA e1b e2     (nofix_error, associate_right) = compareFixity fix1 fix2  ---------------------------@@ -1447,20 +1457,20 @@           -> LHsCmdTop GhcRn             -- Right operand (not an infix)           -> RnM (HsCmd GhcRn) --- (e11 `op1` e12) `op2` e2-mkOpFormRn a1@(L loc+-- (e1a `op1` e1b) `op2` e2+mkOpFormRn e1@(L loc                     (HsCmdTop _                      (L _ (HsCmdArrForm x op1 f (Just fix1)-                        [a11,a12]))))-        op2 fix2 a2+                        [e1a,e1b]))))+        op2 fix2 e2   | nofix_error   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)-       return (HsCmdArrForm x op2 f (Just fix2) [a1, a2])+       return (HsCmdArrForm x op2 f (Just fix2) [e1, e2])    | associate_right-  = do new_c <- mkOpFormRn a12 op2 fix2 a2+  = do new_c <- mkOpFormRn e1a op2 fix2 e2        return (HsCmdArrForm noExtField op1 f (Just fix1)-               [a11, L loc (HsCmdTop [] (L (l2l loc) new_c))])+               [e1b, L loc (HsCmdTop [] (L (l2l loc) new_c))])         -- TODO: locs are wrong   where     (nofix_error, associate_right) = compareFixity fix1 fix2@@ -1474,7 +1484,7 @@ mkConOpPatRn :: LocatedN Name -> Fixity -> LPat GhcRn -> LPat GhcRn              -> RnM (Pat GhcRn) -mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p11 p12))) p2+mkConOpPatRn op2 fix2 p1@(L loc (ConPat NoExtField op1 (InfixCon p1a p1b))) p2   = do  { fix1 <- lookupFixityRn (unLoc op1)         ; let (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -1489,11 +1499,11 @@                 }            else if associate_right then do-                { new_p <- mkConOpPatRn op2 fix2 p12 p2+                { new_p <- mkConOpPatRn op2 fix2 p1b p2                 ; return $ ConPat                     { pat_con_ext = noExtField                     , pat_con = op1-                    , pat_args = InfixCon p11 (L loc new_p)+                    , pat_args = InfixCon p1a (L loc new_p)                     }                 }                 -- XXX loc right?@@ -1946,7 +1956,7 @@                                      extract_lty ty2 $                                      extract_hs_arrow w acc       HsIParamTy _ _ ty           -> extract_lty ty acc-      HsOpTy _ ty1 tv ty2         -> extract_tv tv $+      HsOpTy _ _ ty1 tv ty2       -> extract_tv tv $                                      extract_lty ty1 $                                      extract_lty ty2 acc       HsParTy _ ty                -> extract_lty ty acc

@@ -2350,6 +2350,7 @@                   all_fvs) }}  rnConDecl (ConDeclGADT { con_names   = names+                       , con_dcolon  = dcol                        , con_bndrs   = L l outer_bndrs                        , con_mb_cxt  = mcxt                        , con_g_args  = args@@ -2388,6 +2389,7 @@             (ppr names $$ ppr outer_bndrs')         ; new_mb_doc <- traverse rnLHsDoc mb_doc         ; return (ConDeclGADT { con_g_ext = noAnn, con_names = new_names+                              , con_dcolon = dcol                               , con_bndrs = L l outer_bndrs', con_mb_cxt = new_cxt                               , con_g_args = new_args, con_res_ty = new_res_ty                               , con_doc = new_mb_doc },

@@ -96,6 +96,7 @@   ldSupportsBuildId       <- getBooleanSetting "ld supports build-id"   ldSupportsFilelist      <- getBooleanSetting "ld supports filelist"   ldIsGnuLd               <- getBooleanSetting "ld is GNU ld"+  arSupportsDashL         <- getBooleanSetting "ar supports -L"    let globalpkgdb_path = installed "package.conf.d"       ghc_usage_msg_path  = installed "ghc-usage.txt"@@ -106,7 +107,6 @@   unlit_path <- getToolSetting "unlit command"    windres_path <- getToolSetting "windres command"-  libtool_path <- getToolSetting "libtool command"   ar_path <- getToolSetting "ar command"   otool_path <- getToolSetting "otool command"   install_name_tool_path <- getToolSetting "install_name_tool command"@@ -130,6 +130,9 @@         ld_args  = map Option (cc_args ++ words cc_link_args_str)   ld_r_prog <- getToolSetting "Merge objects command"   ld_r_args <- getSetting "Merge objects flags"+  let ld_r+        | null ld_r_prog = Nothing+        | otherwise      = Just (ld_r_prog, map Option $ words ld_r_args)    llvmTarget <- getSetting "LLVM target" @@ -164,6 +167,7 @@       , toolSettings_ldIsGnuLd               = ldIsGnuLd       , toolSettings_ccSupportsNoPie         = gccSupportsNoPie       , toolSettings_useInplaceMinGW         = useInplaceMinGW+      , toolSettings_arSupportsDashL         = arSupportsDashL        , toolSettings_pgm_L   = unlit_path       , toolSettings_pgm_P   = (cpp_prog, cpp_args)@@ -171,11 +175,10 @@       , toolSettings_pgm_c   = cc_prog       , toolSettings_pgm_a   = (as_prog, as_args)       , toolSettings_pgm_l   = (ld_prog, ld_args)-      , toolSettings_pgm_lm  = (ld_r_prog, map Option $ words ld_r_args)+      , toolSettings_pgm_lm  = ld_r       , toolSettings_pgm_dll = (mkdll_prog,mkdll_args)       , toolSettings_pgm_T   = touch_path       , toolSettings_pgm_windres = windres_path-      , toolSettings_pgm_libtool = libtool_path       , toolSettings_pgm_ar = ar_path       , toolSettings_pgm_otool = otool_path       , toolSettings_pgm_install_name_tool = install_name_tool_path

@@ -480,14 +480,20 @@  -- Out of all arguments passed at runtime only return these ending up in a -- strict field-getStrictConArgs :: DataCon -> [a] -> [a]+getStrictConArgs :: Outputable a => DataCon -> [a] -> [a] getStrictConArgs con args     -- These are always lazy in their arguments.     | isUnboxedTupleDataCon con = []     | isUnboxedSumDataCon con = []     -- For proper data cons we have to check.     | otherwise =+        assertPpr   (length args == length (dataConRuntimeRepStrictness con))+                    (text "Missmatched con arg and con rep strictness lengths:" $$+                     text "Con" <> ppr con <+> text "is applied to" <+> ppr args $$+                     text "But seems to have arity" <> ppr (length repStrictness)) $         [ arg | (arg,MarkedStrict)                     <- zipEqual "getStrictConArgs"                                 args-                                (dataConRuntimeRepStrictness con)]+                                repStrictness]+        where+            repStrictness = (dataConRuntimeRepStrictness con)

@@ -6,7 +6,7 @@ - Variables should be defined before used.  - Let bindings should not have unboxed types (unboxed bindings should only-  appear in case), except when they're join points (see Note [Core let/app+  appear in case), except when they're join points (see Note [Core let-can-float   invariant] and #14117).  - If linting after unarisation, invariants listed in Note [Post-unarisation@@ -47,7 +47,7 @@ import GHC.Core             ( AltCon(..) ) import GHC.Core.Type -import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel )+import GHC.Types.Basic      ( TopLevelFlag(..), isTopLevel, isMarkedCbv ) import GHC.Types.CostCentre ( isCurrentCCS ) import GHC.Types.Error      ( DiagnosticReason(WarningWithoutFlag) ) import GHC.Types.Id@@ -69,6 +69,7 @@ import Control.Applicative ((<|>)) import Control.Monad import Data.Maybe+import GHC.Utils.Misc  lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)                    => Logger@@ -179,10 +180,13 @@         lintStgExpr expr  lintStgRhs rhs@(StgRhsCon _ con _ _ args) = do+    opts <- getStgPprOpts     when (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) $ do-      opts <- getStgPprOpts       addErrL (text "StgRhsCon is an unboxed tuple or sum application" $$                pprStgRhs opts rhs)++    lintConApp con args (pprStgRhs opts rhs)+     mapM_ lintStgArg args     mapM_ checkPostUnariseConArg args @@ -200,7 +204,7 @@       -- always needs to be applied to n arguments.       -- See Note [Strict Worker Ids].       let marks = fromMaybe [] $ idCbvMarks_maybe fun-      if length marks > length args+      if length (dropWhileEndLE (not . isMarkedCbv) marks) > length args         then addErrL $ hang (text "Undersatured cbv marked ID in App" <+> ppr e ) 2 $           (text "marks" <> ppr marks $$           text "args" <> ppr args $$@@ -211,10 +215,15 @@ lintStgExpr app@(StgConApp con _n args _arg_tys) = do     -- unboxed sums should vanish during unarise     lf <- getLintFlags-    when (lf_unarised lf && isUnboxedSumDataCon con) $ do+    let !unarised = lf_unarised lf+    when (unarised && isUnboxedSumDataCon con) $ do       opts <- getStgPprOpts       addErrL (text "Unboxed sum after unarise:" $$                pprStgExpr opts app)++    opts <- getStgPprOpts+    lintConApp con args (pprStgExpr opts app)+     mapM_ lintStgArg args     mapM_ checkPostUnariseConArg args @@ -261,6 +270,18 @@   do     mapM_ checkPostUnariseBndr bndrs     addInScopeVars bndrs (lintStgExpr rhs)++-- Post unarise check we apply constructors to the right number of args.+-- This can be violated by invalid use of unsafeCoerce as showcased by test+-- T9208+lintConApp :: Foldable t => DataCon -> t a -> SDoc -> LintM ()+lintConApp con args app = do+    unarised <- lf_unarised <$> getLintFlags+    when (unarised &&+          not (isUnboxedTupleDataCon con) &&+          length (dataConRuntimeRepStrictness con) /= length args) $ do+      addErrL (text "Constructor applied to incorrect number of arguments:" $$+               text "Application:" <> app)  {- ************************************************************************

@@ -186,6 +186,18 @@ layout to use. Note that unlifted values can't be let-bound, so we don't need types in StgRhsCon. +Note [UnariseEnv]+~~~~~~~~~~~~~~~~~~+At any variable occurrence 'v',+* If the UnariseEnv has a binding for 'v', the binding says what 'v' is bound to+* If not, 'v' stands just for itself.++Most variables are unaffected by unarisation, and (for efficiency) we don't put+them in the UnariseEnv at all.  But NB: when we go under a binding for 'v' we must+remember to delete 'v' from the UnariseEnv, lest occurrences of 'v' see the outer+binding for the variable (#21396).++ Note [UnariseEnv can map to literals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ To avoid redundant case expressions when unarising unboxed sums, UnariseEnv@@ -305,6 +317,8 @@   ppr (UnaryVal arg)   = text "UnaryVal" <+> ppr arg  -- | Extend the environment, checking the UnariseEnv invariant.+-- The id is mapped to one or more things.+-- See Note [UnariseEnv] extendRho :: UnariseEnv -> Id -> UnariseVal -> UnariseEnv extendRho rho x (MultiVal args)   = assert (all (isNvUnaryType . stgArgType) args)@@ -312,7 +326,15 @@ extendRho rho x (UnaryVal val)   = assert (isNvUnaryType (stgArgType val))     extendVarEnv rho x (UnaryVal val)+-- Properly shadow things from an outer scope.+-- See Note [UnariseEnv] +-- The id stands for itself so we don't record a mapping.+-- See Note [UnariseEnv]+extendRhoWithoutValue :: UnariseEnv -> Id -> UnariseEnv+extendRhoWithoutValue rho x = delVarEnv rho x++ --------------------------------------------------------------------------------  unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]@@ -434,7 +456,7 @@   = Nothing   -- Single, non-void PrimRep. Nothing to do!    | otherwise -- Multiple reps, possibly with VoidRep. Eliminate via elimCase-  = Just [ StgLitArg (LitRubbish (primRepToType prep))+  = Just [ StgLitArg (LitRubbish (primRepToRuntimeRep prep))          | prep <- preps, not (isVoidRep prep) ]   where     preps = runtimeRepPrimRep (text "unariseRubbish_maybe") rep@@ -754,7 +776,7 @@       -> do x' <- mkId (mkFastString "us") (primRepToType rep)             return (extendRho rho x (MultiVal [StgVarArg x']), [x'])       | otherwise-      -> return (rho, [x])+      -> return (extendRhoWithoutValue rho x, [x])      reps -> do       xs <- mkIds (mkFastString "us") (map primRepToType reps)

@@ -1722,7 +1722,9 @@         LitChar {}      -> code WordRep         LitNullAddr     -> code AddrRep         LitString {}    -> code AddrRep-        LitRubbish {}   -> code WordRep+        LitRubbish rep  -> case runtimeRepPrimRep (text "pushLiteral") rep of+                             [pr] -> code pr+                             _    -> pprPanic "pushLiteral" (ppr lit)         LitNumber nt _  -> case nt of           LitNumInt     -> code IntRep           LitNumWord    -> code WordRep

@@ -1,8 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-}-{- Note: [The need for Ar.hs]-Building `-staticlib` required the presence of libtool, and was a such-restricted to mach-o only. As libtool on macOS and gnu libtool are very+{- Note [The need for Ar.hs]+   ~~~~~~~~~~~~~~~~~~~~~~~~~+Building `-staticlib` previously required the presence of libtool, and was a+such restricted to mach-o only. As libtool on macOS and gnu libtool are very different, there was no simple portable way to support this.  libtool for static archives does essentially: concatinate the input archives,@@ -11,9 +12,9 @@ features across platforms (e.g. index prefixed retrieval of objects with the same name.) -As Archives are rather simple structurally, we can just build the archives+As archives are rather simple structurally, we can just build the archives with Haskell directly and use ranlib on the final result to get the symbol-index. This should allow us to work around with the differences/abailability+index. This should allow us to work around with the differences/availability of libtool across different platforms. -} module GHC.SysTools.Ar

@@ -68,30 +68,6 @@  -} -{- Note [Windows static libGCC]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The GCC versions being upgraded to in #10726 are configured with-dynamic linking of libgcc supported. This results in libgcc being-linked dynamically when a shared library is created.--This introduces thus an extra dependency on GCC dll that was not-needed before by shared libraries created with GHC. This is a particular-issue on Windows because you get a non-obvious error due to this missing-dependency. This dependent dll is also not commonly on your path.--For this reason using the static libgcc is preferred as it preserves-the same behaviour that existed before. There are however some very good-reasons to have the shared version as well as described on page 181 of-https://gcc.gnu.org/onlinedocs/gcc-5.2.0/gcc.pdf :--"There are several situations in which an application should use the- shared ‘libgcc’ instead of the static version. The most common of these- is when the application wishes to throw and catch exceptions across different- shared libraries. In that case, each of the libraries as well as the application- itself should use the shared ‘libgcc’. "---}- neededLinkArgs :: LinkerInfo -> [Option] neededLinkArgs (GnuLD o)     = o neededLinkArgs (GnuGold o)   = o@@ -166,12 +142,10 @@         -- Process creation is also fairly expensive on win32, so         -- we short-circuit here.         return $ GnuLD $ map Option-          [ -- Emit gcc stack checks+          [ -- Emit stack checks             -- See Note [Windows stack allocations]            "-fstack-check"-            -- Force static linking of libGCC-            -- See Note [Windows static libGCC]-          , "-static-libgcc" ]+          ]       _ -> do         -- In practice, we use the compiler as the linker here. Pass         -- -Wl,--version to get linker version info.

@@ -29,8 +29,10 @@ import GHC.Utils.Logger import GHC.Utils.TmpFs import GHC.Utils.Constants (isWindowsHost)+import GHC.Utils.Panic  import Data.List (tails, isPrefixOf)+import Data.Maybe (fromMaybe) import System.IO import System.Process @@ -325,7 +327,10 @@ runMergeObjects :: Logger -> TmpFs -> DynFlags -> [Option] -> IO () runMergeObjects logger tmpfs dflags args =   traceToolCommand logger "merge-objects" $ do-    let (p,args0) = pgm_lm dflags+    let (p,args0) = fromMaybe err (pgm_lm dflags)+        err = throwGhcException $ UsageError $ unwords+            [ "Attempted to merge object files but the configured linker"+            , "does not support object merging." ]         optl_args = map Option (getOpts dflags opt_lm)         args2     = args0 ++ args ++ optl_args     -- N.B. Darwin's ld64 doesn't support response files. Consequently we only@@ -337,15 +342,6 @@       else do         runSomething logger "Merge objects" p args2 -runLibtool :: Logger -> DynFlags -> [Option] -> IO ()-runLibtool logger dflags args = traceToolCommand logger "libtool" $ do-  linkargs <- neededLinkArgs `fmap` getLinkerInfo logger dflags-  let args1      = map Option (getOpts dflags opt_l)-      args2      = [Option "-static"] ++ args1 ++ args ++ linkargs-      libtool    = pgm_libtool dflags-  mb_env <- getGccEnv args2-  runSomethingFiltered logger id "Libtool" libtool args2 Nothing mb_env- runAr :: Logger -> DynFlags -> Maybe FilePath -> [Option] -> IO () runAr logger dflags cwd args = traceToolCommand logger "ar" $ do   let ar = pgm_ar dflags@@ -369,25 +365,11 @@  runWindres :: Logger -> DynFlags -> [Option] -> IO () runWindres logger dflags args = traceToolCommand logger "windres" $ do-  let cc = pgm_c dflags-      cc_args = map Option (sOpt_c (settings dflags))+  let cc_args = map Option (sOpt_c (settings dflags))       windres = pgm_windres dflags       opts = map Option (getOpts dflags opt_windres)-      quote x = "\"" ++ x ++ "\""-      args' = -- If windres.exe and gcc.exe are in a directory containing-              -- spaces then windres fails to run gcc. We therefore need-              -- to tell it what command to use...-              [ Option ("--preprocessor=" ++ quote cc) ]-              ++ map (Option . ("--preprocessor-arg=" ++) . quote)-                     (map showOpt opts ++ ["-E", "-xc", "-DRC_INVOKED"])-              -- ...but if we do that then if windres calls popen then-              -- it can't understand the quoting, so we have to use-              -- --use-temp-file so that it interprets it correctly.-              -- See #1828.-              ++ [ Option "--use-temp-file" ]-              ++ args   mb_env <- getGccEnv cc_args-  runSomethingFiltered logger id "Windres" windres args' Nothing mb_env+  runSomethingFiltered logger id "Windres" windres (opts ++ args) Nothing mb_env  touch :: Logger -> DynFlags -> String -> String -> IO () touch logger dflags purpose arg = traceToolCommand logger "touch" $

@@ -590,7 +590,7 @@   where     ascribeBool e = noLocA $ ExprWithTySig noAnn e                            $ mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType-                           $ nlHsTyVar boolTyCon_RDR+                           $ nlHsTyVar NotPromoted boolTyCon_RDR  nlConWildPat :: DataCon -> LPat GhcPs -- The pattern (K {})@@ -2233,9 +2233,9 @@   DerivMaxTag _ _     -> mk_sig (L (noAnnSrcSpan loc) (XHsType intTy))   DerivDataDataType _ _ _-    -> mk_sig (nlHsTyVar dataType_RDR)+    -> mk_sig (nlHsTyVar NotPromoted dataType_RDR)   DerivDataConstr _ _ _-    -> mk_sig (nlHsTyVar constr_RDR)+    -> mk_sig (nlHsTyVar NotPromoted constr_RDR)   where     mk_sig = mkHsWildCardBndrs . L (noAnnSrcSpan loc) . mkHsImplicitSigType 

@@ -989,8 +989,8 @@          InferContext wildcard            | null data_cons -- 1.            , not permissive-           -> checkFlag LangExt.EmptyDataDeriving dflags dit `orValid`-              NotValid (no_cons_why rep_tc)+           , not (xopt LangExt.EmptyDataDeriving dflags)+           -> NotValid (no_cons_why rep_tc)            | not (null con_whys)            -> NotValid $ DerivErrBadConstructor (Just $ has_wildcard wildcard) con_whys            | otherwise

@@ -393,17 +393,22 @@  = return ()   | SigSkol user_ctxt _ _ <- info- = restoreLclEnv env $  -- We want to add "In the type signature for f"-                        -- to the error context, which is a bit tiresome+ -- When dealing with a user-written type signature,+ -- we want to add "In the type signature for f".+ = restoreLclEnv env $    setSrcSpan (redundantConstraintsSpan user_ctxt) $    report_redundant_msg True+                  --  ^^^^ add "In the type signature..." - | otherwise  -- But for InstSkol there already *is* a surrounding-              -- "In the instance declaration for Eq [a]" context-              -- and we don't want to say it twice. Seems a bit ad-hoc- = report_redundant_msg False+ | otherwise+ -- But for InstSkol there already *is* a surrounding+ -- "In the instance declaration for Eq [a]" context+ -- and we don't want to say it twice. Seems a bit ad-hoc+ = restoreLclEnv env+ $ report_redundant_msg False+                 --   ^^^^^ don't add "In the type signature..."  where-   report_redundant_msg :: Bool -- whether to add "In ..." to the diagnostic+   report_redundant_msg :: Bool -- whether to add "In the type signature..." to the diagnostic                         -> TcRn ()    report_redundant_msg show_info      = do { lcl_env <- getLclEnv@@ -502,7 +507,7 @@ ---------------------------------------------------------------- reportWanteds :: SolverReportErrCtxt -> TcLevel -> WantedConstraints -> TcM () reportWanteds ctxt tc_lvl wc@(WC { wc_simple = simples, wc_impl = implics-                                 , wc_holes = holes })+                                 , wc_errors = errs })   | isEmptyWC wc = traceTc "reportWanteds empty WC" empty   | otherwise   = do { tidy_items <- mapMaybeM mkErrorItem tidy_cts@@ -510,17 +515,22 @@                                          , text "Suppress =" <+> ppr (cec_suppress ctxt)                                          , text "tidy_cts   =" <+> ppr tidy_cts                                          , text "tidy_items =" <+> ppr tidy_items-                                         , text "tidy_holes =" <+> ppr tidy_holes ])+                                         , text "tidy_errs =" <+> ppr tidy_errs ])         -- This check makes sure that we aren't suppressing the only error that will        -- actually stop compilation-       ; massert $-           null simples ||                  -- no errors to report here-           any ignoreConstraint simples ||  -- one error is ignorable (is reported elsewhere)-           not (all ei_suppress tidy_items) -- not all error are suppressed+       ; assertPprM+           ( do { errs_already <- ifErrsM (return True) (return False)+                ; return $+                    errs_already ||                  -- we already reported an error (perhaps from an outer implication)+                    null simples ||                  -- no errors to report here+                    any ignoreConstraint simples ||  -- one error is ignorable (is reported elsewhere)+                    not (all ei_suppress tidy_items) -- not all errors are suppressed+                } )+           (vcat [text "reportWanteds is suppressing all errors"])           -- First, deal with any out-of-scope errors:-       ; let (out_of_scope, other_holes) = partition isOutOfScopeHole tidy_holes+       ; let (out_of_scope, other_holes, not_conc_errs) = partition_errors tidy_errs                -- don't suppress out-of-scope errors              ctxt_for_scope_errs = ctxt { cec_suppress = False }        ; (_, no_out_of_scope) <- askNoErrs $@@ -535,6 +545,8 @@        ; reportHoles tidy_items ctxt_for_insols other_holes           -- holes never suppress +       ; reportNotConcreteErrs ctxt_for_insols not_conc_errs+           -- See Note [Suppressing confusing errors]        ; let (suppressed_items, items0) = partition suppress tidy_items        ; traceTc "reportWanteds suppressed:" (ppr suppressed_items)@@ -563,10 +575,26 @@          do { (_, more_leftovers) <- tryReporters ctxt3 report3 suppressed_items             ; massertPpr (null more_leftovers) (ppr more_leftovers) } }  where-    env        = cec_tidy ctxt-    tidy_cts   = bagToList (mapBag (tidyCt env)   simples)-    tidy_holes = bagToList (mapBag (tidyHole env) holes)+    env       = cec_tidy ctxt+    tidy_cts  = bagToList (mapBag (tidyCt env)   simples)+    tidy_errs = bagToList (mapBag (tidyDelayedError env) errs) +    partition_errors :: [DelayedError] -> ([Hole], [Hole], [NotConcreteError])+    partition_errors = go [] [] []+      where+        go out_of_scope other_holes syn_eqs []+          = (out_of_scope, other_holes, syn_eqs)+        go es1 es2 es3 (err:errs)+          | (es1, es2, es3) <- go es1 es2 es3 errs+          = case err of+              DE_Hole hole+                | isOutOfScopeHole hole+                -> (hole : es1, es2, es3)+                | otherwise+                -> (es1, hole : es2, es3)+              DE_NotConcrete err+                -> (es1, es2, err : es3)+       -- See Note [Suppressing confusing errors]     suppress :: ErrorItem -> Bool     suppress item@@ -584,10 +612,11 @@     report1 = [ ("custom_error", is_user_type_error, True,  mkUserTypeErrorReporter)                , given_eq_spec-              , ("insoluble2",   utterly_wrong,  True, mkGroupReporter mkEqErr)-              , ("skolem eq1",   very_wrong,     True, mkSkolReporter)-              , ("skolem eq2",   skolem_eq,      True, mkSkolReporter)-              , ("non-tv eq",    non_tv_eq,      True, mkSkolReporter)+              , ("insoluble2",      utterly_wrong,  True, mkGroupReporter mkEqErr)+              , ("skolem eq1",      very_wrong,     True, mkSkolReporter)+              , ("FixedRuntimeRep", is_FRR,         True, mkGroupReporter mkFRRErr)+              , ("skolem eq2",      skolem_eq,      True, mkSkolReporter)+              , ("non-tv eq",       non_tv_eq,      True, mkSkolReporter)                    -- The only remaining equalities are alpha ~ ty,                   -- where alpha is untouchable; and representational equalities@@ -601,7 +630,6 @@     -- report2: we suppress these if there are insolubles elsewhere in the tree     report2 = [ ("Implicit params", is_ip,           False, mkGroupReporter mkIPErr)               , ("Irreds",          is_irred,        False, mkGroupReporter mkIrredErr)-              , ("FixedRuntimeRep", is_FRR,          False, mkGroupReporter mkFRRErr)               , ("Dicts",           is_dict,         False, mkGroupReporter mkDictErr) ]      -- report3: suppressed errors should be reported as categorized by either report1@@ -626,6 +654,9 @@     very_wrong _ (EqPred NomEq ty1 ty2) = isSkolemTy tc_lvl ty1 && isRigidTy ty2     very_wrong _ _                      = False +    -- Representation-polymorphism errors, to be reported using mkFRRErr.+    is_FRR item _ = isJust $ fixedRuntimeRepOrigin_maybe item+     -- Things like (a ~N b) or (a  ~N  F Bool)     skolem_eq _ (EqPred NomEq ty1 _) = isSkolemTy tc_lvl ty1     skolem_eq _ _                    = False@@ -636,23 +667,13 @@      is_user_type_error item _ = isUserTypeError (errorItemPred item) -    is_homo_equality item (EqPred _ ty1 ty2)-      | FixedRuntimeRepOrigin {} <- errorItemOrigin item-      -- Constraints with FixedRuntimeRep origin must be reported using mkFRRErr.-      = False-      | otherwise+    is_homo_equality _ (EqPred _ ty1 ty2)       = tcTypeKind ty1 `tcEqType` tcTypeKind ty2     is_homo_equality _ _       = False -    is_equality item (EqPred {})-      | FixedRuntimeRepOrigin {} <- errorItemOrigin item-      -- Constraints with FixedRuntimeRep origin must be reported using mkFRRErr.-      = False-      | otherwise-      = True-    is_equality _ _-      = False+    is_equality _(EqPred {}) = True+    is_equality _ _          = False      is_dict _ (ClassPred {}) = True     is_dict _ _              = False@@ -660,12 +681,6 @@     is_ip _ (ClassPred cls _) = isIPClass cls     is_ip _ _                 = False -    is_FRR item _-      | FixedRuntimeRepOrigin {} <- errorItemOrigin item-      = True-    is_FRR _ _-      = False-     is_irred _ (IrredPred {}) = True     is_irred _ _              = False @@ -880,6 +895,35 @@                 (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty                 return (tidy_env',  extendNameEnv name_env name tidy_ty) +reportNotConcreteErrs :: SolverReportErrCtxt -> [NotConcreteError] -> TcM ()+reportNotConcreteErrs _ [] = return ()+reportNotConcreteErrs ctxt errs@(err0:_)+  = do { msg <- mkErrorReport (ctLocEnv (nce_loc err0)) diag (Just ctxt) []+       ; reportDiagnostic msg }++  where++    frr_origins = acc_errors errs+    diag = TcRnSolverReport+             [SolverReportWithCtxt ctxt (FixedRuntimeRepError frr_origins)]+             ErrorWithoutFlag noHints++    -- Accumulate the different kind of errors arising from syntactic equality.+    -- (Only SynEq_FRR origin for the moment.)+    acc_errors = go []+      where+        go frr_errs [] = frr_errs+        go frr_errs (err:errs)+          | frr_errs <- go frr_errs errs+          = case err of+              NCE_FRR+                { nce_frr_origin = frr_orig+                , nce_reasons = _not_conc } ->+                FRR_Info+                  { frr_info_origin       = frr_orig+                  , frr_info_not_concrete = Nothing }+                : frr_errs+ {- Note [Skip type holes rapidly] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have module with a /lot/ of partial type signatures, and we@@ -1009,10 +1053,10 @@  -- See Note [No deferring for multiplicity errors] nonDeferrableOrigin :: CtOrigin -> Bool-nonDeferrableOrigin NonLinearPatternOrigin     = True-nonDeferrableOrigin (UsageEnvironmentOf {})    = True-nonDeferrableOrigin (FixedRuntimeRepOrigin {}) = True-nonDeferrableOrigin _                          = False+nonDeferrableOrigin NonLinearPatternOrigin  = True+nonDeferrableOrigin (UsageEnvironmentOf {}) = True+nonDeferrableOrigin (FRROrigin {})          = True+nonDeferrableOrigin _                       = False  maybeReportError :: SolverReportErrCtxt                  -> [ErrorItem]     -- items covered by the Report@@ -1050,9 +1094,7 @@              -> do { -- See Note [Deferred errors for coercion holes]                      let co_var = coHoleCoVar hole                    ; addTcEvBind ev_binds_var $ mkWantedEvBind co_var err_tm-                   ; fillCoercionHole hole (mkTcCoVarCo co_var) }-           NoDest-             -> return () }+                   ; fillCoercionHole hole (mkTcCoVarCo co_var) } } addDeferredBinding _ _ _ = return ()    -- Do not set any evidence for Given  mkErrorTerm :: SolverReportErrCtxt -> CtLoc -> Type  -- of the error term@@ -1438,39 +1480,35 @@  ---------------- --- | Report a representation-polymorphism error to the user: `ty` should have--- a fixed runtime representation, but doesn't.+-- | Report a representation-polymorphism error to the user:+-- a type is required to havehave a fixed runtime representation,+-- but doesn't. -- -- See Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin.-mkFRRErr :: SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport+mkFRRErr :: HasDebugCallStack => SolverReportErrCtxt -> [ErrorItem] -> TcM SolverReport mkFRRErr ctxt items-  = do { -- Zonk and tidy the error items.-       ; (_tidy_env, tidied_origins) <--           zonkTidyOrigins (cec_tidy ctxt) (map errorItemOrigin items)-         -- Then remove duplicates: only retain one 'CtOrigin' per representation-polymorphic type.-       ; let frr_infos =-              nubOrdBy (nonDetCmpType `on` frrInfo_type) $-                zipWith frr_info tidied_origins (map errorItemPred items)+  = do { -- Process the error items.+       ; (_tidy_env, frr_infos) <-+          zonkTidyFRRInfos (cec_tidy ctxt) $+            -- Zonk/tidy to show useful variable names.+          nubOrdBy (nonDetCmpType `on` (frr_type . frr_info_origin)) $+            -- Remove duplicates: only one representation-polymorphism error per type.+          map (expectJust "mkFRRErr" . fixedRuntimeRepOrigin_maybe)+          items        ; return $ important ctxt $ FixedRuntimeRepError frr_infos }-  where -    frr_info :: CtOrigin -> PredType -> FixedRuntimeRepErrorInfo-    frr_info orig pty-      | FixedRuntimeRepOrigin ty frr_orig <- orig-      = FixedRuntimeRepErrorInfo-        { frrInfo_origin     = frr_orig-        , frrInfo_type       = ty-        , frrInfo_isReflPrim = isIsReflPrimPred (classifyPredType pty)-            -- NB: it's useful to categorise the error messages depending on-            -- whether they were triggered by an 'IsRefl#' constraint or not,-            -- so that we can print an extra explanatory message to the user.-            ---            -- See Note [The Concrete mechanism] in GHC.Tc.Utils.Concrete.-        }-      | otherwise-      = pprPanic "mkFRRErr: not a FixedRuntimeRep origin" $-          vcat [ text "origin:" <+> ppr orig-               , text "pty:"    <+> ppr pty ]+-- | Whether to report something using the @FixedRuntimeRep@ mechanism.+fixedRuntimeRepOrigin_maybe :: HasDebugCallStack => ErrorItem -> Maybe FixedRuntimeRepErrorInfo+fixedRuntimeRepOrigin_maybe item+  -- An error that arose directly from a representation-polymorphism check.+  | FRROrigin frr_orig <- errorItemOrigin item+  = Just $ FRR_Info { frr_info_origin = frr_orig+                    , frr_info_not_concrete = Nothing }+  -- Unsolved nominal equalities involving a concrete type variable,+  -- such as @alpha[conc] ~# rr[sk]@ or @beta[conc] ~# RR@ for a+  -- type family application @RR@, are handled by 'mkTyVarEqErr''.+  | otherwise+  = Nothing  {- Note [Constraints include ...]@@ -1611,10 +1649,10 @@              -> ErrorItem              -> TcType -> TcType -> TcM (AccReportMsgs, [GhcHint]) mkEqErr_help ctxt item ty1 ty2-  | Just (tv1, _) <- tcGetCastedTyVar_maybe ty1-  = mkTyVarEqErr ctxt item tv1 ty2-  | Just (tv2, _) <- tcGetCastedTyVar_maybe ty2-  = mkTyVarEqErr ctxt item tv2 ty1+  | Just casted_tv1 <- tcGetCastedTyVar_maybe ty1+  = mkTyVarEqErr ctxt item casted_tv1 ty2+  | Just casted_tv2 <- tcGetCastedTyVar_maybe ty2+  = mkTyVarEqErr ctxt item casted_tv2 ty1   | otherwise   = return (reportEqErr ctxt item ty1 ty2 :| [], []) @@ -1628,30 +1666,40 @@     eqInfos  = eqInfoMsgs ty1 ty2  mkTyVarEqErr :: SolverReportErrCtxt -> ErrorItem-             -> TcTyVar -> TcType -> TcM (AccReportMsgs, [GhcHint])+             -> (TcTyVar, TcCoercionN) -> TcType -> TcM (AccReportMsgs, [GhcHint]) -- tv1 and ty2 are already tidied-mkTyVarEqErr ctxt item tv1 ty2-  = do { traceTc "mkTyVarEqErr" (ppr item $$ ppr tv1 $$ ppr ty2)-       ; mkTyVarEqErr' ctxt item tv1 ty2 }+mkTyVarEqErr ctxt item casted_tv1 ty2+  = do { traceTc "mkTyVarEqErr" (ppr item $$ ppr casted_tv1 $$ ppr ty2)+       ; mkTyVarEqErr' ctxt item casted_tv1 ty2 }  mkTyVarEqErr' :: SolverReportErrCtxt -> ErrorItem-              -> TcTyVar -> TcType -> TcM (AccReportMsgs, [GhcHint])-mkTyVarEqErr' ctxt item tv1 ty2-     -- impredicativity is a simple error to understand; try it first-  | check_eq_result `cterHasProblem` cteImpredicative = do-  tyvar_eq_info <- extraTyVarEqInfo tv1 ty2-  let-      poly_msg = CannotUnifyWithPolytype item tv1 ty2-      poly_msg_with_info-        | isSkolemTyVar tv1-        = mkTcReportWithInfo poly_msg tyvar_eq_info-        | otherwise-        = poly_msg-      -- Unlike the other reports, this discards the old 'report_important'-       -- instead of augmenting it.  This is because the details are not likely-       -- to be helpful since this is just an unimplemented feature.-  return (poly_msg_with_info <| headline_msg :| [], [])+              -> (TcTyVar, TcCoercionN) -> TcType -> TcM (AccReportMsgs, [GhcHint])+mkTyVarEqErr' ctxt item (tv1, co1) ty2 +  -- Is this a representation-polymorphism error, e.g.+  -- alpha[conc] ~# rr[sk] ? If so, handle that first.+  | Just frr_info <- mb_concrete_reason+  = do+      (_, infos) <- zonkTidyFRRInfos (cec_tidy ctxt) [frr_info]+      return (FixedRuntimeRepError infos :| [], [])++  -- Impredicativity is a simple error to understand; try it before+  -- anything more complicated.+  | check_eq_result `cterHasProblem` cteImpredicative+  = do+    tyvar_eq_info <- extraTyVarEqInfo tv1 ty2+    let+        poly_msg = CannotUnifyWithPolytype item tv1 ty2+        poly_msg_with_info+          | isSkolemTyVar tv1+          = mkTcReportWithInfo poly_msg tyvar_eq_info+          | otherwise+          = poly_msg+        -- Unlike the other reports, this discards the old 'report_important'+        -- instead of augmenting it.  This is because the details are not likely+        -- to be helpful since this is just an unimplemented feature.+    return (poly_msg_with_info <| headline_msg :| [], [])+   | isSkolemTyVar tv1  -- ty2 won't be a meta-tyvar; we would have                        -- swapped in Solver.Canonical.canEqTyVarHomo     || isTyVarTyVar tv1 && not (isTyVarTy ty2)@@ -1680,7 +1728,7 @@      -- This is wrinkle (4) in Note [Equalities with incompatible kinds] in     -- GHC.Tc.Solver.Canonical-  | hasCoercionHoleTy ty2+  | hasCoercionHoleCo co1 || hasCoercionHoleTy ty2   = return (mkBlockedEqErr item :| [], [])    -- If the immediately-enclosing implication has 'tv' a skolem, and@@ -1723,6 +1771,25 @@     headline_msg = misMatchOrCND insoluble_occurs_check ctxt item ty1 ty2     mismatch_msg = mkMismatchMsg item ty1 ty2     add_sig      = maybeToList $ suggestAddSig ctxt ty1 ty2++    -- The following doesn't use the cterHasProblem mechanism because+    -- we need to retrieve the ConcreteTvOrigin. Just knowing whether+    -- there is an error is not sufficient. See #21430.+    mb_concrete_reason+      | Just frr_orig <- isConcreteTyVar_maybe tv1+      , not (isConcrete ty2)+      = Just $ frr_reason frr_orig tv1 ty2+      | Just (tv2, frr_orig) <- isConcreteTyVarTy_maybe ty2+      , not (isConcreteTyVar tv1)+      = Just $ frr_reason frr_orig tv2 ty1+      -- NB: if it's an unsolved equality in which both sides are concrete+      -- (e.g. a concrete type variable on both sides), then it's not a+      -- representation-polymorphism problem.+      | otherwise+      = Nothing+    frr_reason (ConcreteFRR frr_orig) conc_tv not_conc+      = FRR_Info { frr_info_origin = frr_orig+                 , frr_info_not_concrete = Just (conc_tv, not_conc) }      ty1 = mkTyVarTy tv1 

@@ -36,7 +36,7 @@ import GHC.Tc.Utils.Monad import GHC.Tc.Utils.Unify import GHC.Tc.Utils.Instantiate-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_MustBeRefl )+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Instance.Family ( tcGetFamInstEnvs, tcLookupDataFamInst_maybe ) import GHC.Tc.Gen.HsType import GHC.Tc.Utils.TcMType@@ -403,15 +403,15 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We cannot have representation-polymorphic or levity-polymorphic function arguments. See Note [Representation polymorphism invariants]-in GHC.Core.  That is checked by the calls to `hasFixedRuntimeRep ` in+in GHC.Core.  That is checked by the calls to `hasFixedRuntimeRep` in `tcEValArg`. -But some /built-in/ functions are representation-polymorphic.  Users-can't define such Ids; they are all GHC built-ins or data+But some /built-in/ functions have representation-polymorphic argument+types. Users can't define such Ids; they are all GHC built-ins or data constructors.  Specifically they are:  1. A few wired-in Ids like unsafeCoerce#, with compulsory unfoldings.-2. Primops, such as raise#+2. Primops, such as raise#. 3. Newtype constructors with `UnliftedNewtypes` that have    a representation-polymorphic argument. 4. Representation-polymorphic data constructors: unboxed tuples@@ -480,8 +480,11 @@    Because we want to accept this, we switch off Lint's representation   polymorphism checks when Lint checks the output of the desugarer;-  see the lf_check_fixed_repy flag in GHC.Core.Lint.lintCoreBindings.+  see the lf_check_fixed_rep flag in GHC.Core.Lint.lintCoreBindings. +  We then rely on the simple optimiser to beta reduce these+  representation-polymorphic lambdas (e.g. GHC.Core.SimpleOpt.simple_app).+ * Arity.  We don't want to check for arguments past the   arity of the function.  For example @@ -564,7 +567,11 @@     -- in the (possibly instantiated) inferred type of the function will     -- be at least the arity of the function. -    check_thing :: Outputable thing => thing -> Arity -> (Int -> FRROrigin) -> TcM ()+    check_thing :: Outputable thing+                => thing+                -> Arity+                -> (Int -> FixedRuntimeRepContext)+                -> TcM ()     check_thing thing arity mk_frr_orig = do       traceTc "tcApp remainingValArgs check_thing" (debug_msg thing arity)       go (nb_applied_vis_val_args + 1) (nb_applied_val_args + 1) arg_tys@@ -587,7 +594,7 @@               InvisArg ->                 go i_visval (i_val + 1) tys               VisArg   -> do-                hasFixedRuntimeRep_MustBeRefl (mk_frr_orig i_visval) arg_ty+                hasFixedRuntimeRep_syntactic (mk_frr_orig i_visval) arg_ty                 go (i_visval + 1) (i_val + 1) tys      -- A message containing all the relevant info, in case this functions

@@ -1,5 +1,6 @@-{-# LANGUAGE RankNTypes    #-}-{-# LANGUAGE TypeFamilies  #-}+{-# LANGUAGE RankNTypes     #-}+{-# LANGUAGE TypeFamilies   #-}+{-# LANGUAGE BlockArguments #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -18,11 +19,10 @@                                        , tcCheckPolyExpr )  import GHC.Hs-import GHC.Hs.Syn.Type import GHC.Tc.Errors.Types import GHC.Tc.Gen.Match import GHC.Tc.Gen.Head( tcCheckId )-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_MustBeRefl )+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.TcType import GHC.Tc.Utils.TcMType import GHC.Tc.Gen.Bind@@ -146,7 +146,7 @@ tcCmd env (L loc cmd) cmd_ty@(_, res_ty)   = setSrcSpan (locA loc) $ do         { cmd' <- tc_cmd env cmd cmd_ty-        ; hasFixedRuntimeRep_MustBeRefl (FRRArrow $ ArrowCmdResTy cmd) res_ty+        ; hasFixedRuntimeRep_syntactic (FRRArrow $ ArrowCmdResTy cmd) res_ty         ; return (L loc cmd') }  tc_cmd :: CmdEnv -> HsCmd GhcRn  -> CmdType -> TcM (HsCmd GhcTc)@@ -163,20 +163,19 @@ tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)   = addErrCtxt (cmdCtxt in_cmd) $ do       (scrut', scrut_ty) <- tcInferRho scrut-      hasFixedRuntimeRep_MustBeRefl-        (FRRArrow $ ArrowCmdCase { isCmdLamCase = False })+      hasFixedRuntimeRep_syntactic+        (FRRArrow $ ArrowCmdCase)         scrut_ty       matches' <- tcCmdMatches env scrut_ty matches (stk, res_ty)       return (HsCmdCase x scrut' matches') -tc_cmd env in_cmd@(HsCmdLamCase x matches) (stk, res_ty)-  = addErrCtxt (cmdCtxt in_cmd) $ do-      (co, [scrut_ty], stk') <- matchExpectedCmdArgs 1 stk-      hasFixedRuntimeRep_MustBeRefl-        (FRRArrow $ ArrowCmdCase { isCmdLamCase = True })-        scrut_ty-      matches' <- tcCmdMatches env scrut_ty matches (stk', res_ty)-      return (mkHsCmdWrap (mkWpCastN co) (HsCmdLamCase x matches'))+tc_cmd env cmd@(HsCmdLamCase x lc_variant match) cmd_ty+  = addErrCtxt (cmdCtxt cmd)+      do { let match_ctxt = ArrowLamCaseAlt lc_variant+         ; checkPatCounts (ArrowMatchCtxt match_ctxt) match+         ; (wrap, match') <-+             tcCmdMatchLambda env match_ctxt match cmd_ty+         ; return (mkHsCmdWrap wrap (HsCmdLamCase x lc_variant match')) }  tc_cmd env (HsCmdIf x NoSyntaxExprRn pred b1 b2) res_ty    -- Ordinary 'if'   = do  { pred' <- tcCheckMonoExpr pred boolTy@@ -229,7 +228,7 @@          ; arg' <- tcCheckMonoExpr arg arg_ty -        ; hasFixedRuntimeRep_MustBeRefl+        ; hasFixedRuntimeRep_syntactic             (FRRArrow $ ArrowCmdArrApp (unLoc fun) (unLoc arg) ho_app)             fun_ty @@ -257,7 +256,7 @@     do  { arg_ty <- newOpenFlexiTyVarTy         ; fun'   <- tcCmd env fun (mkPairTy arg_ty cmd_stk, res_ty)         ; arg'   <- tcCheckMonoExpr arg arg_ty-        ; hasFixedRuntimeRep_MustBeRefl+        ; hasFixedRuntimeRep_syntactic             (FRRArrow $ ArrowCmdApp (unLoc fun) (unLoc arg))             arg_ty         ; return (HsCmdApp x fun' arg') }@@ -269,52 +268,9 @@ -- ------------------------------ -- D;G |-a (\x.cmd) : (t,stk) --> res -tc_cmd env-       (HsCmdLam x (MG { mg_alts = L l [L mtch_loc-                                   (match@(Match { m_pats = pats, m_grhss = grhss }))],-                         mg_origin = origin }))-       (cmd_stk, res_ty)-  = addErrCtxt (pprMatchInCtxt match)        $-    do  { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk--                -- Check the patterns, and the GRHSs inside-        ; (pats', grhss') <- setSrcSpanA mtch_loc                                 $-                             tcPats (ArrowMatchCtxt KappaExpr)-                               pats (map (unrestricted . mkCheckExpType) arg_tys) $-                             tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)--        ; let match' = L mtch_loc (Match { m_ext = noAnn-                                         , m_ctxt = ArrowMatchCtxt KappaExpr-                                         , m_pats = pats'-                                         , m_grhss = grhss' })-              arg_tys = map (unrestricted . hsLPatType) pats'--        ; zipWithM_-            (\ (Scaled _ arg_ty) i ->-              hasFixedRuntimeRep_MustBeRefl (FRRArrow $ ArrowCmdLam i) arg_ty)-            arg_tys-            [1..]--        ; let-              cmd' = HsCmdLam x (MG { mg_alts = L l [match']-                                    , mg_ext = MatchGroupTc arg_tys res_ty-                                    , mg_origin = origin })-        ; return (mkHsCmdWrap (mkWpCastN co) cmd') }-  where-    n_pats     = length pats-    match_ctxt = ArrowMatchCtxt KappaExpr-    pg_ctxt    = PatGuard match_ctxt--    tc_grhss (GRHSs x grhss binds) stk_ty res_ty-        = do { (binds', grhss') <- tcLocalBinds binds $-                                   mapM (wrapLocMA (tc_grhs stk_ty res_ty)) grhss-             ; return (GRHSs x grhss' binds') }--    tc_grhs stk_ty res_ty (GRHS x guards body)-        = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $-                                  \ res_ty -> tcCmd env body-                                                (stk_ty, checkingExpType "tc_grhs" res_ty)-             ; return (GRHS x guards' rhs') }+tc_cmd env (HsCmdLam x match) cmd_ty+  = do { (wrap, match') <- tcCmdMatchLambda env KappaExpr match cmd_ty+       ; return (mkHsCmdWrap wrap (HsCmdLam x match')) }  ------------------------------------------- --              Do notation@@ -340,7 +296,7 @@ --      D; G |-a  (| e c1 ... cn |)  :  stk --> t  tc_cmd env cmd@(HsCmdArrForm x expr f fixity cmd_args) (cmd_stk, res_ty)-  = addErrCtxt (cmdCtxt cmd)    $+  = addErrCtxt (cmdCtxt cmd)     do  { (cmd_args', cmd_tys) <- mapAndUnzipM tc_cmd_arg cmd_args                               -- We use alphaTyVar for 'w'         ; let e_ty = mkInfForAllTy alphaTyVar $@@ -361,19 +317,9 @@             ; cmd' <- tcCmdTop env' names' cmd (stk_ty, res_ty)             ; return (cmd',  mkCmdArrTy env' (mkPairTy alphaTy stk_ty) res_ty) } ---------------------------------------------------------------------              Base case for illegal commands--- This is where expressions that aren't commands get rejected--tc_cmd _ cmd _-  = failWithTc (TcRnArrowCommandExpected cmd)---- | Typechecking for case command alternatives. Used for both--- 'HsCmdCase' and 'HsCmdLamCase'.+-- | Typechecking for case command alternatives. Used for 'HsCmdCase'. tcCmdMatches :: CmdEnv-             -> TcType -- ^ Type of the scrutinee.-                       -- Must have a fixed RuntimeRep as per-                       -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete+             -> TcTypeFRR -- ^ Type of the scrutinee.              -> MatchGroup GhcRn (LHsCmd GhcRn)  -- ^ case alternatives              -> CmdType              -> TcM (MatchGroup GhcTc (LHsCmd GhcTc))@@ -385,7 +331,57 @@     mc_body body res_ty' = do { res_ty' <- expTypeToType res_ty'                               ; tcCmd env body (stk, res_ty') } -matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcType], TcType)+-- | Typechecking for 'HsCmdLam' and 'HsCmdLamCase'.+tcCmdMatchLambda :: CmdEnv+                 -> HsArrowMatchContext+                 -> MatchGroup GhcRn (LHsCmd GhcRn)+                 -> CmdType+                 -> TcM (HsWrapper, MatchGroup GhcTc (LHsCmd GhcTc))+tcCmdMatchLambda env+                 ctxt+                 mg@MG { mg_alts = L l matches }+                 (cmd_stk, res_ty)+  = do { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk++       ; let check_arg_tys = map (unrestricted . mkCheckExpType) arg_tys+       ; matches' <- forM matches $+           addErrCtxt . pprMatchInCtxt . unLoc <*> tc_match check_arg_tys cmd_stk'++       ; let arg_tys' = map unrestricted arg_tys+             mg' = mg { mg_alts = L l matches'+                      , mg_ext = MatchGroupTc arg_tys' res_ty }++       ; return (mkWpCastN co, mg') }+  where+    n_pats | isEmptyMatchGroup mg = 1   -- must be lambda-case+           | otherwise            = matchGroupArity mg++    -- Check the patterns, and the GRHSs inside+    tc_match arg_tys cmd_stk' (L mtch_loc (Match { m_pats = pats, m_grhss = grhss }))+      = do { (pats', grhss') <- setSrcSpanA mtch_loc           $+                                tcPats match_ctxt pats arg_tys $+                                tc_grhss grhss cmd_stk' (mkCheckExpType res_ty)++           ; return $ L mtch_loc (Match { m_ext = noAnn+                                        , m_ctxt = match_ctxt+                                        , m_pats = pats'+                                        , m_grhss = grhss' }) }++    match_ctxt = ArrowMatchCtxt ctxt+    pg_ctxt    = PatGuard match_ctxt++    tc_grhss (GRHSs x grhss binds) stk_ty res_ty+        = do { (binds', grhss') <- tcLocalBinds binds $+                                   mapM (wrapLocMA (tc_grhs stk_ty res_ty)) grhss+             ; return (GRHSs x grhss' binds') }++    tc_grhs stk_ty res_ty (GRHS x guards body)+        = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $+                                  \ res_ty -> tcCmd env body+                                                (stk_ty, checkingExpType "tc_grhs" res_ty)+             ; return (GRHS x guards' rhs') }++matchExpectedCmdArgs :: Arity -> TcType -> TcM (TcCoercionN, [TcTypeFRR], TcType) matchExpectedCmdArgs 0 ty   = return (mkTcNomReflCo ty, [], ty) matchExpectedCmdArgs n ty

@@ -34,7 +34,7 @@ import GHC.Hs import GHC.Tc.Errors.Types import GHC.Tc.Gen.Sig-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_MustBeRefl )+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Monad import GHC.Tc.Types.Origin import GHC.Tc.Utils.Env@@ -509,7 +509,7 @@          CheckGen lbind sig -> tcPolyCheck prag_fn sig lbind      ; mapM_ (\ poly_id ->-        hasFixedRuntimeRep_MustBeRefl (FRRBinder $ idName poly_id) (idType poly_id))+        hasFixedRuntimeRep_syntactic (FRRBinder $ idName poly_id) (idType poly_id))         poly_ids      ; traceTc "} End of bindings for" (vcat [ ppr binder_names, ppr rec_group@@ -1384,7 +1384,7 @@             -- See Note [Existentials in pattern bindings]         ; ((pat', nosig_mbis), pat_ty)             <- addErrCtxt (patMonoBindsCtxt pat grhss) $-               tcInfer $ \ exp_ty ->+               tcInferFRR FRRPatBind $ \ exp_ty ->                tcLetPat inst_sig_fun no_gen pat (unrestricted exp_ty) $                  -- The above inferred type get an unrestricted multiplicity. It may be                  -- worth it to try and find a finer-grained multiplicity here

@@ -40,7 +40,7 @@ import GHC.Core.Multiplicity import GHC.Core.UsageEnv import GHC.Tc.Errors.Types-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_MustBeRefl )+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Instantiate import GHC.Tc.Gen.App import GHC.Tc.Gen.Head@@ -240,11 +240,9 @@         ; return (NegApp x expr' neg_expr') }  tcExpr e@(HsIPVar _ x) res_ty-  = do {   {- Implicit parameters must have a *tau-type* not a-              type scheme.  We enforce this by creating a fresh-              type variable as its type.  (Because res_ty may not-              be a tau-type.) -}-         ip_ty <- newOpenFlexiTyVarTy+  = do { ip_ty <- newFlexiTyVarTy liftedTypeKind+          -- Create a unification type variable of kind 'Type'.+          -- (The type of an implicit parameter must have kind 'Type'.)        ; let ip_name = mkStrLitTy (hsIPNameFS x)        ; ipClass <- tcLookupClass ipClassName        ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])@@ -264,13 +262,13 @@     match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }     herald = ExpectedFunTyLam match -tcExpr e@(HsLamCase x matches) res_ty+tcExpr e@(HsLamCase x lc_variant matches) res_ty   = do { (wrap, matches')            <- tcMatchLambda herald match_ctxt matches res_ty-       ; return (mkHsWrap wrap $ HsLamCase x matches') }+       ; return (mkHsWrap wrap $ HsLamCase x lc_variant matches') }   where-    match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }-    herald = ExpectedFunTyLamCase e+    match_ctxt = MC { mc_what = LamCaseAlt lc_variant, mc_body = tcBody }+    herald = ExpectedFunTyLamCase lc_variant e   @@ -346,7 +344,7 @@        -- This should cause an error, even though (17# :: Int#)        -- is not representation-polymorphic: we don't know how        -- wide the concrete representation of the sum type will be.-       ; hasFixedRuntimeRep_MustBeRefl FRRUnboxedSum res_ty+       ; hasFixedRuntimeRep_syntactic FRRUnboxedSum res_ty        ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) }  @@ -384,7 +382,7 @@         ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut          ; traceTc "HsCase" (ppr scrut_ty)-        ; hasFixedRuntimeRep_MustBeRefl FRRCase scrut_ty+        ; hasFixedRuntimeRep_syntactic FRRCase scrut_ty         ; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty         ; return (HsCase x scrut' matches') }  where@@ -952,11 +950,11 @@     go :: Int -> HsTupArg GhcRn -> TcType -> TcM (HsTupArg GhcTc)     go i (Missing {})     arg_ty       = do { mult <- newFlexiTyVarTy multiplicityTy-           ; hasFixedRuntimeRep_MustBeRefl (FRRTupleSection i) arg_ty+           ; hasFixedRuntimeRep_syntactic (FRRTupleSection i) arg_ty            ; return (Missing (Scaled mult arg_ty)) }     go i (Present x expr) arg_ty       = do { expr' <- tcCheckPolyExpr expr arg_ty-           ; hasFixedRuntimeRep_MustBeRefl (FRRTupleArg i) arg_ty+           ; hasFixedRuntimeRep_syntactic (FRRTupleArg i) arg_ty            ; return (Present x expr') }  ---------------------------@@ -1388,7 +1386,7 @@   | Just field_ty <- assocMaybe flds_w_tys sel_name       = addErrCtxt (fieldCtxt field_lbl) $         do { rhs' <- tcCheckPolyExprNC rhs field_ty-           ; hasFixedRuntimeRep_MustBeRefl (FRRRecordUpdate (unLoc lbl) (unLoc rhs'))+           ; hasFixedRuntimeRep_syntactic (FRRRecordUpdate (unLoc lbl) (unLoc rhs'))                 field_ty            ; let field_id = mkUserLocal (nameOccName sel_name)                                         (nameUnique sel_name)

@@ -497,8 +497,7 @@                            -- nor does it need the 'lifting' treatment                            -- hence no checkTh stuff here -                    _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $-                         ppr thing <+> text "used where a value identifier was expected" }+                    _ -> failWithTc $ TcRnExpectedValueId thing }  ------------------------ @@ -553,16 +552,7 @@     UnknownSubordinate (text "field of type" <+> quotes (ppr p))  notSelector :: Name -> TcRnMessage-notSelector field-  = TcRnUnknownMessage $ mkPlainError noHints $-  hsep [quotes (ppr field), text "is not a record selector"]--naughtyRecordSel :: OccName -> TcRnMessage-naughtyRecordSel lbl-  = TcRnUnknownMessage $ mkPlainError noHints $-    text "Cannot use record selector" <+> quotes (ppr lbl) <+>-    text "as a function due to escaped type variables" $$-    text "Probable fix: use pattern-matching syntax instead"+notSelector = TcRnNotARecordSelector   {- *********************************************************************@@ -755,8 +745,7 @@              (tcTyThingTyCon_maybe -> Just tc) -> fail_tycon tc -- TyCon or TcTyCon              ATyVar name _ -> fail_tyvar name -             _ -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $-                  ppr thing <+> text "used where a value identifier was expected" }+             _ -> failWithTc $ TcRnExpectedValueId thing }   where     fail_tycon tc = do       gre <- getGlobalRdrEnv@@ -803,13 +792,14 @@  check_naughty :: OccName -> TcId -> TcM () check_naughty lbl id-  | isNaughtyRecordSelector id = failWithTc (naughtyRecordSel lbl)+  | isNaughtyRecordSelector id = failWithTc (TcRnRecSelectorEscapedTyVar lbl)   | otherwise                  = return ()  tcInferDataCon :: DataCon -> TcM (HsExpr GhcTc, TcSigmaType) -- See Note [Typechecking data constructors] tcInferDataCon con-  = do { let tvs   = dataConUserTyVarBinders con+  = do { let tvbs  = dataConUserTyVarBinders con+             tvs   = binderVars tvbs              theta = dataConOtherTheta con              args  = dataConOrigArgTys con              res   = dataConOrigResTy con@@ -823,7 +813,7 @@                 -- See Note [Instantiating stupid theta]         ; return ( XExpr (ConLikeTc (RealDataCon con) tvs all_arg_tys)-                , mkInvisForAllTys tvs $ mkPhiTy full_theta $+                , mkInvisForAllTys tvbs $ mkPhiTy full_theta $                   mkVisFunTys scaled_arg_tys res ) }   where     linear_to_poly :: Scaled Type -> TcM (Scaled Type)@@ -839,10 +829,8 @@        Just (expr,ty) -> return (expr,ty)        Nothing        -> failWithTc (nonBidirectionalErr id_name) -nonBidirectionalErr :: Outputable name => name -> TcRnMessage-nonBidirectionalErr name = TcRnUnknownMessage $ mkPlainError noHints $-  text "non-bidirectional pattern synonym"-  <+> quotes (ppr name) <+> text "used in an expression"+nonBidirectionalErr :: Name -> TcRnMessage+nonBidirectionalErr = TcRnPatSynNotBidirectional  {- Note [Typechecking data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -874,7 +862,7 @@  4. The (ConLikeTc K [r,a] [Scaled p a]) is later desugared by    GHC.HsToCore.Expr.dsConLike to:-     (/\r a. \(x %p :: a). K @r @a x)+     (/\r (a :: TYPE r). \(x %p :: a). K @r @a x)    which has the desired type given in the previous bullet.    The 'p' is the multiplicity unification variable, which    will by now have been unified to something, or defaulted in@@ -883,22 +871,38 @@  Wrinkles -* Why put [InvisTVBinder] in ConLikeTc, when we only need [TyVar] to-  desugar?  It's a bit of a toss-up, but having [InvisTvBinder] supports-  a future hsExprType :: HsExpr GhcTc -> Type--* Note that the [InvisTvBinder] is strictly redundant anyway; it's-  just the dataConUserTyVarBinders of the data constructor.  Similarly-  in the [Scaled TcType] field of ConLikeTc, the type comes directly+* Note that the [TcType] is strictly redundant anyway; those are the+  type variables from the dataConUserTyVarBinders of the data constructor.+  Similarly in the [Scaled TcType] field of ConLikeTc, the types come directly   from the data constructor.  The only bit that /isn't/ redundant is the   fresh multiplicity variables!    So an alternative would be to define ConLikeTc like this:       | ConLikeTc [TcType]    -- Just the multiplicity variables-  But then the desugarer (and hsExprType, when we implement it) would-  need to repeat some of the work done here.  So for now at least-  ConLikeTc records this strictly-redundant info.+  But then the desugarer would need to repeat some of the work done here.+  So for now at least ConLikeTc records this strictly-redundant info. +* The lambda expression we produce in (4) can have representation-polymorphic+  arguments, as indeed in (/\r (a :: TYPE r). \(x %p :: a). K @r @a x),+  we have a lambda-bound variable x :: (a :: TYPE r).+  This goes against the representation polymorphism invariants given in+  Note [Representation polymorphism invariants] in GHC.Core. The trick is that+  this this lambda will always be instantiated in a way that upholds the invariants.+  This is achieved as follows:++    A. Any arguments to such lambda abstractions are guaranteed to have+       a fixed runtime representation. This is enforced in 'tcApp' by+       'matchActualFunTySigma'.++    B. If there are fewer arguments than there are bound term variables,+       hasFixedRuntimeRep_remainingValArgs will ensure that we are still+       instantiating at a representation-monomorphic type, e.g.++       ( /\r (a :: TYPE r). \ (x %p :: a). K @r @a x) @IntRep @Int#+         :: Int# -> T IntRep Int#++  We then rely on the simple optimiser to beta reduce the lambda.+ * See Note [Instantiating stupid theta] for an extra wrinkle  @@ -990,7 +994,7 @@         -- bindings of the same splice proxy, but that doesn't         -- matter, although it's a mite untidy.     do  { let id_ty = idType id-        ; checkTc (isTauTy id_ty) (polySpliceErr id)+        ; checkTc (isTauTy id_ty) (TcRnSplicePolymorphicLocalVar id)                -- If x is polymorphic, its occurrence sites might                -- have different instantiations, so we can't use plain                -- 'x' as the splice proxy name.  I don't know how to@@ -1023,11 +1027,6 @@     id_name = idName id  checkCrossStageLifting _ _ _ = return ()--polySpliceErr :: Id -> TcRnMessage-polySpliceErr id-  = TcRnUnknownMessage $ mkPlainError noHints $-  text "Can't splice the polymorphic local variable" <+> quotes (ppr id)  {- Note [Lifting strings]

@@ -634,8 +634,7 @@              (kind_args, _) = splitFunTys (tcTypeKind pred)        ; case getClassPredTys_maybe pred of            Just (cls, tys) -> return (tvs, cls, tys, map scaledThing kind_args)-           Nothing -> failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $-             (text "Illegal deriving item" <+> quotes (ppr hs_ty)) }+           Nothing -> failWithTc $ TcRnIllegalDerivingItem hs_ty }  -- | Typecheck a deriving strategy. For most deriving strategies, this is a -- no-op, but for the @via@ strategy, this requires typechecking the @via@ type.@@ -1132,19 +1131,11 @@     -- While top-level bangs at this point are eliminated (eg !(Maybe Int)),     -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of     -- bangs are invalid, so fail. (#7210, #14761)-    = do { let bangError err = failWith $ TcRnUnknownMessage $ mkPlainError noHints $-                 text "Unexpected" <+> text err <+> text "annotation:" <+> ppr ty $$-                 text err <+> text "annotation cannot appear nested inside a type"-         ; case bang of-             HsSrcBang _ SrcUnpack _           -> bangError "UNPACK"-             HsSrcBang _ SrcNoUnpack _         -> bangError "NOUNPACK"-             HsSrcBang _ NoSrcUnpack SrcLazy   -> bangError "laziness"-             HsSrcBang _ _ _                   -> bangError "strictness" }+    = failWith $ TcRnUnexpectedAnnotation ty bang tc_hs_type _ ty@(HsRecTy {})      _       -- Record types (which only show up temporarily in constructor       -- signatures) should have been removed by now-    = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $-       (text "Record syntax is illegal here:" <+> ppr ty)+    = failWithTc $ TcRnIllegalRecordSyntax ty  -- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceType'. -- Here we get rid of it and add the finalizers to the global environment@@ -1158,14 +1149,13 @@  -- This should never happen; type splices are expanded by the renamer tc_hs_type _ ty@(HsSpliceTy {}) _exp_kind-  = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $-     (text "Unexpected type splice:" <+> ppr ty)+  = failWithTc $ TcRnUnexpectedTypeSplice ty  ---------- Functions and applications tc_hs_type mode (HsFunTy _ mult ty1 ty2) exp_kind   = tc_fun_type mode mult ty1 ty2 exp_kind -tc_hs_type mode (HsOpTy _ ty1 (L _ op) ty2) exp_kind+tc_hs_type mode (HsOpTy _ _ ty1 (L _ op) ty2) exp_kind   | op `hasKey` funTyConKey   = tc_fun_type mode (HsUnrestrictedArrow noHsUniTok) ty1 ty2 exp_kind @@ -1508,7 +1498,7 @@     is_app :: HsType GhcRn -> Bool     is_app (HsAppKindTy {})        = True     is_app (HsAppTy {})            = True-    is_app (HsOpTy _ _ (L _ op) _) = not (op `hasKey` funTyConKey)+    is_app (HsOpTy _ _ _ (L _ op) _) = not (op `hasKey` funTyConKey)       -- I'm not sure why this funTyConKey test is necessary       -- Can it even happen?  Perhaps for   t1 `(->)` t2       -- but then maybe it's ok to treat that like a normal@@ -1524,8 +1514,8 @@     go (L _  (HsAppTy _ f a))      as = go f (HsValArg a : as)     go (L _  (HsAppKindTy l ty k)) as = go ty (HsTypeArg l k : as)     go (L sp (HsParTy _ f))        as = go f (HsArgPar (locA sp) : as)-    go (L _  (HsOpTy _ l op@(L sp _) r)) as-      = ( L (na2la sp) (HsTyVar noAnn NotPromoted op)+    go (L _  (HsOpTy _ prom l op@(L sp _) r)) as+      = ( L (na2la sp) (HsTyVar noAnn prom op)         , HsValArg l : HsValArg r : as )     go f as = (f, as) @@ -1707,10 +1697,7 @@     n_initial_val_args _                    = 0      ty_app_err arg ty-      = failWith $ TcRnUnknownMessage $ mkPlainError noHints $-          text "Cannot apply function of kind" <+> quotes (ppr ty)-            $$ text "to visible kind argument" <+> quotes (ppr arg)-+      = failWith $ TcRnInvalidVisibleKindArgument arg ty  mkAppTyM :: TCvSubst          -> TcType -> TyCoBinder    -- fun, plus its top-level binder@@ -2641,7 +2628,7 @@            ; return ([], res) }      go _ [] hs_bndrs-      = failWithTc (tooManyBindersErr sig_res_kind hs_bndrs)+      = failWithTc (TcRnTooManyBinders sig_res_kind hs_bndrs)      go subst (tcb : tcbs') hs_bndrs       | Bndr tv vis <- tcb@@ -2700,13 +2687,6 @@     -- See Note [Source locations for implicitly bound type variables]     -- in GHC.Tc.Rename.HsType -tooManyBindersErr :: Kind -> [LHsTyVarBndr () GhcRn] -> TcRnMessage-tooManyBindersErr ki bndrs = TcRnUnknownMessage $ mkPlainError noHints $-   hang (text "Not a function kind:")-      4 (ppr ki) $$-   hang (text "but extra binders found:")-      4 (fsep (map ppr bndrs))- {- See Note [kcCheckDeclHeader_sig] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Given a kind signature 'sig_kind' and a declaration header,@@ -3022,15 +3002,7 @@     report_dup :: (Name,Name) -> TcM ()     report_dup (n1,n2)       = setSrcSpan (getSrcSpan n2) $-        addErrTc $ TcRnUnknownMessage $ mkPlainError noHints $-        hang (text "Different names for the same type variable:") 2 info-      where-        info | nameOccName n1 /= nameOccName n2-             = quotes (ppr n1) <+> text "and" <+> quotes (ppr n2)-             | otherwise -- Same OccNames! See C2 in-                         -- Note [Swizzling the tyvars before generaliseTcTyCon]-             = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1)-                    , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ]+        addErrTc $ TcRnDifferentNamesForTyVar n1 n2   {- *********************************************************************@@ -3753,31 +3725,6 @@          ; return (go new_occs new_uniqs subst [] kind) } --- | A description of whether something is a------ * @data@ or @newtype@ ('DataDeclSort')------ * @data instance@ or @newtype instance@ ('DataInstanceSort')------ * @data family@ ('DataFamilySort')------ At present, this data type is only consumed by 'checkDataKindSig'.-data DataSort-  = DataDeclSort     NewOrData-  | DataInstanceSort NewOrData-  | DataFamilySort---- | Local helper type used in 'checkDataKindSig'.------ Superficially similar to 'ContextKind', but it lacks 'AnyKind'--- and 'AnyBoxedKind', and instead of @'TheKind' liftedTypeKind@--- provides 'LiftedKind', which is much simpler to match on and--- handle in 'isAllowedDataResKind'.-data AllowedDataResKind-  = AnyTYPEKind-  | AnyBoxedKind-  | LiftedKind- isAllowedDataResKind :: AllowedDataResKind -> Kind -> Bool isAllowedDataResKind AnyTYPEKind  kind = tcIsRuntimeTypeKind kind isAllowedDataResKind AnyBoxedKind kind = tcIsBoxedTypeKind kind@@ -3814,15 +3761,6 @@        -- Look for the result kind after        -- peeling off any foralls and arrows -    pp_dec :: SDoc-    pp_dec = text $-      case data_sort of-        DataDeclSort     DataType -> "Data type"-        DataDeclSort     NewType  -> "Newtype"-        DataInstanceSort DataType -> "Data instance"-        DataInstanceSort NewType  -> "Newtype instance"-        DataFamilySort            -> "Data family"-     is_newtype :: Bool     is_newtype =       case data_sort of@@ -3875,32 +3813,21 @@     is_kind_var | is_data_family = isJust (tcGetCastedTyVar_maybe res_kind)                 | otherwise      = False -    pp_allowed_kind dflags =-      case allowed_kind dflags of-        AnyTYPEKind  -> ppr tYPETyCon-        AnyBoxedKind -> ppr boxedRepDataConTyCon-        LiftedKind   -> ppr liftedTypeKind-     err_msg :: DynFlags -> TcRnMessage-    err_msg dflags = TcRnUnknownMessage $ mkPlainError noHints $-      sep [ sep [ pp_dec <+>-                  text "has non-" <>-                  pp_allowed_kind dflags-                , (if is_data_family then text "and non-variable" else empty) <+>-                  text "return kind" <+> quotes (ppr kind) ]-          , ext_hint dflags ]+    err_msg dflags =+      TcRnInvalidReturnKind data_sort (allowed_kind dflags) kind (ext_hint dflags)      ext_hint dflags       | tcIsRuntimeTypeKind kind       , is_newtype       , not (xopt LangExt.UnliftedNewtypes dflags)-      = text "Perhaps you intended to use UnliftedNewtypes"+      = Just SuggestUnliftedNewtypes       | tcIsBoxedTypeKind kind       , is_datatype       , not (xopt LangExt.UnliftedDatatypes dflags)-      = text "Perhaps you intended to use UnliftedDatatypes"+      = Just SuggestUnliftedDatatypes       | otherwise-      = empty+      = Nothing  -- | Checks that the result kind of a class is exactly `Constraint`, rejecting -- type synonyms and type families that reduce to `Constraint`. See #16826.@@ -3908,9 +3835,7 @@ checkClassKindSig kind = checkTc (tcIsConstraintKind kind) err_msg   where     err_msg :: TcRnMessage-    err_msg = TcRnUnknownMessage $ mkPlainError noHints $-      text "Kind signature on a class must end with" <+> ppr constraintKind $$-      text "unobscured by type families"+    err_msg = TcRnClassKindNotConstraint kind  tcbVisibilities :: TyCon -> [Type] -> [TyConBndrVis] -- Result is in 1-1 correspondence with orig_args@@ -4378,22 +4303,7 @@  promotionErr :: Name -> PromotionErr -> TcM a promotionErr name err-  = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $-      (hang (pprPECategory err <+> quotes (ppr name) <+> text "cannot be used here")-                   2 (parens reason))-  where-    reason = case err of-               ConstrainedDataConPE pred-                              -> text "it has an unpromotable context"-                                 <+> quotes (ppr pred)-               FamDataConPE   -> text "it comes from a data family instance"-               NoDataKindsDC  -> text "perhaps you intended to use DataKinds"-               PatSynPE       -> text "pattern synonyms cannot be promoted"-               RecDataConPE   -> same_rec_group_msg-               ClassPE        -> same_rec_group_msg-               TyConPE        -> same_rec_group_msg--    same_rec_group_msg = text "it is defined and used in the same recursive group"+  = failWithTc $ TcRnUnpromotableThing name err  {- ************************************************************************

@@ -31,6 +31,7 @@    , tcBody    , tcDoStmt    , tcGuardStmt+   , checkPatCounts    ) where @@ -49,7 +50,7 @@ import GHC.Tc.Utils.TcMType import GHC.Tc.Utils.TcType import GHC.Tc.Gen.Bind-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_MustBeRefl )+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Unify import GHC.Tc.Types.Origin import GHC.Tc.Types.Evidence@@ -105,7 +106,9 @@            -- ann-grabbing, because we don't always have annotations in            -- hand when we call tcMatchesFun...           traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)-        ; checkArgs fun_name matches+           -- We can't easily call checkPatCounts here because fun_id can be an+           -- unfilled thunk+        ; checkArgCounts fun_name matches          ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty ->              -- NB: exp_type may be polymorphic, but@@ -161,8 +164,10 @@               -> ExpRhoType               -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc)) tcMatchLambda herald match_ctxt match res_ty-  = matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty ->-    tcMatches match_ctxt pat_tys rhs_ty match+  =  do { checkPatCounts (mc_what match_ctxt) match+        ; matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty -> do+            -- checking argument counts since this is also used for \cases+            tcMatches match_ctxt pat_tys rhs_ty match }   where     n_pats | isEmptyMatchGroup match = 1   -- must be lambda-case            | otherwise               = matchGroupArity match@@ -431,7 +436,7 @@           -- two multiplicity to still be the same.           (rhs', rhs_ty) <- tcScalingUsage Many $ tcInferRhoNC rhs                                    -- Stmt has a context already-        ; hasFixedRuntimeRep_MustBeRefl FRRBindStmtGuard rhs_ty+        ; hasFixedRuntimeRep_syntactic FRRBindStmtGuard rhs_ty         ; (pat', thing)  <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)                                          pat (unrestricted rhs_ty) $                             thing_inside res_ty@@ -593,7 +598,7 @@                                      thing_inside (mkCheckExpType new_res_ty)                   ; return (rhs_ty, rhs', pat_mult, pat', thing, new_res_ty) } -        ; hasFixedRuntimeRep_MustBeRefl (FRRBindStmt MonadComprehension) rhs_ty+        ; hasFixedRuntimeRep_syntactic (FRRBindStmt MonadComprehension) rhs_ty          -- If (but only if) the pattern can fail, typecheck the 'fail' operator         ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->@@ -629,9 +634,9 @@                   ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty)                   ; return (thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op') } -        ; hasFixedRuntimeRep_MustBeRefl FRRBodyStmtGuard test_ty-        ; hasFixedRuntimeRep_MustBeRefl (FRRBodyStmt MonadComprehension 1) rhs_ty-        ; hasFixedRuntimeRep_MustBeRefl (FRRBodyStmt MonadComprehension 2) new_res_ty+        ; hasFixedRuntimeRep_syntactic FRRBodyStmtGuard test_ty+        ; hasFixedRuntimeRep_syntactic (FRRBodyStmt MonadComprehension 1) rhs_ty+        ; hasFixedRuntimeRep_syntactic (FRRBodyStmt MonadComprehension 2) new_res_ty          ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) } @@ -867,7 +872,7 @@                                       thing_inside (mkCheckExpType new_res_ty)                    ; return (rhs_ty, rhs', pat_mult, pat', new_res_ty, thing) } -        ; hasFixedRuntimeRep_MustBeRefl (FRRBindStmt DoNotation) rhs_ty+        ; hasFixedRuntimeRep_syntactic (FRRBindStmt DoNotation) rhs_ty          -- If (but only if) the pattern can fail, typecheck the 'fail' operator         ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->@@ -901,8 +906,8 @@                do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty                   ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty)                   ; return (rhs', rhs_ty, new_res_ty, thing) }-        ; hasFixedRuntimeRep_MustBeRefl (FRRBodyStmt DoNotation 1) rhs_ty-        ; hasFixedRuntimeRep_MustBeRefl (FRRBodyStmt DoNotation 2) new_res_ty+        ; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 1) rhs_ty+        ; hasFixedRuntimeRep_syntactic (FRRBodyStmt DoNotation 2) new_res_ty         ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) }  tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names@@ -1132,23 +1137,35 @@ *                                                                      * ************************************************************************ -@sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same+@checkArgCounts@ takes a @[RenamedMatch]@ and decides whether the same number of args are used in each equation. -} -checkArgs :: AnnoBody body-          => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()-checkArgs _ (MG { mg_alts = L _ [] })+checkArgCounts :: AnnoBody body+               => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()+checkArgCounts = check_match_pats . (text "Equations for" <+>) . quotes . ppr++-- @checkPatCounts@ takes a @[RenamedMatch]@ and decides whether the same+-- number of patterns are used in each alternative+checkPatCounts :: AnnoBody body+               => HsMatchContext GhcTc -> MatchGroup GhcRn (LocatedA (body GhcRn))+               -> TcM ()+checkPatCounts = check_match_pats . pprMatchContextNouns++check_match_pats :: AnnoBody body+                 => SDoc -> MatchGroup GhcRn (LocatedA (body GhcRn))+                 -> TcM ()+check_match_pats _ (MG { mg_alts = L _ [] })     = return ()-checkArgs fun (MG { mg_alts = L _ (match1:matches) })+check_match_pats err_msg (MG { mg_alts = L _ (match1:matches) })     | null bad_matches     = return ()     | otherwise     = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $-      (vcat [ text "Equations for" <+> quotes (ppr fun) <+>-                         text "have different numbers of arguments"-                       , nest 2 (ppr (getLocA match1))-                       , nest 2 (ppr (getLocA (head bad_matches)))])+      (vcat [ err_msg <+>+              text "have different numbers of arguments"+            , nest 2 (ppr (getLocA match1))+            , nest 2 (ppr (getLocA (head bad_matches)))])   where     n_args1 = args_in_match match1     bad_matches = [m | m <- matches, args_in_match m /= n_args1]

@@ -43,7 +43,7 @@ import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Core.Multiplicity-import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_MustBeRefl )+import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep_syntactic ) import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcMType import GHC.Tc.Validity( arityErr )@@ -120,11 +120,13 @@   where     penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin } -tcInferPat :: HsMatchContext GhcTc -> LPat GhcRn+tcInferPat :: FixedRuntimeRepContext+           -> HsMatchContext GhcTc+           -> LPat GhcRn            -> TcM a-           -> TcM ((LPat GhcTc, a), TcSigmaType)-tcInferPat ctxt pat thing_inside-  = tcInfer $ \ exp_ty ->+           -> TcM ((LPat GhcTc, a), TcSigmaTypeFRR)+tcInferPat frr_orig ctxt pat thing_inside+  = tcInferFRR frr_orig $ \ exp_ty ->     tc_lpat (unrestricted exp_ty) penv pat thing_inside  where     penv = PE { pe_lazy = False, pe_ctxt = LamPat ctxt, pe_orig = PatOrigin }@@ -471,7 +473,7 @@  Then, when taking that arrow apart we want to get a *sigma* type (forall b. b->(Int,b)), because that's what we want to bind 'x' to.-Fortunately that's what matchExpectedFunTySigma returns anyway.+Fortunately that's what matchActualFunTySigma returns anyway. -}  -- Type signatures in patterns@@ -932,7 +934,7 @@         -- See test case T20363.         ; zipWithM_             ( \ i arg_sty ->-              hasFixedRuntimeRep_MustBeRefl+              hasFixedRuntimeRep_syntactic                 (FRRDataConArg Pattern data_con i)                 (scaledThing arg_sty)             )@@ -1044,7 +1046,8 @@         ; traceTc "instCall" (ppr req_wrap)            -- Pattern synonyms can never have representation-polymorphic argument types,-          -- as checked in 'GHC.Tc.Gen.Sig.tcPatSynSig' (see use of 'FixedRuntimeRepPatSynSigArg').+          -- as checked in 'GHC.Tc.Gen.Sig.tcPatSynSig' (see use of 'FixedRuntimeRepPatSynSigArg')+          -- and 'GHC.Tc.TyCl.PatSyn.tcInferPatSynDecl'.           -- (If you want to lift this restriction, use 'hasFixedRuntimeRep' here, to match           -- 'tcDataConPat'.)         ; let

@@ -152,13 +152,20 @@         -- See Note [Re-quantify type variables in rules]        ; forall_tkvs <- candidateQTyVarsOfTypes (rule_ty : map idType tpl_ids)-       ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars forall_tkvs+       ; let don't_default = nonDefaultableTyVarsOfWC residual_lhs_wanted+       ; let weed_out = (`dVarSetMinusVarSet` don't_default)+             quant_cands = forall_tkvs { dv_kvs = weed_out (dv_kvs forall_tkvs)+                                       , dv_tvs = weed_out (dv_tvs forall_tkvs) }+       ; qtkvs <- quantifyTyVars skol_info DefaultNonStandardTyVars quant_cands        ; traceTc "tcRule" (vcat [ pprFullRuleName rname-                                , ppr forall_tkvs-                                , ppr qtkvs-                                , ppr rule_ty-                                , ppr ty_bndrs-                                , ppr (qtkvs ++ tpl_ids)+                                , text "forall_tkvs:" <+> ppr forall_tkvs+                                , text "quant_cands:" <+> ppr quant_cands+                                , text "don't_default:" <+> ppr don't_default+                                , text "residual_lhs_wanted:" <+> ppr residual_lhs_wanted+                                , text "qtkvs:" <+> ppr qtkvs+                                , text "rule_ty:" <+> ppr rule_ty+                                , text "ty_bndrs:" <+> ppr ty_bndrs+                                , text "qtkvs ++ tpl_ids:" <+> ppr (qtkvs ++ tpl_ids)                                 , vcat [ ppr id <+> dcolon <+> ppr (idType id) | id <- tpl_ids ]                   ]) @@ -440,7 +447,6 @@                              do { ev_id <- newEvVar pred                                 ; fillCoercionHole hole (mkTcCoVarCo ev_id)                                 ; return ev_id }-          NoDest -> pprPanic "mk_quant_ev: NoDest" (ppr ct)     mk_quant_ev ct = pprPanic "mk_quant_ev" (ppr ct)  @@ -466,9 +472,9 @@   = float_wc emptyVarSet wc   where     float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints)-    float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_holes = holes })+    float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs })       = ( simple_yes `andCts` implic_yes-        , emptyWC { wc_simple = simple_no, wc_impl = implics_no, wc_holes = holes })+        , emptyWC { wc_simple = simple_no, wc_impl = implics_no, wc_errors = errs })      where         (simple_yes, simple_no) = partitionBag (rule_quant_ct skol_tvs) simples         (implic_yes, implics_no) = mapAccumBagL (float_implic skol_tvs)@@ -486,10 +492,6 @@       EqPred _ t1 t2         | not (ok_eq t1 t2)         -> False        -- Note [RULE quantification over equalities]-      SpecialPred {}-        -- Rules should not quantify over special predicates, as these-        -- are a GHC implementation detail.-        -> False       _ -> tyCoVarsOfCt ct `disjointVarSet` skol_tvs      ok_eq t1 t2

@@ -301,7 +301,7 @@       HsListTy _ ty                  -> go ty       HsTupleTy _ _ tys              -> gos tys       HsSumTy _ tys                  -> gos tys-      HsOpTy _ ty1 _ ty2             -> go ty1 && go ty2+      HsOpTy _ _ ty1 _ ty2           -> go ty1 && go ty2       HsParTy _ ty                   -> go ty       HsIParamTy _ _ ty              -> go ty       HsKindSig _ ty kind            -> go ty && go kind

@@ -44,7 +44,6 @@ import GHC.Utils.Error( Validity'(..), Validity, allValid ) import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain ( assert )  import GHC.Data.Pair             ( Pair(..) ) import Data.List        ( nubBy )@@ -552,7 +551,10 @@ -- See Note [The liberal coverage condition] closeWrtFunDeps preds fixed_tvs   | null tv_fds = fixed_tvs -- Fast escape hatch for common case.-  | otherwise   = assert (closeOverKinds fixed_tvs == fixed_tvs)+  | otherwise   = assertPpr (closeOverKinds fixed_tvs == fixed_tvs)+                    (vcat [ text "closeWrtFunDeps: fixed_tvs is not closed over kinds"+                          , text "fixed_tvs:" <+> ppr fixed_tvs+                          , text "closure:" <+> ppr (closeOverKinds fixed_tvs) ])                 $ fixVarSet extend fixed_tvs   where 

@@ -2516,8 +2516,8 @@ getGhciStepIO = do     ghciTy <- getGHCiMonad     a_tv <- newName (mkTyVarOccFS (fsLit "a"))-    let ghciM   = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)-        ioM     = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)+    let ghciM   = nlHsAppTy (nlHsTyVar NotPromoted ghciTy) (nlHsTyVar NotPromoted a_tv)+        ioM     = nlHsAppTy (nlHsTyVar NotPromoted ioTyConName) (nlHsTyVar NotPromoted a_tv)          step_ty :: LHsSigType GhcRn         step_ty = noLocA $ HsSig

@@ -235,15 +235,16 @@                                         -- any skolem variables here |  Note [Wrapping failing kind equalities]                          ; emitImplication implic                          ; failM }-           Just (simples, holes)+           Just (simples, errs)               -> do { _ <- promoteTyVarSet (tyCoVarsOfCts simples)                     ; traceTc "emitFlatConstraints }" $                       vcat [ text "simples:" <+> ppr simples-                           , text "holes:  " <+> ppr holes ]-                    ; emitHoles holes -- Holes don't need promotion+                           , text "errs:   " <+> ppr errs ]+                      -- Holes and other delayed errors don't need promotion+                    ; emitDelayedErrors errs                     ; emitSimples simples } } -floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag Hole)+floatKindEqualities :: WantedConstraints -> Maybe (Bag Ct, Bag DelayedError) -- Float out all the constraints from the WantedConstraints, -- Return Nothing if any constraints can't be floated (captured -- by skolems), or if there is an insoluble constraint, or@@ -256,15 +257,15 @@ -- See Note [floatKindEqualities vs approximateWC] floatKindEqualities wc = float_wc emptyVarSet wc   where-    float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag Hole)+    float_wc :: TcTyCoVarSet -> WantedConstraints -> Maybe (Bag Ct, Bag DelayedError)     float_wc trapping_tvs (WC { wc_simple = simples                               , wc_impl = implics-                              , wc_holes = holes })+                              , wc_errors = errs })       | all is_floatable simples-      = do { (inner_simples, inner_holes)+      = do { (inner_simples, inner_errs)                 <- flatMapBagPairM (float_implic trapping_tvs) implics            ; return ( simples `unionBags` inner_simples-                    , holes `unionBags` inner_holes) }+                    , errs `unionBags` inner_errs) }       | otherwise       = Nothing       where@@ -272,7 +273,7 @@            | insolubleEqCt ct = False            | otherwise        = tyCoVarsOfCt ct `disjointVarSet` trapping_tvs -    float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag Hole)+    float_implic :: TcTyCoVarSet -> Implication -> Maybe (Bag Ct, Bag DelayedError)     float_implic trapping_tvs (Implic { ic_wanted = wanted, ic_given_eqs = given_eqs                                       , ic_skols = skols, ic_status = status })       | isInsolubleStatus status@@ -496,14 +497,22 @@       , gopt Opt_PrintExplicitRuntimeReps dflags -- See Note [Defaulting insolubles]       = try_class_defaulting wc       | otherwise-      = do { free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)-           ; let meta_tvs = filter (isTyVar <&&> isMetaTyVar) free_tvs-                   -- zonkTyCoVarsAndFV: the wc_first_go is not yet zonked-                   -- filter isMetaTyVar: we might have runtime-skolems in GHCi,-                   -- and we definitely don't want to try to assign to those!-                   -- The isTyVar is needed to weed out coercion variables+      = do { -- Need to zonk first, as the WantedConstraints are not yet zonked.+           ; free_tvs <- TcS.zonkTyCoVarsAndFVList (tyCoVarsOfWCList wc)+           ; let defaultable_tvs = filter can_default free_tvs+                 can_default tv+                   =   isTyVar tv+                       -- Weed out coercion variables. -           ; defaulted <- mapM defaultTyVarTcS meta_tvs   -- Has unification side effects+                    && isMetaTyVar tv+                       -- Weed out runtime-skolems in GHCi, which we definitely+                       -- shouldn't try to default.++                    && not (tv `elemVarSet` nonDefaultableTyVarsOfWC wc)+                       -- Weed out variables for which defaulting would be unhelpful,+                       -- e.g. alpha appearing in [W] alpha[conc] ~# rr[sk].++           ; defaulted <- mapM defaultTyVarTcS defaultable_tvs -- Has unification side effects            ; if or defaulted              then do { wc_residual <- nestTcS (solveWanteds wc)                             -- See Note [Must simplify after defaulting]@@ -513,7 +522,7 @@     try_class_defaulting :: WantedConstraints -> TcS WantedConstraints     try_class_defaulting wc       | isEmptyWC wc || insolubleWC wc -- See Note [Defaulting insolubles]-      = return wc+      = try_callstack_defaulting wc       | otherwise  -- See Note [When to do type-class defaulting]       = do { something_happened <- applyDefaultingRules wc                                    -- See Note [Top-level Defaulting Plan]@@ -594,6 +603,20 @@ errors if there are *any* insoluble errors, anywhere, but that seems too drastic. +Note [Don't default in syntactic equalities]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When there are unsolved syntactic equalities such as++  rr[sk] ~S# alpha[conc]++we should not default alpha, lest we obtain a poor error message such as++  Couldn't match kind `rr' with `LiftedRep'++We would rather preserve the original syntactic equality to be+reported to the user, especially as the concrete metavariable alpha+might store an informative origin for the user.+ Note [Must simplify after defaulting] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We may have a deeply buried constraint@@ -797,9 +820,25 @@  which is just plain wrong. -Conclusion: we should do RuntimeRep-defaulting on insolubles only when the user does not-want to hear about RuntimeRep stuff -- that is, when -fprint-explicit-runtime-reps-is not set.+Another situation in which we don't want to default involves concrete metavariables.++In equalities such as   alpha[conc] ~# rr[sk]  ,  alpha[conc] ~# RR beta[tau]+for a type family RR (all at kind RuntimeRep), we would prefer to report a+representation-polymorphism error rather than default alpha and get error:++  Could not unify `rr` with `Lifted` / Could not unify `RR b0` with `Lifted`++which is very confusing. For this reason, we weed out the concrete+metavariables participating in such equalities in nonDefaultableTyVarsOfWC.+Just looking at insolublity is not enough, as `alpha[conc] ~# RR beta[tau]` could+become soluble after defaulting beta (see also #21430).++Conclusion: we should do RuntimeRep-defaulting on insolubles only when the+user does not want to hear about RuntimeRep stuff -- that is, when+-fprint-explicit-runtime-reps is not set.+However, we must still take care not to default concrete type variables+participating in an equality with a non-concrete type, as seen in the+last example above. -}  ------------------@@ -1672,7 +1711,7 @@        ; tc_lvl <- TcM.getTcLevel        ; let psig_tys = mkTyVarTys psig_qtvs ++ psig_theta -             co_vars = coVarsOfTypes (psig_tys ++ taus)+             co_vars = coVarsOfTypes (psig_tys ++ taus ++ candidates)              co_var_tvs = closeOverKinds co_vars                -- The co_var_tvs are tvs mentioned in the types of covars or                -- coercion holes. We can't quantify over these covars, so we@@ -2216,7 +2255,7 @@        ; return result }  solveWanteds :: WantedConstraints -> TcS WantedConstraints-solveWanteds wc@(WC { wc_holes = holes })+solveWanteds wc@(WC { wc_errors = errs })   = do { cur_lvl <- TcS.getTcLevel        ; traceTcS "solveWanteds {" $          vcat [ text "Level =" <+> ppr cur_lvl@@ -2225,8 +2264,8 @@        ; dflags <- getDynFlags        ; solved_wc <- simplify_loop 0 (solverIterations dflags) True wc -       ; holes' <- simplifyHoles holes-       ; let final_wc = solved_wc { wc_holes = holes' }+       ; errs' <- simplifyDelayedErrors errs+       ; let final_wc = solved_wc { wc_errors = errs' }         ; ev_binds_var <- getTcEvBindsVar        ; bb <- TcS.getTcEvBindsMap ev_binds_var@@ -2268,6 +2307,7 @@                                      , wc_impl = implics2 }) }         ; unif_happened <- resetUnificationFlag+       ; csTraceTcS $ text "unif_happened" <+> ppr unif_happened          -- Note [The Unification Level Flag] in GHC.Tc.Solver.Monad        ; maybe_simplify_again (n+1) limit unif_happened wc2 } @@ -2483,12 +2523,12 @@                  then Nothing                  else Just final_implic }  where-   WC { wc_simple = simples, wc_impl = implics, wc_holes = holes } = wc+   WC { wc_simple = simples, wc_impl = implics, wc_errors = errs } = wc     pruned_implics = filterBag keep_me implics    pruned_wc = WC { wc_simple = simples                   , wc_impl   = pruned_implics-                  , wc_holes  = holes }   -- do not prune holes; these should be reported+                  , wc_errors = errs }   -- do not prune holes; these should be reported     keep_me :: Implication -> Bool    keep_me ic@@ -2602,9 +2642,13 @@      | otherwise = evVarsOfTerm rhs `unionVarSet` needs  --------------------------------------------------simplifyHoles :: Bag Hole -> TcS (Bag Hole)-simplifyHoles = mapBagM simpl_hole+simplifyDelayedErrors :: Bag DelayedError -> TcS (Bag DelayedError)+simplifyDelayedErrors = mapBagM simpl_err   where+    simpl_err :: DelayedError -> TcS DelayedError+    simpl_err (DE_Hole hole) = DE_Hole <$> simpl_hole hole+    simpl_err err@(DE_NotConcrete {}) = return err+     simpl_hole :: Hole -> TcS Hole       -- See Note [Do not simplify ConstraintHoles]@@ -2836,23 +2880,20 @@ -- | Like 'defaultTyVar', but in the TcS monad. defaultTyVarTcS :: TcTyVar -> TcS Bool defaultTyVarTcS the_tv-  | isRuntimeRepVar the_tv-  , not (isTyVarTyVar the_tv)+  | isTyVarTyVar the_tv     -- TyVarTvs should only be unified with a tyvar     -- never with a type; c.f. GHC.Tc.Utils.TcMType.defaultTyVar     -- and Note [Inferring kinds for type declarations] in GHC.Tc.TyCl+  = return False+  | isRuntimeRepVar the_tv   = do { traceTcS "defaultTyVarTcS RuntimeRep" (ppr the_tv)        ; unifyTyVar the_tv liftedRepTy        ; return True }   | isLevityVar the_tv-  , not (isTyVarTyVar the_tv)   = do { traceTcS "defaultTyVarTcS Levity" (ppr the_tv)        ; unifyTyVar the_tv liftedDataConTy        ; return True }   | isMultiplicityVar the_tv-  , not (isTyVarTyVar the_tv)  -- TyVarTvs should only be unified with a tyvar-                             -- never with a type; c.f. TcMType.defaultTyVar-                             -- See Note [Kind generalisation and SigTvs]   = do { traceTcS "defaultTyVarTcS Multiplicity" (ppr the_tv)        ; unifyTyVar the_tv manyDataConTy        ; return True }

@@ -124,9 +124,6 @@   = {-# SCC "canEqLeafTyVarEq" #-}     canEqNC ev eq_rel (canEqLHSType lhs) rhs -canonicalize (CSpecialCan { cc_ev = ev, cc_special_pred = special_pred })-  = canSpecial ev special_pred- canNC :: CtEvidence -> TcS (StopOrContinue Ct) canNC ev =   case classifyPredType pred of@@ -138,8 +135,6 @@                                   canIrred ev       ForAllPred tvs th p   -> do traceTcS "canEvNC:forall" (ppr pred)                                   canForAllNC ev tvs th p-      SpecialPred spec      -> do traceTcS "canEvNC:special" (ppr pred)-                                  canSpecial ev spec    where     pred = ctEvPred ev@@ -750,9 +745,6 @@                                     -- in with a polytype. This is #18987.                                     do traceTcS "canEvNC:forall" (ppr pred)                                        canForAllNC ev tvs th p-           SpecialPred {}        -> -- IrredPreds have kind Constraint, so cannot-                                    -- become SpecialPreds-                                    pprPanic "canIrred: SpecialPred" (ppr ev)            IrredPred {}          -> continueWith $                                     mkIrredCt IrredShapeReason new_ev } } @@ -923,47 +915,7 @@ via addInertForall.  Then, if we look up (C x Int Bool), say, we'll find a match in the InstEnv. - ************************************************************************-*                                                                      *-*                       Special predicates-*                                                                      *-********************************************************************* -}---- | Canonicalise a 'SpecialPred' constraint.-canSpecial :: CtEvidence -> SpecialPred -> TcS (StopOrContinue Ct)-canSpecial ev special_pred =-  case special_pred of-    IsReflPrimPred lhs rhs ->-      canIsReflPrim ev lhs rhs---- | Canonicalise a 'IsRefl#' constraint: zonk the lhs and rhs,--- and solve it if they are equal.------ See Note [IsRefl#] in GHC.Tc.Utils.Concrete.------ Important: we never rewrite the arguments to an 'IsRefl#' constraint--- (we only zonk them), as rewriting would defeat the whole purpose of the constraint!-canIsReflPrim :: CtEvidence -> TcType -> TcType -> TcS (StopOrContinue Ct)-canIsReflPrim ev lhs rhs-  = do { -- IsRefl# constraints should never appear in Givens.-       ; massertPpr (not $ isGivenOrigin $ ctEvOrigin ev)-           (text "canIsReflPrim: Given IsRefl# constraint" $$ ppr ev)-       ; lhs <- zonkTcType lhs-       ; rhs <- zonkTcType rhs-       ; if lhs `tcEqType` rhs-         then stopWith ev "Solved IsRefl#"-         else-    do { let new_pty  = mkIsReflPrimPred lhs rhs-             new_ev   = setCtEvPredType ev new_pty-             new_ct   = CSpecialCan { cc_ev = new_ev-                                    , cc_special_pred = IsReflPrimPred lhs rhs }-       ; traceTcS "canIsReflPrim continueWith" $-           vcat [ text "new_ev =" <+> ppr new_ev-                , text "lhs =" <+> ppr lhs, text "rhs =" <+> ppr rhs ]-       ; continueWith new_ct }}--{-********************************************************************** *                                                                      * *        Equalities *                                                                      *

@@ -140,13 +140,13 @@ -- Try solving these constraints -- Affects the unification state (of course) but not the inert set -- The result is not necessarily zonked-solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_holes = holes })+solve_simple_wanteds (WC { wc_simple = simples1, wc_impl = implics1, wc_errors = errs })   = nestTcS $     do { solveSimples simples1        ; (implics2, unsolved) <- getUnsolvedInerts        ; return (WC { wc_simple = unsolved                     , wc_impl   = implics1 `unionBags` implics2-                    , wc_holes  = holes }) }+                    , wc_errors = errs }) }  {- Note [The solveSimpleWanteds loop] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -429,9 +429,6 @@              CEqCan       {} -> interactEq      ics wi              CIrredCan    {} -> interactIrred   ics wi              CDictCan     {} -> interactDict    ics wi-             CSpecialCan { cc_special_pred = spec } ->-               case spec of-                 IsReflPrimPred {} -> continueWith wi -- cannot have IsRefl# Givens, so nothing to interact with              _ -> pprPanic "interactWithInerts" (ppr wi) }                 -- CNonCanonical have been canonicalised @@ -1895,11 +1892,6 @@             CIrredCan {} ->              doTopReactOther work_item--           CSpecialCan { cc_special_pred = spec } ->-             case spec of-               IsReflPrimPred {} -> continueWith work_item-               -- No top-level interactions for IsRefl# constraints.             -- Any other work item does not react with any top-level equations            _  -> continueWith work_item }

@@ -648,8 +648,6 @@     CQuantCan {}     -> panic "removeInertCt: CQuantCan"     CIrredCan {}     -> panic "removeInertCt: CIrredEvCan"     CNonCanonical {} -> panic "removeInertCt: CNonCanonical"-    CSpecialCan { cc_special_pred = special_pred } ->-      pprPanic "removeInertCt" (ppr "CSpecialCan" <+> parens (ppr special_pred))  -- | Looks up a family application in the inerts. lookupFamAppInert :: (CtFlavourRole -> Bool)  -- can it rewrite the target?@@ -1253,8 +1251,11 @@ touchabilityTest flav tv1 rhs   | flav /= Given  -- See Note [Do not unify Givens]   , MetaTv { mtv_tclvl = tv_lvl, mtv_info = info } <- tcTyVarDetails tv1-  , canSolveByUnification info rhs-  = do { ambient_lvl  <- getTcLevel+  = do { can_continue_solving <- wrapTcS $ startSolvingByUnification info rhs+       ; if not can_continue_solving+         then return Untouchable+         else+    do { ambient_lvl  <- getTcLevel        ; given_eq_lvl <- getInnermostGivenEqLevel         ; if | tv_lvl `sameDepthAs` ambient_lvl@@ -1265,7 +1266,7 @@             -> return (TouchableOuterLevel free_metas tv_lvl)              | otherwise-            -> return Untouchable }+            -> return Untouchable } }   | otherwise   = return Untouchable   where@@ -1605,7 +1606,6 @@   = do { useVars (coVarsOfCo co)        ; fillCoercionHole hole co } setWantedEq (EvVarDest ev) _ = pprPanic "setWantedEq: EvVarDest" (ppr ev)-setWantedEq NoDest         _ = panic "setWantedEq: NoDest"  -- | Good for both equalities and non-equalities setWantedEvTerm :: TcEvDest -> EvTerm -> TcS ()@@ -1621,8 +1621,6 @@  setWantedEvTerm (EvVarDest ev_id) tm   = setEvBind (mkWantedEvBind ev_id tm)-setWantedEvTerm NoDest tm-  = pprPanic "setWantedEvTerm: NoDest" (ppr tm)  {- Note [Yukky eq_sel for a HoleDest] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -210,9 +210,7 @@             -> PatSynMatcher -> PatSynBuilder             -> ([InvisTVBinder], ThetaType) -- ^ Univ and req             -> ([InvisTVBinder], ThetaType) -- ^ Ex and prov-            -> [Type]                       -- ^ Argument types-                                            -- These must have a fixed RuntimeRep as per-                                            -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.+            -> [FRRType]                    -- ^ Argument types             -> Type                         -- ^ Result type             -> [FieldLabel]                 -- ^ Field labels for                                             --   a record pattern synonym

@@ -924,7 +924,7 @@                   -- Check that the result kind of the TyCon applied to its args                   -- is compatible with the explicit signature (or Type, if there                   -- is none)-                  ; let hs_lhs = nlHsTyConApp fixity (getName fam_tc) hs_pats+                  ; let hs_lhs = nlHsTyConApp NotPromoted fixity (getName fam_tc) hs_pats                   ; _ <- unifyKind (Just . HsTypeRnThing $ unLoc hs_lhs) lhs_applied_kind res_kind                    ; traceTc "tcDataFamInstHeader" $

@@ -43,7 +43,7 @@ import GHC.Types.Var import GHC.Types.Var.Env( emptyTidyEnv, mkInScopeSet ) import GHC.Types.Id-import GHC.Types.Id.Info( RecSelParent(..), setLevityInfoWithType )+import GHC.Types.Id.Info( RecSelParent(..) ) import GHC.Tc.Gen.Bind import GHC.Types.Basic import GHC.Tc.Solver@@ -150,8 +150,8 @@         ; let (arg_names, is_infix) = collectPatSynArgInfo details        ; (tclvl, wanted, ((lpat', args), pat_ty))-            <- pushLevelAndCaptureConstraints  $-               tcInferPat PatSyn lpat          $+            <- pushLevelAndCaptureConstraints      $+               tcInferPat FRRPatSynArg PatSyn lpat $                mapM tcLookupId arg_names         ; let (ex_tvs, prov_dicts) = tcCollectEx lpat'@@ -669,9 +669,9 @@                  -> TcPragEnv                  -> ([TcInvisTVBinder], [PredType], TcEvBinds, [EvVar])                  -> ([TcInvisTVBinder], [TcType], [PredType], [EvTerm])-                 -> ([LHsExpr GhcTc], [TcType])+                 -> ([LHsExpr GhcTc], [TcTypeFRR])                    -- ^ Pattern arguments and types.-                   -- These must have a fixed RuntimeRep as per+                   -- These must have a syntactically fixed RuntimeRep as per                    -- Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.                  -> TcType            -- ^ Pattern type                  -> [FieldLabel]      -- ^ Selector names@@ -910,9 +910,7 @@             Just (builder_name, builder_ty, need_dummy_arg) ->  -- Normal case     do { -- Bidirectional, so patSynBuilder returns Just-         let pat_ty = patSynResultType patsyn-             builder_id = modifyIdInfo (`setLevityInfoWithType` pat_ty) $-                          mkExportedVanillaId builder_name builder_ty+         let builder_id = mkExportedVanillaId builder_name builder_ty                          -- See Note [Exported LocalIds] in GHC.Types.Id              prags = lookupPragEnv prag_fn ps_name              -- See Note [Pragmas for pattern synonyms]

@@ -7,33 +7,46 @@ module GHC.Tc.Utils.Concrete   ( -- * Ensuring that a type has a fixed runtime representation     hasFixedRuntimeRep-  , hasFixedRuntimeRep_MustBeRefl+  , hasFixedRuntimeRep_syntactic++    -- * Making a type concrete+  , makeTypeConcrete   )  where  import GHC.Prelude -import GHC.Builtin.Types       ( unliftedTypeKindTyCon, liftedTypeKindTyCon )+import GHC.Builtin.Types       ( liftedTypeKindTyCon, unliftedTypeKindTyCon ) -import GHC.Core.Coercion       ( Role(..) )-import GHC.Core.Predicate      ( mkIsReflPrimPred )-import GHC.Core.TyCo.Rep       ( Type(TyConApp), mkTyVarTy )-import GHC.Core.Type           ( isConcrete, typeKind )+import GHC.Core.Coercion       ( coToMCo, mkCastTyMCo )+import GHC.Core.TyCo.Rep       ( Type(..), MCoercion(..) )+import GHC.Core.TyCon          ( isConcreteTyCon )+import GHC.Core.Type           ( isConcrete, typeKind, tyVarKind, tcView+                               , mkTyVarTy, mkTyConApp, mkFunTy, mkAppTy ) -import GHC.Tc.Types            ( TcM, ThStage(Brack), PendingStuff(TcPending) )-import GHC.Tc.Types.Constraint ( mkNonCanonical )-import GHC.Tc.Types.Evidence   ( TcCoercion )-import GHC.Tc.Types.Origin     ( CtOrigin(..), FRROrigin(..) )-import GHC.Tc.Utils.Monad      ( emitSimple, getStage )-import GHC.Tc.Utils.TcType     ( TcType, TcKind, TcTyVar, MetaInfo(ConcreteTv) )-import GHC.Tc.Utils.TcMType    ( newAnonMetaTyVar, newWanted, emitWantedEq )+import GHC.Tc.Types            ( TcM, ThStage(..), PendingStuff(..) )+import GHC.Tc.Types.Constraint ( NotConcreteError(..), NotConcreteReason(..) )+import GHC.Tc.Types.Evidence   ( Role(..), TcCoercionN, TcMCoercionN+                               , mkTcGReflRightMCo, mkTcNomReflCo )+import GHC.Tc.Types.Origin     ( CtOrigin(..), FixedRuntimeRepContext, FixedRuntimeRepOrigin(..) )+import GHC.Tc.Utils.Monad      ( emitNotConcreteError, setTcLevel, getCtLocM, getStage, traceTc )+import GHC.Tc.Utils.TcType     ( TcType, TcKind, TcTypeFRR+                               , MetaInfo(..), ConcreteTvOrigin(..)+                               , isMetaTyVar, metaTyVarInfo, tcTyVarLevel )+import GHC.Tc.Utils.TcMType    ( newConcreteTyVar, isFilledMetaTyVar_maybe, writeMetaTyVar+                               , emitWantedEq )  import GHC.Types.Basic         ( TypeOrKind(..) )- import GHC.Utils.Misc          ( HasDebugCallStack ) import GHC.Utils.Outputable-import GHC.Utils.Panic         ( assertPpr ) +import Control.Monad      ( void )+import Data.Functor       ( ($>) )+import Data.List.NonEmpty ( NonEmpty((:|)) )++import Control.Monad.Trans.Class      ( lift )+import Control.Monad.Trans.Writer.CPS ( WriterT, runWriterT, tell )+ {- Note [Concrete overview] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ GHC ensures that certain types have a fixed runtime representation in the@@ -109,8 +122,8 @@     Note [Reporting representation-polymorphism errors] in GHC.Tc.Types.Origin      When we emit a constraint to enforce a fixed representation, we also provide-    a 'FRROrigin' which gives context about the check being done. This origin gets-    reported to the user if we end up with such an an unsolved Wanted constraint.+    a 'FixedRuntimeRepOrigin' which gives context about the check being done.+    This origin gets reported to the user if we end up with such an an unsolved Wanted constraint.  Note [Representation polymorphism checking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -166,7 +179,7 @@             - a concrete type constructor (as defined below), or             - a concrete type variable (see Note [ConcreteTv] below), or             - an application of a concrete type to another concrete type-            See GHC.Core.Type.isConcrete+GHC.Core.Type.isConcrete checks whether a type meets this definition.  Definition: a /concrete type constructor/ is defined by             - a promoted data constructor@@ -175,7 +188,7 @@             - an abstract type as defined in a Backpack signature file               (see Note [Synonyms implement abstract data] in GHC.Tc.Module)             In particular, type and data families are not concrete.-            See GHC.Core.TyCon.isConcreteTyCon.+GHC.Core.TyCon.isConcreteTyCon checks whether a TyCon meets this definition.  Examples of concrete types:    Lifted, BoxedRep Lifted, TYPE (BoxedRep Lifted) are all concrete@@ -194,9 +207,6 @@ Concrete Kinds Property (CKP)   The kind of a concrete type is concrete. -The CCP and the CKP taken together mean that we never have to inspect-in kinds to check concreteness.- Note [ConcreteTv] ~~~~~~~~~~~~~~~~~ A concrete metavariable is a metavariable whose 'MetaInfo' is 'ConcreteTv'.@@ -224,8 +234,9 @@       ki ~# concrete_tv      The origin for such an equality constraint uses-    `GHC.Tc.Types.Origin.FRROrigin`, so that we can report the appropriate-    representation-polymorphism error if any such constraint goes unsolved.+    `GHC.Tc.Types.Origin.FixedRuntimeRepOrigin`, so that we can report the+    appropriate representation-polymorphism error if any such constraint+    goes unsolved.  To solve `ki ~# concrete_ki`, we must unify `concrete_tv := concrete_ki`, where `concrete_ki` is some concrete type. We can then compute `kindPrimRep`@@ -238,19 +249,16 @@  The Concrete mechanism is being implemented in two separate phases. -In PHASE 1 (currently implemented), we enforce that we only solve the emitted-constraints `co :: ki ~# concrete_tv` with `Refl`. This forbids any program+In PHASE 1, we enforce that we only solve the emitted constraints+`co :: ki ~# concrete_tv` with `Refl`. This forbids any program which requires type family evaluation in order to determine that a 'RuntimeRep'-is fixed. We do this using the `IsRefl#` special predicate (see Note [IsRefl#]);-we only solve `IsRefl# a b` if `a` and `b` are equal (after zonking, but not rewriting).-This means that it is safe to not use the coercion `co` anywhere in the program.-PHASE 1 corresponds to calls to `hasFixedRuntimeRep_MustBeRefl` in the code: on top-of emitting a constraint of the form `ki ~# concrete_tv`, we also emit-`IsRefl# ki concrete_tv` to ensure we only solve the equality constraint using-reflexivity.+is fixed.+To achieve this, instead of creating a new concrete metavariable, we directly+ensure that 'ki' is concrete, using 'makeTypeConcrete'. If it fails, then+we report an error (even though rewriting might have allowed us to proceed).  In PHASE 2, we lift this restriction. This means we replace a call to-`hasFixedRuntimeRep_MustBeRefl` with a call to `hasFixedRuntimeRep`, and insert the+`hasFixedRuntimeRep_syntactic` with a call to `hasFixedRuntimeRep`, and insert the obtained coercion in the typechecked result. To illustrate what this entails, recall that the code generator needs to be able to compute 'PrimRep's, so that it can put function arguments in the correct registers, etc.@@ -274,17 +282,37 @@ As `( a |> kco ) :: TYPE Int#`, the code generator knows to use a machine-sized integer register for `x`, and all is good again. +Because we can convert calls from hasFixedRuntimeRep_syntactic to+hasFixedRuntimeRep one at a time, we can migrate from PHASE 1 to PHASE 2+incrementally.+ Example test cases that require PHASE 2: T13105, T17021, T20363b.  Note [Fixed RuntimeRep] ~~~~~~~~~~~~~~~~~~~~~~~-Definition:-  a type `ty :: ki` has a /fixed RuntimeRep/-    <=>-  there exists a concrete type `concrete_ty` (in the sense of Note [Concrete types])-  such that we can solve `ki ~# concrete_ty`.+Definitions: -This definition is crafted to be useful to satisfy the invariants of+  FRR.++    The type `ty :: ki` has a /syntactically fixed RuntimeRep/+    (we also say that `ty` is an `FRRType`)+      <=>+    the kind `ki` is concrete (in the sense of Note [Concrete types])+      <=>+    `typePrimRep ty` (= `kindPrimRep ki`) does not crash+    (assuming that typechecking succeeded, so that all metavariables+    in `ty` have been filled)++  Fixed RuntimeRep.++    The type `ty :: ki` has a /fixed RuntimeRep/+      <=>+    there exists an FRR type `ty'` with `ty ~# ty'`+      <=>+    there exists a concrete type `concrete_ki` such that+    `ki ~ concrete_ki`++These definitions are crafted to be useful to satisfy the invariants of Core; see Note [Representation polymorphism invariants] in GHC.Core.  Notice that "fixed RuntimeRep" means (for now anyway) that@@ -307,6 +335,16 @@ `concrete_tv` of kind `ki`, and emit a constraint `ki ~# concrete_tv`, which will only be solved if we can prove that 'ty' indeed has a fixed RuntimeRep. +If we can solve the equality constraint, i.e. produce a coercion+`kco :: ki ~# concrete_tv`, then 'hasFixedRuntimeRep' returns the coercion++  co = GRefl ty kco :: ty ~# ty |> kco++The RHS of the coercion `co` is `ty |> kco`. The kind of this type is+concrete (by construction), which means that `ty |> kco` is an FRRType+in the sense of Note [Fixed RuntimeRep], so that we can directely compute+its runtime representation using `typePrimRep`.+   [Wrinkle: Typed Template Haskell]     We don't perform any checks when type-checking a typed Template Haskell quote:     we want to allow representation polymorphic quotes, as long as they are@@ -338,132 +376,309 @@     this shouldn't cause any problems in practice.  See ticket #18170.      Test case: rep-poly/T18170a.--Note [IsRefl#]-~~~~~~~~~~~~~~-`IsRefl# :: forall k. k -> k -> TYPE (TupleRep '[])` is a constraint with no-evidence. `IsRefl# a b' can be solved precisely when `a` and `b` are equal (up to zonking,-but __without__ any rewriting).--That is, if we have a type family `F` with `F Int` reducing to `Int`, we __cannot__ solve-`IsRefl# (F Int) Int`.--What is the point of such a constraint? As outlined in Note [The Concrete mechanism],-to check `ty :: ki` has a fixed RuntimeRep we create a concrete metavariable `concrete_tv`-and emit a Wanted equality constraint--  {co_hole} :: ki ~# concrete_tv--Then, when we fill in the coercion hole with a coercion `co`, we must make use of it-(as that Note explains). If we don't, then we can only safely discard it if it is-reflexive. Therefore, whenever we perform a representation polymorphism check but also-discard the resulting coercion, we also emit a special constraint `IsRefl# ki concrete_tv`.-See 'hasFixedRuntimeRep_MustBeRefl', which calls 'hasFixedRuntimeRep', and thenemits-an 'IsRefl#' constraint to ensure that discarding the coercion is safe. -} --- | Like 'hasFixedRuntimeRep', but we insist that the obtained coercion must be 'Refl'.+-- | Given a type @ty :: ki@, this function ensures that @ty@+-- has a __fixed__ 'RuntimeRep', by emitting a new equality constraint+-- @ki ~ concrete_tv@ for a concrete metavariable @concrete_tv@. --+-- Returns a coercion @co :: ty ~# concrete_ty@ as evidence.+-- If @ty@ obviously has a fixed 'RuntimeRep', e.g @ki = IntRep@,+-- then this function immediately returns 'MRefl',+-- without emitting any constraints.+hasFixedRuntimeRep :: HasDebugCallStack+                   => FixedRuntimeRepContext+                        -- ^ Context to be reported to the user+                        -- if the type ends up not having a fixed+                        -- 'RuntimeRep'.+                   -> TcType+                        -- ^ The type to check (we only look at its kind).+                   -> TcM (TcCoercionN, TcTypeFRR)+                        -- ^ @(co, ty')@ where @ty' :: ki'@,+                        -- @ki@ is concrete, and @co :: ty ~# ty'@.+                        -- That is, @ty'@ has a syntactically fixed RuntimeRep+                        -- in the sense of Note [Fixed RuntimeRep].+hasFixedRuntimeRep frr_ctxt ty = checkFRR_with unifyConcrete frr_ctxt ty++-- | Like 'hasFixedRuntimeRep', but we perform an eager syntactic check.+--+-- Throws an error in the 'TcM' monad if the check fails.+-- -- This is useful if we are not actually going to use the coercion returned -- from 'hasFixedRuntimeRep'; it would generally be unsound to allow a non-reflexive--- coercion but not actually make use of it in a cast. See Note [IsRefl#].+-- coercion but not actually make use of it in a cast. -- -- The goal is to eliminate all uses of this function and replace them with--- 'hasFixedRuntimeRep', making use of the returned coercion.-hasFixedRuntimeRep_MustBeRefl :: FRROrigin -> TcType -> TcM ()-hasFixedRuntimeRep_MustBeRefl frr_orig ty-  = do { -- STEP 1: check that the type has a fixed 'RuntimeRep'.-         mb_co <- hasFixedRuntimeRep frr_orig ty-         -- STEP 2: ensure that we only solve using a reflexive coercion.-       ; case mb_co of-           -- If the coercion is immediately reflexive: we're OK.-       { Nothing -> return ()-           -- Otherwise: emit an @IsRefl#@ constraint.-           -- This means we are free to discard the coercion.-       ; Just (ki, _co, concrete_kv) ->-    do { isRefl_ctev <- newWanted (FixedRuntimeRepOrigin ty frr_orig)-                                  (Just KindLevel) $-                          mkIsReflPrimPred ki (mkTyVarTy concrete_kv)-       ; emitSimple $ mkNonCanonical isRefl_ctev } } }+-- 'hasFixedRuntimeRep', making use of the returned coercion. This is what+-- is meant by going from PHASE 1 to PHASE 2, in Note [The Concrete mechanism].+hasFixedRuntimeRep_syntactic :: HasDebugCallStack+                             => FixedRuntimeRepContext+                                  -- ^ Context to be reported to the user+                                  -- if the type does not have a syntactically+                                  -- fixed 'RuntimeRep'.+                             -> TcType+                                  -- ^ The type to check (we only look at its kind).+                             -> TcM ()+hasFixedRuntimeRep_syntactic frr_ctxt ty+  = void $ checkFRR_with ensure_conc frr_ctxt ty+    where+      ensure_conc :: FixedRuntimeRepOrigin -> TcKind -> TcM TcMCoercionN+      ensure_conc frr_orig ki = ensureConcrete frr_orig ki $> MRefl --- | Given a type @ty :: ki@, this function ensures that @ty@--- has a __fixed__ 'RuntimeRep', by emitting a new equality constraint--- @ki ~ concrete_tv@ for a concrete metavariable @concrete_tv@.+-- | Internal function to check whether the given type has a fixed 'RuntimeRep'. ----- Returns a coercion @co :: ki ~# concrete_tv@ as evidence.--- If @ty@ obviously has a fixed 'RuntimeRep', e.g @ki = IntRep@,--- then this function immediately returns 'Nothing'--- instead of emitting a new constraint.-hasFixedRuntimeRep :: FRROrigin -- ^ Context to be reported to the user-                                -- if the type ends up not having a fixed-                                -- 'RuntimeRep' (unsolved Wanted constraint).-                   -> TcType    -- ^ The type to check (we only look at its kind).-                   -> TcM (Maybe (TcType, TcCoercion, TcTyVar) )-                        -- ^ @Just ( ki, co, concrete_tv )@-                        -- where @co :: ki ~# concrete_ty@ is evidence that-                        -- the type @ty :: ki@ has a fixed 'RuntimeRep',-                        -- or 'Nothing' if 'ki' responds 'True' to 'isConcrete',-                        -- (i.e. we can take @co = Refl@).-hasFixedRuntimeRep frr_orig ty+-- Use 'hasFixedRuntimeRep' to allow rewriting, or 'hasFixedRuntimeRep_syntactic'+-- to perform a syntactic check.+checkFRR_with :: HasDebugCallStack+              => (FixedRuntimeRepOrigin -> TcKind -> TcM TcMCoercionN)+                   -- ^ The check to perform on the kind.+              -> FixedRuntimeRepContext+                   -- ^ The context which required a fixed 'RuntimeRep',+                   -- e.g. an application, a lambda abstraction, ...+              -> TcType+                   -- ^ The type @ty@ to check (the check itself only looks at its kind).+              -> TcM (TcCoercionN, TcTypeFRR)+                  -- ^ Returns @(co, frr_ty)@ with @co :: ty ~# frr_ty@+                  -- and @frr_@ty has a fixed 'RuntimeRep'.+checkFRR_with check_kind frr_ctxt ty   = do { th_stage <- getStage        ; if           -- Shortcut: check for 'Type' and 'UnliftedType' type synonyms.           | TyConApp tc [] <- ki           , tc == liftedTypeKindTyCon || tc == unliftedTypeKindTyCon-          -> return Nothing+          -> return refl            -- See [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep].           | Brack _ (TcPending {}) <- th_stage-          -> return Nothing+          -> return refl +          -- Otherwise: ensure that the kind 'ki' of 'ty' is concrete.           | otherwise-          -- Ensure that the kind 'ki' of 'ty' is concrete.-          -> emitNewConcreteWantedEq_maybe orig ki-              -- NB: the kind of 'ki' is 'Data.Kind.Type', which is concrete.-              -- This means that the invariant required to call-              -- 'newConcreteTyVar' is satisfied.-       }+          -> do { kco <- check_kind frr_orig ki+                ; return ( mkTcGReflRightMCo Nominal ty kco+                         , mkCastTyMCo ty kco ) } }+   where+    refl :: (TcCoercionN, TcType)+    refl = (mkTcNomReflCo ty, ty)     ki :: TcKind     ki = typeKind ty-    orig :: CtOrigin-    orig = FixedRuntimeRepOrigin ty frr_orig+    frr_orig :: FixedRuntimeRepOrigin+    frr_orig = FixedRuntimeRepOrigin { frr_type = ty, frr_context = frr_ctxt } --- | Create a new metavariable, of the given kind, which can only be unified--- with a concrete type.+-- | Ensure that the given type @ty@ can unify with a concrete type,+-- in the sense of Note [Concrete types]. ----- Invariant: the kind must be concrete, as per Note [ConcreteTv].--- This is checked with an assertion.-newConcreteTyVar :: HasDebugCallStack => TcKind -> TcM TcTyVar-newConcreteTyVar kind =-  assertPpr (isConcrete kind)-    (text "newConcreteTyVar: non-concrete kind" <+> ppr kind)-  $ newAnonMetaTyVar ConcreteTv kind---- | Create a new concrete metavariable @concrete_tv@ and emit a new non-canonical Wanted--- equality constraint @ty ~# concrete_tv@ with the given 'CtOrigin'.+-- Returns a coercion @co :: ty ~# conc_ty@, where @conc_ty@ is+-- concrete. ----- Short-cut: if the type responds 'True' to 'isConcrete', then--- we already know it is concrete, so don't emit any new constraints,--- and return 'Nothing'.+-- If the type is already syntactically concrete, this+-- immediately returns a reflexive coercion. Otherwise,+-- it creates a new concrete metavariable @concrete_tv@+-- and emits an equality constraint @ty ~# concrete_tv@,+-- to be handled by the constraint solver. -- -- Invariant: the kind of the supplied type must be concrete. ----- We also assume the provided type is already at the kind-level.---(This only matters for error messages.)-emitNewConcreteWantedEq_maybe :: CtOrigin -> TcType -> TcM (Maybe (TcType, TcCoercion, TcTyVar))-emitNewConcreteWantedEq_maybe orig ty-  -- The input type is already concrete: no need to do anything.-  -- Return 'Nothing', indicating that reflexivity is valid evidence.-  | isConcrete ty-  = return Nothing-  -- Otherwise: create a new concrete metavariable and emit a new Wanted equality constraint.-  | otherwise-  = do { concrete_tv <- newConcreteTyVar ki-       ; co <- emitWantedEq orig KindLevel Nominal ty (mkTyVarTy concrete_tv)-                        --       ^^^^^^^^^ we assume 'ty' is at the kind level.-                        -- (For representation polymorphism checks, we are always checking a kind.)-       ; return $ Just (ty, co, concrete_tv) }+-- We assume the provided type is already at the kind-level+-- (this only matters for error messages).+unifyConcrete :: HasDebugCallStack+              => FixedRuntimeRepOrigin -> TcType -> TcM TcMCoercionN+unifyConcrete frr_orig ty+  = do { (ty, errs) <- makeTypeConcrete (ConcreteFRR frr_orig) ty+       ; case errs of+           -- We were able to make the type fully concrete.+         { [] -> return MRefl+           -- The type could not be made concrete; perhaps it contains+           -- a skolem type variable, a type family application, ...+           --+           -- Create a new ConcreteTv metavariable @concrete_tv@+           -- and unify @ty ~# concrete_tv@.+         ; _  ->+    do { conc_tv <- newConcreteTyVar (ConcreteFRR frr_orig) ki+           -- NB: newConcreteTyVar asserts that 'ki' is concrete.+       ; coToMCo <$> emitWantedEq orig KindLevel Nominal ty (mkTyVarTy conc_tv) } } }   where     ki :: TcKind     ki = typeKind ty+    orig :: CtOrigin+    orig = FRROrigin frr_orig++-- | Ensure that the given type is concrete.+--+-- This is an eager syntactic check, and never defers+-- any work to the constraint solver.+--+-- Invariant: the kind of the supplied type must be concrete.+-- Invariant: the output type is equal to the input type,+--            up to zonking.+--+-- We assume the provided type is already at the kind-level+-- (this only matters for error messages).+ensureConcrete :: HasDebugCallStack+               => FixedRuntimeRepOrigin+               -> TcType+               -> TcM TcType+ensureConcrete frr_orig ty+  = do { (ty', errs) <- makeTypeConcrete conc_orig ty+       ; case errs of+          { err:errs ->+              do { traceTc "ensureConcrete } failure" $+                     vcat [ text "ty:" <+> ppr ty+                          , text "ty':" <+> ppr ty' ]+                 ; loc <- getCtLocM (FRROrigin frr_orig) (Just KindLevel)+                 ; emitNotConcreteError $+                     NCE_FRR+                       { nce_loc = loc+                       , nce_frr_origin = frr_orig+                       , nce_reasons = err :| errs }+                 }+          ; [] ->+              traceTc "ensureConcrete } success" $+                vcat [ text "ty: " <+> ppr ty+                     , text "ty':" <+> ppr ty' ] }+        ; return ty' }+  where+    conc_orig :: ConcreteTvOrigin+    conc_orig = ConcreteFRR frr_orig++{-***********************************************************************+%*                                                                      *+                    Making a type concrete+%*                                                                      *+%************************************************************************++Note [Unifying concrete metavariables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Unifying concrete metavariables (as defined in Note [ConcreteTv]) is not+an all-or-nothing affair as it is for other sorts of metavariables.++Consider the following unification problem in which all metavariables+are unfilled (and ignoring any TcLevel considerations):++  alpha[conc] ~# TYPE (TupleRep '[ beta[conc], IntRep, gamma[tau] ])++We can't immediately unify `alpha` with the RHS, because the RHS is not+a concrete type (in the sense of Note [Concrete types]). Instead, we+proceed as follows:++  - create a fresh concrete metavariable variable `gamma'[conc]`,+  - write gamma[tau] := gamma'[conc],+  - write alpha[conc] := TYPE (TupleRep '[ beta[conc], IntRep, gamma'[conc] ]).++Thus, in general, to unify `alpha[conc] ~# rhs`, we first try to turn+`rhs` into a concrete type (see the 'makeTypeConcrete' function).+If this succeeds, resulting in a concrete type `rhs'`, we simply fill+`alpha[conc] := rhs'`. If it fails, then syntactic unification fails.++Example 1:++    alpha[conc] ~# TYPE (TupleRep '[ beta[conc], IntRep, gamma[tau] ])++  We proceed by filling metavariables:++    gamma[tau] := gamma[conc]+    alpha[conc] := TYPE (TupleRep '[ beta[conc], IntRep, gamma[conc] ])++  This successfully unifies alpha.++Example 2:++  For a type family `F :: Type -> Type`:++    delta[conc] ~# TYPE (SumRep '[ zeta[tau], a[sk], F omega[tau] ])++  We write zeta[tau] := zeta[conc], and then fail, providing the following+  two reasons:++    - `a[sk]` is not a concrete type variable, so the overall type+      cannot be concrete+    - `F` is not a concrete type constructor, in the sense of+       Note [Concrete types]. So we keep it as is; in particular,+       we /should not/ try to make its argument `omega[tau]` into+       a ConcreteTv.++  Note that making zeta concrete allows us to propagate information.+  For example, after more typechecking, we might try to unify+  `zeta ~# rr[sk]`. If we made zeta a ConcreteTv, we will report+  this unsolved equality using the 'ConcreteTvOrigin' stored in zeta[conc].+  This allows us to report ALL the problems in a representation-polymorphism+  check (instead of only a non-empty subset).+-}++-- | Try to turn the provided type into a concrete type, by ensuring+-- unfilled metavariables are appropriately marked as concrete.+--+-- Returns a zonked type which is "as concrete as possible", and+-- a list of problems encountered when trying to make it concrete.+--+-- INVARIANT: the returned type is equal to the input type, up to zonking.+-- INVARIANT: if this function returns an empty list of 'NotConcreteReasons',+-- then the returned type is concrete, in the sense of Note [Concrete types].+makeTypeConcrete :: ConcreteTvOrigin -> TcType -> TcM (TcType, [NotConcreteReason])+-- TODO: it could be worthwhile to return enough information to continue solving.+-- Consider unifying `alpha[conc] ~# TupleRep '[ beta[tau], F Int ]` for+-- a type family 'F'.+-- This function will concretise `beta[tau] := beta[conc]` and return+-- that `TupleRep '[ beta[conc], F Int ]` is not concrete because of the+-- type family application `F Int`. But we could decompose by setting+-- alpha := TupleRep '[ beta, gamma[conc] ] and emitting `[W] gamma[conc] ~ F Int`.+--+-- This would be useful in startSolvingByUnification.+makeTypeConcrete conc_orig ty =+  do { res@(ty', _) <- runWriterT $ go ty+     ; traceTc "makeTypeConcrete" $+        vcat [ text "ty:" <+> ppr ty+             , text "ty':" <+> ppr ty' ]+     ; return res }+  where+    go :: TcType -> WriterT [NotConcreteReason] TcM TcType+    go ty+      | Just ty <- tcView ty+      = go ty+      | isConcrete ty+      = pure ty+    go ty@(TyVarTy tv) -- not a ConcreteTv (already handled above)+      = do { mb_filled <- lift $ isFilledMetaTyVar_maybe tv+           ; case mb_filled of+           { Just ty -> go ty+           ; Nothing+               | isMetaTyVar tv+               , TauTv <- metaTyVarInfo tv+               -> -- Change the MetaInfo to ConcreteTv, but retain the TcLevel+               do { kind <- go (tyVarKind tv)+                  ; lift $+                    do { conc_tv <- setTcLevel (tcTyVarLevel tv) $+                                    newConcreteTyVar conc_orig kind+                       ; let conc_ty = mkTyVarTy conc_tv+                       ; writeMetaTyVar tv conc_ty+                       ; return conc_ty } }+               | otherwise+               -- Don't attempt to make other type variables concrete+               -- (e.g. SkolemTv, TyVarTv, CycleBreakerTv, RuntimeUnkTv).+               -> bale_out ty (NonConcretisableTyVar tv) } }+    go ty@(TyConApp tc tys)+      | isConcreteTyCon tc+      = mkTyConApp tc <$> mapM go tys+      | otherwise+      = bale_out ty (NonConcreteTyCon tc tys)+    go (FunTy af w ty1 ty2)+      = do { w <- go w+           ; ty1 <- go ty1+           ; ty2 <- go ty2+           ; return $ mkFunTy af w ty1 ty2 }+    go (AppTy ty1 ty2)+      = do { ty1 <- go ty1+           ; ty2 <- go ty2+           ; return $ mkAppTy ty1 ty2 }+    go ty@(LitTy {})+      = return ty+    go ty@(CastTy cast_ty kco)+      = bale_out ty (ContainsCast cast_ty kco)+    go ty@(ForAllTy tcv body)+      = bale_out ty (ContainsForall tcv body)+    go ty@(CoercionTy co)+      = bale_out ty (ContainsCoercionTy co)++    bale_out :: TcType -> NotConcreteReason -> WriterT [NotConcreteReason] TcM TcType+    bale_out ty reason = do { tell [reason]; return ty }