ghc-lib 0.20220301 → 0.20220401

raw patch · 148 files changed

+4586/−3424 lines, 148 filesdep ~ghc-lib-parser

Dependency ranges changed: ghc-lib-parser

Files

• compiler/GHC.hs +3/−4
• compiler/GHC/Builtin/Names/TH.hs +9/−7
• compiler/GHC/Builtin/Utils.hs +4/−4
• compiler/GHC/ByteCode/InfoTable.hs +0/−2
• compiler/GHC/ByteCode/Instr.hs +1/−1
• compiler/GHC/Cmm/CallConv.hs +0/−1
• compiler/GHC/Cmm/Dataflow.hs +5/−5
• compiler/GHC/Cmm/InitFini.hs +78/−0
• compiler/GHC/Cmm/Parser.y +1/−0
• compiler/GHC/Cmm/Ppr/Decl.hs +2/−0
• compiler/GHC/Cmm/ProcPoint.hs +1/−1
• compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +3/−3
• compiler/GHC/CmmToAsm/CFG.hs +3/−3
• compiler/GHC/CmmToAsm/Dwarf.hs +1/−1
• compiler/GHC/CmmToAsm/PPC/CodeGen.hs +7/−5
• compiler/GHC/CmmToAsm/PPC/Ppr.hs +2/−0
• compiler/GHC/CmmToAsm/Ppr.hs +11/−1
• compiler/GHC/CmmToAsm/Reg/Linear.hs +3/−3
• compiler/GHC/CmmToAsm/X86/CodeGen.hs +40/−6
• compiler/GHC/CmmToC.hs +33/−34
• compiler/GHC/CmmToLlvm.hs +1/−1
• compiler/GHC/CmmToLlvm/CodeGen.hs +2/−2
• compiler/GHC/CmmToLlvm/Data.hs +44/−1
• compiler/GHC/Core/Opt/CprAnal.hs +76/−39
• compiler/GHC/Core/Opt/DmdAnal.hs +183/−42
• compiler/GHC/Core/Opt/Exitify.hs +2/−2
• compiler/GHC/Core/Opt/FloatIn.hs +3/−2
• compiler/GHC/Core/Opt/FloatOut.hs +2/−0
• compiler/GHC/Core/Opt/Simplify.hs +36/−17
• compiler/GHC/Core/Opt/Simplify/Env.hs +2/−0
• compiler/GHC/Core/Opt/Simplify/Utils.hs +4/−11
• compiler/GHC/Core/Opt/SpecConstr.hs +26/−14
• compiler/GHC/Core/Opt/Specialise.hs +6/−1
• compiler/GHC/Core/Opt/WorkWrap.hs +29/−15
• compiler/GHC/Core/Opt/WorkWrap/Utils.hs +166/−129
• compiler/GHC/CoreToStg.hs +8/−3
• compiler/GHC/CoreToStg/Prep.hs +7/−15
• compiler/GHC/Data/Graph/Color.hs +6/−6
• compiler/GHC/Driver/Backpack.hs +6/−1
• compiler/GHC/Driver/CodeOutput.hs +49/−34
• compiler/GHC/Driver/Config/StgToCmm.hs +3/−1
• compiler/GHC/Driver/Config/Tidy.hs +73/−0
• compiler/GHC/Driver/Main.hs +58/−11
• compiler/GHC/Driver/Make.hs +31/−67
• compiler/GHC/Hs/Syn/Type.hs +2/−3
• compiler/GHC/HsToCore.hs +2/−4
• compiler/GHC/HsToCore/Binds.hs +12/−9
• compiler/GHC/HsToCore/Coverage.hs +18/−23
• compiler/GHC/HsToCore/Docs.hs +281/−116
• compiler/GHC/HsToCore/Expr.hs +10/−9
• compiler/GHC/HsToCore/Foreign/Decl.hs +21/−19
• compiler/GHC/HsToCore/Match.hs +1/−0
• compiler/GHC/HsToCore/Match/Literal.hs +3/−3
• compiler/GHC/HsToCore/Pmc/Desugar.hs +4/−3
• compiler/GHC/HsToCore/Pmc/Solver.hs +24/−24
• compiler/GHC/HsToCore/Quote.hs +14/−10
• compiler/GHC/HsToCore/Types.hs +1/−1
• compiler/GHC/Iface/Ext/Ast.hs +68/−38
• compiler/GHC/Iface/Load.hs +6/−17
• compiler/GHC/Iface/Make.hs +8/−14
• compiler/GHC/Iface/Recomp.hs +0/−1
• compiler/GHC/Iface/Recomp/Flags.hs +3/−4
• compiler/GHC/Iface/Tidy.hs +137/−170
• compiler/GHC/Iface/Tidy/StaticPtrTable.hs +40/−60
• compiler/GHC/IfaceToCore.hs +2/−1
• compiler/GHC/Linker/Loader.hs +7/−29
• compiler/GHC/Llvm/Ppr.hs +1/−0
• compiler/GHC/Llvm/Types.hs +2/−0
• compiler/GHC/Plugins.hs +8/−0
• compiler/GHC/Rename/Doc.hs +46/−0
• compiler/GHC/Rename/Env.hs +20/−9
• compiler/GHC/Rename/Expr.hs +7/−4
• compiler/GHC/Rename/Expr.hs-boot +6/−0
• compiler/GHC/Rename/HsType.hs +13/−16
• compiler/GHC/Rename/Module.hs +26/−12
• compiler/GHC/Rename/Names.hs +3/−3
• compiler/GHC/Rename/Splice.hs +70/−42
• compiler/GHC/Runtime/Eval.hs +11/−20
• compiler/GHC/Stg/BcPrep.hs +2/−3
• compiler/GHC/Stg/CSE.hs +6/−6
• compiler/GHC/Stg/Debug.hs +2/−1
• compiler/GHC/Stg/FVs.hs +3/−2
• compiler/GHC/Stg/InferTags.hs +16/−5
• compiler/GHC/Stg/InferTags/Rewrite.hs +17/−18
• compiler/GHC/Stg/Lift.hs +4/−2
• compiler/GHC/Stg/Lift/Analysis.hs +2/−2
• compiler/GHC/Stg/Lint.hs +11/−6
• compiler/GHC/Stg/Stats.hs +1/−2
• compiler/GHC/Stg/Unarise.hs +38/−25
• compiler/GHC/Stg/Utils.hs +8/−5
• compiler/GHC/StgToByteCode.hs +17/−16
• compiler/GHC/StgToCmm.hs +4/−7
• compiler/GHC/StgToCmm/Bind.hs +21/−15
• compiler/GHC/StgToCmm/Closure.hs +4/−3
• compiler/GHC/StgToCmm/DataCon.hs +2/−1
• compiler/GHC/StgToCmm/Env.hs +10/−1
• compiler/GHC/StgToCmm/Expr.hs +9/−8
• compiler/GHC/StgToCmm/Expr.hs-boot +0/−7
• compiler/GHC/StgToCmm/Prim.hs +2/−2
• compiler/GHC/StgToCmm/TagCheck.hs +36/−12
• compiler/GHC/StgToCmm/Ticky.hs +116/−28
• compiler/GHC/Tc/Deriv.hs +189/−151
• compiler/GHC/Tc/Deriv/Functor.hs +3/−3
• compiler/GHC/Tc/Deriv/Generate.hs +171/−134
• compiler/GHC/Tc/Deriv/Generics.hs +92/−95
• compiler/GHC/Tc/Deriv/Infer.hs +154/−150
• compiler/GHC/Tc/Deriv/Utils.hs +347/−157
• compiler/GHC/Tc/Errors.hs +47/−28
• compiler/GHC/Tc/Errors/Hole.hs +39/−18
• compiler/GHC/Tc/Gen/App.hs +31/−29
• compiler/GHC/Tc/Gen/Arrow.hs +22/−15
• compiler/GHC/Tc/Gen/Bind.hs +46/−31
• compiler/GHC/Tc/Gen/Export.hs +19/−14
• compiler/GHC/Tc/Gen/Expr.hs +40/−39
• compiler/GHC/Tc/Gen/Expr.hs-boot +4/−3
• compiler/GHC/Tc/Gen/Foreign.hs +80/−108
• compiler/GHC/Tc/Gen/Head.hs +8/−11
• compiler/GHC/Tc/Gen/Match.hs +17/−26
• compiler/GHC/Tc/Gen/Pat.hs +65/−37
• compiler/GHC/Tc/Gen/Rule.hs +18/−22
• compiler/GHC/Tc/Gen/Splice.hs +64/−55
• compiler/GHC/Tc/Gen/Splice.hs-boot +7/−7
• compiler/GHC/Tc/Module.hs +37/−23
• compiler/GHC/Tc/Solver.hs +10/−9
• compiler/GHC/Tc/Solver/Canonical.hs +39/−214
• compiler/GHC/Tc/Solver/Interact.hs +9/−6
• compiler/GHC/Tc/Solver/Monad.hs +38/−101
• compiler/GHC/Tc/TyCl.hs +1/−1
• compiler/GHC/Tc/TyCl/Build.hs +2/−0
• compiler/GHC/Tc/TyCl/Class.hs +3/−4
• compiler/GHC/Tc/TyCl/Instance.hs +12/−16
• compiler/GHC/Tc/TyCl/PatSyn.hs +6/−1
• compiler/GHC/Tc/TyCl/Utils.hs +8/−8
• compiler/GHC/Tc/Utils/Concrete.hs +217/−255
• compiler/GHC/Tc/Utils/Env.hs +1/−1
• compiler/GHC/Tc/Utils/Instantiate.hs +2/−2
• compiler/GHC/Tc/Utils/TcMType.hs +16/−15
• compiler/GHC/Tc/Utils/Unify.hs +153/−49
• compiler/GHC/Tc/Utils/Zonk.hs +32/−29
• compiler/GHC/Tc/Validity.hs +7/−2
• compiler/GHC/ThToHs.hs +184/−139
• compiler/GHC/Types/Unique/MemoFun.hs +21/−0
• compiler/ghc-llvm-version.h +1/−1
• ghc-lib.cabal +9/−2
• ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +42/−42
• ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl +30/−30
• ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +4/−4
• ghc-lib/stage0/rts/build/include/ghcautoconf.h +1/−1

@@ -338,7 +338,6 @@ import GHC.Iface.Load        ( loadSysInterface ) import GHC.Hs import GHC.Builtin.Types.Prim ( alphaTyVars )-import GHC.Iface.Tidy import GHC.Data.StringBuffer import GHC.Data.FastString import qualified GHC.LanguageExtensions as LangExt@@ -1171,7 +1170,7 @@  type ParsedSource      = Located HsModule type RenamedSource     = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],-                          Maybe LHsDocString)+                          Maybe (LHsDoc GhcRn)) type TypecheckedSource = LHsBinds GhcTc  -- NOTE:@@ -1330,12 +1329,12 @@          if simplify           then do              -- If simplify is true: simplify (hscSimplify), then tidy-             -- (tidyProgram).+             -- (hscTidy).              hsc_env <- getSession              simpl_guts <- liftIO $ do                plugins <- readIORef (tcg_th_coreplugins tcg)                hscSimplify hsc_env plugins mod_guts-             tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts+             tidy_guts <- liftIO $ hscTidy hsc_env simpl_guts              return $ Left tidy_guts           else              return $ Right mod_guts

@@ -594,10 +594,11 @@ quoteTypeName       = qqFun (fsLit "quoteType") quoteTypeKey  -- data Inline = ...-noInlineDataConName, inlineDataConName, inlinableDataConName :: Name+noInlineDataConName, inlineDataConName, inlinableDataConName, opaqueDataConName :: Name noInlineDataConName  = thCon (fsLit "NoInline")  noInlineDataConKey inlineDataConName    = thCon (fsLit "Inline")    inlineDataConKey inlinableDataConName = thCon (fsLit "Inlinable") inlinableDataConKey+opaqueDataConName    = thCon (fsLit "Opaque")    opaqueDataConKey  -- data RuleMatch = ... conLikeDataConName, funLikeDataConName :: Name@@ -700,21 +701,22 @@ -- If you want to change this, make sure you check in GHC.Builtin.Names  -- data Inline = ...-noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique+noInlineDataConKey, inlineDataConKey, inlinableDataConKey, opaqueDataConKey :: Unique noInlineDataConKey  = mkPreludeDataConUnique 200 inlineDataConKey    = mkPreludeDataConUnique 201 inlinableDataConKey = mkPreludeDataConUnique 202+opaqueDataConKey    = mkPreludeDataConUnique 203  -- data RuleMatch = ... conLikeDataConKey, funLikeDataConKey :: Unique-conLikeDataConKey = mkPreludeDataConUnique 203-funLikeDataConKey = mkPreludeDataConUnique 204+conLikeDataConKey = mkPreludeDataConUnique 204+funLikeDataConKey = mkPreludeDataConUnique 205  -- data Phases = ... allPhasesDataConKey, fromPhaseDataConKey, beforePhaseDataConKey :: Unique-allPhasesDataConKey   = mkPreludeDataConUnique 205-fromPhaseDataConKey   = mkPreludeDataConUnique 206-beforePhaseDataConKey = mkPreludeDataConUnique 207+allPhasesDataConKey   = mkPreludeDataConUnique 206+fromPhaseDataConKey   = mkPreludeDataConUnique 207+beforePhaseDataConKey = mkPreludeDataConUnique 208  -- data Overlap = .. overlappableDataConKey,

@@ -65,6 +65,7 @@ import GHC.Types.Name.Env import GHC.Types.Id.Make import GHC.Types.Unique.FM+import GHC.Types.Unique.Map import GHC.Types.TyThing import GHC.Types.Unique ( isValidKnownKeyUnique ) @@ -80,7 +81,6 @@ import Control.Applicative ((<|>)) import Data.List        ( intercalate , find ) import Data.Maybe-import qualified Data.Map as Map  {- ************************************************************************@@ -244,15 +244,15 @@    [ availTC n [n] []    | tc <- exposedPrimTyCons, let n = tyConName tc  ] -ghcPrimDeclDocs :: DeclDocMap-ghcPrimDeclDocs = DeclDocMap $ Map.fromList $ mapMaybe findName primOpDocs+ghcPrimDeclDocs :: Docs+ghcPrimDeclDocs = emptyDocs { docs_decls = listToUniqMap $ mapMaybe findName primOpDocs }   where     names = map idName ghcPrimIds ++             map idName allThePrimOpIds ++             map tyConName exposedPrimTyCons     findName (nameStr, doc)       | Just name <- find ((nameStr ==) . getOccString) names-      = Just (name, mkHsDocString doc)+      = Just (name, [WithHsDocIdentifiers (mkGeneratedHsDocString doc) []])       | otherwise = Nothing  {-

@@ -10,8 +10,6 @@  import GHC.Prelude -import GHC.Driver.Session- import GHC.Platform import GHC.Platform.Profile 

@@ -223,7 +223,7 @@   char '{' <+> ppr (fst (head bs)) <+> text "= ...; ... }"  pprStgAltShort :: OutputablePass pass => StgPprOpts -> GenStgAlt pass -> SDoc-pprStgAltShort opts (con, args, expr) =+pprStgAltShort opts GenStgAlt{alt_con=con, alt_bndrs=args, alt_rhs=expr} =   ppr con <+> sep (map ppr args) <+> text "->" <+> pprStgExprShort opts expr  pprStgRhsShort :: OutputablePass pass => StgPprOpts -> GenStgRhs pass -> SDoc

@@ -14,7 +14,6 @@ import GHC.Cmm (Convention(..)) import GHC.Cmm.Ppr () -- For Outputable instances -import GHC.Driver.Session import GHC.Platform import GHC.Platform.Profile import GHC.Utils.Outputable

@@ -151,8 +151,8 @@     join       = fact_join lattice      loop-        :: IntHeap     -- ^ Worklist, i.e., blocks to process-        -> FactBase f  -- ^ Current result (increases monotonically)+        :: IntHeap     -- Worklist, i.e., blocks to process+        -> FactBase f  -- Current result (increases monotonically)         -> FactBase f     loop todo !fbase1 | Just (index, todo1) <- IntSet.minView todo =         let block = block_arr ! index@@ -218,9 +218,9 @@     join       = fact_join lattice      loop-        :: IntHeap            -- ^ Worklist, i.e., blocks to process-        -> LabelMap (Block node C C)  -- ^ Rewritten blocks.-        -> FactBase f         -- ^ Current facts.+        :: IntHeap                    -- Worklist, i.e., blocks to process+        -> LabelMap (Block node C C)  -- Rewritten blocks.+        -> FactBase f                 -- Current facts.         -> UniqSM (LabelMap (Block node C C), FactBase f)     loop todo !blocks1 !fbase1       | Just (index, todo1) <- IntSet.minView todo = do

@@ -0,0 +1,78 @@+-- | Utilities for dealing with constructors/destructors.+module GHC.Cmm.InitFini+    ( InitOrFini(..)+    , isInitOrFiniArray+    ) where++import GHC.Prelude++import GHC.Cmm.CLabel+import GHC.Cmm+import GHC.Utils.Panic+import GHC.Utils.Outputable++{-+Note [Initializers and finalizers in Cmm]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Most platforms support some mechanism for marking a procedure to be run when a+program is loaded (in which case the procedure is known as an "initializer",+"constructor", or "ctor") or unloaded (a "finalizer", "deconstructor", or+"dtor").++For instance, on ELF platforms pointers to initializer and finalizer functions+are listed in .init_array and .fini_array sections, which are traversed by libc+during program startup and shutdown.++In GHC-generated code, initializers are used for a few things:++ * registration of cost-centres and cost-centre stacks for profiling+ * registration of info-table provenance entries+ * registration of ticky tickers+ * registration of HPC ticks++All of these initializers are implemented as C functions, emitted by the+compiler as ForeignStubs. Consequently the GHC.Types.ForeignStubs.CStub type+carries with it lists of functions which should be marked as initializers or+finalizers.++These initializer and finalizer lists are then turned into CmmData declarations+which are fed to the backend. These declarations are distinguished by their+Section (e.g. InitArray or FiniArray) and consist of an array of words, where each+word is a pointer to an initializer/finalizer function. Since this is the same+form that most platforms expect initializer or finalizer lists to appear in+assembler, the NCG backends naturally emit the appropriate assembler.++However, for non-NCG backends (e.g. the C and LLVM backends) these+initializer/finalizer list declarations need to be detected and dealt with+appropriately. We provide isInitOrFiniArray to distinguish such declarations+and turn them back into a list of CLabels.++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 that we maintain the invariant that at most one initializer and one+finalizer CmmDecl will be emitted per module.+-}++data InitOrFini = IsInitArray | IsFiniArray++isInitOrFiniArray :: RawCmmDecl -> Maybe (InitOrFini, [CLabel])+isInitOrFiniArray (CmmData sect (CmmStaticsRaw _ lits))+  | Just initOrFini <- isInitOrFiniSection sect+  = Just (initOrFini, map get_label lits)+  where+    get_label :: CmmStatic -> CLabel+    get_label (CmmStaticLit (CmmLabel lbl)) = lbl+    get_label static = pprPanic "isInitOrFiniArray: invalid entry" (ppr static)+isInitOrFiniArray _ = Nothing++isInitOrFiniSection :: Section -> Maybe InitOrFini+isInitOrFiniSection (Section InitArray _) = Just IsInitArray+isInitOrFiniSection (Section FiniArray _) = Just IsFiniArray+isInitOrFiniSection _                     = Nothing

@@ -1519,6 +1519,7 @@         let fstate = F.initFCodeState (profilePlatform $ targetProfile dflags)         let fcode = do               ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return ()+              -- See Note [Mapping Info Tables to Source Positions] (IPE Maps)               let used_info = map (cmmInfoTableToInfoProvEnt this_mod)                                               (mapMaybe topInfoTable cmm)               ((), cmm2) <- getCmm $ mapM_ emitInfoTableProv used_info

@@ -166,5 +166,7 @@   ReadOnlyData16          -> text "readonly16"   RelocatableReadOnlyData -> text "relreadonly"   UninitialisedData       -> text "uninitialised"+  InitArray               -> text "initarray"+  FiniArray               -> text "finiarray"   CString                 -> text "cstring"   OtherSection s'         -> text s'

@@ -213,7 +213,7 @@                                 ProcPoint -> 1                                 ReachedBy ps -> setSize ps                 block_procpoints = nreached (entryLabel b)-                -- | Looking for a successor of b that is reached by+                -- Looking for a successor of b that is reached by                 -- more proc points than b and is not already a proc                 -- point.  If found, it can become a proc point.                 newId succ_id = not (setMember succ_id procPoints') &&

@@ -171,7 +171,7 @@ -- ----------------------------------------------------------------------------- -- | Utilities ann :: SDoc -> Instr -> Instr-ann doc instr {- | debugIsOn -} = ANN doc instr+ann doc instr {- debugIsOn -} = ANN doc instr -- ann _ instr = instr {-# INLINE ann #-} @@ -199,8 +199,8 @@ -- forced until we actually force them, and without -dppr-debug they should -- never end up being forced. annExpr :: CmmExpr -> Instr -> Instr-annExpr e instr {- | debugIsOn -} = ANN (text . show $ e) instr--- annExpr e instr {- | debugIsOn -} = ANN (pprExpr genericPlatform e) instr+annExpr e instr {- debugIsOn -} = ANN (text . show $ e) instr+-- annExpr e instr {- debugIsOn -} = ANN (pprExpr genericPlatform e) instr -- annExpr _ instr = instr {-# INLINE annExpr #-} 

@@ -712,7 +712,7 @@     increaseBackEdgeWeight (g_entry graph) $ cfg   where -    -- | Increase the weight of all backedges in the CFG+    -- Increase the weight of all backedges in the CFG     -- this helps to make loop jumpbacks the heaviest edges     increaseBackEdgeWeight :: BlockId -> CFG -> CFG     increaseBackEdgeWeight root cfg =@@ -725,7 +725,7 @@         in  foldl'  (\cfg edge -> updateEdgeWeight update edge cfg)                     cfg backedges -    -- | Since we cant fall through info tables we penalize these.+    -- Since we cant fall through info tables we penalize these.     penalizeInfoTables :: LabelMap a -> CFG -> CFG     penalizeInfoTables info cfg =         mapWeights fupdate cfg@@ -736,7 +736,7 @@           = weight - (fromIntegral $ infoTablePenalty weights)           | otherwise = weight -    -- | If a block has two successors, favour the one with fewer+    -- If a block has two successors, favour the one with fewer     -- predecessors and/or the one allowing fall through.     favourFewerPreds :: CFG -> CFG     favourFewerPreds cfg =

@@ -245,7 +245,7 @@           where uws'   = addDefaultUnwindings initUws uws                 nested = concatMap flatten blocks -        -- | If the current procedure has an info table, then we also say that+        -- If the current procedure has an info table, then we also say that         -- its first block has one to ensure that it gets the necessary -1         -- offset applied to its start address.         -- See Note [Info Offset] in "GHC.CmmToAsm.Dwarf.Types".

@@ -2143,12 +2143,14 @@                     ]         return code   where-    indexExpr = cmmOffset platform exprWidened offset+    -- See Note [Sub-word subtlety during jump-table indexing] in+    -- GHC.CmmToAsm.X86.CodeGen for why we must first offset, then widen.+    indexExpr0 = cmmOffset platform expr offset     -- We widen to a native-width register to santize the high bits-    exprWidened = CmmMachOp-      (MO_UU_Conv (cmmExprWidth platform expr)-                  (platformWordWidth platform))-      [expr]+    indexExpr = CmmMachOp+      (MO_UU_Conv expr_w (platformWordWidth platform))+      [indexExpr0]+    expr_w = cmmExprWidth platform expr     (offset, ids) = switchTargetsToTable targets     platform      = ncgPlatform config 

@@ -299,6 +299,8 @@        ReadOnlyData16    -> text ".align 4"        -- TODO: This is copied from the ReadOnlyData case, but it can likely be        -- made more efficient.+       InitArray         -> text ".align 3"+       FiniArray         -> text ".align 3"        CString         | ppc64          -> text ".align 3"         | otherwise      -> text ".align 2"

@@ -227,6 +227,14 @@       ReadOnlyData16 | OSMinGW32 <- platformOS platform                                  -> text ".rdata$cst16"                      | otherwise -> text ".rodata.cst16"+      InitArray+        | OSMinGW32 <- platformOS platform+                    -> text ".ctors"+        | otherwise -> text ".init_array"+      FiniArray+        | OSMinGW32 <- platformOS platform+                    -> text ".dtors"+        | otherwise -> text ".fini_array"       CString         | OSMinGW32 <- platformOS platform                     -> text ".rdata"@@ -251,7 +259,7 @@   ReadOnlyData16          -> text ".csect .text[PR] # ReadOnlyData16"   CString                 -> text ".csect .text[PR] # CString"   UninitialisedData       -> text ".csect .data[BS]"-  OtherSection _          -> panic "pprXcoffSectionHeader: unknown section type"+  _                       -> panic "pprXcoffSectionHeader: unknown section type"  pprDarwinSectionHeader :: SectionType -> SDoc pprDarwinSectionHeader t = case t of@@ -261,5 +269,7 @@   RelocatableReadOnlyData -> text ".const_data"   UninitialisedData       -> text ".data"   ReadOnlyData16          -> text ".const"+  InitArray               -> text ".section\t__DATA,__mod_init_func,mod_init_funcs"+  FiniArray               -> panic "pprDarwinSectionHeader: fini not supported"   CString                 -> text ".section\t__TEXT,__cstring,cstring_literals"   OtherSection _          -> panic "pprDarwinSectionHeader: unknown section type"

@@ -385,9 +385,9 @@                 , [NatBasicBlock instr])        --   fresh blocks of fixup code. linearRA block_live block_id = go [] []   where-    go :: [instr]                              -- ^ accumulator for instructions already processed.-       -> [NatBasicBlock instr]                -- ^ accumulator for blocks of fixup code.-       -> [LiveInstr instr]                    -- ^ liveness annotated instructions in this block.+    go :: [instr]                              -- accumulator for instructions already processed.+       -> [NatBasicBlock instr]                -- accumulator for blocks of fixup code.+       -> [LiveInstr instr]                    -- liveness annotated instructions in this block.        -> RegM freeRegs                ( [instr]                       --   instructions after register allocation                , [NatBasicBlock instr] )       --   fresh blocks of fixup code.

@@ -2773,18 +2773,52 @@ -- ----------------------------------------------------------------------------- -- Generating a table-branch +{-+Note [Sub-word subtlety during jump-table indexing]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Offset the index by the start index of the jump table.+It's important that we do this *before* the widening below. To see+why, consider a switch with a sub-word, signed discriminant such as:++    switch [-5...+2] x::I16 {+        case -5: ...+        ...+        case +2: ...+    }++Consider what happens if we offset *after* widening in the case that+x=-4:++                                         // x == -4 == 0xfffc::I16+    indexWidened = UU_Conv(x);           // == 0xfffc::I64+    indexExpr    = indexWidened - (-5);  // == 0x10000::I64++This index is clearly nonsense given that the jump table only has+eight entries.++By contrast, if we widen *after* we offset then we get the correct+index (1),++                                         // x == -4 == 0xfffc::I16+    indexOffset  = x - (-5);             // == 1::I16+    indexExpr    = UU_Conv(indexOffset); // == 1::I64++See #21186.+-}+ genSwitch :: CmmExpr -> SwitchTargets -> NatM InstrBlock  genSwitch expr targets = do   config <- getConfig   let platform = ncgPlatform config-      -- We widen to a native-width register because we cannot use arbitry sizes+      expr_w = cmmExprWidth platform expr+      indexExpr0 = cmmOffset platform expr offset+      -- We widen to a native-width register because we cannot use arbitrary sizes       -- in x86 addressing modes.-      exprWidened = CmmMachOp-        (MO_UU_Conv (cmmExprWidth platform expr)-                    (platformWordWidth platform))-        [expr]-      indexExpr = cmmOffset platform exprWidened offset+      -- See Note [Sub-word subtlety during jump-table indexing].+      indexExpr = CmmMachOp+        (MO_UU_Conv expr_w (platformWordWidth platform))+        [indexExpr0]   if ncgPIC config   then do         (reg,e_code) <- getNonClobberedReg indexExpr

@@ -40,6 +40,7 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Utils import GHC.Cmm.Switch+import GHC.Cmm.InitFini  import GHC.Types.ForeignCall import GHC.Types.Unique.Set@@ -53,15 +54,12 @@  import Data.ByteString (ByteString) import qualified Data.ByteString as BS-import Control.Monad.ST import Data.Char import Data.List (intersperse) import Data.Map (Map)-import Data.Word import qualified Data.Map as Map import Control.Monad (ap)-import qualified Data.Array.Unsafe as U ( castSTUArray )-import Data.Array.ST+import GHC.Float  -- -------------------------------------------------------------------------- -- Now do some real work@@ -103,6 +101,9 @@    -- We only handle (a) arrays of word-sized things and (b) strings. +  cmm_data | Just (initOrFini, clbls) <- isInitOrFiniArray cmm_data ->+    pprCtorArray platform initOrFini clbls+   (CmmData section (CmmStaticsRaw lbl [CmmString str])) ->     pprExternDecl platform lbl $$     hcat [@@ -269,7 +270,6 @@         hargs    = zip args arg_hints          need_cdecl-          | Just _align <- machOpMemcpyishAlign op = True           | MO_ResumeThread  <- op                 = True           | MO_SuspendThread <- op                 = True           | otherwise                              = False@@ -358,7 +358,7 @@     caseify (_     , _    ) = panic "pprSwitch: switch with no cases!"      def | Just l <- mbdef = text "default: goto" <+> pprBlockId l <> semi-        | otherwise       = empty+        | otherwise       = text "default: __builtin_unreachable();"  -- --------------------------------------------------------------------- -- Expressions.@@ -638,14 +638,15 @@     -- single-word (or smaller) literals.     decomposeMultiWord :: CmmLit -> [CmmLit]     decomposeMultiWord (CmmFloat n W64)-      -- This will produce a W64 integer, which will then be broken up further-      -- on the next iteration on 32-bit platforms.-      = [doubleToWord64 n]+      | W32 <- wordWidth platform = decomposeMultiWord (doubleToWord64 n)+      | otherwise = [doubleToWord64 n]     decomposeMultiWord (CmmFloat n W32)       = [floatToWord32 n]     decomposeMultiWord (CmmInt n W64)       | W32 <- wordWidth platform-      = [CmmInt hi W32, CmmInt lo W32]+      = case platformByteOrder platform of+          BigEndian -> [CmmInt hi W32, CmmInt lo W32]+          LittleEndian -> [CmmInt lo W32, CmmInt hi W32]       where         hi = n `shiftR` 32         lo = n .&. 0xffffffff@@ -930,10 +931,10 @@         MO_F32_Fabs     -> text "fabsf"         MO_ReadBarrier  -> text "load_load_barrier"         MO_WriteBarrier -> text "write_barrier"-        MO_Memcpy _     -> text "memcpy"-        MO_Memset _     -> text "memset"-        MO_Memmove _    -> text "memmove"-        MO_Memcmp _     -> text "memcmp"+        MO_Memcpy _     -> text "__builtin_memcpy"+        MO_Memset _     -> text "__builtin_memset"+        MO_Memmove _    -> text "__builtin_memmove"+        MO_Memcmp _     -> text "__builtin_memcmp"          MO_SuspendThread -> text "suspendThread"         MO_ResumeThread  -> text "resumeThread"@@ -1410,28 +1411,10 @@ -- can safely initialise to static locations.  floatToWord32 :: Rational -> CmmLit-floatToWord32 r-  = runST $ do-        arr <- newArray_ ((0::Int),0)-        writeArray arr 0 (fromRational r)-        arr' <- castFloatToWord32Array arr-        w32 <- readArray arr' 0-        return (CmmInt (toInteger w32) W32)-  where-    castFloatToWord32Array :: STUArray s Int Float -> ST s (STUArray s Int Word32)-    castFloatToWord32Array = U.castSTUArray+floatToWord32 r = CmmInt (toInteger (castFloatToWord32 (fromRational r))) W32  doubleToWord64 :: Rational -> CmmLit-doubleToWord64 r-  = runST $ do-        arr <- newArray_ ((0::Int),1)-        writeArray arr 0 (fromRational r)-        arr' <- castDoubleToWord64Array arr-        w64 <- readArray arr' 0-        return $ CmmInt (toInteger w64) W64-  where-    castDoubleToWord64Array :: STUArray s Int Double -> ST s (STUArray s Int Word64)-    castDoubleToWord64Array = U.castSTUArray+doubleToWord64 r = CmmInt (toInteger (castDoubleToWord64 (fromRational r))) W64   -- ---------------------------------------------------------------------------@@ -1508,3 +1491,19 @@              (q,r) = w' `quotRem` 16              dig | r < 10    = char (chr (fromInteger r + ord '0'))                  | otherwise = char (chr (fromInteger r - 10 + ord 'a'))++-- | Construct a constructor/finalizer function. Instead of emitting a+-- initializer/finalizer array we rather just emit a single function, annotated+-- with the appropriate C attribute, which then calls each of the initializers.+pprCtorArray :: Platform -> InitOrFini -> [CLabel] -> SDoc+pprCtorArray platform initOrFini lbls =+       decls+    <> text "static __attribute__((" <> attribute <> text "))"+    <> text "void _hs_" <> attribute <> text "()"+    <> braces body+  where+    body = vcat [ pprCLabel platform CStyle lbl <> text " ();" | lbl <- lbls ]+    decls = vcat [ text "void" <+> pprCLabel platform CStyle lbl <> text " (void);" | lbl <- lbls ]+    attribute = case initOrFini of+                  IsInitArray -> text "constructor"+                  IsFiniArray -> text "destructor"

@@ -65,7 +65,7 @@          when (not (llvmVersionSupported ver) && doWarn) $ putMsg logger $            "You are using an unsupported version of LLVM!" $$            "Currently only" <+> text (llvmVersionStr supportedLlvmVersionLowerBound) <+>-           "to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "is supported." <+>+           "up to" <+> text (llvmVersionStr supportedLlvmVersionUpperBound) <+> "(non inclusive) is supported." <+>            "System LLVM version: " <> text (llvmVersionStr ver) $$            "We will try though..."          let isS390X = platformArch (llvmCgPlatform cfg)  == ArchS390X

@@ -1738,7 +1738,7 @@               [vx',vy'] -> doExprW ty $ binOp vx' vy'               _         -> panic "genMachOp_slow: binCastLlvmOp" -        -- | Need to use EOption here as Cmm expects word size results from+        -- Need to use EOption here as Cmm expects word size results from         -- comparisons while LLVM return i1. Need to extend to llvmWord type         -- if expected. See Note [Literals and branch conditions].         genBinComp opt cmp = do@@ -1761,7 +1761,7 @@          genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op) -        -- | Detect if overflow will occur in signed multiply of the two+        -- Detect if overflow will occur in signed multiply of the two         -- CmmExpr's. This is the LLVM assembly equivalent of the NCG         -- implementation. Its much longer due to type information/safety.         -- This should actually compile to only about 3 asm instructions.

@@ -15,6 +15,7 @@  import GHC.Cmm.BlockId import GHC.Cmm.CLabel+import GHC.Cmm.InitFini import GHC.Cmm import GHC.Platform @@ -65,6 +66,14 @@      pure ([LMGlobal aliasDef $ Just orig], [tyAlias]) +-- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini.+genLlvmData (sect, statics)+  | Just (initOrFini, clbls) <- isInitOrFiniArray (CmmData sect statics)+  = let var = case initOrFini of+                IsInitArray -> fsLit "llvm.global_ctors"+                IsFiniArray -> fsLit "llvm.global_dtors"+    in genGlobalLabelArray var clbls+ genLlvmData (sec, CmmStaticsRaw lbl xs) = do     label <- strCLabel_llvm lbl     static <- mapM genData xs@@ -88,6 +97,37 @@      return ([globDef], [tyAlias]) +-- | Produce an initializer or finalizer array declaration.+-- See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for+-- details.+genGlobalLabelArray :: FastString -> [CLabel] -> LlvmM LlvmData+genGlobalLabelArray var_nm clbls = do+    lbls <- mapM strCLabel_llvm clbls+    decls <- mapM mkFunDecl lbls+    let entries = map toArrayEntry lbls+        static = LMStaticArray entries arr_ty+        arr = LMGlobal arr_var (Just static)+    return ([arr], decls)+  where+    mkFunDecl :: LMString -> LlvmM LlvmType+    mkFunDecl fn_lbl = do+        let fn_ty = mkFunTy fn_lbl+        funInsert fn_lbl fn_ty+        return (fn_ty)++    toArrayEntry :: LMString -> LlvmStatic+    toArrayEntry fn_lbl =+        let fn_var = LMGlobalVar fn_lbl (LMPointer $ mkFunTy fn_lbl) Internal Nothing Nothing Global+            fn = LMStaticPointer fn_var+            null = LMStaticLit (LMNullLit i8Ptr)+            prio = LMStaticLit $ LMIntLit 0xffff i32+        in LMStaticStrucU [prio, fn, null] entry_ty++    arr_var = LMGlobalVar var_nm arr_ty Internal Nothing Nothing Global+    mkFunTy lbl = LMFunction $ LlvmFunctionDecl lbl ExternallyVisible CC_Ccc LMVoid FixedArgs [] Nothing+    entry_ty = LMStructU [i32, LMPointer $ mkFunTy $ fsLit "placeholder", LMPointer i8]+    arr_ty = LMArray (length clbls) entry_ty+ -- | Format the section type part of a Cmm Section llvmSectionType :: Platform -> SectionType -> FastString llvmSectionType p t = case t of@@ -106,7 +146,10 @@     CString                 -> case platformOS p of                                  OSMinGW32 -> fsLit ".rdata$str"                                  _         -> fsLit ".rodata.str"-    (OtherSection _)        -> panic "llvmSectionType: unknown section type"++    InitArray               -> panic "llvmSectionType: InitArray"+    FiniArray               -> panic "llvmSectionType: FiniArray"+    OtherSection _          -> panic "llvmSectionType: unknown section type"  -- | Format a Cmm Section into a LLVM section name llvmSection :: Section -> LlvmM LMSection

@@ -20,6 +20,7 @@ import GHC.Types.Id.Info import GHC.Types.Demand import GHC.Types.Cpr+import GHC.Types.Unique.MemoFun  import GHC.Core.FamInstEnv import GHC.Core.DataCon@@ -343,7 +344,7 @@   = fst $ cprAnalApp env rhs args   -- DataCon worker   | Just con <- isDataConWorkId_maybe id-  = cprTransformDataConWork (ae_fam_envs env) con args+  = cprTransformDataConWork env con args   -- Imported function   | otherwise   = applyCprTy (getCprSig (idCprSig id)) (length args)@@ -361,20 +362,17 @@ -- | Get a (possibly nested) 'CprType' for an application of a 'DataCon' worker, -- given a saturated number of 'CprType's for its field expressions. -- Implements the Nested part of Note [Nested CPR].-cprTransformDataConWork :: FamInstEnvs -> DataCon -> [(CprType, CoreArg)] -> CprType-cprTransformDataConWork fam_envs con args+cprTransformDataConWork :: AnalEnv -> DataCon -> [(CprType, CoreArg)] -> CprType+cprTransformDataConWork env con args   | null (dataConExTyCoVars con)  -- No existentials   , wkr_arity <= mAX_CPR_SIZE -- See Note [Trimming to mAX_CPR_SIZE]   , args `lengthIs` wkr_arity-  , isRecDataCon fam_envs fuel con /= DefinitelyRecursive -- See Note [CPR for recursive data constructors]+  , ae_rec_dc env con /= DefinitelyRecursive -- See Note [CPR for recursive data constructors]   -- , pprTrace "cprTransformDataConWork" (ppr con <+> ppr wkr_arity <+> ppr args) True   = CprType 0 (ConCpr (dataConTag con) (strictZipWith extract_nested_cpr args wkr_str_marks))   | otherwise   = topCprType   where-    fuel = 3 -- If we can unbox more than 3 constructors to find a-             -- recursive occurrence, then we can just as well unbox it-             -- See Note [CPR for recursive data constructors], point (4)     wkr_arity = dataConRepArity con     wkr_str_marks = dataConRepStrictness con     -- See Note [Nested CPR]@@ -430,6 +428,31 @@           where             (id', rhs', env') = cprAnalBind env id rhs +{-+Note [The OPAQUE pragma and avoiding the reboxing of results]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:++  {-# OPAQUE f #-}+  f x = (x,y)++  g True  = f 2 x+  g False = (0,0)++Where if we didn't strip the CPR info from 'f' we would end up with the+following W/W pair for 'g':++  $wg True  = case f 2 of (x, y) -> (# x, y #)+  $wg False = (# 0, 0 #)++  g b = case wg$ b of (# x, y #) -> (x, y)++Where the worker unboxes the result of 'f', only for wrapper to box it again.+That's because the non-stripped CPR signature of 'f' is saying to W/W-transform+'f'. However, OPAQUE-annotated binders aren't W/W transformed (see+Note [OPAQUE pragma]), so we should strip 'f's CPR signature.+-}+ -- | Process the RHS of the binding for a sensible arity, add the CPR signature -- to the Id, and augment the environment with the signature as well. cprAnalBind@@ -454,8 +477,12 @@       | otherwise   = rhs_ty     -- See Note [Arity trimming for CPR signatures]     sig  = mkCprSigForArity (idArity id) rhs_ty'-    id'  = setIdCprSig id sig-    env' = extendSigEnv env id sig+    -- See Note [OPAQUE pragma]+    -- See Note [The OPAQUE pragma and avoiding the reboxing of results]+    sig' | isOpaquePragma (idInlinePragma id) = topCprSig+         | otherwise                          = sig+    id'  = setIdCprSig id sig'+    env' = extendSigEnv env id sig'      -- See Note [CPR for thunks]     stays_thunk = is_thunk && not_strict@@ -563,6 +590,8 @@   -- iteration. See Note [Initialising strictness] in "GHC.Core.Opt.DmdAnal"   , ae_fam_envs :: FamInstEnvs   -- ^ Needed when expanding type families and synonyms of product types.+  , ae_rec_dc :: DataCon -> IsRecDataConResult+  -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'   }  instance Outputable AnalEnv where@@ -594,7 +623,11 @@   { ae_sigs = SE emptyUnVarSet emptyVarEnv   , ae_virgin = True   , ae_fam_envs = fam_envs-  }+  , ae_rec_dc = memoiseUniqueFun (isRecDataCon fam_envs fuel)+  } where+    fuel = 3 -- If we can unbox more than 3 constructors to find a+             -- recursive occurrence, then we can just as well unbox it+             -- See Note [CPR for recursive data constructors], point (4)  modifySigEnv :: (SigEnv -> SigEnv) -> AnalEnv -> AnalEnv modifySigEnv f env = env { ae_sigs = f (ae_sigs env) }@@ -985,43 +1018,47 @@ Note [CPR for recursive data constructors]? That is up to 'GHC.Core.Opt.WorkWrapW.Utils.isRecDataCon' to decide. It does a DFS search over the field types of the DataCon and looks for term-level recursion into the data-constructor's type constructor. A few perhaps surprising points:+constructor's type constructor. Assuming infinite fuel (point (4) below), it+looks inside the following class of types, represented by `ty` (and responds+`NonRecursiveOrUnsure` in all other cases): + A. If `ty = forall v. ty'`, then look into `ty'`+ B. If `ty = Tc tc_args` and `Tc` is an `AlgTyCon`, look into the arg+    types of its data constructors and check `tc_args` for recursion.+ C. If `ty = F tc_args`, `F` is a `FamTyCon` and we can reduce `F tc_args` to+    `rhs`, look into the `rhs` type.++A few perhaps surprising points:+   1. It deems any function type as non-recursive, because it's unlikely that      a recursion through a function type builds up a recursive data structure.   2. It doesn't look into kinds or coercion types because there's nothing to unbox.      Same for promoted data constructors.-  3. We don't care whether a NewTyCon or DataTyCon App is fully saturated or not;-     we simply look at its definition/DataCons and its field tys. Any recursive arg-     occs will have been detected before (see the invariant of 'go_tc_app').-     This is so that we expand the `ST` in `StateT Int (ST s) a`.+  3. We don't care whether an AlgTyCon app `T tc_args` is fully saturated or not;+     we simply look at its definition/DataCons and its field tys and look for+     recursive occs in the `tc_args` we are given. This is so that we expand+     the `ST` in `StateT Int (ST s) a`.   4. We don't recurse deeper than 3 (at the moment of this writing) TyCons and-     assume the DataCon is non-recursive after that. One reason is guaranteed-     constant-time efficiency; the other is that it's fair to say that a recursion-     over 3 or more TyCons doesn't really count as a list-like data structure-     anymore and a bit of unboxing doesn't hurt much.-  5. It checks TyConApps like `T <huge> <type>` by eagerly checking the-     potentially huge argument types *before* it tries to expand the-     DataCons/NewTyCon/TyFams/etc. so that it doesn't need to re-check those-     argument types after having been substituted into every occurrence of-     the the respective TyCon parameter binders. It's like call-by-value vs.-     call-by-name: Eager checking of argument types means we only need to check-     them exactly once.-     There's one exception to that rule, namely when we are able to reduce a-     TyFam by considering argument types. Then we pay the price of potentially-     checking the same type arg twice (or more, if the TyFam is recursive).-     It should hardly matter.+     assume the DataCon is non-recursive after that. One reason for this "fuel"+     approach is guaranteed constant-time efficiency; the other is that it's+     fair to say that a recursion over 3 or more TyCons doesn't really count as+     a list-like data structure anymore and a bit of unboxing doesn't hurt much.+  5. It checks AlgTyCon apps like `T tc_args` by eagerly checking the `tc_args`+     *before* it looks into the expanded DataCons/NewTyCon, so that it+     terminates before doing a deep nest of expansions only to discover that the+     first level already contained a recursion.   6. As a result of keeping the implementation simple, it says "recursive"      for `data T = MkT [T]`, even though we could argue that the inner recursion      (through the `[]` TyCon) by way of which `T` is recursive will already be      "broken" and thus never unboxed. Consequently, it might be OK to CPR a      function returning `T`. Lacking arguments for or against the current simple      behavior, we stick to it.-  7. When the search hits an abstract TyCon (one without visible DataCons, e.g.,-     from an .hs-boot file), it returns 'Nothing' for "inconclusive", the same-     as when we run out of fuel. If there is ever a recursion through an-     abstract TyCon, then it's not part of the same function we are looking at,-     so we can treat it as if it wasn't recursive.+  7. When the search hits an abstract TyCon (algebraic, but without visible+     DataCons, e.g., from an .hs-boot file), it returns 'NonRecursiveOrUnsure',+     the same as when we run out of fuel. If there is ever a recursion through+     an abstract TyCon, then it's not part of the same function we are looking+     at in CPR, so we can treat it as if it wasn't recursive.+     We handle stuck type and data families much the same.  Here are a few examples of data constructors or data types with a single data con and the answers of our function:@@ -1044,12 +1081,12 @@       E Int = Char       E (a,b) = (E a, E b)       E Char = Blub-    data Blah = Blah (E (Int, (Int, Int)))     NonRec  (see point (5))+    data Blah = Blah (E (Int, (Int, Int)))     NonRec     data Blub = Blub (E (Char, Int))           Rec-    data Blub2 = Blub2 (E (Bool, Int))     }   Rec, because stuck+    data Blub2 = Blub2 (E (Bool, Int))     }   Unsure, because stuck (see point (7))    { data T1 = T1 T2; data T2 = T2 T3;-    ... data T5 = T5 T1                    }   Nothing (out of fuel)  (see point (4))+    ... data T5 = T5 T1                    }   Unsure (out of fuel)  (see point (4))    { module A where -- A.hs-boot       data T@@ -1057,7 +1094,7 @@       import {-# SOURCE #-} A       data U = MkU T       f :: T -> U-      f t = MkU t                              Nothing (T is abstract)  (see point (7))+      f t = MkU t                              Unsure (T is abstract)  (see point (7))     module A where -- A.hs       import B       data T = MkT U }

@@ -40,10 +40,11 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Panic.Plain-import GHC.Data.Maybe         ( isJust, orElse )+import GHC.Data.Maybe import GHC.Builtin.PrimOps import GHC.Builtin.Types.Prim ( realWorldStatePrimTy ) import GHC.Types.Unique.Set+import GHC.Types.Unique.MemoFun  import GHC.Utils.Trace _ = pprTrace -- Tired of commenting out the import all the time@@ -96,7 +97,7 @@     add_exported_uses :: AnalEnv -> DmdType -> [Id] -> DmdType     add_exported_uses env = foldl' (add_exported_use env) -    -- | If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@+    -- If @e@ is denoted by @dmd_ty@, then @add_exported_use _ dmd_ty id@     -- corresponds to the demand type of @(id, e)@, but is a lot more direct.     -- See Note [Analysing top-level bindings].     add_exported_use :: AnalEnv -> DmdType -> Id -> DmdType@@ -352,7 +353,7 @@   -- NB: (:*) expands AbsDmd and BotDmd as needed   -- See Note [Analysing with absent demand]   | WithDmdType dmd_ty e' <- dmdAnal env sd e-  = assertPpr (not (isUnliftedType (exprType e)) || exprOkForSpeculation e) (ppr e)+  = assertPpr (mightBeLiftedType (exprType e) || exprOkForSpeculation e) (ppr e)     -- The argument 'e' should satisfy the let/app invariant     (toPlusDmdArg $ multDmdType n dmd_ty, e') @@ -428,8 +429,9 @@  dmdAnal' env dmd (Case scrut case_bndr ty [Alt alt bndrs rhs])   -- Only one alternative.-  -- If it's a DataAlt, it should be the only constructor of the type.-  | is_single_data_alt alt+  -- If it's a DataAlt, it should be the only constructor of the type and we+  -- can consider its field demands when analysing the scrutinee.+  | want_precise_field_dmds alt   = let         WithDmdType rhs_ty rhs'           = dmdAnal env dmd rhs         WithDmdType alt_ty1 fld_dmds      = findBndrsDmds env rhs_ty bndrs@@ -454,10 +456,9 @@           -- __DEFAULT and literal alts. Simply add demands and discard the           -- evaluation cardinality, as we evaluate the scrutinee exactly once.           = assert (null bndrs) (bndrs, case_bndr_sd)-        fam_envs                 = ae_fam_envs env         alt_ty3           -- See Note [Precise exceptions and strictness analysis] in "GHC.Types.Demand"-          | exprMayThrowPreciseException fam_envs scrut+          | exprMayThrowPreciseException (ae_fam_envs env) scrut           = deferAfterPreciseException alt_ty2           | otherwise           = alt_ty2@@ -474,8 +475,12 @@ --                                   , text "res_ty" <+> ppr res_ty ]) $     WithDmdType res_ty (Case scrut' case_bndr' ty [Alt alt bndrs' rhs'])     where-      is_single_data_alt (DataAlt dc) = isJust $ tyConSingleAlgDataCon_maybe $ dataConTyCon dc-      is_single_data_alt _            = True+      want_precise_field_dmds alt = case alt of+        (DataAlt dc)+          | Nothing <- tyConSingleAlgDataCon_maybe $ dataConTyCon dc -> False+          | DefinitelyRecursive <- ae_rec_dc env dc                  -> False+              -- See Note [Demand analysis for recursive data constructors]+        _                                                            -> True   @@ -689,12 +694,29 @@ from 'topDiv' to 'conDiv', leading to bugs, performance regressions and complexity that didn't justify the single fixed testcase T13380c. +Note [Demand analysis for recursive data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+T11545 features a single-product, recursive data type+  data A = A A A ... A+    deriving Eq+Naturally, `(==)` is deeply strict in `A` and in fact will never terminate. That+leads to very large (exponential in the depth) demand signatures and fruitless+churn in boxity analysis, demand analysis and worker/wrapper.+So we detect `A` as a recursive data constructor+(see Note [Detecting recursive data constructors]) analysing `case x of A ...`+and simply assume L for the demand on field binders, which is the same code+path as we take for sum types.+Combined with the B demand on the case binder, we get the very small demand+signature <1S><1S>b on `(==)`. This improves ghc/alloc performance on T11545+tenfold! See also Note [CPR for recursive data constructors] which describes the+sibling mechanism in CPR analysis.+ Note [Demand on the scrutinee of a product case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When figuring out the demand on the scrutinee of a product case, we use the demands of the case alternative, i.e. id_dmds. But note that these include the demand on the case binder;-see Note [Demand on case-alternative binders] in GHC.Types.Demand.+see Note [Demand on case-alternative binders]. This is crucial. Example:    f x = case x of y { (a,b) -> k y a } If we just take scrut_demand = 1P(L,A), then we won't pass x to the@@ -869,7 +891,7 @@ -- to the Id, and augment the environment with the signature as well. -- See Note [NOINLINE and strictness] dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs-  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr sig $$ ppr lazy_fv) $+  = -- pprTrace "dmdAnalRhsSig" (ppr id $$ ppr let_dmd $$ ppr rhs_dmds $$ ppr sig $$ ppr lazy_fv) $     (final_env, lazy_fv, final_id, final_rhs)   where     rhs_arity = idArity id@@ -882,15 +904,17 @@       -- See Note [Demand analysis for join points]       -- See Note [Invariants on join points] invariant 2b, in GHC.Core       --     rhs_arity matches the join arity of the join point-      = let_dmd+      -- See Note [Unboxed demand on function bodies returning small products]+      = unboxedWhenSmall env rec_flag (resultType_maybe id) let_dmd       | otherwise       -- See Note [Unboxed demand on function bodies returning small products]-      = unboxedWhenSmall (ae_opts env) (unboxableResultWidth env id) topSubDmd+      = unboxedWhenSmall env rec_flag (resultType_maybe id) topSubDmd -    -- See Note [Do not unbox class dictionaries]     WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs-    DmdType rhs_fv rhs_dmds rhs_div    = rhs_dmd_ty-    (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id rhs_arity rhs'+    DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty+    -- See Note [Do not unbox class dictionaries]+    -- See Note [Boxity for bottoming functions]+    (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id rhs_arity rhs' rhs_div                                   `orElse` (rhs_dmds, rhs')      sig = mkDmdSigForArity rhs_arity (DmdType sig_fv final_rhs_dmds rhs_div)@@ -920,26 +944,45 @@     -- See Note [Lazy and unleashable free variables]     !(!lazy_fv, !sig_fv) = partitionVarEnv isWeakDmd rhs_fv2 -unboxableResultWidth :: AnalEnv -> Id -> Maybe Arity-unboxableResultWidth env id+-- | The result type after applying 'idArity' many arguments. Returns 'Nothing'+-- when the type doesn't have exactly 'idArity' many arrows.+resultType_maybe :: Id -> Maybe Type+resultType_maybe id   | (pis,ret_ty) <- splitPiTys (idType id)   , count (not . isNamedBinder) pis == idArity id-  , Just (tc, _tc_args, _co) <- normSplitTyConApp_maybe (ae_fam_envs env) ret_ty-  , Just dc <- tyConSingleAlgDataCon_maybe tc-  , null (dataConExTyCoVars dc) -- Can't unbox results with existentials-  = Just (dataConRepArity dc)+  = Just $! ret_ty   | otherwise   = Nothing -unboxedWhenSmall :: DmdAnalOpts -> Maybe Arity -> SubDemand -> SubDemand+unboxedWhenSmall :: AnalEnv -> RecFlag -> Maybe Type -> SubDemand -> SubDemand -- See Note [Unboxed demand on function bodies returning small products]-unboxedWhenSmall opts mb_n sd-  | Just n <- mb_n-  , n <= dmd_unbox_width opts-  = unboxSubDemand sd-  | otherwise-  = sd+unboxedWhenSmall _   _        Nothing       sd = sd+unboxedWhenSmall env rec_flag (Just ret_ty) sd = go 1 ret_ty sd+  where+    -- Magic constant, bounding the depth of optimistic 'Unboxed' flags. We+    -- might want to minmax in the future.+    max_depth | isRec rec_flag = 3 -- So we get at most something as deep as !P(L!P(L!L))+              | otherwise      = 1 -- Otherwise be unbox too deep in T18109, T18174 and others and get a bunch of stack overflows+    go :: Int -> Type -> SubDemand -> SubDemand+    go depth ty sd+      | depth <= max_depth+      , Just (tc, tc_args, _co) <- normSplitTyConApp_maybe (ae_fam_envs env) ty+      , Just dc <- tyConSingleAlgDataCon_maybe tc+      , null (dataConExTyCoVars dc) -- Can't unbox results with existentials+      , dataConRepArity dc <= dmd_unbox_width (ae_opts env)+      , Just (_, ds) <- viewProd (dataConRepArity dc) sd+      , arg_tys <- map scaledThing $ dataConInstArgTys dc tc_args+      , equalLength ds arg_tys+      = mkProd Unboxed $! strictZipWith (go_dmd (depth+1)) arg_tys ds+      | otherwise+      = sd +    go_dmd :: Int -> Type -> Demand -> Demand+    go_dmd depth ty dmd = case dmd of+      AbsDmd  -> AbsDmd+      BotDmd  -> BotDmd+      n :* sd -> n :* go depth ty sd+ -- | If given the (local, non-recursive) let-bound 'Id', 'useLetUp' determines -- whether we should process the binding up (body before rhs) or down (rhs -- before body).@@ -1157,6 +1200,69 @@ (since it is apparently Absent) and then inline (\x. fst g) we get disaster.  But regardless, #18638 was a more complicated version of this, that actually happened in practice.++Note [Boxity for bottoming functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+```hs+indexError :: Show a => (a, a) -> a -> String -> b+-- Str=<..><1!P(S,S)><1S><S>b+indexError rng i s = error (show rng ++ show i ++ show s)++get :: (Int, Int) -> Int -> [a] -> a+get p@(l,u) i xs+  | l <= i, i < u = xs !! (i-u)+  | otherwise     = indexError p i "get"+```+The hot path of `get` certainly wants to unbox `p` as well as `l` and `u`, but+the unimportant, diverging error path needs `l` and `u` boxed (although the+wrapper for `indexError` *will* unbox `p`). This pattern often occurs in+performance sensitive code that does bounds-checking.++It would be a shame to let `Boxed` win for the fields! So here's what we do:+While to summarising `indexError`'s boxity signature in `finaliseArgBoxities`,+we `unboxDeeplyDmd` all its argument demands and are careful not to discard+excess boxity in the `StopUnboxing` case, to get the signature+`<1!P(!S,!S)><1!S><S!S>b`.++Then worker/wrapper will not only unbox the pair passed to `indexError` (as it+would do anyway), demand analysis will also pretend that `indexError` needs `l`+and `u` unboxed (and the two other args). Which is a lie, because `indexError`'s+type abstracts over their types and could never unbox them.++The important change is at the *call sites* of `$windexError`: Boxity analysis+will conclude to unbox `l` and `u`, which *will* incur reboxing of crud that+should better float to the call site of `$windexError`. There we don't care+much, because it's in the slow, diverging code path! And that floating often+happens, but not always. See Note [Reboxed crud for bottoming calls].++Note [Reboxed crud for bottoming calls]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For functions like `get` in Note [Boxity for bottoming functions], it's clear+that the reboxed crud will be floated inside to the call site of `$windexError`.+But here's an example where that is not the case:+```hs+import GHC.Ix++theresCrud :: Int -> Int -> Int+theresCrud x y = go x+  where+    go 0 = index (0,y) 0+    go 1 = index (x,y) 1+    go n = go (n-1)+    {-# NOINLINE theresCrud #-}+```+If you look at the Core, you'll see that `y` will be reboxed and used in the+two exit join points for the `$windexError` calls, while `x` is only reboxed in the+exit join point for `index (x,y) 1` (happens in lvl below):+```+$wtheresCrud = \ ww ww1 ->+      let { y = I# ww1 } in+      join { lvl2 = ... case lvl1 ww y of wild { }; ... } in+      join { lvl3 = ... case lvl y of wild { }; ... } in+      ...+```+This is currently a bug that we willingly accept and it's documented in #21128. -}  {- *********************************************************************@@ -1410,6 +1516,24 @@ To achieve this, we use the classic almost-circular programming technique in which we we write one pass that takes a lazy list of the Budgets for every layer.++Note [The OPAQUE pragma and avoiding the reboxing of arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In https://gitlab.haskell.org/ghc/ghc/-/issues/13143 it was identified that when+a function 'f' with a NOINLINE pragma is W/W transformed, then the worker for+'f' should get the NOINLINE annotation, while the wrapper /should/ be inlined.++That's because if the wrapper for 'f' had stayed NOINLINE, then any worker of a+W/W-transformed /caller of/ 'f' would immediately rebox any unboxed arguments+that is applied to the wrapper of 'f'. When the wrapper is inlined, that kind of+reboxing does not happen.++But now we have functions with OPAQUE pragmas, which by definition (See Note+[OPAQUE pragma]) do not get W/W-transformed. So in order to avoid reboxing+workers of any W/W-transformed /callers of/ 'f' we need to strip all boxity+information from 'f' in the demand analysis. This will inform the+W/W-transformation code that boxed arguments of 'f' must definitely be passed+along in boxed form and as such dissuade the creation of reboxing workers. -}  data Budgets = MkB Arity Budgets   -- An infinite list of arity budgets@@ -1420,9 +1544,9 @@ positiveTopBudget :: Budgets -> Bool positiveTopBudget (MkB n _) = n >= 0 -finaliseArgBoxities :: AnalEnv -> Id -> Arity -> CoreExpr+finaliseArgBoxities :: AnalEnv -> Id -> Arity -> CoreExpr -> Divergence                     -> Maybe ([Demand], CoreExpr)-finaliseArgBoxities env fn arity rhs+finaliseArgBoxities env fn arity rhs div   | arity > count isId bndrs  -- Can't find enough binders   = Nothing  -- This happens if we have   f = g              -- Then there are no binders; we don't worker/wrapper; and we@@ -1453,13 +1577,20 @@      mk_triple :: Id -> (Type,StrictnessMark,Demand)     mk_triple bndr | is_cls_arg ty = (ty, NotMarkedStrict, trimBoxity dmd)+                   | is_bot_fn     = (ty, NotMarkedStrict, unboxDeeplyDmd dmd)+                   -- See Note [OPAQUE pragma]+                   -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]+                   | is_opaque     = (ty, NotMarkedStrict, trimBoxity dmd)                    | otherwise     = (ty, NotMarkedStrict, dmd)                    where-                     ty  = idType bndr-                     dmd = idDemandInfo bndr+                     ty        = idType bndr+                     dmd       = idDemandInfo bndr+                     is_opaque = isOpaquePragma (idInlinePragma fn)      -- is_cls_arg: see Note [Do not unbox class dictionaries]     is_cls_arg arg_ty = is_inlinable_fn && isClassPred arg_ty+    -- is_bot_fn:  see Note [Boxity for bottoming functions]+    is_bot_fn         = div == botDiv      go_args :: Budgets -> [(Type,StrictnessMark,Demand)] -> (Budgets, [Demand])     go_args bg triples = mapAccumL go_arg bg triples@@ -1467,8 +1598,11 @@     go_arg :: Budgets -> (Type,StrictnessMark,Demand) -> (Budgets, Demand)     go_arg bg@(MkB bg_top bg_inner) (ty, str_mark, dmd@(n :* _))       = case wantToUnboxArg False fam_envs ty dmd of-          DropAbsent   -> (bg,                      dmd)-          StopUnboxing -> (MkB (bg_top-1) bg_inner, trimBoxity dmd)+          StopUnboxing+            | not is_bot_fn+                -- If bot: Keep deep boxity even though WW won't unbox+                -- See Note [Boxity for bottoming functions]+            -> (MkB (bg_top-1) bg_inner, trimBoxity dmd)            Unbox DataConPatContext{dcpc_dc=dc, dcpc_tc_args=tc_args} dmds             -> (MkB (bg_top-1) final_bg_inner, final_dmd)@@ -1484,10 +1618,13 @@                      -- isStrict: see Note [No lazy, Unboxed demands in demand signature]                      -- isMarkedStrict: see Note [Unboxing evaluated arguments]                   , positiveTopBudget bg_inner'+                  , NonRecursiveOrUnsure <- ae_rec_dc env dc+                     -- See Note [Which types are unboxed?]+                     -- and Note [Demand analysis for recursive data constructors]                   = (bg_inner', dmd')                   | otherwise                   = (bg_inner, trimBoxity dmd)-          Unlift -> panic "No unlifting in DmdAnal"+          _ -> (bg, dmd)      add_demands :: [Demand] -> CoreExpr -> CoreExpr     -- Attach the demands to the outer lambdas of this expression@@ -1817,12 +1954,15 @@   data AnalEnv = AE-   { ae_opts      :: !DmdAnalOpts -- ^ Analysis options-   , ae_sigs      :: !SigEnv-   , ae_virgin    :: !Bool -- ^ True on first iteration only-                           -- See Note [Initialising strictness]-   , ae_fam_envs  :: !FamInstEnvs-   }+  { ae_opts      :: !DmdAnalOpts+  -- ^ Analysis options+  , ae_sigs      :: !SigEnv+  , ae_virgin    :: !Bool+  -- ^ True on first iteration only. See Note [Initialising strictness]+  , ae_fam_envs  :: !FamInstEnvs+  , ae_rec_dc    :: DataCon -> IsRecDataConResult+  -- ^ Memoised result of 'GHC.Core.Opt.WorkWrap.Utils.isRecDataCon'+  }          -- We use the se_env to tell us whether to         -- record info about a variable in the DmdEnv@@ -1845,6 +1985,7 @@          , ae_sigs         = emptySigEnv          , ae_virgin       = True          , ae_fam_envs     = fam_envs+         , ae_rec_dc       = memoiseUniqueFun (isRecDataCon fam_envs 3)          }  emptySigEnv :: SigEnv

@@ -131,11 +131,11 @@     -- variables bound on the way and lifts it out as a join point.     --     -- ExitifyM is a state monad to keep track of floated binds-    go :: [Var]           -- ^ Variables that are in-scope here, but+    go :: [Var]           -- Variables that are in-scope here, but                           -- not in scope at the joinrec; that is,                           -- we must potentially abstract over them.                           -- Invariant: they are kept in dependency order-       -> CoreExprWithFVs -- ^ Current expression in tail position+       -> CoreExprWithFVs -- Current expression in tail position        -> ExitifyM CoreExpr      -- We first look at the expression (no matter what it shape is)

@@ -27,7 +27,7 @@ import GHC.Core.FVs import GHC.Core.Type -import GHC.Types.Basic      ( RecFlag(..), isRec )+import GHC.Types.Basic      ( RecFlag(..), isRec, Levity(Unlifted) ) import GHC.Types.Id         ( isOneShotBndr, idType, isJoinId, isJoinId_maybe ) import GHC.Types.Tickish import GHC.Types.Var@@ -448,6 +448,7 @@  fiExpr platform to_drop (_, AnnCase scrut case_bndr _ [AnnAlt con alt_bndrs rhs])   | isUnliftedType (idType case_bndr)+     -- binders have a fixed RuntimeRep so it's OK to call isUnliftedType   , exprOkForSideEffects (deAnnotate scrut)       -- See Note [Floating primops]   = wrapFloats shared_binds $@@ -592,7 +593,7 @@  noFloatIntoArg :: CoreExprWithFVs' -> Type -> Bool noFloatIntoArg expr expr_ty-  | isUnliftedType expr_ty+  | Just Unlifted <- typeLevity_maybe expr_ty   = True  -- See Note [Do not destroy the let/app invariant]     | AnnLam bndr e <- expr

@@ -269,6 +269,8 @@   = go [] [] (bagToList fs)   where     go ul_prs prs (FloatLet (NonRec b r) : fs) | isUnliftedType (idType b)+                                               -- NB: isUnliftedType is OK here as binders always+                                               -- have a fixed RuntimeRep.                                                , not (isJoinId b)                                                = go ((b,r):ul_prs) prs fs                                                | otherwise

@@ -574,25 +574,40 @@  Its not wrong to drop it on the floor, but better to keep it. -Note [Cast w/w: unlifted]-~~~~~~~~~~~~~~~~~~~~~~~~~-BUT don't do cast worker/wrapper if 'e' has an unlifted type.-This *can* happen:+Note [Preserve RuntimeRep info in cast w/w]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We must not do cast w/w when the presence of the coercion is needed in order+to determine the runtime representation. -     foo :: Int = (error (# Int,Int #) "urk")-                  `cast` CoUnsafe (# Int,Int #) Int+Example: -If do the makeTrivial thing to the error call, we'll get-    foo = case error (# Int,Int #) "urk" of v -> v `cast` ...-But 'v' isn't in scope!+  Suppose we have a type family: -These strange casts can happen as a result of case-of-case-        bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of-                (# p,q #) -> p+q+    type F :: RuntimeRep+    type family F where+      F = LiftedRep -NOTE: Nowadays we don't use casts for these error functions;-instead, we use (case erorr ... of {}). So I'm not sure-this Note makes much sense any more.+  together with a type `ty :: TYPE F` and a top-level binding++    a :: ty |> TYPE F[0]++  The kind of `ty |> TYPE F[0]` is `LiftedRep`, so `a` is a top-level lazy binding.+  However, were we to apply cast w/w, we would get:++    b :: ty+    b = ...++    a :: ty |> TYPE F[0]+    a = b `cast` GRefl (TYPE F[0])++  Now we are in trouble because `ty :: TYPE F` does not have a known runtime+  representation, because we need to be able to reduce the nullary type family+  application `F` to find that out.++Conclusion: only do cast w/w when doing so would not lose the RuntimeRep+information. That is, when handling `Cast rhs co`, don't attempt cast w/w+unless the kind of the type of rhs is concrete, in the sense of+Note [Concrete types] in GHC.Tc.Utils.Concrete. -}  tryCastWorkerWrapper :: SimplEnv -> TopLevelFlag@@ -606,8 +621,11 @@                         --            a DFunUnfolding in mk_worker_unfolding   , not (exprIsTrivial rhs)        -- Not x = y |> co; Wrinkle 1   , not (hasInlineUnfolding info)  -- Not INLINE things: Wrinkle 4-  , not (isUnliftedType rhs_ty)    -- Not if rhs has an unlifted type;-                                   --     see Note [Cast w/w: unlifted]+  , isConcrete (typeKind rhs_ty)   -- Don't peel off a cast if doing so would+                                   -- lose the underlying runtime representation.+                                   -- 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         ; let work_name = mkSystemVarName uniq occ_fs@@ -2850,6 +2868,7 @@   = isTyCoArg scrut        -- Note [Core type and coercion invariant]    | isUnliftedType (idType case_bndr)+    -- OK to call isUnliftedType: scrutinees always have a fixed RuntimeRep (see FRRCase)   = exprOkForSpeculation scrut    | otherwise  -- Scrut has a lifted type

@@ -526,6 +526,8 @@           -- 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 

@@ -590,21 +590,14 @@       | Just (_, arg_ty, fun_ty') <- splitFunTy_maybe fun_ty        -- Add strict-type info       , dmd : rest_dmds <- dmds       , let dmd'-             -- TODO: we should just use isLiftedType_maybe, but that-             -- function is currently wrong (#20837).-             | Just rr <- getRuntimeRep_maybe arg_ty-             , Just False <- isLiftedRuntimeRep_maybe rr-             -- The type is definitely unlifted, such as:-             --   - TYPE (BoxedRep Unlifted)-             --   - TYPE IntRep, TYPE FloatRep, ...+             | Just Unlifted <- typeLevity_maybe arg_ty              = strictifyDmd dmd              | otherwise-             -- Could be definitely lifted, or we're not sure (e.g. levity-polymorphic).+             -- Something that's not definitely unlifted.+             -- If the type is representation-polymorphic, we can't know whether+             -- it's strict.              = dmd       = dmd' : add_type_strictness fun_ty' rest_dmds-          -- If the type is representation-polymorphic, we can't know whether-          -- it's strict. isLiftedType_maybe will return Just False only when-          -- we're sure the type is unlifted.        | otherwise       = dmds

@@ -30,7 +30,7 @@ import GHC.Core.Unfold import GHC.Core.FVs     ( exprsFreeVarsList ) import GHC.Core.Opt.Monad-import GHC.Core.Opt.WorkWrap.Utils ( isWorkerSmallEnough, mkWorkerArgs )+import GHC.Core.Opt.WorkWrap.Utils import GHC.Core.DataCon import GHC.Core.Coercion hiding( substCo ) import GHC.Core.Rules@@ -1650,7 +1650,14 @@   = -- pprTrace "specialise bot" (ppr fn) $     return (nullUsage, spec_info) -  | not (isNeverActive (idInlineActivation fn))  -- See Note [Transfer activation]+  | not (isNeverActive (idInlineActivation fn))+      -- See Note [Transfer activation]+      --+      --+      -- Don't specialise OPAQUE things, see Note [OPAQUE pragma].+      -- Since OPAQUE things are always never-active (see+      -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for+      -- OPAQUE things.   , not (null arg_bndrs)                         -- Only specialise functions   , Just all_calls <- lookupVarEnv bind_calls fn -- Some calls to it   = -- pprTrace "specialise entry {" (ppr fn <+> ppr all_calls) $@@ -1771,20 +1778,25 @@                  -- And build the results         ; let spec_body_ty   = exprType spec_body-              (spec_lam_args1, spec_sig, spec_arity, spec_join_arity)+              (spec_lam_args1, spec_sig, spec_arity1, spec_join_arity1)                   = calcSpecInfo fn call_pat extra_bndrs                   -- Annotate the variables with the strictness information from                   -- the function (see Note [Strictness information in worker binders]) -              (spec_lam_args, spec_call_args,_) = mkWorkerArgs fn False-                                                    spec_lam_args1 []-                                                    spec_body_ty-                -- mkWorkerArgs: usual w/w hack to avoid generating-                -- a spec_rhs of unlifted type and no args.-                -- Unlike W/W we don't turn functions into strict workers-                -- immediately here instead letting tidy handle this.-                -- For this reason we can ignore the cbv marks.-                -- See Note [Strict Worker Ids]. See Note [Tag Inference].+              (spec_lam_args, spec_call_args, spec_arity, spec_join_arity)+                  | needsVoidWorkerArg fn arg_bndrs spec_lam_args1+                  , (spec_lam_args, spec_call_args, _) <- addVoidWorkerArg spec_lam_args1 []+                      -- needsVoidWorkerArg: usual w/w hack to avoid generating+                      -- a spec_rhs of unlifted type and no args.+                      -- Unlike W/W we don't turn functions into strict workers+                      -- immediately here instead letting tidy handle this.+                      -- For this reason we can ignore the cbv marks.+                      -- See Note [Strict Worker Ids]. See Note [Tag Inference].+                  , !spec_arity      <- spec_arity1 + 1+                  , !spec_join_arity <- fmap (+ 1) spec_join_arity1+                  = (spec_lam_args,  spec_call_args, spec_arity,  spec_join_arity)+                  | otherwise+                  = (spec_lam_args1, spec_lam_args1, spec_arity1, spec_join_arity1)                spec_id    = mkLocalId spec_name Many                                      (mkLamTypes spec_lam_args spec_body_ty)@@ -2442,7 +2454,7 @@ setStrUnfolding :: Id -> StrictnessMark  -> Id -- setStrUnfolding id str = id setStrUnfolding id str-  -- | pprTrace "setStrUnfolding"+  -- pprTrace "setStrUnfolding"   --   (ppr id <+> ppr (isMarkedCbv str) $$   --    ppr (idType id) $$   --    text "boxed:" <> ppr (isBoxedType (idType id)) $$@@ -2453,7 +2465,7 @@   | not (isId id) || isEvaldUnfolding (idUnfolding id)   = id   | isMarkedStrict str-  , not (isUnliftedType (idType id)) -- Pointless to stick an evald unfolding on unlifted types+  , not $ isUnliftedType (idType id) -- Pointless to stick an evald unfolding on unlifted types   = -- trace "setStrUnfolding2" $     assert (isId id) $     assert (not $ hasCoreUnfolding $ idUnfolding id) $

@@ -1431,6 +1431,11 @@   && not (isNeverActive (idInlineActivation fn))         -- Don't specialise NOINLINE things         -- See Note [Auto-specialisation and RULES]+        --+        -- Don't specialise OPAQUE things, see Note [OPAQUE pragma].+        -- Since OPAQUE things are always never-active (see+        -- GHC.Parser.PostProcess.mkOpaquePragma) this guard never fires for+        -- OPAQUE things.  --   && not (certainlyWillInline (idUnfolding fn))      -- And it's not small --      See Note [Inline specialisations] for why we do not@@ -1519,7 +1524,7 @@                  -- Maybe add a void arg to the specialised function,                  -- to avoid unlifted bindings                  -- See Note [Specialisations Must Be Lifted]-                 -- C.f. GHC.Core.Opt.WorkWrap.Utils.mkWorkerArgs+                 -- C.f. GHC.Core.Opt.WorkWrap.Utils.needsVoidWorkerArg                  add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn)                  (spec_bndrs, spec_rhs, spec_fn_ty)                    | add_void_arg = ( voidPrimId : spec_bndrs1

@@ -534,9 +534,6 @@                                         -- if two, then a worker and a                                         -- wrapper. tryWW ww_opts is_rec fn_id rhs-  -- Do this even if there is a NOINLINE pragma-  -- See Note [Worker/wrapper for NOINLINE functions]-   -- See Note [Drop absent bindings]   | isAbsDmd (demandInfo fn_info)   , not (isJoinId fn_id)@@ -551,6 +548,35 @@   | isRecordSelector fn_id   = return [ (new_fn_id, rhs ) ] +  -- Don't w/w OPAQUE things+  -- See Note [OPAQUE pragma]+  --+  -- Whilst this check might seem superfluous, since we strip boxity+  -- information in GHC.Core.Opt.DmdAnal.finaliseArgBoxities and+  -- CPR information in GHC.Core.Opt.CprAnal.cprAnalBind, it actually+  -- isn't. That is because we would still perform w/w when:+  --+  -- - An argument is used strictly, and -fworker-wrapper-cbv is+  --   enabled, or,+  -- - When demand analysis marks an argument as absent.+  --+  -- In a debug build we do assert that boxity and CPR information+  -- are actually stripped, since we want to prevent callers of OPAQUE+  -- things to do reboxing. See:+  -- - Note [The OPAQUE pragma and avoiding the reboxing of arguments]+  -- - Note [The OPAQUE pragma and avoiding the reboxing of results]+  | isOpaquePragma (inlinePragInfo fn_info)+  = assertPpr (onlyBoxedArguments (dmdSigInfo fn_info) &&+               isTopCprSig (cprSigInfo fn_info))+              (text "OPAQUE fun with boxity" $$+               ppr new_fn_id $$+               ppr (dmdSigInfo fn_info) $$+               ppr (cprSigInfo fn_info) $$+               ppr rhs) $+    return [ (new_fn_id, rhs) ]++  -- Do this even if there is a NOINLINE pragma+  -- See Note [Worker/wrapper for NOINLINE functions]   | is_fun   = splitFun ww_opts new_fn_id rhs @@ -899,18 +925,6 @@  The demand on the worker is then calculated using mkWorkerDemand, and always of the form [Demand=<L,1*(C1(...(C1(U))))>]---Note [Do not split void functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this rather common form of binding:-        $j = \x:Void# -> ...no use of x...--Since x is not used it'll be marked as absent.  But there is no point-in w/w-ing because we'll simply add (\y:Void#), see GHC.Core.Opt.WorkWrap.Utils.mkWorerArgs.--If x has a more interesting type (eg Int, or Int#), there *is* a point-in w/w so that we don't pass the argument at all.  Note [Thunk splitting] ~~~~~~~~~~~~~~~~~~~~~~

@@ -8,7 +8,8 @@ {-# LANGUAGE ViewPatterns #-}  module GHC.Core.Opt.WorkWrap.Utils-   ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWWstr_one, mkWorkerArgs+   ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWWstr_one+   , needsVoidWorkerArg, addVoidWorkerArg    , DataConPatContext(..)    , UnboxingDecision(..), wantToUnboxArg    , findTypeShape, IsRecDataConResult(..), isRecDataCon@@ -34,6 +35,7 @@ import GHC.Core.Reduction import GHC.Core.FamInstEnv import GHC.Core.TyCon+import GHC.Core.TyCon.Set import GHC.Core.TyCon.RecWalk import GHC.Core.SimpleOpt( SimpleOpts ) @@ -48,7 +50,6 @@ import GHC.Types.Name ( getOccFS )  import GHC.Data.FastString-import GHC.Data.Maybe import GHC.Data.OrdList import GHC.Data.List.SetOps @@ -141,7 +142,6 @@   { wo_fam_envs          :: !FamInstEnvs   , wo_simple_opts       :: !SimpleOpts   , wo_cpr_anal          :: !Bool-  , wo_fun_to_thunk      :: !Bool    -- Used for absent argument error message   , wo_module            :: !Module@@ -155,7 +155,6 @@   { wo_fam_envs          = fam_envs   , wo_simple_opts       = initSimpleOpts dflags   , wo_cpr_anal          = gopt Opt_CprAnal dflags-  , wo_fun_to_thunk      = gopt Opt_FunToThunk dflags   , wo_module            = this_mod   , wo_unlift_strict     = gopt Opt_WorkerWrapperUnlift dflags   }@@ -240,11 +239,14 @@         ; let (work_args, work_marks) = unzip work_args_cbv          -- Do CPR w/w.  See Note [Always do CPR w/w]-        ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)+        ; (useful2, wrap_fn_cpr, work_fn_cpr)               <- mkWWcpr_entry opts res_ty' res_cpr -        ; let (work_lam_args, work_call_args, work_call_cbv) = mkWorkerArgs fun_id (wo_fun_to_thunk opts)-                                                                 work_args work_marks cpr_res_ty+        ; let (work_lam_args, work_call_args, work_call_cbv)+                | needsVoidWorkerArg fun_id arg_vars work_args+                = addVoidWorkerArg work_args work_marks+                | otherwise+                = (work_args, work_args, work_marks)                call_work work_fn  = mkVarApps (Var work_fn) work_call_args               call_rhs fn_rhs = mkAppsBeta fn_rhs fn_args@@ -347,10 +349,20 @@     of the fun body in the next run of the Simplifier, but CoreLint will complain     in the meantime, so zap it. -We zap in mkWwBodies because we need the zapped variables both when binding them-in mkWWstr (mkAbsentFiller, specifically) and in mkWorkerArgs, where we produce-the call to the fun body.+We zap in mkWwBodies because we need the zapped variables when binding them in+mkWWstr (mkAbsentFiller, specifically). +Note [Do not split void functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this rather common form of binding:+        $j = \x:Void# -> ...no use of x...++Since x is not used it'll be marked as absent.  But there is no point+in w/w-ing because we'll simply add (\y:Void#), see addVoidWorkerArg.++If x has a more interesting type (eg Int, or Int#), there *is* a point+in w/w so that we don't pass the argument at all.+ ************************************************************************ *                                                                      * \subsection{Making wrapper args}@@ -369,44 +381,29 @@ We use the state-token type which generates no code. -} --- | Prevent a function from becoming a thunk by adding a void argument if--- required.-mkWorkerArgs :: Id      -- The wrapper Id-             -> Bool    -- Allow fun->thunk conversion.-             -> [Var]-             -> [CbvMark]-             -> Type    -- Type of body-             -> ([Var], -- Lambda bound args-                 [Var], -- Args at call site-                 [CbvMark] -- cbv semantics for the worker args.-                 )-mkWorkerArgs wrap_id fun_to_thunk args cbv_marks res_ty-    | not (isJoinId wrap_id) -- Join Ids never need an extra arg-    , not (any isId args)    -- No existing value lambdas-    , needs_a_value_lambda   -- and we need to add one-    = (args ++ [voidArgId], args ++ [voidPrimId], cbv_marks ++ [NotMarkedCbv])--    | otherwise-    = (args, args, cbv_marks)-    where-      -- If fun_to_thunk is False we always keep at least one value-      --   argument: see Note [Protecting the last value argument]-      -- If it is True, we only need to keep a value argument if-      --   the result type is (or might be) unlifted, in which case-      --   dropping the last arg would mean we wrongly used call-by-value-      needs_a_value_lambda-        = not fun_to_thunk-          || might_be_unlifted+-- | Whether the worker needs an additional `Void#` arg as per+-- Note [Protecting the last value argument] or+-- Note [Preserving float barriers].+needsVoidWorkerArg :: Id -> [Var] -> [Var] -> Bool+needsVoidWorkerArg fn_id wrap_args work_args+  =  not (isJoinId fn_id) && no_value_arg -- See Note [Protecting the last value argument]+  || needs_float_barrier                  -- See Note [Preserving float barriers]+  where+    no_value_arg        = all (not . isId) work_args+    is_float_barrier v  = isId v && hasNoOneShotInfo (idOneShotInfo v)+    wrap_had_barrier    = any is_float_barrier wrap_args+    work_has_barrier    = any is_float_barrier work_args+    needs_float_barrier = wrap_had_barrier && not work_has_barrier -      -- Might the result be lifted?-      --     False => definitely lifted-      --     True  => might be unlifted-      -- We may encounter a representation-polymorphic result, in which case we-      -- conservatively assume that we have laziness that needs-      -- preservation. See #15186.-      might_be_unlifted = case isLiftedType_maybe res_ty of-                            Just lifted -> not lifted-                            Nothing     -> True+-- | Inserts a `Void#` arg before the first value argument (but after leading type args).+addVoidWorkerArg :: [Var] -> [CbvMark]+                 -> ([Var],     -- Lambda bound args+                     [Var],     -- Args at call site+                     [CbvMark]) -- cbv semantics for the worker args.+addVoidWorkerArg work_args cbv_marks+  = (ty_args ++ voidArgId:rest, ty_args ++ voidPrimId:rest, NotMarkedCbv:cbv_marks)+  where+    (ty_args, rest) = break isId work_args  {- Note [Protecting the last value argument]@@ -414,14 +411,72 @@ If the user writes (\_ -> E), they might be intentionally disallowing the sharing of E. Since absence analysis and worker-wrapper are keen to remove such unused arguments, we add in a void argument to prevent-the function from becoming a thunk.+the function from becoming a thunk.  Three reasons why turning a function+into a thunk might be bad: -The user can avoid adding the void argument with the -ffun-to-thunk-flag. However, this can create sharing, which may be bad in two ways. 1) It can-create a space leak. 2) It can prevent inlining *under a lambda*. If w/w-removes the last argument from a function f, then f now looks like a thunk, and-so f can't be inlined *under a lambda*.+1) It can create a space leak. e.g.+      f x = let y () = [1..x]+            in (sum (y ()) + length (y ()))+   As written it'll calculate [1..x] twice, and avoid keeping a big+   list around.  (Of course let-floating may introduce the leak; but+   at least w/w doesn't.) +2) It can prevent inlining *under a lambda*. e.g.+       g = \y. [1..100]+       f = \t. g ()+   Here we can inline g under the \t.  But we won't if we remove the \y.++3) It can create an unlifted binding.  E.g.+       g :: Int -> Int#+       g = \x. 30#+   Removing the \x would leave an unlifted binding.++NB: none of these apply to a join point.++Note [Preserving float barriers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+```+let+  t = sum [0..x]+  f a{os} b[Dmd=A] c{os} = ... t ...+in f 1 2 3 + f 4 5 6+```+Here, we would like to drop the argument `b` because it's absent. But doing so+leaves behind only one-shot lambdas, `$wf a{os} c{os} = ...`, and then the+Simplifier will inline `t` into `$wf`, because `$wf` says "I'm only called+once". That's bad, because we lost sharing of `t`! Similarly, FloatIn would+happily float `t` into `$wf`, see Note [Floating in past a lambda group].++Why does floating happen after dropping `b` but not before? Because `b` was the+only non-one-shot value lambda left, acting as our "float barrier".++Definition:  A float barrier is a non-one-shot value lambda.+Key insight: If `f` had a float barrier, `$wf` has to have one, too.++To this end, in `needsVoidWorkerArg`, we check whether the wrapper had a float+barrier and if the worker has none so far. If that is the case, we add a `Void#`+argument at the end as an artificial float barrier.++The issue is tracked in #21150. It came up when compiling GHC itself, in+GHC.Tc.Gen.Bind.mkEdges. There the key_map thunk was inlined after WW dropped a+leading absent non-one-shot arg. Here are some example wrapper arguments of+which some are absent or one-shot and the resulting worker arguments:++  * \a{Abs}.\b{os}.\c{os}... ==> \b{os}.\c{os}.\(_::Void#)...+    Wrapper arg `a` was the only float barrier and had been dropped. Hence Void#+  * \a{Abs,os}.\b{os}.\c... ==> \b{os}.\c...+    Worker arg `c` is a float barrier.+  * \a.\b{Abs}.\c{os}... ==> \a.\c{os}...+    Worker arg `a` is a float barrier.+  * \a{os}.\b{Abs,os}.\c{os}... ==> \a{os}.\c{os}...+    Wrapper didn't have a float barrier, no need for Void#.+  * \a{Abs,os}.... ==> ... (no value lambda left)+    This examples simply demonstrates that preserving float barriers is not+    enough to subsume Note [Protecting the last value argument].++Executable examples in T21150.+ Note [Join points and beta-redexes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Originally, the worker would invoke the original function by calling it with@@ -575,6 +630,7 @@   , isStrUsedDmd dmd   , not (isFunTy ty)   , not (isUnliftedType ty) -- Already unlifted!+    -- NB: function arguments have a fixed RuntimeRep, so it's OK to call isUnliftedType here   = Unlift    | otherwise@@ -605,7 +661,7 @@   = StopUnboxing    where-    -- | See Note [non-algebraic or open body type warning]+    -- See Note [non-algebraic or open body type warning]     open_body_ty_warning = warnPprTrace True "wantToUnboxResult: non-algebraic or open body type" (ppr ty) Nothing  isLinear :: Scaled a -> Bool@@ -621,6 +677,7 @@    1. A strict data type argument, that        * is an algebraic data type (not a newtype)+       * is not recursive (as per 'isRecDataCon')        * has a single constructor (thus is a "product")        * that may bind existentials      We can transform@@ -632,6 +689,7 @@    2. The constructed result of a function, if        * its type is an algebraic data type (not a newtype)+       * is not recursive (as per 'isRecDataCon')        * (might have multiple constructors, in contrast to (1))        * the applied data constructor *does not* bind existentials      We can transform@@ -860,7 +918,7 @@ mkAbsentFiller opts arg   -- The lifted case: Bind 'absentError' for a nice panic message if we are   -- wrong (like we were in #11126). See (1) in Note [Absent fillers]-  | not (isUnliftedType arg_ty)+  | mightBeLiftedType arg_ty   , not is_strict, not is_evald -- See (2) in Note [Absent fillers]   = Just (mkAbsentErrorApp arg_ty msg) @@ -1189,15 +1247,17 @@  -- | @isRecDataCon _ fuel dc@, where @tc = dataConTyCon dc@ returns -----   * @Just Recursive@ if the analysis found that @tc@ is reachable through one---     of @dc@'s fields---   * @Just NonRecursive@ if the analysis found that @tc@ is not reachable---     through one of @dc@'s fields---   * @Nothing@ is returned in two cases. The first is when @fuel /= Infinity@---     and @f@ expansions of nested data TyCons were not enough to prove+--   * @DefinitelyRecursive@ if the analysis found that @tc@ is reachable+--     through one of @dc@'s @arg_tys@.+--   * @NonRecursiveOrUnsure@ if the analysis found that @tc@ is not reachable+--     through one of @dc@'s fields (so surely non-recursive).+--   * @NonRecursiveOrUnsure@ when @fuel /= Infinity@+--     and @fuel@ expansions of nested data TyCons were not enough to prove --     non-recursivenss, nor arrive at an occurrence of @tc@ thus proving---     recursiveness. The other is when we hit an abstract TyCon (one without+--     recursiveness. (So not sure if non-recursive.)+--   * @NonRecursiveOrUnsure@ when we hit an abstract TyCon (one without --     visible DataCons), such as those imported from .hs-boot files.+--     Similarly for stuck type and data families. -- -- If @fuel = 'Infinity'@ and there are no boot files involved, then the result -- is never @Nothing@ and the analysis is a depth-first search. If @fuel = 'Int'@@ -1207,84 +1267,64 @@ -- See Note [Detecting recursive data constructors] for which recursive DataCons -- we want to flag. isRecDataCon :: FamInstEnvs -> IntWithInf -> DataCon -> IsRecDataConResult-isRecDataCon fam_envs fuel dc-  | isTupleDataCon dc || isUnboxedSumDataCon dc+isRecDataCon fam_envs fuel orig_dc+  | isTupleDataCon orig_dc || isUnboxedSumDataCon orig_dc   = NonRecursiveOrUnsure   | otherwise-  = -- pprTrace "isRecDataCon" (ppr dc <+> dcolon <+> ppr (dataConRepType dc) $$ ppr fuel $$ ppr answer)-    answer+  = -- pprTraceWith "isRecDataCon" (\answer -> ppr dc <+> dcolon <+> ppr (dataConRepType dc) $$ ppr fuel $$ ppr answer) $+    go_dc fuel emptyTyConSet orig_dc   where-    answer = go_dc fuel (setRecTcMaxBound 1 initRecTc) dc-    (<||>) = combineIRDCR--    go_dc :: IntWithInf -> RecTcChecker -> DataCon -> IsRecDataConResult-    go_dc fuel rec_tc dc =-      combineIRDCRs [ go_arg_ty fuel rec_tc (scaledThing arg_ty)-                    | arg_ty <- dataConRepArgTys dc ]+    go_dc :: IntWithInf -> TyConSet -> DataCon -> IsRecDataConResult+    go_dc fuel visited_tcs dc =+      combineIRDCRs [ go_arg_ty fuel visited_tcs arg_ty+                    | arg_ty <- map scaledThing (dataConRepArgTys dc) ] -    go_arg_ty :: IntWithInf -> RecTcChecker -> Type -> IsRecDataConResult-    go_arg_ty fuel rec_tc ty+    go_arg_ty :: IntWithInf -> TyConSet -> Type -> IsRecDataConResult+    go_arg_ty fuel visited_tcs ty       --- | pprTrace "arg_ty" (ppr ty) False = undefined -      | Just (_, _arg_ty, _res_ty) <- splitFunTy_maybe ty-      -- = go_arg_ty fuel rec_tc _arg_ty <||> go_arg_ty fuel rec_tc _res_ty-          -- Plausible, but unnecessary for CPR.-          -- See Note [Detecting recursive data constructors], point (1)-      = NonRecursiveOrUnsure-       | Just (_tcv, ty') <- splitForAllTyCoVar_maybe ty-      = go_arg_ty fuel rec_tc ty'-          -- See Note [Detecting recursive data constructors], point (2)+      = go_arg_ty fuel visited_tcs ty'+          -- See Note [Detecting recursive data constructors], point (A)        | Just (tc, tc_args) <- splitTyConApp_maybe ty-      = combineIRDCRs (map (go_arg_ty fuel rec_tc) tc_args)-        <||> go_tc_app fuel rec_tc tc tc_args+      = go_tc_app fuel visited_tcs tc tc_args        | otherwise       = NonRecursiveOrUnsure -    -- | PRECONDITION: tc_args has no recursive occs-    -- See Note [Detecting recursive data constructors], point (5)-    go_tc_app :: IntWithInf -> RecTcChecker -> TyCon -> [Type] -> IsRecDataConResult-    go_tc_app fuel rec_tc tc tc_args+    go_tc_app :: IntWithInf -> TyConSet -> TyCon -> [Type] -> IsRecDataConResult+    go_tc_app fuel visited_tcs tc tc_args =+      case tyConDataCons_maybe tc of       --- | pprTrace "tc_app" (vcat [ppr tc, ppr tc_args]) False = undefined--      | tc == dataConTyCon dc-      = DefinitelyRecursive -- loop found!--      | isPrimTyCon tc-      = NonRecursiveOrUnsure--      | not $ tcIsRuntimeTypeKind $ tyConResKind tc-      = NonRecursiveOrUnsure--      | isAbstractTyCon tc   -- When tc has no DataCons, from an hs-boot file-      = NonRecursiveOrUnsure -- See Note [Detecting recursive data constructors], point (7)--      | isFamilyTyCon tc-      -- This is the only place where we look at tc_args-      -- See Note [Detecting recursive data constructors], point (5)-      = case topReduceTyFamApp_maybe fam_envs tc tc_args of-          Just (HetReduction (Reduction _ rhs) _) -> go_arg_ty fuel rec_tc rhs-          Nothing                                 -> DefinitelyRecursive -- we hit this case for 'Any'+        _ | Just (HetReduction (Reduction _ rhs) _) <- topReduceTyFamApp_maybe fam_envs tc tc_args+          -- This is the only place where we look at tc_args, which might have+          -- See Note [Detecting recursive data constructors], point (C) and (5)+          -> go_arg_ty fuel visited_tcs rhs -      | otherwise-      = assertPpr (isAlgTyCon tc) (ppr tc <+> ppr dc) $-        case checkRecTc rec_tc tc of-          Nothing -> NonRecursiveOrUnsure-            -- we expanded this TyCon once already, no need to test it multiple times+        _ | tc == dataConTyCon orig_dc+          -> DefinitelyRecursive -- loop found! -          Just rec_tc'-            | Just (_tvs, rhs, _co) <- unwrapNewTyCon_maybe tc-                -- See Note [Detecting recursive data constructors], points (2) and (3)-            -> go_arg_ty fuel rec_tc' rhs+        Just dcs+          | DefinitelyRecursive <- combineIRDCRs [ go_arg_ty fuel visited_tcs' ty | ty <- tc_args ]+              -- Check tc_args, See Note [Detecting recursive data constructors], point (5)+              -- The new visited_tcs', so that we don't recursively check tc,+              -- promising that we will check it below.+              -- Do the tc_args check *before* the dcs check below, otherwise+              -- we might miss an obvious rec occ in tc_args when we run out of+              -- fuel and respond NonRecursiveOrUnsure instead+          -> DefinitelyRecursive -            | fuel < 0-            -> NonRecursiveOrUnsure -- that's why we track fuel!+          | fuel >= 0+              -- See Note [Detecting recursive data constructors], point (4)+          , not (tc `elemTyConSet` visited_tcs)+              -- only need to check tc if we haven't visited it already. NB: original visited_tcs+          -> combineIRDCRs [ go_dc (subWithInf fuel 1) visited_tcs' dc | dc <- dcs ]+              -- Finally: check ds -            | let dcs = expectJust "isRecDataCon:go_tc_app" $ tyConDataCons_maybe tc-            -> combineIRDCRs (map (\dc -> go_dc (subWithInf fuel 1) rec_tc' dc) dcs)-                -- See Note [Detecting recursive data constructors], point (4)+        _ -> NonRecursiveOrUnsure+        where+          visited_tcs' = extendTyConSet visited_tcs tc  {- ************************************************************************@@ -1301,12 +1341,10 @@   -> Cpr                               -- CPR analysis results   -> UniqSM (Bool,            -- Is w/w'ing useful?              CoreExpr -> CoreExpr,     -- New wrapper. 'nop_fn' if not useful-             CoreExpr -> CoreExpr,     -- New worker.  'nop_fn' if not useful-             Type)                     -- Type of worker's body.-                                       -- Just the input body_ty if not useful+             CoreExpr -> CoreExpr)     -- New worker.  'nop_fn' if not useful -- ^ Entrypoint to CPR W/W. See Note [Worker/wrapper for CPR] for an overview. mkWWcpr_entry opts body_ty body_cpr-  | not (wo_cpr_anal opts) = return (badWorker, nop_fn, nop_fn, body_ty)+  | not (wo_cpr_anal opts) = return (badWorker, nop_fn, nop_fn)   | otherwise = do     -- Part (1)     res_bndr <- mk_res_bndr body_ty@@ -1322,10 +1360,9 @@     -- Stacking unboxer (work_fn) and builder (wrap_fn) together     let wrap_fn      = unbox_transit_tup rebuilt_result                 -- 3 2         work_fn body = bind_res_bndr body (work_unpack_res transit_tup) -- 1 2 3-        work_body_ty = exprType transit_tup     return $ if not useful-                then (badWorker, nop_fn, nop_fn, body_ty)-                else (goodWorker, wrap_fn, work_fn, work_body_ty)+                then (badWorker, nop_fn, nop_fn)+                else (goodWorker, wrap_fn, work_fn)  -- | Part (1) of Note [Worker/wrapper for CPR]. mk_res_bndr :: Type -> UniqSM Id

@@ -1,3 +1,4 @@+{-# LANGUAGE DataKinds #-}  {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-}@@ -455,7 +456,7 @@        ; alts2 <- extendVarEnvCts [(bndr, LambdaBound)] (mapM vars_alt alts)        ; return (StgCase scrut2 bndr (mkStgAltType bndr alts) alts2) }   where-    vars_alt :: CoreAlt -> CtsM (AltCon, [Var], StgExpr)+    vars_alt :: CoreAlt -> CtsM StgAlt     vars_alt (Alt con binders rhs)       | DataAlt c <- con, c == unboxedUnitDataCon       = -- This case is a bit smelly.@@ -463,14 +464,18 @@         -- where a nullary tuple is mapped to (State# World#)         assert (null binders) $         do { rhs2 <- coreToStgExpr rhs-           ; return (DEFAULT, [], rhs2)  }+           ; return GenStgAlt{alt_con=DEFAULT,alt_bndrs=mempty,alt_rhs=rhs2}+           }       | otherwise       = let     -- Remove type variables             binders' = filterStgBinders binders         in         extendVarEnvCts [(b, LambdaBound) | b <- binders'] $ do         rhs2 <- coreToStgExpr rhs-        return (con, binders', rhs2)+        return $! GenStgAlt{ alt_con   = con+                           , alt_bndrs = binders'+                           , alt_rhs   = rhs2+                           }  coreToStgExpr (Let bind body) = coreToStgLet bind body coreToStgExpr e               = pprPanic "coreToStgExpr" (ppr e)

@@ -1054,9 +1054,9 @@             (Var f)             args         | Just KeepAliveOp <- isPrimOpId_maybe f-        , CpeApp (Type arg_rep)-          : CpeApp (Type arg_ty)+        , CpeApp (Type arg_lev)           : CpeApp (Type _result_rep)+          : CpeApp (Type arg_ty)           : CpeApp (Type result_ty)           : CpeApp arg           : CpeApp s0@@ -1070,13 +1070,14 @@                   _          -> cpe_app env k (CpeApp s0 : rest)              ; let touchId = primOpId TouchOp                    expr = Case k' y result_ty [Alt DEFAULT [] rhs]-                   rhs = let scrut = mkApps (Var touchId) [Type arg_rep, Type arg_ty, arg, Var realWorldPrimId]+                   rhs = let scrut = mkApps (Var touchId) [Type arg_lev, Type arg_ty, arg, Var realWorldPrimId]                          in Case scrut s2 result_ty [Alt DEFAULT [] (Var y)]              ; (floats', expr') <- cpeBody env expr              ; return (floats `appendFloats` floats', expr')              }         | Just KeepAliveOp <- isPrimOpId_maybe f-        = panic "invalid keepAlive# application"+        = pprPanic "invalid keepAlive# application" $+            vcat [ text "args:" <+> ppr args ]      -- runRW# magic     cpe_app env (Var f) (CpeApp _runtimeRep@Type{} : CpeApp _type@Type{} : CpeApp arg : rest)@@ -1135,7 +1136,7 @@            ; (app, floats,unsat_ticks) <- rebuild_app env args fun' fun_floats [] Nothing            ; mb_saturate Nothing app floats unsat_ticks (val_args args) } -    -- | Count the number of value arguments.+    -- Count the number of value arguments.     val_args :: [ArgInfo] -> Int     val_args args = go args 0       where@@ -1651,16 +1652,7 @@     ok bndr (Var arg) = bndr == arg     ok _    _         = False -    -- We can't eta reduce something which must be saturated.-    ok_to_eta_reduce (Var f) =  not (hasNoBinding f) &&-                                not (isLinearType (idType f)) && -- Unsure why this is unsafe.-                                (not (isJoinId f) || idJoinArity f <= n_remaining) &&-                                -- Don't undersaturate join points.-                                -- See Note [Invariants on join points] in GHC.Core, and #20599-                                (idCbvMarkArity f <= n_remaining_vals)-                                -- Similar for StrictWorkerIds. See Note [Strict Worker Ids]--+    ok_to_eta_reduce (Var f) = canEtaReduceToArity f n_remaining n_remaining_vals     ok_to_eta_reduce _       = False -- Safe. ToDo: generalise  

@@ -268,9 +268,9 @@ assignColors colors graph ks         = assignColors' colors graph [] ks - where  assignColors' :: UniqFM cls (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).-                        -> Graph k cls color            -- ^ the graph-                        -> [k]                          -- ^ nodes to assign a color to.+ where  assignColors' :: UniqFM cls (UniqSet color)     -- map of (node class -> set of colors available for this class).+                        -> Graph k cls color            -- the graph+                        -> [k]                          -- nodes to assign a color to.                         -> [k]                         -> ( Graph k cls color          -- the colored graph                         , [k])@@ -303,9 +303,9 @@ selectColor         :: ( Uniquable k, Uniquable cls, Uniquable color            , Outputable cls)-        => UniqFM cls (UniqSet color)       -- ^ map of (node class -> set of colors available for this class).-        -> Graph k cls color            -- ^ the graph-        -> k                            -- ^ key of the node to select a color for.+        => UniqFM cls (UniqSet color)   -- map of (node class -> set of colors available for this class).+        -> Graph k cls color            -- the graph+        -> k                            -- key of the node to select a color for.         -> Maybe color  selectColor colors graph u

@@ -920,7 +920,12 @@      -- Now, what are the dependencies.     let inst_nodes = map NodeKey_Unit inst_deps-        mod_nodes  = [k | (_, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys]+        mod_nodes  =+          -- hs-boot edge+          [k | k <- [NodeKey_Module (ModNodeKeyWithUid (GWIB (ms_mod_name ms) IsBoot)  (moduleUnitId this_mod))], NotBoot == isBootSummary ms,  k `elem` home_keys ] +++          -- Normal edges+          [k | (_, mnwib) <- msDeps ms, let k = NodeKey_Module (ModNodeKeyWithUid (fmap unLoc mnwib) (moduleUnitId this_mod)), k `elem` home_keys]+      return (ModuleNode (mod_nodes ++ inst_nodes) ms) 

@@ -4,7 +4,7 @@ \section{Code output phase} -} -+{-# LANGUAGE ScopedTypeVariables #-}  module GHC.Driver.CodeOutput    ( codeOutput@@ -23,7 +23,7 @@  import GHC.CmmToC           ( cmmToC ) import GHC.Cmm.Lint         ( cmmLint )-import GHC.Cmm              ( RawCmmGroup )+import GHC.Cmm import GHC.Cmm.CLabel  import GHC.Driver.Session@@ -70,7 +70,8 @@ -}  codeOutput-    :: Logger+    :: forall a.+       Logger     -> TmpFs     -> DynFlags     -> UnitState@@ -110,18 +111,39 @@                 ; return cmm                 } -        ; a <- case backend dflags of+        ; let final_stream :: Stream IO RawCmmGroup (ForeignStubs, a)+              final_stream = do+                  { a <- linted_cmm_stream+                  ; let stubs = genForeignStubs a+                  ; emitInitializerDecls this_mod stubs+                  ; return (stubs, a) }++        ; (stubs, a) <- case backend dflags of                  NCG         -> outputAsm logger dflags this_mod location filenm-                                          linted_cmm_stream-                 ViaC        -> outputC logger dflags filenm linted_cmm_stream pkg_deps-                 LLVM        -> outputLlvm logger dflags filenm linted_cmm_stream+                                          final_stream+                 ViaC        -> outputC logger dflags filenm final_stream pkg_deps+                 LLVM        -> outputLlvm logger dflags filenm final_stream                  Interpreter -> panic "codeOutput: Interpreter"                  NoBackend   -> panic "codeOutput: NoBackend"-        ; let stubs = genForeignStubs a         ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs         ; return (filenm, stubs_exist, foreign_fps, a)         } +-- | See Note [Initializers and finalizers in Cmm] in GHC.Cmm.InitFini for details.+emitInitializerDecls :: Module -> ForeignStubs -> Stream IO RawCmmGroup ()+emitInitializerDecls this_mod (ForeignStubs _ cstub)+  | initializers <- getInitializers cstub+  , not $ null initializers =+      let init_array = CmmData sect statics+          lbl = mkInitializerArrayLabel this_mod+          sect = Section InitArray lbl+          statics = CmmStaticsRaw lbl+            [ CmmStaticLit $ CmmLabel fn_name+            | fn_name <- initializers+            ]+    in Stream.yield [init_array]+emitInitializerDecls _ _ = return ()+ doOutput :: String -> (Handle -> IO a) -> IO a doOutput filenm io_action = bracket (openFile filenm WriteMode) hClose io_action @@ -221,7 +243,7 @@      NoStubs ->         return (False, Nothing) -     ForeignStubs (CHeader h_code) (CStub c_code) -> do+     ForeignStubs (CHeader h_code) (CStub c_code _ _) -> do         let             stub_c_output_d = pprCode CStyle c_code             stub_c_output_w = showSDoc dflags stub_c_output_d@@ -298,20 +320,18 @@ -- | Generate code to initialise cost centres profilingInitCode :: Platform -> Module -> CollectedCCs -> CStub profilingInitCode platform this_mod (local_CCs, singleton_CCSs)- = CStub $ vcat-    $  map emit_cc_decl local_CCs-    ++ map emit_ccs_decl singleton_CCSs-    ++ [emit_cc_list local_CCs]-    ++ [emit_ccs_list singleton_CCSs]-    ++ [ text "static void prof_init_" <> ppr this_mod-            <> text "(void) __attribute__((constructor));"-       , text "static void prof_init_" <> ppr this_mod <> text "(void)"-       , braces (vcat-                 [ text "registerCcList" <> parens local_cc_list_label <> semi-                 , text "registerCcsList" <> parens singleton_cc_list_label <> semi-                 ])-       ]+ = initializerCStub platform fn_name decls body  where+   fn_name = mkInitializerStubLabel this_mod "prof_init"+   decls = vcat+        $  map emit_cc_decl local_CCs+        ++ map emit_ccs_decl singleton_CCSs+        ++ [emit_cc_list local_CCs]+        ++ [emit_ccs_list singleton_CCSs]+   body = vcat+        [ text "registerCcList" <> parens local_cc_list_label <> semi+        , text "registerCcsList" <> parens singleton_cc_list_label <> semi+        ]    emit_cc_decl cc =        text "extern CostCentre" <+> cc_lbl <> text "[];"      where cc_lbl = pdoc platform (mkCCLabel cc)@@ -343,19 +363,14 @@   -> [InfoProvEnt]   -> CStub ipInitCode do_info_table platform this_mod ents- = if not do_info_table-    then mempty-    else CStub $ vcat-    $  map emit_ipe_decl ents-    ++ [emit_ipe_list ents]-    ++ [ text "static void ip_init_" <> ppr this_mod-            <> text "(void) __attribute__((constructor));"-       , text "static void ip_init_" <> ppr this_mod <> text "(void)"-       , braces (vcat-                 [ text "registerInfoProvList" <> parens local_ipe_list_label <> semi-                 ])-       ]+  | not do_info_table = mempty+  | otherwise = initializerCStub platform fn_nm decls body  where+   fn_nm = mkInitializerStubLabel this_mod "ip_init"+   decls = vcat+        $  map emit_ipe_decl ents+        ++ [emit_ipe_list ents]+   body = text "registerInfoProvList" <> parens local_ipe_list_label <> semi    emit_ipe_decl ipe =        text "extern InfoProvEnt" <+> ipe_lbl <> text "[];"      where ipe_lbl = pprCLabel platform CStyle (mkIPELabel ipe)

@@ -22,7 +22,7 @@   , stgToCmmTmpDir        = tmpDir          dflags   , stgToCmmContext       = initSDocContext dflags defaultDumpStyle   , stgToCmmDebugLevel    = debugLevel      dflags-  , stgToCmmBinBlobThresh = binBlobThreshold               dflags+  , stgToCmmBinBlobThresh = b_blob   , stgToCmmMaxInlAllocSize = maxInlineAllocSize           dflags   -- ticky options   , stgToCmmDoTicky       = gopt Opt_Ticky                 dflags@@ -57,11 +57,13 @@   , stgToCmmAvx           = isAvxEnabled                   dflags   , stgToCmmAvx2          = isAvx2Enabled                  dflags   , stgToCmmAvx512f       = isAvx512fEnabled               dflags+  , stgToCmmTickyAP       = gopt Opt_Ticky_AP dflags   } where profile  = targetProfile dflags           platform = profilePlatform profile           bk_end  = backend dflags           ncg     = bk_end == NCG           llvm    = bk_end == LLVM+          b_blob  = if not ncg then Nothing else binBlobThreshold dflags           x86ish  = case platformArch platform of                       ArchX86    -> True                       ArchX86_64 -> True

@@ -0,0 +1,73 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE LambdaCase #-}++module GHC.Driver.Config.Tidy+  ( initTidyOpts+  , initStaticPtrOpts+  )+where++import GHC.Prelude++import GHC.Iface.Tidy+import GHC.Iface.Tidy.StaticPtrTable++import GHC.Driver.Session+import GHC.Driver.Env+import GHC.Driver.Backend++import GHC.Core.Make (getMkStringIds)+import GHC.Data.Maybe+import GHC.Utils.Panic+import GHC.Utils.Outputable+import GHC.Builtin.Names+import GHC.Tc.Utils.Env (lookupGlobal_maybe)+import GHC.Types.TyThing+import GHC.Platform.Ways++import qualified GHC.LanguageExtensions as LangExt++initTidyOpts :: HscEnv -> IO TidyOpts+initTidyOpts hsc_env = do+  let dflags = hsc_dflags hsc_env+  static_ptr_opts <- if not (xopt LangExt.StaticPointers dflags)+    then pure Nothing+    else Just <$> initStaticPtrOpts hsc_env+  pure $ TidyOpts+    { opt_name_cache        = hsc_NC hsc_env+    , opt_collect_ccs       = ways dflags `hasWay` WayProf+    , opt_unfolding_opts    = unfoldingOpts dflags+    , opt_expose_unfoldings = if | gopt Opt_OmitInterfacePragmas dflags -> ExposeNone+                                 | gopt Opt_ExposeAllUnfoldings dflags  -> ExposeAll+                                 | otherwise                            -> ExposeSome+    , opt_expose_rules      = not (gopt Opt_OmitInterfacePragmas dflags)+    , opt_trim_ids          = gopt Opt_OmitInterfacePragmas dflags+    , opt_static_ptr_opts   = static_ptr_opts+    }++initStaticPtrOpts :: HscEnv -> IO StaticPtrOpts+initStaticPtrOpts hsc_env = do+  let dflags = hsc_dflags hsc_env++  let lookupM n = lookupGlobal_maybe hsc_env n >>= \case+        Succeeded r -> pure r+        Failed err  -> pprPanic "initStaticPtrOpts: couldn't find" (ppr (err,n))++  mk_string <- getMkStringIds (fmap tyThingId . lookupM)+  static_ptr_info_datacon <- tyThingDataCon <$> lookupM staticPtrInfoDataConName+  static_ptr_datacon      <- tyThingDataCon <$> lookupM staticPtrDataConName++  pure $ StaticPtrOpts+    { opt_platform = targetPlatform dflags++      -- If we are compiling for the interpreter we will insert any necessary+      -- SPT entries dynamically, otherwise we add a C stub to do so+    , opt_gen_cstub = case backend dflags of+                        Interpreter -> False+                        _           -> True++    , opt_mk_string = mk_string+    , opt_static_ptr_info_datacon = static_ptr_info_datacon+    , opt_static_ptr_datacon      = static_ptr_datacon+    }+

@@ -1,7 +1,6 @@ {-# LANGUAGE BangPatterns #-}  {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE GADTs #-}  {-# OPTIONS_GHC -fprof-auto-top #-}@@ -80,6 +79,9 @@     , hscParseExpr     , hscParseType     , hscCompileCoreExpr+    , hscTidy++     -- * Low-level exports for hooks     , hscCompileCoreExpr'       -- We want to make sure that we export enough to be able to redefine@@ -110,6 +112,7 @@ import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts) import GHC.Driver.Config.StgToCmm (initStgToCmmConfig) import GHC.Driver.Config.Diagnostic+import GHC.Driver.Config.Tidy import GHC.Driver.Hooks  import GHC.Runtime.Context@@ -143,14 +146,17 @@ import GHC.Core import GHC.Core.Tidy           ( tidyExpr ) import GHC.Core.Type           ( Type, Kind )-import GHC.Core.Lint           ( lintInteractiveExpr )+import GHC.Core.Lint           ( lintInteractiveExpr, endPassIO ) import GHC.Core.Multiplicity import GHC.Core.Utils          ( exprType ) import GHC.Core.ConLike+import GHC.Core.Opt.Monad      ( CoreToDo (..)) import GHC.Core.Opt.Pipeline import GHC.Core.TyCon import GHC.Core.InstEnv import GHC.Core.FamInstEnv+import GHC.Core.Rules+import GHC.Core.Stats  import GHC.CoreToStg.Prep import GHC.CoreToStg    ( coreToStg )@@ -444,8 +450,6 @@         PFailed pst ->             handleWarningsThrowErrors (getPsMessages pst)         POk pst rdr_module -> do-            let (warns, errs) = getPsMessages pst-            logDiagnostics (GhcPsMessage <$> warns)             liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser"                         FormatHaskell (ppr rdr_module)             liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST"@@ -454,7 +458,6 @@                                                    rdr_module)             liftIO $ putDumpFileMaybe logger Opt_D_source_stats "Source Statistics"                         FormatText (ppSourceStats False rdr_module)-            when (not $ isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs)              -- To get the list of extra source files, we take the list             -- that the parser gave us,@@ -490,10 +493,16 @@              -- apply parse transformation of plugins             let applyPluginAction p opts-                  = parsedResultAction p opts mod_summary+                  = uncurry (parsedResultAction p opts mod_summary)             hsc_env <- getHscEnv-            withPlugins (hsc_plugins hsc_env) applyPluginAction res+            (transformed, (warns, errs)) <-+              withPlugins (hsc_plugins hsc_env) applyPluginAction (res, getPsMessages pst) +            logDiagnostics (GhcPsMessage <$> warns)+            unless (isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs)++            return transformed+ checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String)) checkBidirectionFormatChars start_loc sb   | containsBidirectionalFormatChar sb = Just $ go start_loc sb@@ -941,8 +950,8 @@           plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)           simplified_guts <- hscSimplify' plugins desugared_guts -          (cg_guts, details) <- {-# SCC "CoreTidy" #-}-              liftIO $ tidyProgram hsc_env simplified_guts+          (cg_guts, details) <-+              liftIO $ hscTidy hsc_env simplified_guts            let !partial_iface =                 {-# SCC "GHC.Driver.Main.mkPartialIface" #-}@@ -1432,7 +1441,7 @@                       $ mkErrorMsgEnvelope l (pkgQual state)                       $ GhcDriverMessage $ DriverCannotImportUnsafeModule m -    -- | Check the package a module resides in is trusted. Safe compiled+    -- Check the package a module resides in is trusted. Safe compiled     -- modules are trusted without requiring that their package is trusted. For     -- trustworthy modules, modules in the home package are trusted but     -- otherwise we check the package trust flag.@@ -2028,7 +2037,7 @@       hscSimplify hsc_env plugins ds_result      {- Tidy -}-    (tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg+    (tidy_cg, mod_details) <- liftIO $ hscTidy hsc_env simpl_mg      let !CgGuts{ cg_module    = this_mod,                  cg_binds     = core_binds,@@ -2197,6 +2206,44 @@                 liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST"                             FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing)                 return thing++hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)+hscTidy hsc_env guts = do+  let logger   = hsc_logger hsc_env+  let this_mod = mg_module guts++  opts <- initTidyOpts hsc_env+  (cgguts, details) <- withTiming logger+    (text "CoreTidy"<+>brackets (ppr this_mod))+    (const ())+    $! {-# SCC "CoreTidy" #-} tidyProgram opts guts++  -- post tidy pretty-printing and linting...+  let tidy_rules     = md_rules details+  let all_tidy_binds = cg_binds cgguts+  let print_unqual   = mkPrintUnqualified (hsc_unit_env hsc_env) (mg_rdr_env guts)++  endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules++  -- If the endPass didn't print the rules, but ddump-rules is+  -- on, print now+  unless (logHasDumpFlag logger Opt_D_dump_simpl) $+    putDumpFileMaybe logger Opt_D_dump_rules+      (renderWithContext defaultSDocContext (ppr CoreTidy <+> text "rules"))+      FormatText+      (pprRulesForUser tidy_rules)++  -- Print one-line size info+  let cs = coreBindsStats all_tidy_binds+  putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats"+    FormatText+    (text "Tidy size (terms,types,coercions)"+     <+> ppr (moduleName this_mod) <> colon+     <+> int (cs_tm cs)+     <+> int (cs_ty cs)+     <+> int (cs_co cs))++  pure (cgguts, details)   {- **********************************************************************

@@ -15,7 +15,6 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE RecordWildCards #-}  -- -----------------------------------------------------------------------------@@ -62,7 +61,6 @@ import qualified GHC.Linker.Loader as Linker import GHC.Linker.Types -import GHC.Runtime.Context import GHC.Platform.Ways  import GHC.Driver.Config.Finder (initFinderOpts)@@ -108,7 +106,6 @@ import GHC.Types.SourceError import GHC.Types.SrcLoc import GHC.Types.Unique.FM-import GHC.Types.Name import GHC.Types.PkgQual  import GHC.Unit@@ -151,7 +148,7 @@ import Control.Monad.Trans.Maybe import GHC.Runtime.Loader import GHC.Rename.Names-+import GHC.Utils.Constants  -- ----------------------------------------------------------------------------- -- Loading the program@@ -680,8 +677,6 @@     liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep")                                     2 (ppr build_plan)) -    let direct_deps = mkDepsMap (mgModSummaries' mod_graph)-     n_jobs <- case parMakeCount (hsc_dflags hsc_env) of                     Nothing -> liftIO getNumProcessors                     Just n  -> return n@@ -689,7 +684,7 @@     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) direct_deps build_plan+      liftIO $ upsweep n_jobs hsc_env mHscMessage (toCache pruned_cache) build_plan     setSession hsc_env1     fmap (, new_cache) $ case upsweep_ok of       Failed -> loadFinish upsweep_ok@@ -709,29 +704,6 @@   = do modifySession discardIC        return all_ok --- | Discard the contents of the InteractiveContext, but keep the DynFlags and--- the loaded plugins.  It will also keep ic_int_print and ic_monad if their--- names are from external packages.-discardIC :: HscEnv -> HscEnv-discardIC hsc_env-  = hsc_env { hsc_IC = empty_ic { ic_int_print = new_ic_int_print-                                , ic_monad     = new_ic_monad-                                , ic_plugins   = old_plugins-                                } }-  where-  -- Force the new values for ic_int_print and ic_monad to avoid leaking old_ic-  !new_ic_int_print = keep_external_name ic_int_print-  !new_ic_monad = keep_external_name ic_monad-  !old_plugins = ic_plugins old_ic-  dflags = ic_dflags old_ic-  old_ic = hsc_IC hsc_env-  empty_ic = emptyInteractiveContext dflags-  keep_external_name ic_name-    | nameIsFromExternalPackage home_unit old_name = old_name-    | otherwise = ic_name empty_ic-    where-    home_unit = hsc_home_unit hsc_env-    old_name = ic_name old_ic  -- | If there is no -o option, guess the name of target executable -- by using top-level source file name as a base.@@ -994,12 +966,11 @@ -- See Note [Upsweep] for a high-level description. interpretBuildPlan :: HomeUnitGraph                    -> M.Map ModNodeKeyWithUid HomeModInfo-                   -> (NodeKey -> [NodeKey])                    -> [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 deps_map plan = do+interpretBuildPlan hug 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))@@ -1041,7 +1012,7 @@       home_mod_map <- getBuildMap       hug_var <- gets hug_var       -- 1. Get the transitive dependencies of this module, by looking up in the dependency map-      let direct_deps = deps_map (mkNodeKey mod)+      let direct_deps = nodeDependencies False mod           doc_build_deps = map (expectJust "dep_map" . flip M.lookup home_mod_map) direct_deps           build_deps = map snd doc_build_deps       -- 2. Set the default way to build this node, not in a loop here@@ -1049,11 +1020,10 @@             case mod of               InstantiationNode uid iu ->                 const Nothing <$> executeInstantiationNode mod_idx n_mods (wait_deps_hug hug_var build_deps) uid iu-              ModuleNode build_deps ms -> do+              ModuleNode _build_deps ms -> do                   let !old_hmi = M.lookup (msKey ms) old_hpt                       rehydrate_mods = mapMaybe moduleGraphNodeModule <$> rehydrate_nodes-                      build_deps_vars = map snd $ map (expectJust "build_deps" . flip M.lookup home_mod_map) build_deps-                  hmi <- executeCompileNode mod_idx n_mods old_hmi (wait_deps_hug hug_var build_deps_vars) rehydrate_mods ms+                  hmi <- executeCompileNode mod_idx n_mods old_hmi (wait_deps_hug hug_var build_deps) rehydrate_mods ms                   -- This global MVar is incrementally modified in order to avoid having to                   -- recreate the HPT before compiling each module which leads to a quadratic amount of work.                   hsc_env <- asks hsc_env@@ -1063,9 +1033,8 @@                     maybeRehydrateAfter hmi new_hsc rehydrate_mods                       )                   return (Just hmi')-              LinkNode nks uid -> do-                  let link_deps = map snd $ map (\nk -> expectJust "build_deps_link" . flip M.lookup home_mod_map $ nk) nks-                  executeLinkNode (wait_deps_hug hug_var link_deps) (mod_idx, n_mods) uid nks+              LinkNode _nks uid -> do+                  executeLinkNode (wait_deps_hug hug_var build_deps) (mod_idx, n_mods) uid direct_deps                   return Nothing  @@ -1105,11 +1074,10 @@     -> HscEnv -- ^ The base HscEnv, which is augmented for each module     -> Maybe Messager     -> M.Map ModNodeKeyWithUid HomeModInfo-    -> (NodeKey -> [NodeKey]) -- A function which computes the direct dependencies of a NodeKey     -> [BuildPlan]     -> IO (SuccessFlag, HscEnv, [HomeModInfo])-upsweep n_jobs hsc_env mHscMessage old_hpt direct_deps build_plan = do-    (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) old_hpt direct_deps build_plan+upsweep n_jobs hsc_env mHscMessage old_hpt build_plan = do+    (cycle, pipelines, collect_result) <- interpretBuildPlan (hsc_HUG hsc_env) old_hpt build_plan     runPipelines n_jobs hsc_env mHscMessage pipelines     res <- collect_result @@ -1364,14 +1332,6 @@ modNodeMapUnionWith :: (a -> a -> a) -> ModNodeMap a -> ModNodeMap a -> ModNodeMap a modNodeMapUnionWith f (ModNodeMap m) (ModNodeMap n) = ModNodeMap (M.unionWith f m n) --- | Efficiently construct a map from a NodeKey to its list of transitive dependencies-mkDepsMap :: [ModuleGraphNode] -> (NodeKey -> [NodeKey])-mkDepsMap nodes =-  -- Important that we force this before returning a lambda so we can share the module graph-  -- for each node-  let !(mg, lookup_node) = moduleGraphNodes False nodes-  in \nk -> map (mkNodeKey . node_payload) $ outgoingG mg (expectJust "mkDepsMap" (lookup_node nk))- -- | If there are {-# SOURCE #-} imports between strongly connected -- components in the topological sort, then those imports can -- definitely be replaced by ordinary non-SOURCE imports: if SOURCE@@ -1457,7 +1417,12 @@           in map Right instantiation_nodes               ++ maybeToList (linkNodes (instantiation_nodes ++ summaries) uid hue) -        calcDeps ms = [(ms_unitid ms, b, c) | (b, c) <- msDeps ms ]+        calcDeps ms =+          -- Add a dependency on the HsBoot file if it exists+          -- This gets passed to the loopImports function which just ignores it if it+          -- can't be found.+          [(ms_unitid ms, NoPkgQual, GWIB (noLoc $ ms_mod_name ms) IsBoot) | NotBoot <- [isBootSummary ms] ] +++          [(ms_unitid ms, b, c) | (b, c) <- msDeps ms ]          logger = hsc_logger hsc_env         roots  = hsc_targets hsc_env@@ -1646,7 +1611,6 @@   -> IO [ModuleGraphNode] enableCodeGenForTH logger tmpfs unit_env =   enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env-  where  -- | Helper used to implement 'enableCodeGenForTH'. -- In particular, this enables@@ -1741,14 +1705,9 @@     -- #16331 - when no "internal interpreter" is available but we     -- need to process some TemplateHaskell or QuasiQuotes, we automatically     -- turn on -fexternal-interpreter.-    ext_interp_enable ms = not host_internalInterpreter && internalInterpreter+    ext_interp_enable ms = not ghciSupported && internalInterpreter       where        lcl_dflags   = ms_hspp_opts ms-#if defined(HAVE_INTERNAL_INTERPRETER)-       host_internalInterpreter = True-#else-       host_internalInterpreter = False-#endif        internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)  @@ -1916,7 +1875,7 @@           -> IO SummariseResult  -summariseModule hsc_env' home_unit old_summary_map is_boot (L loc wanted_mod) mb_pkg+summariseModule hsc_env' home_unit old_summary_map is_boot (L _ wanted_mod) mb_pkg                 maybe_buf excl_mods   | wanted_mod `elem` excl_mods   = return NotThere@@ -1933,12 +1892,9 @@         found <- findImportedModule hsc_env wanted_mod mb_pkg         case found of              Found location mod-                | isJust (ml_hs_file location) -> do+                | isJust (ml_hs_file location) ->                         -- Home package-                         fresult <- just_found location mod-                         return $ case fresult of-                            Left err -> FoundHomeWithError (moduleUnitId mod, err)-                            Right ms -> FoundHome ms+                         just_found location mod                 | VirtUnit iud <- moduleUnit mod                 , not (isHomeModule home_unit mod)                   -> return $ FoundInstantiation iud@@ -1960,8 +1916,14 @@                 -- It might have been deleted since the Finder last found it         maybe_h <- fileHashIfExists src_fn         case maybe_h of-          Nothing -> return $ Left $ noHsFileErr loc src_fn-          Just h  -> new_summary_cache_check location' mod src_fn h+          -- This situation can also happen if we have found the .hs file but the+          -- .hs-boot file doesn't exist.+          Nothing -> return NotThere+          Just h  -> do+            fresult <- new_summary_cache_check location' mod src_fn h+            return $ case fresult of+              Left err -> FoundHomeWithError (moduleUnitId mod, err)+              Right ms -> FoundHome ms      new_summary_cache_check loc mod src_fn h       | Just old_summary <- Map.lookup src_fn old_summary_map =@@ -2149,9 +2111,11 @@   = mkPlainErrorMsgEnvelope loc $ GhcDriverMessage $ DriverUnknownMessage $ mkPlainError noHints $     cannotFindModule hsc_env wanted_mod err +{- noHsFileErr :: SrcSpan -> String -> DriverMessages noHsFileErr loc path   = singleMessage $ mkPlainErrorMsgEnvelope loc (DriverFileNotFound path)+  -}  moduleNotFoundErr :: ModuleName -> DriverMessages moduleNotFoundErr mod = singleMessage $ mkPlainErrorMsgEnvelope noSrcSpan (DriverModuleNotFound mod)@@ -2448,7 +2412,7 @@  Solution: **rehydration**.  *Before compiling `R.hs`*, rehydrate all the ModIfaces below it that depend on R.hs-boot.  To rehydrate a ModIface, call-`rehydrateIface` to convert it to a ModDetails.  It's just a de-serialisation+`typecheckIface` to convert it to a ModDetails.  It's just a de-serialisation step, no type inference, just lookups.  Now `S` will be bound to a thunk that, when forced, will "see" the final binding

@@ -129,9 +129,8 @@   Nothing -> asi_ty   where     asi_ty = arithSeqInfoType asi-hsExprType (HsBracket v _) = dataConCantHappen v-hsExprType (HsRnBracketOut v _ _) = dataConCantHappen v-hsExprType (HsTcBracketOut ty _wrap _bracket _pending) = ty+hsExprType (HsTypedBracket   (HsBracketTc _ ty _wrap _pending) _) = ty+hsExprType (HsUntypedBracket (HsBracketTc _ ty _wrap _pending) _) = ty hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE"                                       (ppr e)                                       -- Typed splices should have been eliminated during zonking, but we

@@ -225,7 +225,7 @@          ; foreign_files <- readIORef th_foreign_files_var -        ; (doc_hdr, decl_docs, arg_docs) <- extractDocs tcg_env+        ; docs <- extractDocs dflags tcg_env          ; let mod_guts = ModGuts {                 mg_module       = mod,@@ -255,9 +255,7 @@                 mg_safe_haskell = safe_mode,                 mg_trust_pkg    = imp_trust_own_pkg imports,                 mg_complete_matches = complete_matches,-                mg_doc_hdr      = doc_hdr,-                mg_decl_docs    = decl_docs,-                mg_arg_docs     = arg_docs+                mg_docs         = docs               }         ; return (msgs, Just mod_guts)         }}}}

@@ -201,10 +201,12 @@                            else []         ; return (force_var', sel_binds) } -dsHsBind dflags (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts-                          , abs_exports = exports-                          , abs_ev_binds = ev_binds-                          , abs_binds = binds, abs_sig = has_sig })+dsHsBind+  dflags+  (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dicts+                        , abs_exports = exports+                        , abs_ev_binds = ev_binds+                        , abs_binds = binds, abs_sig = has_sig }))   = do { ds_binds <- addTyCs FromSource (listToBag dicts) $                      dsLHsBinds binds              -- addTyCs: push type constraints deeper@@ -220,7 +222,7 @@  ----------------------- dsAbsBinds :: DynFlags-           -> [TyVar] -> [EvVar] -> [ABExport GhcTc]+           -> [TyVar] -> [EvVar] -> [ABExport]            -> [CoreBind]                -- Desugared evidence bindings            -> ([Id], [(Id,CoreExpr)])   -- Desugared value bindings            -> Bool                      -- Single binding with signature@@ -271,7 +273,7 @@     --    lcl_id{inl-prag} = rhs  -- Auxiliary binds     --    gbl_id = lcl_id |> co   -- Main binds   | null tyvars, null dicts-  = do { let mk_main :: ABExport GhcTc -> DsM (Id, CoreExpr)+  = do { let mk_main :: ABExport -> DsM (Id, CoreExpr)              mk_main (ABE { abe_poly = gbl_id, abe_mono = lcl_id                           , abe_wrap = wrap })                      -- No SpecPrags (no dicts)@@ -360,7 +362,7 @@             [] lcls      -- find exports or make up new exports for force variables-    get_exports :: [Id] -> DsM ([Id], [ABExport GhcTc])+    get_exports :: [Id] -> DsM ([Id], [ABExport])     get_exports lcls =       foldM (\(glbls, exports) lcl ->               case lookupVarEnv global_env lcl of@@ -373,8 +375,7 @@     mk_export local =       do global <- newSysLocalDs Many                      (exprType (mkLams tyvars (mkLams dicts (Var local))))-         return (ABE { abe_ext   = noExtField-                     , abe_poly  = global+         return (ABE { abe_poly  = global                      , abe_mono  = local                      , abe_wrap  = WpHole                      , abe_prags = SpecPrags [] })@@ -398,6 +399,7 @@   = case inlinePragmaSpec inline_prag of           NoUserInlinePrag -> (gbl_id, rhs)           NoInline  {}     -> (gbl_id, rhs)+          Opaque    {}     -> (gbl_id, rhs)           Inlinable {}     -> (gbl_id `setIdUnfolding` inlinable_unf, rhs)           Inline    {}     -> inline_pair   where@@ -768,6 +770,7 @@     -- phase specification in the SPECIALISE pragma     no_act_spec = case inlinePragmaSpec spec_inl of                     NoInline _   -> isNeverActive  spec_prag_act+                    Opaque _     -> isNeverActive  spec_prag_act                     _            -> isAlwaysActive spec_prag_act     rule_act | no_act_spec = inlinePragmaActivation id_inl   -- Inherit              | otherwise   = spec_prag_act                   -- Specified by user

@@ -285,12 +285,13 @@ addTickLHsBinds = mapBagM addTickLHsBind  addTickLHsBind :: LHsBind GhcTc -> TM (LHsBind GhcTc)-addTickLHsBind (L pos bind@(AbsBinds { abs_binds   = binds,-                                       abs_exports = abs_exports })) =+addTickLHsBind (L pos (XHsBindsLR bind@(AbsBinds { abs_binds = binds+                                                 , abs_exports = abs_exports+                                                 }))) =   withEnv add_exports $     withEnv add_inlines $ do       binds' <- addTickLHsBinds binds-      return $ L pos $ bind { abs_binds = binds' }+      return $ L pos $ XHsBindsLR $ bind { abs_binds = binds' }   where    -- in AbsBinds, the Id on each binding is not the actual top-level    -- Id that we are defining, they are related by the abs_exports@@ -637,9 +638,8 @@  addTickHsExpr (HsPragE x p e) =         liftM (HsPragE x p) (addTickLHsExpr e)-addTickHsExpr e@(HsBracket     {})   = return e-addTickHsExpr e@(HsTcBracketOut  {}) = return e-addTickHsExpr e@(HsRnBracketOut  {}) = return e+addTickHsExpr e@(HsTypedBracket {})  = return e+addTickHsExpr e@(HsUntypedBracket{}) = return e addTickHsExpr e@(HsSpliceE  {})      = return e addTickHsExpr e@(HsGetField {})      = return e addTickHsExpr e@(HsProjection {})    = return e@@ -1229,7 +1229,7 @@           -> TM CoreTickish mkTickish boxLabel countEntries topOnly pos fvs decl_path = do -  let ids = filter (not . isUnliftedType . idType) $ nonDetOccEnvElts fvs+  let ids = filter (not . mightBeUnliftedType . idType) $ nonDetOccEnvElts fvs           -- unlifted types cause two problems here:           --   * we can't bind them  at the GHCi prompt           --     (bindLocalsAtBreakpoint already filters them out),@@ -1343,23 +1343,18 @@ hpcInitCode :: Platform -> Module -> HpcInfo -> CStub hpcInitCode _ _ (NoHpcInfo {}) = mempty hpcInitCode platform this_mod (HpcInfo tickCount hashNo)- = CStub $ vcat-    [ text "static void hpc_init_" <> ppr this_mod-         <> text "(void) __attribute__((constructor));"-    , text "static void hpc_init_" <> ppr this_mod <> text "(void)"-    , braces (vcat [-        text "extern StgWord64 " <> tickboxes <>-               text "[]" <> semi,-        text "hs_hpc_module" <>-          parens (hcat (punctuate comma [-              doubleQuotes full_name_str,-              int tickCount, -- really StgWord32-              int hashNo,    -- really StgWord32-              tickboxes-            ])) <> semi-       ])-    ]+ = initializerCStub platform fn_name decls body   where+    fn_name = mkInitializerStubLabel this_mod "hpc"+    decls = text "extern StgWord64 " <> tickboxes <> text "[]" <> semi+    body = text "hs_hpc_module" <>+              parens (hcat (punctuate comma [+                  doubleQuotes full_name_str,+                  int tickCount, -- really StgWord32+                  int hashNo,    -- really StgWord32+                  tickboxes+                ])) <> semi+     tickboxes = pprCLabel platform CStyle (mkHpcTicksLabel $ this_mod)      module_name  = hcat (map (text.charToC) $ BS.unpack $

@@ -8,8 +8,6 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE BangPatterns #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.HsToCore.Docs where  import GHC.Prelude@@ -32,89 +30,237 @@ import Data.Bifunctor (first) import Data.IntMap (IntMap) import qualified Data.IntMap as IM-import Data.Map (Map)+import Data.Map.Strict (Map) import qualified Data.Map as M+import qualified Data.Set as Set import Data.Maybe import Data.Semigroup import GHC.IORef (readIORef)+import GHC.Unit.Types+import GHC.Hs+import GHC.Types.Avail+import GHC.Unit.Module+import qualified Data.List.NonEmpty as NonEmpty+import Data.List.NonEmpty (NonEmpty ((:|)))+import GHC.Unit.Module.Imported+import GHC.Driver.Session+import GHC.Types.TypeEnv+import GHC.Types.Id+import GHC.Types.Unique.Map  -- | Extract docs from renamer output. -- This is monadic since we need to be able to read documentation added from -- Template Haskell's @putDoc@, which is stored in 'tcg_th_docs'. extractDocs :: MonadIO m-            => TcGblEnv-            -> m (Maybe HsDocString, DeclDocMap, ArgDocMap)+            => DynFlags -> TcGblEnv+            -> m (Maybe Docs)             -- ^             -- 1. Module header             -- 2. Docs on top level declarations             -- 3. Docs on arguments-extractDocs TcGblEnv { tcg_semantic_mod = mod-                     , tcg_rn_decls = mb_rn_decls-                     , tcg_insts = insts-                     , tcg_fam_insts = fam_insts-                     , tcg_doc_hdr = mb_doc_hdr-                     , tcg_th_docs = th_docs_var-                     } = do+extractDocs dflags+      TcGblEnv { tcg_semantic_mod = semantic_mdl+               , tcg_mod = mdl+               , tcg_rn_decls = Just rn_decls+               , tcg_rn_exports = mb_rn_exports+               , tcg_exports = all_exports+               , tcg_imports = import_avails+               , tcg_insts = insts+               , tcg_fam_insts = fam_insts+               , tcg_doc_hdr = mb_doc_hdr+               , tcg_th_docs = th_docs_var+               , tcg_type_env = ty_env+               } = do     th_docs <- liftIO $ readIORef th_docs_var-    let doc_hdr = th_doc_hdr <|> (unLoc <$> mb_doc_hdr)-        ExtractedTHDocs-          th_doc_hdr-          (DeclDocMap th_doc_map)-          (ArgDocMap th_arg_map)-          (DeclDocMap th_inst_map) = extractTHDocs th_docs-    return-      ( doc_hdr-      , DeclDocMap (th_doc_map <> th_inst_map <> doc_map)-      , ArgDocMap (th_arg_map `unionArgMaps` arg_map)-      )+    let doc_hdr = (unLoc <$> mb_doc_hdr)+        ExtractedTHDocs th_hdr th_decl_docs th_arg_docs th_inst_docs = extractTHDocs th_docs+        mod_docs+         =  Docs+         { docs_mod_hdr = th_hdr <|> doc_hdr+         -- Left biased union (see #21220)+         , docs_decls = plusUniqMap_C (\a _ -> a)+                          ((:[]) <$> th_decl_docs `plusUniqMap` th_inst_docs)+                          -- These will not clash so safe to use plusUniqMap+                          doc_map+         , docs_args = th_arg_docs `unionArgMaps` arg_map+         , docs_structure = doc_structure+         , docs_named_chunks = named_chunks+         , docs_haddock_opts = haddockOptions dflags+         , docs_language = language_+         , docs_extensions = exts+         }+    pure (Just mod_docs)   where-    (doc_map, arg_map) = maybe (M.empty, M.empty)-                               (mkMaps local_insts)-                               mb_decls_with_docs-    mb_decls_with_docs = topDecls <$> mb_rn_decls-    local_insts = filter (nameIsLocalOrFrom mod)+    exts = extensionFlags dflags+    language_ = language dflags++    -- We need to lookup the Names for default methods, so we+    -- can put them in the correct map+    -- See Note [default method Name] in GHC.Iface.Recomp+    def_meths_env = mkOccEnv [(occ, nm)+                             | id <- typeEnvIds ty_env+                             , let nm = idName id+                                   occ = nameOccName nm+                             , isDefaultMethodOcc occ+                             ]++    (doc_map, arg_map) = mkMaps def_meths_env local_insts decls_with_docs+    decls_with_docs = topDecls rn_decls+    local_insts = filter (nameIsLocalOrFrom semantic_mdl)                          $ map getName insts ++ map getName fam_insts+    doc_structure = mkDocStructure mdl import_avails mb_rn_exports rn_decls+                                   all_exports def_meths_env+    named_chunks = getNamedChunks (isJust mb_rn_exports) rn_decls+extractDocs _ _ = pure Nothing +-- | If we have an explicit export list, we extract the documentation structure+-- from that.+-- Otherwise we use the renamed exports and declarations.+mkDocStructure :: Module                               -- ^ The current module+               -> ImportAvails                         -- ^ Imports+               -> Maybe [(LIE GhcRn, Avails)] -- ^ Explicit export list+               -> HsGroup GhcRn+               -> [AvailInfo]                          -- ^ All exports+               -> OccEnv Name                          -- ^ Default Methods+               -> DocStructure+mkDocStructure mdl import_avails (Just export_list) _ _ _ =+    mkDocStructureFromExportList mdl import_avails export_list+mkDocStructure _ _ Nothing rn_decls all_exports def_meths_env =+    mkDocStructureFromDecls def_meths_env all_exports rn_decls++-- TODO:+-- * Maybe remove items that export nothing?+-- * Combine sequences of DsiExports?+-- * Check the ordering of avails in DsiModExport+mkDocStructureFromExportList+  :: Module                         -- ^ The current module+  -> ImportAvails+  -> [(LIE GhcRn, Avails)] -- ^ Explicit export list+  -> DocStructure+mkDocStructureFromExportList mdl import_avails export_list =+    toDocStructure . first unLoc <$> export_list+  where+    toDocStructure :: (IE GhcRn, Avails) -> DocStructureItem+    toDocStructure = \case+      (IEModuleContents _ lmn, avails) -> moduleExport (unLoc lmn) avails+      (IEGroup _ level doc, _)         -> DsiSectionHeading level (unLoc doc)+      (IEDoc _ doc, _)                 -> DsiDocChunk (unLoc doc)+      (IEDocNamed _ name, _)           -> DsiNamedChunkRef name+      (_, avails)                      -> DsiExports (nubAvails avails)++    moduleExport :: ModuleName -- Alias+                 -> Avails+                 -> DocStructureItem+    moduleExport alias avails =+        DsiModExport (nubSortNE orig_names) (nubAvails avails)+      where+        orig_names = M.findWithDefault aliasErr alias aliasMap+        aliasErr = error $ "mkDocStructureFromExportList: "+                           ++ (moduleNameString . moduleName) mdl+                           ++ ": Can't find alias " ++ moduleNameString alias+        nubSortNE = NonEmpty.fromList .+                    Set.toList .+                    Set.fromList .+                    NonEmpty.toList++    -- Map from aliases to true module names.+    aliasMap :: Map ModuleName (NonEmpty ModuleName)+    aliasMap =+        M.fromListWith (<>) $+          (this_mdl_name, this_mdl_name :| [])+          : (flip concatMap (moduleEnvToList imported) $ \(mdl, imvs) ->+              [(imv_name imv, moduleName mdl :| []) | imv <- imvs])+      where+        this_mdl_name = moduleName mdl++    imported :: ModuleEnv [ImportedModsVal]+    imported = mapModuleEnv importedByUser (imp_mods import_avails)++-- | Figure out the documentation structure by correlating+-- the module exports with the located declarations.+mkDocStructureFromDecls :: OccEnv Name -- ^ The default method environment+                        -> [AvailInfo] -- ^ All exports, unordered+                        -> HsGroup GhcRn+                        -> DocStructure+mkDocStructureFromDecls env all_exports decls =+    map unLoc (sortLocated (docs ++ avails))+  where+    avails :: [Located DocStructureItem]+    avails = flip fmap all_exports $ \avail ->+      case M.lookup (availName avail) name_locs of+        Just loc -> L loc (DsiExports [avail])+        -- FIXME: This is just a workaround that we use when handling e.g.+        -- associated data families like in the html-test Instances.hs.+        Nothing -> noLoc (DsiExports [avail])+        -- Nothing -> panicDoc "mkDocStructureFromDecls: No loc found for"+        --                     (ppr avail)++    docs = mapMaybe structuralDoc (hs_docs decls)++    structuralDoc :: LDocDecl GhcRn+                  -> Maybe (Located DocStructureItem)+    structuralDoc = \case+      L loc (DocCommentNamed _name doc) ->+        -- TODO: Is this correct?+        -- NB: There is no export list where we could reference the named chunk.+        Just (L (locA loc) (DsiDocChunk (unLoc doc)))++      L loc (DocGroup level doc) ->+        Just (L (locA loc) (DsiSectionHeading level (unLoc doc)))++      _ -> Nothing++    name_locs = M.fromList (concatMap ldeclNames (ungroup decls))+    ldeclNames (L loc d) = zip (getMainDeclBinder env d) (repeat (locA loc))++-- | Extract named documentation chunks from the renamed declarations.+--+-- If there is no explicit export list, we simply return an empty map+-- since there would be no way to link to a named chunk.+getNamedChunks :: Bool -- ^ Do we have an explicit export list?+               -> HsGroup (GhcPass pass)+               -> Map String (HsDoc (GhcPass pass))+getNamedChunks True decls =+  M.fromList $ flip mapMaybe (unLoc <$> hs_docs decls) $ \case+    DocCommentNamed name doc -> Just (name, unLoc doc)+    _                        -> Nothing+getNamedChunks False _ = M.empty+ -- | Create decl and arg doc-maps by looping through the declarations. -- For each declaration, find its names, its subordinates, and its doc strings.-mkMaps :: [Name]-       -> [(LHsDecl GhcRn, [HsDocString])]-       -> (Map Name (HsDocString), Map Name (IntMap HsDocString))-mkMaps instances decls =-    ( f' (map (nubByName fst) decls')-    , f  (filterMapping (not . IM.null) args)+mkMaps :: OccEnv Name+       -> [Name]+       -> [(LHsDecl GhcRn, [HsDoc GhcRn])]+       -> (UniqMap Name [HsDoc GhcRn], UniqMap Name (IntMap (HsDoc GhcRn)))+mkMaps env instances decls =+    ( listsToMapWith (++) (map (nubByName fst) decls')+    , listsToMapWith (<>) (filterMapping (not . IM.null) args)     )   where     (decls', args) = unzip (map mappings decls) -    f :: (Ord a, Semigroup b) => [[(a, b)]] -> Map a b-    f = M.fromListWith (<>) . concat--    f' :: Ord a => [[(a, HsDocString)]] -> Map a HsDocString-    f' = M.fromListWith appendDocs . concat+    listsToMapWith f = listToUniqMap_C f . concat      filterMapping :: (b -> Bool) ->  [[(a, b)]] -> [[(a, b)]]     filterMapping p = map (filter (p . snd)) -    mappings :: (LHsDecl GhcRn, [HsDocString])-             -> ( [(Name, HsDocString)]-                , [(Name, IntMap HsDocString)]+    mappings :: (LHsDecl GhcRn, [HsDoc GhcRn])+             -> ( [(Name, [HsDoc GhcRn])]+                , [(Name, IntMap (HsDoc GhcRn))]                 )-    mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, docStrs) =+    mappings (L (SrcSpanAnn _ (RealSrcSpan l _)) decl, doc) =            (dm, am)       where-        doc = concatDocs docStrs         args = declTypeDocs decl -        subs :: [(Name, [HsDocString], IntMap HsDocString)]-        subs = subordinates instanceMap decl+        subs :: [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]+        subs = subordinates env instanceMap decl -        (subDocs, subArgs) =-          unzip (map (\(_, strs, m) -> (concatDocs strs, m)) subs)+        (subNs, subDocs, subArgs) =+          unzip3 subs          ns = names l decl-        subNs = [ n | (n, _, _) <- subs ]-        dm = [(n, d) | (n, Just d) <- zip ns (repeat doc) ++ zip subNs subDocs]+        dm = [(n, d) | (n, d) <- zip ns (repeat doc) ++ zip subNs subDocs, not $ all (isEmptyDocString . hsDocString) d]         am = [(n, args) | n <- ns] ++ zip subNs subArgs     mappings (L (SrcSpanAnn _ (UnhelpfulSpan _)) _, _) = ([], []) @@ -124,7 +270,7 @@     names :: RealSrcSpan -> HsDecl GhcRn -> [Name]     names _ (InstD _ d) = maybeToList $ lookupSrcSpan (getInstLoc d) instanceMap     names l (DerivD {}) = maybeToList (M.lookup l instanceMap) -- See Note [1].-    names _ decl = getMainDeclBinder decl+    names _ decl = getMainDeclBinder env decl  {- Note [1]:@@ -135,27 +281,37 @@ user-written. This lets us relate Names (from ClsInsts) to comments (associated with InstDecls and DerivDecls). -}-getMainDeclBinder :: (Anno (IdGhcP p) ~ SrcSpanAnnN, CollectPass (GhcPass p))-                  => HsDecl (GhcPass p) -> [IdP (GhcPass p)]-getMainDeclBinder (TyClD _ d) = [tcdName d]-getMainDeclBinder (ValD _ d) =++getMainDeclBinder+  :: OccEnv Name -- ^ Default method environment for this module. See Note [default method Name] in GHC.Iface.Recomp+  -> HsDecl GhcRn -> [Name]+getMainDeclBinder _ (TyClD _ d) = [tcdName d]+getMainDeclBinder _ (ValD _ d) =   case collectHsBindBinders CollNoDictBinders d of     []       -> []     (name:_) -> [name]-getMainDeclBinder (SigD _ d) = sigNameNoLoc d-getMainDeclBinder (ForD _ (ForeignImport _ name _ _)) = [unLoc name]-getMainDeclBinder (ForD _ (ForeignExport _ _ _ _)) = []-getMainDeclBinder _ = []+getMainDeclBinder env (SigD _ d) = sigNameNoLoc env d+getMainDeclBinder _   (ForD _ (ForeignImport _ name _ _)) = [unLoc name]+getMainDeclBinder _   (ForD _ (ForeignExport _ _ _ _)) = []+getMainDeclBinder _ _ = []  -sigNameNoLoc :: forall pass. UnXRec pass => Sig pass -> [IdP pass]-sigNameNoLoc (TypeSig    _   ns _)         = map (unXRec @pass) ns-sigNameNoLoc (ClassOpSig _ _ ns _)         = map (unXRec @pass) ns-sigNameNoLoc (PatSynSig  _   ns _)         = map (unXRec @pass) ns-sigNameNoLoc (SpecSig    _   n _ _)        = [unXRec @pass n]-sigNameNoLoc (InlineSig  _   n _)          = [unXRec @pass n]-sigNameNoLoc (FixSig _ (FixitySig _ ns _)) = map (unXRec @pass) ns-sigNameNoLoc _                             = []+-- | The "OccEnv Name" is the default method environment for this module+-- Ultimately, the a special "defaultMethodOcc" name is used for+-- the signatures on bindings for default methods. Unfortunately, this+-- name isn't generated until typechecking, so it is not in the renamed AST.+-- We have to look it up from the 'OccEnv' parameter constructed from the typechecked+-- AST.+-- See also Note [default method Name] in GHC.Iface.Recomp+sigNameNoLoc :: forall a . (UnXRec a, HasOccName (IdP a)) => OccEnv (IdP a) -> Sig a -> [IdP a]+sigNameNoLoc _   (TypeSig    _   ns _)         = map (unXRec @a) ns+sigNameNoLoc _   (ClassOpSig _ False ns _)     = map (unXRec @a) ns+sigNameNoLoc env (ClassOpSig _ True  ns _)     = mapMaybe (lookupOccEnv env . mkDefaultMethodOcc . occName) $ map (unXRec @a) ns+sigNameNoLoc _   (PatSynSig  _   ns _)         = map (unXRec @a) ns+sigNameNoLoc _   (SpecSig    _   n _ _)        = [unXRec @a n]+sigNameNoLoc _   (InlineSig  _   n _)          = [unXRec @a n]+sigNameNoLoc _   (FixSig _ (FixitySig _ ns _)) = map (unXRec @a) ns+sigNameNoLoc _   _                             = []  -- Extract the source location where an instance is defined. This is used -- to correlate InstDecls with their Instance/CoAxiom Names, via the@@ -180,15 +336,21 @@ -- | Get all subordinate declarations inside a declaration, and their docs. -- A subordinate declaration is something like the associate type or data -- family of a type class.-subordinates :: Map RealSrcSpan Name+subordinates :: OccEnv Name -- ^ The default method environment+             -> Map RealSrcSpan Name              -> HsDecl GhcRn-             -> [(Name, [HsDocString], IntMap HsDocString)]-subordinates instMap decl = case decl of-  InstD _ (ClsInstD _ d) -> do-    DataFamInstDecl { dfid_eqn =-      FamEqn { feqn_tycon = L l _-             , feqn_rhs   = defn }} <- unLoc <$> cid_datafam_insts d-    [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn+             -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]+subordinates env instMap decl = case decl of+  InstD _ (ClsInstD _ d) -> let+    data_fams = do+      DataFamInstDecl { dfid_eqn =+        FamEqn { feqn_tycon = L l _+               , feqn_rhs   = defn }} <- unLoc <$> cid_datafam_insts d+      [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ] ++ dataSubs defn+    ty_fams = do+      TyFamInstDecl { tfid_eqn = FamEqn { feqn_tycon = L l _ } } <- unLoc <$> cid_tyfam_insts d+      [ (n, [], IM.empty) | Just n <- [lookupSrcSpan (locA l) instMap] ]+    in data_fams ++ ty_fams    InstD _ (DataFamInstD _ (DataFamInstDecl d))     -> dataSubs (feqn_rhs d)@@ -198,11 +360,11 @@   where     classSubs dd = [ (name, doc, declTypeDocs d)                    | (L _ d, doc) <- classDecls dd-                   , name <- getMainDeclBinder d, not (isValD d)+                   , name <- getMainDeclBinder env d, not (isValD d)                    ]     dataSubs :: HsDataDefn GhcRn-             -> [(Name, [HsDocString], IntMap HsDocString)]-    dataSubs dd = constrs ++ fields ++ derivs+             -> [(Name, [HsDoc GhcRn], IntMap (HsDoc GhcRn))]+    dataSubs dd = constrs ++ fields  ++ derivs       where         cons = map unLoc $ (dd_cons dd)         constrs = [ ( unLoc cname@@ -220,13 +382,13 @@                                 dd_derivs dd                   , Just instName <- [lookupSrcSpan l instMap] ] -        extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDocString)]+        extract_deriv_clause_tys :: LDerivClauseTys GhcRn -> [(SrcSpan, LHsDoc GhcRn)]         extract_deriv_clause_tys (L _ dct) =           case dct of             DctSingle _ ty -> maybeToList $ extract_deriv_ty ty             DctMulti _ tys -> mapMaybe extract_deriv_ty tys -        extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDocString)+        extract_deriv_ty :: LHsSigType GhcRn -> Maybe (SrcSpan, LHsDoc GhcRn)         extract_deriv_ty (L l (HsSig{sig_body = L _ ty})) =           case ty of             -- deriving (C a {- ^ Doc comment -})@@ -234,25 +396,25 @@             _               -> Nothing  -- | Extract constructor argument docs from inside constructor decls.-conArgDocs :: ConDecl GhcRn -> IntMap HsDocString+conArgDocs :: ConDecl GhcRn -> IntMap (HsDoc GhcRn) conArgDocs (ConDeclH98{con_args = args}) =   h98ConArgDocs args conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) =   gadtConArgDocs args (unLoc res_ty) -h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap HsDocString+h98ConArgDocs :: HsConDeclH98Details GhcRn -> IntMap (HsDoc GhcRn) h98ConArgDocs con_args = case con_args of   PrefixCon _ args   -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args   InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1)                                        , unLoc (hsScaledThing arg2) ]   RecCon _           -> IM.empty -gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap HsDocString+gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> IntMap (HsDoc GhcRn) gadtConArgDocs con_args res_ty = case con_args of   PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty]   RecConGADT _ _     -> con_arg_docs 1 [res_ty] -con_arg_docs :: Int -> [HsType GhcRn] -> IntMap HsDocString+con_arg_docs :: Int -> [HsType GhcRn] -> IntMap (HsDoc GhcRn) con_arg_docs n = IM.fromList . catMaybes . zipWith f [n..]   where     f n (HsDocTy _ _ lds) = Just (n, unLoc lds)@@ -265,7 +427,7 @@  -- | All the sub declarations of a class (that we handle), ordered by -- source location, with documentation attached if it exists.-classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDocString])]+classDecls :: TyClDecl GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])] classDecls class_ = filterDecls . collectDocs . sortLocatedA $ decls   where     decls = docs ++ defs ++ sigs ++ ats@@ -275,7 +437,7 @@     ats   = mkDecls tcdATs (TyClD noExtField . FamDecl noExtField) class_  -- | Extract function argument docs from inside top-level decls.-declTypeDocs :: HsDecl GhcRn -> IntMap (HsDocString)+declTypeDocs :: HsDecl GhcRn -> IntMap (HsDoc GhcRn) declTypeDocs = \case   SigD  _ (TypeSig _ _ ty)          -> sigTypeDocs (unLoc (dropWildCards ty))   SigD  _ (ClassOpSig _ _ _ ty)     -> sigTypeDocs (unLoc ty)@@ -296,7 +458,7 @@         y = f x  -- | Extract function argument docs from inside types.-typeDocs :: HsType GhcRn -> IntMap HsDocString+typeDocs :: HsType GhcRn -> IntMap (HsDoc GhcRn) typeDocs = go 0   where     go n = \case@@ -308,12 +470,12 @@       _                                     -> IM.empty  -- | Extract function argument docs from inside types.-sigTypeDocs :: HsSigType GhcRn -> IntMap HsDocString+sigTypeDocs :: HsSigType GhcRn -> IntMap (HsDoc GhcRn) sigTypeDocs (HsSig{sig_body = body}) = typeDocs (unLoc body)  -- | The top-level declarations of a module that we care about, -- ordered by source location, with documentation attached if it exists.-topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDocString])]+topDecls :: HsGroup GhcRn -> [(LHsDecl GhcRn, [HsDoc GhcRn])] topDecls = filterClasses . filterDecls . collectDocs . sortLocatedA . ungroup  -- | Take all declarations except pragmas, infix decls, rules from an 'HsGroup'.@@ -340,14 +502,14 @@ -- | Collect docs and attach them to the right declarations. -- -- A declaration may have multiple doc strings attached to it.-collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDocString])]+collectDocs :: forall p. UnXRec p => [LHsDecl p] -> [(LHsDecl p, [HsDoc p])] -- ^ This is an example. collectDocs = go [] Nothing   where     go docs mprev decls = case (decls, mprev) of-      ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing)   -> go (s:docs) Nothing ds-      ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [s] Nothing ds-      ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev)     -> go (s:docs) mprev ds+      ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Nothing)   -> go (unLoc s:docs) Nothing ds+      ((unXRec @p -> DocD _ (DocCommentNext s)) : ds, Just prev) -> finished prev docs $ go [unLoc s] Nothing ds+      ((unXRec @p -> DocD _ (DocCommentPrev s)) : ds, mprev)     -> go (unLoc s:docs) mprev ds       (d                                  : ds, Nothing)   -> go docs (Just d) ds       (d                                  : ds, Just prev) -> finished prev docs $ go [] (Just d) ds       ([]                                     , Nothing)   -> []@@ -401,14 +563,15 @@ extractTHDocs docs =   -- Split up docs into separate maps for each 'DocLoc' type   ExtractedTHDocs-    docHeader-    (DeclDocMap (searchDocs decl))-    (ArgDocMap (searchDocs args))-    (DeclDocMap (searchDocs insts))+    { ethd_mod_header = docHeader+    , ethd_decl_docs  = searchDocs decl+    , ethd_arg_docs   = searchDocs args+    , ethd_inst_docs  = searchDocs insts+    }   where-    docHeader :: Maybe HsDocString+    docHeader :: Maybe (HsDoc GhcRn)     docHeader-      | ((_, s):_) <- filter isModDoc (M.toList docs) = Just (mkHsDocString s)+      | ((_, s):_) <- filter isModDoc (M.toList docs) = Just s       | otherwise = Nothing      isModDoc (ModuleDoc, _) = True@@ -417,38 +580,40 @@     -- Folds over the docs, applying 'f' as the accumulating function.     -- We use different accumulating functions to sift out the specific types of     -- documentation-    searchDocs :: Monoid a => (a -> (DocLoc, String) -> a) -> a-    searchDocs f = foldl' f mempty $ M.toList docs+    searchDocs :: (UniqMap Name a -> (DocLoc, HsDoc GhcRn) -> UniqMap Name a) -> UniqMap Name a+    searchDocs f = foldl' f emptyUniqMap $ M.toList docs      -- Pick out the declaration docs-    decl acc ((DeclDoc name), s) = M.insert name (mkHsDocString s) acc+    decl acc ((DeclDoc name), s) = addToUniqMap acc name s     decl acc _ = acc      -- Pick out the instance docs-    insts acc ((InstDoc name), s) = M.insert name (mkHsDocString s) acc+    insts acc ((InstDoc name), s) = addToUniqMap acc name s     insts acc _ = acc      -- Pick out the argument docs-    args :: Map Name (IntMap HsDocString)-         -> (DocLoc, String)-         -> Map Name (IntMap HsDocString)+    args :: UniqMap Name (IntMap (HsDoc GhcRn))+         -> (DocLoc, HsDoc GhcRn)+         -> UniqMap Name (IntMap (HsDoc GhcRn))     args acc ((ArgDoc name i), s) =       -- Insert the doc for the arg into the argument map for the function. This       -- means we have to search to see if an map already exists for the       -- function, and insert the new argument if it exists, or create a new map-      let ds = mkHsDocString s-       in M.insertWith (\_ m -> IM.insert i ds m) name (IM.singleton i ds) acc+       addToUniqMap_C (\_ m -> IM.insert i s m) acc name (IM.singleton i s)     args acc _ = acc  -- | Unions together two 'ArgDocMaps' (or ArgMaps in haddock-api), such that two -- maps with values for the same key merge the inner map as well. -- Left biased so @unionArgMaps a b@ prefers @a@ over @b@.-unionArgMaps :: Map Name (IntMap b)-             -> Map Name (IntMap b)-             -> Map Name (IntMap b)-unionArgMaps a b = M.foldlWithKey go b a++unionArgMaps :: forall b . UniqMap Name (IntMap b)+             -> UniqMap Name (IntMap b)+             -> UniqMap Name (IntMap b)+unionArgMaps a b = nonDetFoldUniqMap go b a   where-    go acc n newArgMap-      | Just oldArgMap <- M.lookup n acc =-          M.insert n (newArgMap `IM.union` oldArgMap) acc-      | otherwise = M.insert n newArgMap acc+    go :: (Name, IntMap b)+            -> UniqMap Name (IntMap b) -> UniqMap Name (IntMap b)+    go (n, newArgMap) acc+      | Just oldArgMap <- lookupUniqMap acc n =+          addToUniqMap acc n (newArgMap `IM.union` oldArgMap)+      | otherwise = addToUniqMap acc n newArgMap

@@ -143,7 +143,7 @@              ; dsUnliftedBind bind body }   where-    is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })+    is_polymorphic (XHsBindsLR (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs }))                      = not (null tvs && null evs)     is_polymorphic _ = False @@ -161,6 +161,7 @@         ; (force_vars,prs) <- dsLHsBinds binds         ; let body' = foldr seqVar body force_vars         ; assertPpr (not (any (isUnliftedType . idType . fst) prs)) (ppr is_rec $$ ppr binds) $+          -- NB: bindings have a fixed RuntimeRep, so it's OK to call isUnliftedType           case prs of             [] -> return body             _  -> return (Let (Rec prs) body') }@@ -177,10 +178,10 @@  ------------------ dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr-dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []-               , abs_exports = exports-               , abs_ev_binds = ev_binds-               , abs_binds = lbinds }) body+dsUnliftedBind (XHsBindsLR (AbsBinds { abs_tvs = [], abs_ev_vars = []+                                     , abs_exports = exports+                                     , abs_ev_binds = ev_binds+                                     , abs_binds = lbinds })) body   = do { let body1 = foldr bind_export body exports              bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b        ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body)@@ -745,10 +746,11 @@ -- Here is where we desugar the Template Haskell brackets and escapes  -- Template Haskell stuff+-- See Note [The life cycle of a TH quotation] -dsExpr (HsRnBracketOut x _ _)  = dataConCantHappen x-dsExpr (HsTcBracketOut _ hs_wrapper x ps) = dsBracket hs_wrapper x ps-dsExpr (HsSpliceE _ s)         = pprPanic "dsExpr:splice" (ppr s)+dsExpr (HsTypedBracket   (HsBracketTc q _ hs_wrapper ps) _) = dsBracket hs_wrapper q ps+dsExpr (HsUntypedBracket (HsBracketTc q _ hs_wrapper ps) _) = dsBracket hs_wrapper q ps+dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)  -- Arrow notation extension dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd@@ -761,7 +763,6 @@ dsExpr (OpApp x _ _ _)   = dataConCantHappen x dsExpr (SectionL x _ _)  = dataConCantHappen x dsExpr (SectionR x _ _)  = dataConCantHappen x-dsExpr (HsBracket x _)   = dataConCantHappen x  ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr ds_prag_expr (HsPragSCC _ _ cc) expr = do

@@ -43,6 +43,7 @@  import GHC.Cmm.Expr import GHC.Cmm.Utils+import GHC.Cmm.CLabel import GHC.Driver.Ppr import GHC.Types.ForeignCall import GHC.Builtin.Types@@ -95,11 +96,12 @@   = return (NoStubs, nilOL) dsForeigns' fos = do     mod <- getModule+    platform <- targetPlatform <$> getDynFlags     fives <- mapM do_ldecl fos     let         (hs, cs, idss, bindss) = unzip4 fives         fe_ids = concat idss-        fe_init_code = foreignExportsInitialiser mod fe_ids+        fe_init_code = foreignExportsInitialiser platform mod fe_ids     --     return (ForeignStubs              (mconcat hs)@@ -298,7 +300,7 @@                                                 simpl_opts                                                 wrap_rhs' -    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc)+    return ([(work_id, work_rhs), (fn_id_w_inl, wrap_rhs')], mempty, CStub cDoc [] [])  {- ************************************************************************@@ -526,7 +528,9 @@                    Int          -- total size of arguments                   ) mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc- = (header_bits, c_bits, type_string,+ = ( header_bits+   , CStub body [] []+   , type_string,     sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args          -- NB. the calculation here isn't strictly speaking correct.          -- We have a primitive Haskell type (eg. Int#, Double#), and@@ -646,7 +650,7 @@     -- finally, the whole darn thing-  c_bits = CStub $+  body =     space $$     extern_decl $$     fun_proto  $$@@ -682,10 +686,9 @@      , rbrace      ] --foreignExportsInitialiser :: Module -> [Id] -> CStub-foreignExportsInitialiser _   []     = mempty-foreignExportsInitialiser mod hs_fns =+foreignExportsInitialiser :: Platform -> Module -> [Id] -> CStub+foreignExportsInitialiser _        _   []     = mempty+foreignExportsInitialiser platform mod hs_fns =    -- Initialise foreign exports by registering a stable pointer from an    -- __attribute__((constructor)) function.    -- The alternative is to do this from stginit functions generated in@@ -696,21 +699,18 @@    -- (this is bad for big umbrella modules like Graphics.Rendering.OpenGL)    --    -- See Note [Tracking foreign exports] in rts/ForeignExports.c-   CStub $ vcat-    [ text "static struct ForeignExportsList" <+> list_symbol <+> equals+   initializerCStub platform fn_nm list_decl fn_body+  where+    fn_nm       = mkInitializerStubLabel mod "fexports"+    mod_str     = pprModuleName (moduleName mod)+    fn_body     = text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi+    list_symbol = text "stg_exports_" <> mod_str+    list_decl   = text "static struct ForeignExportsList" <+> list_symbol <+> equals          <+> braces (            text ".exports = " <+> export_list <> comma <+>            text ".n_entries = " <+> ppr (length hs_fns))          <> semi-    , text "static void " <> ctor_symbol <> text "(void)"-         <+> text " __attribute__((constructor));"-    , text "static void " <> ctor_symbol <> text "()"-    , braces (text "registerForeignExports" <> parens (char '&' <> list_symbol) <> semi)-    ]-  where-    mod_str = pprModuleName (moduleName mod)-    ctor_symbol = text "stginit_export_" <> mod_str-    list_symbol = text "stg_exports_" <> mod_str+     export_list = braces $ pprWithCommas closure_ptr hs_fns      closure_ptr :: Id -> SDoc@@ -820,6 +820,8 @@      Just (_, _, data_con, [Scaled _ prim_ty]) ->         assert (dataConSourceArity data_con == 1) $         assertPpr (isUnliftedType prim_ty) (ppr prim_ty)+          -- NB: it's OK to call isUnliftedType here, as we don't allow+          -- representation-polymorphic types in foreign import/export declarations         prim_ty      _other -> pprPanic "GHC.HsToCore.Foreign.Decl.getPrimTyOf" (ppr ty)   where

@@ -450,6 +450,7 @@     -- Doing this check during type-checking is unsatisfactory because we may     -- not fully know the zonked types yet. We sure do here.   = do  { let unlifted_bndrs = filter (isUnliftedType . idType) (collectPatBinders CollNoDictBinders pat)+            -- NB: the binders can't be representation-polymorphic, so we're OK to call isUnliftedType         ; unless (null unlifted_bndrs) $           putSrcSpanDs (getLocA pat) $           diagnosticDs (DsLazyPatCantBindVarsOfUnliftedType unlifted_bndrs)

@@ -506,9 +506,9 @@  tidyLitPat :: HsLit GhcTc -> Pat GhcTc -- Result has only the following HsLits:---      HsIntPrim, HsWordPrim, HsCharPrim, HsFloatPrim---      HsDoublePrim, HsStringPrim, HsString---  * HsInteger, HsRat, HsInt can't show up in LitPats+--      HsIntPrim, HsWordPrim, HsCharPrim, HsString+--  * HsInteger, HsRat, HsInt, as well as HsStringPrim,+--    HsFloatPrim and HsDoublePrim can't show up in LitPats --  * We get rid of HsChar right here tidyLitPat (HsChar src c) = unLoc (mkCharLitPat src c) tidyLitPat (HsString src s)

@@ -388,12 +388,13 @@       , GRHSs{grhssGRHSs = [L _ (GRHS _ _grds rhs)]} <- grhss = do           core_rhs <- dsLExpr rhs           return [PmLet x core_rhs]-    go (L _ AbsBinds{ abs_tvs = [], abs_ev_vars = []-                    , abs_exports=exports, abs_binds = binds }) = do+    go (L _ (XHsBindsLR (AbsBinds+                          { abs_tvs = [], abs_ev_vars = []+                          , abs_exports=exports, abs_binds = binds }))) = do       -- Typechecked HsLocalBinds are wrapped in AbsBinds, which carry       -- renamings. See Note [Long-distance information for HsLocalBinds]       -- for the details.-      let go_export :: ABExport GhcTc -> Maybe PmGrd+      let go_export :: ABExport -> Maybe PmGrd           go_export ABE{abe_poly = x, abe_mono = y, abe_wrap = wrap}             | isIdHsWrapper wrap             = assertPpr (idType x `eqType` idType y)

@@ -46,6 +46,7 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Data.Bag+import GHC.Types.Basic (Levity(..)) import GHC.Types.CompleteMatch import GHC.Types.Unique.Set import GHC.Types.Unique.DSet@@ -146,7 +147,7 @@ -- Ex.: @vanillaCompleteMatchTC 'Maybe' ==> Just ("Maybe", {'Just','Nothing'})@ vanillaCompleteMatchTC :: TyCon -> Maybe CompleteMatch vanillaCompleteMatchTC tc =-  let -- | TYPE acts like an empty data type on the term-level (#14086), but+  let -- TYPE acts like an empty data type on the term-level (#14086), but       -- it is a PrimTyCon, so tyConDataCons_maybe returns Nothing. Hence a       -- special case.       mb_dcs | tc == tYPETyCon = Just []@@ -172,7 +173,7 @@ addTyConMatches :: TyCon -> ResidualCompleteMatches -> DsM ResidualCompleteMatches addTyConMatches tc rcm = add_tc_match <$> addCompleteMatches rcm   where-    -- | Add the vanilla COMPLETE set from the data defn, if any. But only if+    -- Add the vanilla COMPLETE set from the data defn, if any. But only if     -- it's not already present.     add_tc_match rcm       = rcm{rcm_vanilla = rcm_vanilla rcm <|> vanillaCompleteMatchTC tc}@@ -674,7 +675,7 @@ filterUnliftedFields :: PmAltCon -> [Id] -> [Id] filterUnliftedFields con args =   [ arg | (arg, bang) <- zipEqual "addPhiCt" args (pmAltConImplBangs con)-        , isBanged bang || isUnliftedType (idType arg) ]+        , isBanged bang || typeLevity_maybe (idType arg) == Just Unlifted ]  -- | Adds the constraint @x ~ ⊥@, e.g. that evaluation of a particular 'Id' @x@ -- surely diverges. Quite similar to 'addConCt', only that it only cares about@@ -685,11 +686,12 @@   case bot of     IsNotBot -> mzero      -- There was x ≁ ⊥. Contradiction!     IsBot    -> pure nabla -- There already is x ~ ⊥. Nothing left to do-    MaybeBot ->            -- We add x ~ ⊥+    MaybeBot               -- We add x ~ ⊥+      | Just Unlifted <- typeLevity_maybe (idType x)       -- Case (3) in Note [Strict fields and variables of unlifted type]-      if isUnliftedType (idType x)-        then mzero -- unlifted vars can never be ⊥-        else do+      -> mzero -- unlifted vars can never be ⊥+      | otherwise+      -> do           let vi' = vi{ vi_bot = IsBot }           pure nabla{ nabla_tm_st = ts{ts_facts = addToUSDFM env y vi' } } @@ -720,7 +722,7 @@     Just x  -> markDirty x nabla'     Nothing -> nabla'   where-    -- | Update `x`'s 'VarInfo' entry. Fail ('MaybeT') if contradiction,+    -- Update `x`'s 'VarInfo' entry. Fail ('MaybeT') if contradiction,     -- otherwise return updated entry and `Just x'` if `x` should be marked dirty,     -- where `x'` is the representative of `x`.     go :: VarInfo -> MaybeT DsM (Maybe Id, VarInfo)@@ -844,7 +846,7 @@   -- lift $ tracePm "addCoreCt" (ppr x <+> dcolon <+> ppr (idType x) $$ ppr e $$ ppr e')   execStateT (core_expr x e') nabla   where-    -- | Takes apart a 'CoreExpr' and tries to extract as much information about+    -- Takes apart a 'CoreExpr' and tries to extract as much information about     -- literals and constructor applications as possible.     core_expr :: Id -> CoreExpr -> StateT Nabla (MaybeT DsM) ()     -- TODO: Handle newtypes properly, by wrapping the expression in a DataCon@@ -885,7 +887,7 @@         -- up substituting inside a forall or lambda (i.e. seldom)         -- so using exprFreeVars seems fine.   See MR !1647. -    -- | The @e@ in @let x = e@ had no familiar form. But we can still see if+    -- The @e@ in @let x = e@ had no familiar form. But we can still see if     -- see if we already encountered a constraint @let y = e'@ with @e'@     -- semantically equivalent to @e@, in which case we may add the constraint     -- @x ~ y@.@@ -901,7 +903,7 @@       core_expr x e       pure x -    -- | Look at @let x = K taus theta es@ and generate the following+    -- Look at @let x = K taus theta es@ and generate the following     -- constraints (assuming universals were dropped from @taus@ before):     --   1. @x ≁ ⊥@ if 'K' is not a Newtype constructor.     --   2. @a_1 ~ tau_1, ..., a_n ~ tau_n@ for fresh @a_i@@@ -928,7 +930,7 @@       -- 4. @x ~ K as ys@       pm_alt_con_app x (PmAltConLike (RealDataCon dc)) ex_tvs arg_ids -    -- | Adds a literal constraint, i.e. @x ~ 42@.+    -- Adds a literal constraint, i.e. @x ~ 42@.     -- Also we assume that literal expressions won't diverge, so this     -- will add a @x ~/ ⊥@ constraint.     pm_lit :: Id -> PmLit -> StateT Nabla (MaybeT DsM) ()@@ -936,7 +938,7 @@       modifyT $ \nabla -> addNotBotCt nabla x       pm_alt_con_app x (PmAltLit lit) [] [] -    -- | Adds the given constructor application as a solution for @x@.+    -- Adds the given constructor application as a solution for @x@.     pm_alt_con_app :: Id -> PmAltCon -> [TyVar] -> [Id] -> StateT Nabla (MaybeT DsM) ()     pm_alt_con_app x con tvs args = modifyT $ \nabla -> addConCt nabla x con tvs args @@ -1355,15 +1357,13 @@ isDataConTriviallyInhabited dc   | isTyConTriviallyInhabited (dataConTyCon dc) = True isDataConTriviallyInhabited dc =-  null (dataConTheta dc) &&         -- (1)-  null (dataConImplBangs dc) &&     -- (2)-  null (dataConUnliftedFieldTys dc) -- (3)+  null (dataConTheta dc) &&                -- (1)+  null (dataConImplBangs dc) &&            -- (2)+  null (dataConMightBeUnliftedFieldTys dc) -- (3) -dataConUnliftedFieldTys :: DataCon -> [Type]-dataConUnliftedFieldTys =-  -- A representation-polymorphic field requires an inhabitation test, hence compare to-  -- @Just True@-  filter ((== Just True) . isLiftedType_maybe) . map scaledThing . dataConOrigArgTys+dataConMightBeUnliftedFieldTys :: DataCon -> [Type]+dataConMightBeUnliftedFieldTys =+  filter mightBeUnliftedType . map scaledThing . dataConOrigArgTys  isTyConTriviallyInhabited :: TyCon -> Bool isTyConTriviallyInhabited tc = elementOfUniqSet (getUnique tc) triviallyInhabitedTyConKeys@@ -1401,7 +1401,7 @@     -- the unlikely bogus case of an unlifted field that has a bang.     unlifted_or_strict_fields :: DataCon -> Int     unlifted_or_strict_fields dc = fast_length (dataConImplBangs dc)-                                 + fast_length (dataConUnliftedFieldTys dc)+                                 + fast_length (dataConMightBeUnliftedFieldTys dc)  -- | @instCon fuel nabla (x::match_ty) K@ tries to instantiate @x@ to @K@ by -- adding the proper constructor constraint.@@ -1836,7 +1836,7 @@       | otherwise       -> generateInhabitingPatterns mode xs n nabla   where-    -- | Tries to instantiate a variable by possibly following the chain of+    -- Tries to instantiate a variable by possibly following the chain of     -- newtypes and then instantiating to all ConLikes of the wrapped type's     -- minimal residual COMPLETE set.     try_instantiate :: Id -> [Id] -> Int -> Nabla -> DsM [Nabla]@@ -1868,7 +1868,7 @@                 then generateInhabitingPatterns mode xs n newty_nabla -- bot is still possible. Display a wildcard!                 else pure nablas' -    -- | Instantiates a chain of newtypes, beginning at @x@.+    -- Instantiates a chain of newtypes, beginning at @x@.     -- Turns @x nabla [T,U,V]@ to @(y, nabla')@, where @nabla'@ we has the fact     -- @x ~ T (U (V y))@.     instantiate_newtype_chain :: Id -> Nabla -> [(Type, DataCon, Type)] -> MaybeT DsM (Id, Nabla)

@@ -158,7 +158,7 @@  ----------------------------------------------------------------------------- dsBracket :: Maybe QuoteWrapper -- ^ This is Nothing only when we are dealing with a VarBr-          -> HsBracket GhcRn+          -> HsQuote GhcRn      -- See Note [The life cycle of a TH quotation]           -> [PendingTcSplice]           -> DsM CoreExpr -- See Note [Desugaring Brackets]@@ -168,7 +168,6 @@  dsBracket wrap brack splices   = do_brack brack-   where     runOverloaded act = do       -- In the overloaded case we have to get given a wrapper, it is just@@ -177,7 +176,6 @@       mw <- mkMetaWrappers (expectJust "runOverloaded" wrap)       runReaderT (mapReaderT (dsExtendMetaEnv new_bit) act) mw -     new_bit = mkNameEnv [(n, DsSplice (unLoc e))                         | PendingTcSplice n e <- splices] @@ -186,9 +184,9 @@     do_brack (PatBr _ p)   = runOverloaded $ do { MkC p1  <- repTopP p   ; return p1 }     do_brack (TypBr _ t)   = runOverloaded $ do { MkC t1  <- repLTy t    ; return t1 }     do_brack (DecBrG _ gp) = runOverloaded $ do { MkC ds1 <- repTopDs gp ; return ds1 }-    do_brack (DecBrL {})   = panic "dsBracket: unexpected DecBrL"-    do_brack (TExpBr _ e)  = runOverloaded $ do { MkC e1  <- repLE e     ; return e1 }+    do_brack (DecBrL {})   = panic "dsUntypedBracket: unexpected DecBrL" + {- Note [Desugaring Brackets] ~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1120,6 +1118,7 @@  repInline :: InlineSpec -> MetaM (Core TH.Inline) repInline (NoInline          _ )   = dataCon noInlineDataConName+repInline (Opaque            _ )   = dataCon opaqueDataConName repInline (Inline            _ )   = dataCon inlineDataConName repInline (Inlinable         _ )   = dataCon inlinableDataConName repInline NoUserInlinePrag        = notHandled ThNoUserInline@@ -1636,9 +1635,8 @@          then repE ds_expr          else repE orig_expr } repE e@(HsPragE _ (HsPragSCC {}) _) = notHandled (ThCostCentres e)-repE e@(HsBracket{}) = notHandled (ThExpressionForm e)-repE e@(HsRnBracketOut{}) = notHandled (ThExpressionForm e)-repE e@(HsTcBracketOut{}) = notHandled (ThExpressionForm e)+repE e@(HsTypedBracket{})   = notHandled (ThExpressionForm e)+repE e@(HsUntypedBracket{}) = notHandled (ThExpressionForm e) repE e@(HsProc{}) = notHandled (ThExpressionForm e)  {- Note [Quotation and rebindable syntax]@@ -1911,7 +1909,6 @@         ; ans <- repVal patcore x empty_decls         ; return (srcLocSpan (getSrcLoc v), ans) } -rep_bind (L _ (AbsBinds {}))  = panic "rep_bind: AbsBinds" rep_bind (L loc (PatSynBind _ (PSB { psb_id   = syn                                    , psb_args = args                                    , psb_def  = pat@@ -2078,7 +2075,14 @@ repP (NPat _ (L _ l) Nothing _) = do { a <- repOverloadedLiteral l                                      ; repPlit a } repP (ViewPat _ e p) = do { e' <- repLE e; p' <- repLP p; repPview e' p' }-repP p@(NPat _ _ (Just _) _) = notHandled (ThNegativeOverloadedPatterns p)+repP p@(NPat _ (L _ l) (Just _) _)+  | OverLitRn rebindable _ <- ol_ext l+  , rebindable = notHandled (ThNegativeOverloadedPatterns p)+  | HsIntegral i <- ol_val l = do { a <- repOverloadedLiteral l{ol_val = HsIntegral (negateIntegralLit i)}+                                  ; repPlit a }+  | HsFractional i <- ol_val l = do { a <- repOverloadedLiteral l{ol_val = HsFractional (negateFractionalLit i)}+                                  ; repPlit a }+  | otherwise = notHandled (ThExoticPattern p) repP (SigPat _ p t) = do { p' <- repLP p                          ; t' <- repLTy (hsPatSigType t)                          ; repPsig p' t' }

@@ -85,7 +85,7 @@                        -- The Id has type THSyntax.Var    | DsSplice (HsExpr GhcTc) -- These bindings are introduced by-                            -- the PendingSplices on a HsBracketOut+                            -- the PendingSplices on a Hs*Bracket  -- | Desugaring monad. See also 'TcM'. type DsM = TcRnIf DsGblEnv DsLclEnv

@@ -205,7 +205,7 @@ -- These synonyms match those defined in compiler/GHC.hs type RenamedSource     = ( HsGroup GhcRn, [LImportDecl GhcRn]                          , Maybe [(LIE GhcRn, Avails)]-                         , Maybe LHsDocString )+                         , Maybe (LHsDoc GhcRn) ) type TypecheckedSource = LHsBinds GhcTc  @@ -267,12 +267,11 @@   addSubstitution mono poly hs =     hs{name_remapping = extendNameEnv (name_remapping hs) (varName mono) poly} -modifyState :: ModifyState (IdP p) => [ABExport p] -> HieState -> HieState+modifyState :: [ABExport] -> HieState -> HieState modifyState = foldr go id   where     go ABE{abe_poly=poly,abe_mono=mono} f       = addSubstitution mono poly . f-    go _ f = f  type HieM = ReaderT NodeOrigin (State HieState) @@ -317,12 +316,13 @@  enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]   -> HieASTs Type-enrichHie ts (hsGrp, imports, exports, _) ev_bs insts tcs =+enrichHie ts (hsGrp, imports, exports, docs) ev_bs insts tcs =   runIdentity $ flip evalStateT initState $ flip runReaderT SourceInfo $ do     tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts     rasts <- processGrp hsGrp     imps <- toHie $ filter (not . ideclImplicit . unLoc) imports     exps <- toHie $ fmap (map $ IEC Export . fst) exports+    docs <- toHie docs     -- Add Instance bindings     forM_ insts $ \i ->       addUnlocatedEvBind (is_dfun i) (EvidenceVarBind (EvInstBind False (is_cls_nm i)) ModuleScope Nothing)@@ -342,6 +342,7 @@           , rasts           , imps           , exps+          , docs           ]          modulify (HiePath file) xs' = do@@ -388,6 +389,7 @@       , toHie $ hs_warnds grp       , toHie $ hs_annds grp       , toHie $ hs_ruleds grp+      , toHie $ hs_docs grp       ]  getRealSpanA :: SrcSpanAnn' ann -> Maybe Span@@ -723,7 +725,7 @@       fallback :: HieM [HieAST Type]       fallback = makeNodeA e spn -      -- | Skip computing the type of some expressions for performance reasons.+      -- Skip computing the type of some expressions for performance reasons.       --       -- See impact on Haddock output (esp. missing type annotations or links)       -- before skipping more kinds of expressions. See impact on Haddock@@ -847,21 +849,27 @@       VarBind{var_rhs = expr} ->         [ toHie expr         ]-      AbsBinds{ abs_exports = xs, abs_binds = binds-              , abs_ev_binds = ev_binds-              , abs_ev_vars = ev_vars } ->-        [  lift (modify (modifyState xs)) >> -- Note [Name Remapping]-                (toHie $ fmap (BC context scope) binds)-        , toHie $ map (L span . abe_wrap) xs-        , toHie $-            map (EvBindContext (mkScopeA span) (getRealSpanA span)-                . L span) ev_binds-        , toHie $-            map (C (EvidenceVarBind EvSigBind-                                    (mkScopeA span)-                                    (getRealSpanA span))-                . L span) ev_vars-        ]+      XHsBindsLR ext -> case hiePass @p of+#if __GLASGOW_HASKELL__ < 811+        HieRn -> dataConCantHappen ext+#endif+        HieTc+          | AbsBinds{ abs_exports = xs, abs_binds = binds+                    , abs_ev_binds = ev_binds+                    , abs_ev_vars = ev_vars } <- ext+          ->+            [  lift (modify (modifyState xs)) >> -- Note [Name Remapping]+                    (toHie $ fmap (BC context scope) binds)+            , toHie $ map (L span . abe_wrap) xs+            , toHie $+                map (EvBindContext (mkScopeA span) (getRealSpanA span)+                    . L span) ev_binds+            , toHie $+                map (C (EvidenceVarBind EvSigBind+                                        (mkScopeA span)+                                        (getRealSpanA span))+                    . L span) ev_vars+            ]       PatSynBind _ psb ->         [ toHie $ L (locA span) psb -- PatSynBinds only occur at the top level         ]@@ -1178,17 +1186,23 @@       HsStatic _ expr ->         [ toHie expr         ]-      HsBracket _ b ->-        [ toHie b-        ]-      HsRnBracketOut _ b p ->-        [ toHie b-        , toHie p-        ]-      HsTcBracketOut _ _wrap b p ->-        [ toHie b-        , toHie p-        ]+      HsTypedBracket xbracket b -> case hiePass @p of+        HieRn ->+          [ toHie b+          ]+        HieTc | HsBracketTc _ _ _ p <- xbracket ->+          [ toHie b+          , toHie p+          ]+      HsUntypedBracket xbracket b -> case hiePass @p of+        HieRn ->+            [ toHie b+            , toHie xbracket+            ]+        HieTc | HsBracketTc _ _ _ p <- xbracket ->+          [ toHie b+          , toHie p+          ]       HsSpliceE _ x ->         [ toHie $ L mspan x         ]@@ -1585,7 +1599,8 @@ instance ToHie (LocatedA (ConDecl GhcRn)) where   toHie (L span decl) = concatM $ makeNode decl (locA span) : case decl of       ConDeclGADT { con_names = names, con_bndrs = L outer_bndrs_loc outer_bndrs-                  , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ } ->+                  , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ+                  , con_doc = doc} ->         [ toHie $ map (C (Decl ConDec $ getRealSpanA span)) names         , case outer_bndrs of             HsOuterImplicit{hso_ximplicit = imp_vars} ->@@ -1596,6 +1611,7 @@         , toHie ctx         , toHie args         , toHie typ+        , toHie doc         ]         where           rhsScope = combineScopes argsScope tyScope@@ -1606,11 +1622,13 @@           tyScope = mkLScopeA typ           resScope = ResolvedScopes [ctxScope, rhsScope]       ConDeclH98 { con_name = name, con_ex_tvs = qvars-                 , con_mb_cxt = ctx, con_args = dets } ->+                 , con_mb_cxt = ctx, con_args = dets+                 , con_doc = doc} ->         [ toHie $ C (Decl ConDec $ getRealSpan (locA span)) name         , toHie $ tvScopes (ResolvedScopes []) rhsScope qvars         , toHie ctx         , toHie dets+        , toHie doc         ]         where           rhsScope = combineScopes ctxScope argsScope@@ -1769,8 +1787,9 @@       HsSpliceTy _ a ->         [ toHie $ L span a         ]-      HsDocTy _ a _ ->+      HsDocTy _ a doc ->         [ toHie a+        , toHie doc         ]       HsBangTy _ _ ty ->         [ toHie ty@@ -1821,9 +1840,10 @@  instance ToHie (LocatedA (ConDeclField GhcRn)) where   toHie (L span field) = concatM $ makeNode field (locA span) : case field of-      ConDeclField _ fields typ _ ->+      ConDeclField _ fields typ doc ->         [ toHie $ map (RFC RecFieldDecl (getRealSpan $ loc typ)) fields         , toHie typ+        , toHie doc         ]  instance ToHie (LHsExpr a) => ToHie (ArithSeqInfo a) where@@ -1848,7 +1868,7 @@         [ toHie splice         ] -instance ToHie (HsBracket a) where+instance ToHie (HsQuote a) where   toHie _ = pure []  instance ToHie PendingRnSplice where@@ -2077,8 +2097,8 @@       IEModuleContents _ n ->         [ toHie $ IEC c n         ]-      IEGroup _ _ _ -> []-      IEDoc _ _ -> []+      IEGroup _ _ d -> [toHie d]+      IEDoc _ d -> [toHie d]       IEDocNamed _ _ -> []  instance ToHie (IEContext (LIEWrappedName Name)) where@@ -2098,3 +2118,13 @@       [ makeNode lbl span       , toHie $ C (IEThing c) $ L span (flSelector lbl)       ]++instance ToHie (LocatedA (DocDecl GhcRn)) where+  toHie (L span d) = concatM $ makeNodeA d span : case d of+    DocCommentNext d -> [ toHie d ]+    DocCommentPrev d -> [ toHie d ]+    DocCommentNamed _ d -> [ toHie d ]+    DocGroup _ d -> [ toHie d ]++instance ToHie (LHsDoc GhcRn) where+  toHie (L span d@(WithHsDocIdentifiers _ ids)) = concatM $ makeNode d span : [toHie $ map (C Use) ids]

@@ -21,7 +21,7 @@         -- RnM/TcM functions         loadModuleInterface, loadModuleInterfaces,         loadSrcInterface, loadSrcInterface_maybe,-        loadInterfaceForName, loadInterfaceForNameMaybe, loadInterfaceForModule,+        loadInterfaceForName, loadInterfaceForModule,          -- IfM functions         loadInterface,@@ -349,15 +349,6 @@       ; assertPpr (isExternalName name) (ppr name) $         initIfaceTcRn $ loadSysInterface doc (nameModule name) } --- | Only loads the interface for external non-local names.-loadInterfaceForNameMaybe :: SDoc -> Name -> TcRn (Maybe ModIface)-loadInterfaceForNameMaybe doc name-  = do { this_mod <- getModule-       ; if nameIsLocalOrFrom this_mod name || not (isExternalName name)-         then return Nothing-         else Just <$> (initIfaceTcRn $ loadSysInterface doc (nameModule name))-       }- -- | Loads the interface for a given Module. loadInterfaceForModule :: SDoc -> Module -> TcRn ModIface loadInterfaceForModule doc m@@ -1025,7 +1016,7 @@         mi_decls    = [],         mi_fixities = fixities,         mi_final_exts = (mi_final_exts empty_iface){ mi_fix_fn = mkIfaceFixCache fixities },-        mi_decl_docs = ghcPrimDeclDocs -- See Note [GHC.Prim Docs]+        mi_docs = Just ghcPrimDeclDocs -- See Note [GHC.Prim Docs]         }   where     empty_iface = emptyFullModIface gHC_PRIM@@ -1142,9 +1133,7 @@         , pprTrustInfo (mi_trust iface)         , pprTrustPkg (mi_trust_pkg iface)         , vcat (map ppr (mi_complete_matches iface))-        , text "module header:" $$ nest 2 (ppr (mi_doc_hdr iface))-        , text "declaration docs:" $$ nest 2 (ppr (mi_decl_docs iface))-        , text "arg docs:" $$ nest 2 (ppr (mi_arg_docs iface))+        , text "docs:" $$ nest 2 (ppr (mi_docs iface))         , text "extensible fields:" $$ nest 2 (pprExtensibleFields (mi_ext_fields iface))         ]   where@@ -1209,13 +1198,13 @@ pprTrustPkg :: Bool -> SDoc pprTrustPkg tpkg = text "require own pkg trusted:" <+> ppr tpkg -instance Outputable Warnings where+instance Outputable (Warnings pass) where     ppr = pprWarns -pprWarns :: Warnings -> SDoc+pprWarns :: Warnings pass -> SDoc pprWarns NoWarnings         = Outputable.empty pprWarns (WarnAll txt)  = text "Warn all" <+> ppr txt-pprWarns (WarnSome prs) = text "Warnings"+pprWarns (WarnSome prs) = text "Warnings:"                         <+> vcat (map pprWarning prs)     where pprWarning (name, txt) = ppr name <+> ppr txt 

@@ -125,12 +125,10 @@          , mg_hpc_info     = hpc_info          , mg_safe_haskell = safe_mode          , mg_trust_pkg    = self_trust-         , mg_doc_hdr      = doc_hdr-         , mg_decl_docs    = decl_docs-         , mg_arg_docs     = arg_docs+         , mg_docs         = docs          }   = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust-             safe_mode usages doc_hdr decl_docs arg_docs mod_summary mod_details+             safe_mode usages docs mod_summary mod_details  -- | Fully instantiate an interface. Adds fingerprints and potentially code -- generator produced information.@@ -222,34 +220,32 @@           usages <- mkUsageInfo hsc_env this_mod (imp_mods imports) used_names                       dep_files merged needed_links needed_pkgs -          (doc_hdr', doc_map, arg_map) <- extractDocs tc_result+          docs <- extractDocs (ms_hspp_opts mod_summary) tc_result            let partial_iface = mkIface_ hsc_env                    this_mod hsc_src                    used_th deps rdr_env                    fix_env warns hpc_info                    (imp_trust_own_pkg imports) safe_mode usages-                   doc_hdr' doc_map arg_map mod_summary+                   docs mod_summary                    mod_details            mkFullIface hsc_env partial_iface Nothing  mkIface_ :: HscEnv -> Module -> HscSource          -> Bool -> Dependencies -> GlobalRdrEnv-         -> NameEnv FixItem -> Warnings -> HpcInfo+         -> NameEnv FixItem -> Warnings GhcRn -> HpcInfo          -> Bool          -> SafeHaskellMode          -> [Usage]-         -> Maybe HsDocString-         -> DeclDocMap-         -> ArgDocMap+         -> Maybe Docs          -> ModSummary          -> ModDetails          -> PartialModIface mkIface_ hsc_env          this_mod hsc_src used_th deps rdr_env fix_env src_warns          hpc_info pkg_trust_req safe_mode usages-         doc_hdr decl_docs arg_docs mod_summary+         docs mod_summary          ModDetails{  md_insts     = insts,                       md_fam_insts = fam_insts,                       md_rules     = rules,@@ -322,9 +318,7 @@           mi_trust       = trust_info,           mi_trust_pkg   = pkg_trust_req,           mi_complete_matches = icomplete_matches,-          mi_doc_hdr     = doc_hdr,-          mi_decl_docs   = decl_docs,-          mi_arg_docs    = arg_docs,+          mi_docs        = docs,           mi_final_exts  = (),           mi_ext_fields  = emptyExtensibleFields,           mi_src_hash = ms_hs_hash mod_summary

@@ -1,5 +1,4 @@ {-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-}

@@ -28,9 +28,8 @@ -- the finger print on important fields in @DynFlags@ so that -- the recompilation checker can use this fingerprint. ----- NB: The 'Module' parameter is the 'Module' recorded by the--- *interface* file, not the actual 'Module' according to our--- 'DynFlags'.+-- NB: The 'Module' parameter is the 'Module' recorded by the *interface*+-- file, not the actual 'Module' according to our 'DynFlags'. fingerprintDynFlags :: HscEnv -> Module                     -> (BinHandle -> Name -> IO ())                     -> IO Fingerprint@@ -43,7 +42,7 @@         safeHs   = setSafeMode safeHaskell         -- oflags   = sort $ filter filterOFlags $ flags dflags -        -- *all* the extension flags and the language+        -- all the extension flags and the language         lang = (fmap fromEnum language,                 map fromEnum $ EnumSet.toList extensionFlags) 

@@ -6,21 +6,19 @@  {- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998--\section{Tidying up Core} -} -module GHC.Iface.Tidy (-       mkBootModDetailsTc, tidyProgram-   ) where+-- | Tidying up Core+module GHC.Iface.Tidy+  ( TidyOpts (..)+  , UnfoldingExposure (..)+  , tidyProgram+  , mkBootModDetailsTc+  )+where  import GHC.Prelude -import GHC.Driver.Session-import GHC.Driver.Backend-import GHC.Driver.Ppr-import GHC.Driver.Env- import GHC.Tc.Types import GHC.Tc.Utils.Env @@ -29,11 +27,7 @@ import GHC.Core.Unfold.Make import GHC.Core.FVs import GHC.Core.Tidy-import GHC.Core.Opt.Monad-import GHC.Core.Stats   (coreBindsStats, CoreStats(..)) import GHC.Core.Seq     (seqBinds)-import GHC.Core.Lint-import GHC.Core.Rules import GHC.Core.Opt.Arity   ( exprArity, exprBotStrictness_maybe ) import GHC.Core.InstEnv import GHC.Core.Type     ( tidyTopType )@@ -64,7 +58,6 @@ import GHC.Types.Name hiding (varName) import GHC.Types.Name.Set import GHC.Types.Name.Cache-import GHC.Types.Name.Ppr import GHC.Types.Avail import GHC.Types.Tickish import GHC.Types.TypeEnv@@ -80,7 +73,6 @@ import Data.Function import Data.List        ( sortBy, mapAccumL ) import qualified Data.Set as S-import GHC.Platform.Ways import GHC.Types.CostCentre  {-@@ -303,8 +295,7 @@     [Even non-exported things need system-wide Uniques because the     byte-code generator builds a single Name->BCO symbol table.] -    We use the NameCache kept in the HscEnv as the-    source of such system-wide uniques.+    We use the given NameCache as the source of such system-wide uniques.      For external Ids, use the original-name cache in the NameCache     to ensure that the unique assigned is the same as the Id had@@ -348,145 +339,125 @@   load a compulsory unfolding -} -tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)-tidyProgram hsc_env  (ModGuts { mg_module           = mod-                              , mg_exports          = exports-                              , mg_rdr_env          = rdr_env-                              , mg_tcs              = tcs-                              , mg_insts            = cls_insts-                              , mg_fam_insts        = fam_insts-                              , mg_binds            = binds-                              , mg_patsyns          = patsyns-                              , mg_rules            = imp_rules-                              , mg_anns             = anns-                              , mg_complete_matches = complete_matches-                              , mg_deps             = deps-                              , mg_foreign          = foreign_stubs-                              , mg_foreign_files    = foreign_files-                              , mg_hpc_info         = hpc_info-                              , mg_modBreaks        = modBreaks-                              , mg_boot_exports     = boot_exports-                              })--  = Err.withTiming logger-                   (text "CoreTidy"<+>brackets (ppr mod))-                   (const ()) $-    do  { let { omit_prags = gopt Opt_OmitInterfacePragmas dflags-              ; expose_all = gopt Opt_ExposeAllUnfoldings  dflags-              ; print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) rdr_env-              ; implicit_binds = concatMap getImplicitBinds tcs-              }--        ; (unfold_env, tidy_occ_env)-              <- chooseExternalIds hsc_env mod omit_prags expose_all-                                   binds implicit_binds imp_rules-        ; let { (trimmed_binds, trimmed_rules)-                    = findExternalRules omit_prags binds imp_rules unfold_env }+data UnfoldingExposure+  = ExposeNone -- ^ Don't expose unfoldings+  | ExposeSome -- ^ Only expose required unfoldings+  | ExposeAll  -- ^ Expose all unfoldings+  deriving (Show,Eq,Ord) -        ; let uf_opts = unfoldingOpts dflags-        ; (tidy_env, tidy_binds)-                 <- tidyTopBinds uf_opts unfold_env boot_exports tidy_occ_env trimmed_binds+data TidyOpts = TidyOpts+  { opt_name_cache        :: !NameCache+  , opt_collect_ccs       :: !Bool+  , opt_unfolding_opts    :: !UnfoldingOpts+  , opt_expose_unfoldings :: !UnfoldingExposure+      -- ^ Which unfoldings to expose+  , opt_trim_ids :: !Bool+      -- ^ trim off the arity, one-shot-ness, strictness etc which were+      -- retained for the benefit of the code generator+  , opt_expose_rules :: !Bool+      -- ^ Are rules exposed or not?+  , opt_static_ptr_opts :: !(Maybe StaticPtrOpts)+      -- ^ Options for generated static pointers, if enabled (/= Nothing).+  } -          -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.-        ; (spt_entries, tidy_binds') <--             sptCreateStaticBinds hsc_env mod tidy_binds-        ; let { platform = targetPlatform (hsc_dflags hsc_env)-              ; spt_init_code = sptModuleInitCode platform mod spt_entries-              ; add_spt_init_code =-                  case backend dflags of-                    -- If we are compiling for the interpreter we will insert-                    -- any necessary SPT entries dynamically-                    Interpreter -> id-                    -- otherwise add a C stub to do so-                    _              -> (`appendStubC` spt_init_code)+tidyProgram :: TidyOpts -> ModGuts -> IO (CgGuts, ModDetails)+tidyProgram opts (ModGuts { mg_module           = mod+                          , mg_exports          = exports+                          , mg_tcs              = tcs+                          , mg_insts            = cls_insts+                          , mg_fam_insts        = fam_insts+                          , mg_binds            = binds+                          , mg_patsyns          = patsyns+                          , mg_rules            = imp_rules+                          , mg_anns             = anns+                          , mg_complete_matches = complete_matches+                          , mg_deps             = deps+                          , mg_foreign          = foreign_stubs+                          , mg_foreign_files    = foreign_files+                          , mg_hpc_info         = hpc_info+                          , mg_modBreaks        = modBreaks+                          , mg_boot_exports     = boot_exports+                          }) = do -              -- The completed type environment is gotten from-              --      a) the types and classes defined here (plus implicit things)-              --      b) adding Ids with correct IdInfo, including unfoldings,-              --              gotten from the bindings-              -- From (b) we keep only those Ids with External names;-              --          the CoreTidy pass makes sure these are all and only-              --          the externally-accessible ones-              -- This truncates the type environment to include only the-              -- exported Ids and things needed from them, which saves space-              ---              -- See Note [Don't attempt to trim data types]-              ; final_ids  = [ trimId omit_prags id-                             | id <- bindersOfBinds tidy_binds-                             , isExternalName (idName id)-                             , not (isWiredIn id)-                             ]   -- See Note [Drop wired-in things]+  let implicit_binds = concatMap getImplicitBinds tcs -              ; final_tcs      = filterOut isWiredIn tcs-                                 -- See Note [Drop wired-in things]-              ; tidy_type_env  = typeEnvFromEntities final_ids final_tcs patsyns fam_insts-              ; tidy_cls_insts = mkFinalClsInsts tidy_type_env $ mkInstEnv cls_insts-              ; tidy_rules     = tidyRules tidy_env trimmed_rules+  (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod binds implicit_binds imp_rules+  let (trimmed_binds, trimmed_rules) = findExternalRules opts binds imp_rules unfold_env -              ; -- See Note [Injecting implicit bindings]-                all_tidy_binds = implicit_binds ++ tidy_binds'+  let uf_opts = opt_unfolding_opts opts+  (tidy_env, tidy_binds) <- tidyTopBinds uf_opts unfold_env boot_exports tidy_occ_env trimmed_binds -              -- Get the TyCons to generate code for.  Careful!  We must use-              -- the untidied TyCons here, because we need-              --  (a) implicit TyCons arising from types and classes defined-              --      in this module-              --  (b) wired-in TyCons, which are normally removed from the-              --      TypeEnv we put in the ModDetails-              --  (c) Constructors even if they are not exported (the-              --      tidied TypeEnv has trimmed these away)-              ; alg_tycons = filter isAlgTyCon tcs+  -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.+  (spt_entries, mcstub, tidy_binds') <- case opt_static_ptr_opts opts of+    Nothing    -> pure ([], Nothing, tidy_binds)+    Just sopts -> sptCreateStaticBinds sopts mod tidy_binds +  let all_foreign_stubs = case mcstub of+        Nothing    -> foreign_stubs+        Just cstub -> foreign_stubs `appendStubC` cstub -              ; local_ccs-                  | ways dflags `hasWay` WayProf-                        = collectCostCentres mod all_tidy_binds tidy_rules-                  | otherwise-                        = S.empty-              }+      -- The completed type environment is gotten from+      --      a) the types and classes defined here (plus implicit things)+      --      b) adding Ids with correct IdInfo, including unfoldings,+      --              gotten from the bindings+      -- From (b) we keep only those Ids with External names;+      --          the CoreTidy pass makes sure these are all and only+      --          the externally-accessible ones+      -- This truncates the type environment to include only the+      -- exported Ids and things needed from them, which saves space+      --+      -- See Note [Don't attempt to trim data types]+      final_ids  = [ trimId (opt_trim_ids opts) id+                   | id <- bindersOfBinds tidy_binds+                   , isExternalName (idName id)+                   , not (isWiredIn id)+                   ]   -- See Note [Drop wired-in things] -        ; endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules+      final_tcs      = filterOut isWiredIn tcs+                       -- See Note [Drop wired-in things]+      tidy_type_env  = typeEnvFromEntities final_ids final_tcs patsyns fam_insts+      tidy_cls_insts = mkFinalClsInsts tidy_type_env $ mkInstEnv cls_insts+      tidy_rules     = tidyRules tidy_env trimmed_rules -          -- If the endPass didn't print the rules, but ddump-rules is-          -- on, print now-        ; unless (logHasDumpFlag logger Opt_D_dump_simpl) $-            Logger.putDumpFileMaybe logger Opt_D_dump_rules-              (showSDoc dflags (ppr CoreTidy <+> text "rules"))-              FormatText-              (pprRulesForUser tidy_rules)+      -- See Note [Injecting implicit bindings]+      all_tidy_binds = implicit_binds ++ tidy_binds' -          -- Print one-line size info-        ; let cs = coreBindsStats tidy_binds-        ; Logger.putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats"-            FormatText-            (text "Tidy size (terms,types,coercions)"-             <+> ppr (moduleName mod) <> colon-             <+> int (cs_tm cs)-             <+> int (cs_ty cs)-             <+> int (cs_co cs) )+      -- Get the TyCons to generate code for.  Careful!  We must use+      -- the untidied TyCons here, because we need+      --  (a) implicit TyCons arising from types and classes defined+      --      in this module+      --  (b) wired-in TyCons, which are normally removed from the+      --      TypeEnv we put in the ModDetails+      --  (c) Constructors even if they are not exported (the+      --      tidied TypeEnv has trimmed these away)+      alg_tycons = filter isAlgTyCon tcs -        ; return (CgGuts { cg_module   = mod,-                           cg_tycons   = alg_tycons,-                           cg_binds    = all_tidy_binds,-                           cg_ccs      = S.toList local_ccs,-                           cg_foreign  = add_spt_init_code foreign_stubs,-                           cg_foreign_files = foreign_files,-                           cg_dep_pkgs = dep_direct_pkgs deps,-                           cg_hpc_info = hpc_info,-                           cg_modBreaks = modBreaks,-                           cg_spt_entries = spt_entries },+      local_ccs+        | opt_collect_ccs opts+              = collectCostCentres mod all_tidy_binds tidy_rules+        | otherwise+              = S.empty -                   ModDetails { md_types            = tidy_type_env,-                                md_rules            = tidy_rules,-                                md_insts            = tidy_cls_insts,-                                md_fam_insts        = fam_insts,-                                md_exports          = exports,-                                md_anns             = anns,      -- are already tidy-                                md_complete_matches = complete_matches-                              })-        }-  where-    dflags = hsc_dflags hsc_env-    logger = hsc_logger hsc_env+  return (CgGuts { cg_module        = mod+                 , cg_tycons        = alg_tycons+                 , cg_binds         = all_tidy_binds+                 , cg_ccs           = S.toList local_ccs+                 , cg_foreign       = all_foreign_stubs+                 , cg_foreign_files = foreign_files+                 , cg_dep_pkgs      = dep_direct_pkgs deps+                 , cg_hpc_info      = hpc_info+                 , cg_modBreaks     = modBreaks+                 , cg_spt_entries   = spt_entries+                 }+         , ModDetails { md_types            = tidy_type_env+                      , md_rules            = tidy_rules+                      , md_insts            = tidy_cls_insts+                      , md_fam_insts        = fam_insts+                      , md_exports          = exports+                      , md_anns             = anns      -- are already tidy+                      , md_complete_matches = complete_matches+                      }+         )   ------------------------------------------------------------------------------@@ -541,8 +512,8 @@ -- etc which tidyTopIdInfo retains for the benefit of the code generator -- but which we don't want in the interface file or ModIface for -- downstream compilations-trimId omit_prags id-  | omit_prags, not (isImplicitId id)+trimId do_trim id+  | do_trim, not (isImplicitId id)   = id `setIdInfo`      vanillaIdInfo        `setIdUnfolding` idUnfolding id        -- We respect the final unfolding chosen by tidyTopIdInfo.@@ -673,21 +644,20 @@   --   -- Bool => expose unfolding or not. -chooseExternalIds :: HscEnv+chooseExternalIds :: TidyOpts                   -> Module-                  -> Bool -> Bool                   -> [CoreBind]                   -> [CoreBind]                   -> [CoreRule]                   -> IO (UnfoldEnv, TidyOccEnv)                   -- Step 1 from the notes above -chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_rules+chooseExternalIds opts mod binds implicit_binds imp_id_rules   = do { (unfold_env1,occ_env1) <- search init_work_list emptyVarEnv init_occ_env        ; let internal_ids = filter (not . (`elemVarEnv` unfold_env1)) binders        ; tidy_internal internal_ids unfold_env1 occ_env1 }  where-  name_cache = hsc_NC hsc_env+  name_cache = opt_name_cache opts    -- init_ext_ids is the initial list of Ids that should be   -- externalised.  It serves as the starting point for finding a@@ -701,18 +671,14 @@   init_ext_ids   = sortBy (compare `on` getOccName) $ filter is_external binders    -- An Id should be external if either (a) it is exported,-  -- (b) it appears in the RHS of a local rule for an imported Id, or-  -- See Note [Which rules to expose]-  is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars+  -- (b) local rules are exposed and it appears in the RHS of a local rule for+  -- an imported Id, or See Note [Which rules to expose]+  is_external id+    | isExportedId id       = True+    | opt_expose_rules opts = id `elemVarSet` rule_rhs_vars+    | otherwise             = False -  rule_rhs_vars-    -- No rules are exposed when omit_prags is enabled see #19836-    -- imp_id_rules are the RULES in /this/ module for /imported/ Ids-    -- If omit_prags is True, these rules won't be put in the interface file.-    -- But if omit_prags is False, so imp_id_rules are in the interface file for-    -- this module, then the local-defined Ids they use must be made external.-    | omit_prags = emptyVarSet-    | otherwise = mapUnionVarSet ruleRhsFreeVars imp_id_rules+  rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules    binders          = map fst $ flattenBinds binds   implicit_binders = bindersOfBinds implicit_binds@@ -758,7 +724,7 @@     | otherwise = do       (occ_env', name') <- tidyTopName mod name_cache (Just referrer) occ_env idocc       let-          (new_ids, show_unfold) = addExternal omit_prags expose_all refined_id+          (new_ids, show_unfold) = addExternal opts refined_id                  -- 'idocc' is an *occurrence*, but we need to see the                 -- unfolding in the *definition*; so look up in binder_set@@ -780,9 +746,9 @@       let unfold_env' = extendVarEnv unfold_env id (name',False)       tidy_internal ids unfold_env' occ_env' -addExternal :: Bool -> Bool -> Id -> ([Id], Bool)-addExternal omit_prags expose_all id-  | omit_prags+addExternal :: TidyOpts -> Id -> ([Id], Bool)+addExternal opts id+  | ExposeNone <- opt_expose_unfoldings opts   , not (isCompulsoryUnfolding unfolding)   = ([], False)  -- See Note [Always expose compulsory unfoldings]                  -- in GHC.HsToCore@@ -804,8 +770,9 @@         -- In GHCi the unfolding is used by importers      show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance })-       =  expose_all         -- 'expose_all' says to expose all-                             -- unfoldings willy-nilly+       = opt_expose_unfoldings opts == ExposeAll+            -- 'ExposeAll' says to expose all+            -- unfoldings willy-nilly         || isStableSource src     -- Always expose things whose                                  -- source is an inline rule@@ -1000,13 +967,13 @@ This stuff is the only reason for the ru_auto field in a Rule. -} -findExternalRules :: Bool       -- Omit pragmas+findExternalRules :: TidyOpts                   -> [CoreBind]                   -> [CoreRule] -- Local rules for imported fns                   -> UnfoldEnv  -- Ids that are exported, so we need their rules                   -> ([CoreBind], [CoreRule]) -- See Note [Finding external rules]-findExternalRules omit_prags binds imp_id_rules unfold_env+findExternalRules opts binds imp_id_rules unfold_env   = (trimmed_binds, filter keep_rule all_rules)   where     imp_rules         = filter expose_rule imp_id_rules@@ -1031,7 +998,7 @@         --      been discarded; see Note [Trimming auto-rules]      expose_rule rule-        | omit_prags = False+        | not (opt_expose_rules opts) = False         | otherwise  = all is_external_id (ruleLhsFreeIdsList rule)                 -- Don't expose a rule whose LHS mentions a locally-defined                 -- Id that is completely internal (i.e. not visible to an

@@ -1,4 +1,4 @@-{-# LANGUAGE ViewPatterns  #-}+{-# LANGUAGE ViewPatterns #-}  -- | Code generation for the Static Pointer Table --@@ -48,9 +48,11 @@ --  module GHC.Iface.Tidy.StaticPtrTable-    ( sptCreateStaticBinds-    , sptModuleInitCode-    ) where+  ( sptCreateStaticBinds+  , sptModuleInitCode+  , StaticPtrOpts (..)+  )+where  {- Note [Grand plan for static forms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -126,37 +128,35 @@ import GHC.Prelude import GHC.Platform -import GHC.Driver.Session-import GHC.Driver.Env- import GHC.Core import GHC.Core.Utils (collectMakeStaticArgs) import GHC.Core.DataCon-import GHC.Core.Make (mkStringExprFSWith)+import GHC.Core.Make (mkStringExprFSWith,MkStringIds(..)) import GHC.Core.Type  import GHC.Cmm.CLabel  import GHC.Unit.Module import GHC.Utils.Outputable as Outputable-import GHC.Utils.Panic-import GHC.Builtin.Names-import GHC.Tc.Utils.Env (lookupGlobal)  import GHC.Linker.Types -import GHC.Types.Name import GHC.Types.Id-import GHC.Types.TyThing import GHC.Types.ForeignStubs+import GHC.Data.Maybe -import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State.Strict import Data.List (intercalate)-import Data.Maybe import GHC.Fingerprint-import qualified GHC.LanguageExtensions as LangExt +data StaticPtrOpts = StaticPtrOpts+  { opt_platform                :: !Platform    -- ^ Target platform+  , opt_gen_cstub               :: !Bool        -- ^ Generate CStub or not+  , opt_mk_string               :: !MkStringIds -- ^ Ids for `unpackCString[Utf8]#`+  , opt_static_ptr_info_datacon :: !DataCon          -- ^ `StaticPtrInfo` datacon+  , opt_static_ptr_datacon      :: !DataCon          -- ^ `StaticPtr` datacon+  }+ -- | Replaces all bindings of the form -- -- > b = /\ ... -> makeStatic location value@@ -170,16 +170,13 @@ -- -- It also yields the C stub that inserts these bindings into the static -- pointer table.-sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram-                     -> IO ([SptEntry], CoreProgram)-sptCreateStaticBinds hsc_env this_mod binds-    | not (xopt LangExt.StaticPointers dflags) =-      return ([], binds)-    | otherwise = do-      -- Make sure the required interface files are loaded.-      _ <- lookupGlobal hsc_env unpackCStringName+sptCreateStaticBinds :: StaticPtrOpts -> Module -> CoreProgram -> IO ([SptEntry], Maybe CStub, CoreProgram)+sptCreateStaticBinds opts this_mod binds = do       (fps, binds') <- evalStateT (go [] [] binds) 0-      return (fps, binds')+      let cstub+            | opt_gen_cstub opts = Just (sptModuleInitCode (opt_platform opts) this_mod fps)+            | otherwise          = Nothing+      return (fps, cstub, binds')   where     go fps bs xs = case xs of       []        -> return (reverse fps, reverse bs)@@ -187,8 +184,6 @@         (fps', bnd') <- replaceStaticBind bnd         go (reverse fps' ++ fps) (bnd' : bs) xs' -    dflags = hsc_dflags hsc_env-     -- Generates keys and replaces 'makeStatic' with 'StaticPtr'.     --     -- The 'Int' state is used to produce a different key for each binding.@@ -214,19 +209,16 @@     mkStaticBind t srcLoc e = do       i <- get       put (i + 1)-      staticPtrInfoDataCon <--        lift $ lookupDataConHscEnv staticPtrInfoDataConName+      let staticPtrInfoDataCon = opt_static_ptr_info_datacon opts       let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i-      info <- mkConApp staticPtrInfoDataCon <$>-            (++[srcLoc]) <$>-            mapM (mkStringExprFSWith (lift . lookupIdHscEnv))-                 [ unitFS $ moduleUnit this_mod-                 , moduleNameFS $ moduleName this_mod-                 ]+      let mk_string_fs = mkStringExprFSWith (opt_mk_string opts)+      let info = mkConApp staticPtrInfoDataCon+                  [ mk_string_fs $ unitFS $ moduleUnit this_mod+                  , mk_string_fs $ moduleNameFS $ moduleName this_mod+                  , srcLoc+                  ] -      -- The module interface of GHC.StaticPtr should be loaded at least-      -- when looking up 'fromStatic' during type-checking.-      staticPtrDataCon <- lift $ lookupDataConHscEnv staticPtrDataConName+      let staticPtrDataCon = opt_static_ptr_datacon opts       return (fp, mkConApp staticPtrDataCon                                [ Type t                                , mkWord64LitWord64 w0@@ -241,17 +233,6 @@         , show n         ] -    lookupIdHscEnv :: Name -> IO Id-    lookupIdHscEnv n = lookupType hsc_env n >>=-                         maybe (getError n) (return . tyThingId)--    lookupDataConHscEnv :: Name -> IO DataCon-    lookupDataConHscEnv n = lookupType hsc_env n >>=-                              maybe (getError n) (return . tyThingDataCon)--    getError n = pprPanic "sptCreateStaticBinds.get: not found" $-      text "Couldn't find" <+> ppr n- -- | @sptModuleInitCode module fps@ is a C stub to insert the static entries -- of @module@ into the static pointer table. --@@ -259,11 +240,12 @@ -- its fingerprint. sptModuleInitCode :: Platform -> Module -> [SptEntry] -> CStub sptModuleInitCode _        _        [] = mempty-sptModuleInitCode platform this_mod entries = CStub $ vcat-    [ text "static void hs_spt_init_" <> ppr this_mod-           <> text "(void) __attribute__((constructor));"-    , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"-    , braces $ vcat $+sptModuleInitCode platform this_mod entries =+    initializerCStub platform init_fn_nm empty init_fn_body `mappend`+    finalizerCStub platform fini_fn_nm empty fini_fn_body+  where+    init_fn_nm = mkInitializerStubLabel this_mod "spt"+    init_fn_body = vcat         [  text "static StgWord64 k" <> int i <> text "[2] = "            <> pprFingerprint fp <> semi         $$ text "extern StgPtr "@@ -277,17 +259,15 @@         <> semi         |  (i, SptEntry n fp) <- zip [0..] entries         ]-    , text "static void hs_spt_fini_" <> ppr this_mod-           <> text "(void) __attribute__((destructor));"-    , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"-    , braces $ vcat $++    fini_fn_nm = mkFinalizerStubLabel this_mod "spt"+    fini_fn_body = vcat         [  text "StgWord64 k" <> int i <> text "[2] = "            <> pprFingerprint fp <> semi         $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi         | (i, (SptEntry _ fp)) <- zip [0..] entries         ]-    ]-  where+     pprFingerprint :: Fingerprint -> SDoc     pprFingerprint (Fingerprint w1 w2) =       braces $ hcat $ punctuate comma

@@ -38,6 +38,7 @@ import GHC.Iface.Env  import GHC.StgToCmm.Types+import GHC.Runtime.Heap.Layout  import GHC.Tc.Errors.Types import GHC.Tc.TyCl.Build@@ -602,7 +603,7 @@        return $ SelfBoot { sb_mds = mds                          , sb_tcs = mkNameSet tcs }   where-    -- | Retuerns @True@ if, when you call 'tcIfaceDecl' on+    -- Retuerns @True@ if, when you call 'tcIfaceDecl' on     -- this 'IfaceDecl', an ATyCon would be returned.     -- NB: This code assumes that a TyCon cannot be implicit.     isIfaceTyCon IfaceId{}      = False

@@ -69,9 +69,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain-#if defined(CAN_LOAD_DLL)-import GHC.Utils.Constants (isWindowsHost, isDarwinHost)-#endif import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.TmpFs@@ -1295,23 +1292,6 @@                 -- letting go of them (plus of course depopulating                 -- the symbol table which is done in the main body) --- If this package is already part of the GHCi binary, we'll already--- have the right DLLs for this package loaded, so don't try to--- load them again.------ But on Win32 we must load them 'again'; doing so is a harmless no-op--- as far as the loader is concerned, but it does initialise the list--- of DLL handles that rts/Linker.c maintains, and that in turn is--- used by lookupSymbol.  So we must call addDLL for each library--- just to get the DLL handle into the list.-#if defined(CAN_LOAD_DLL)-partOfGHCi :: [PackageName]-partOfGHCi- | isWindowsHost || isDarwinHost = []- | otherwise = map (PackageName . mkFastString)-                   ["base", "template-haskell", "editline"]-#endif- showLS :: LibrarySpec -> String showLS (Objects nms)  = "(static) [" ++ intercalate ", " nms ++ "]" showLS (Archive nm)   = "(static archive) " ++ nm@@ -1429,16 +1409,14 @@         maybePutSDoc logger             (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ") -        -- See comments with partOfGHCi #if defined(CAN_LOAD_DLL)-        when (unitPackageName pkg `notElem` partOfGHCi) $ do-            loadFrameworks interp platform pkg-            -- See Note [Crash early load_dyn and locateLib]-            -- Crash early if can't load any of `known_dlls`-            mapM_ (load_dyn interp hsc_env True) known_dlls-            -- For remaining `dlls` crash early only when there is surely-            -- no package's DLL around ... (not is_dyn)-            mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls+        loadFrameworks interp platform pkg+        -- See Note [Crash early load_dyn and locateLib]+        -- Crash early if can't load any of `known_dlls`+        mapM_ (load_dyn interp hsc_env True) known_dlls+        -- For remaining `dlls` crash early only when there is surely+        -- no package's DLL around ... (not is_dyn)+        mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls #endif         -- After loading all the DLLs, we can load the static objects.         -- Ordering isn't important here, because we do one final link

@@ -569,6 +569,7 @@   LMStaticStr   s t -> ppr t <> text " c\"" <> ftext s <> text "\\00\""   LMStaticArray d t -> ppr t <> text " [" <> ppCommaJoin (map (ppStatic opts) d) <> char ']'   LMStaticStruc d t -> ppr t <> text "<{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}>"+  LMStaticStrucU d t -> ppr t <> text "{" <> ppCommaJoin (map (ppStatic opts) d) <> text "}"   LMStaticPointer v -> ppVar opts v   LMTrunc v t       -> ppr t <> text " trunc (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'   LMBitc v t        -> ppr t <> text " bitcast (" <> ppStatic opts v <> text " to " <> ppr t <> char ')'

@@ -140,6 +140,7 @@   | LMStaticStr LMString LlvmType       -- ^ Defines a static 'LMString'   | LMStaticArray [LlvmStatic] LlvmType -- ^ A static array   | LMStaticStruc [LlvmStatic] LlvmType -- ^ A static structure type+  | LMStaticStrucU [LlvmStatic] LlvmType -- ^ A static structure type   | LMStaticPointer LlvmVar             -- ^ A pointer to other data    -- static expressions, could split out but leave@@ -191,6 +192,7 @@ getStatType (LMStaticStr   _ t) = t getStatType (LMStaticArray _ t) = t getStatType (LMStaticStruc _ t) = t+getStatType (LMStaticStrucU _ t) = t getStatType (LMStaticPointer v) = getVarType v getStatType (LMTrunc       _ t) = t getStatType (LMBitc        _ t) = t

@@ -58,6 +58,9 @@    , module GHC.Unit.Module.ModIface    , module GHC.Types.Meta    , module GHC.Types.SourceError+   , module GHC.Parser.Errors.Types+   , module GHC.Types.Error+   , module GHC.Hs    , -- * Getting 'Name's      thNameToGhcName    )@@ -139,6 +142,11 @@ import GHC.Tc.Utils.Env ( lookupGlobal )  import GHC.Tc.Errors.Hole.FitTypes++-- For parse result plugins+import GHC.Parser.Errors.Types ( PsWarning, PsError )+import GHC.Types.Error         ( Messages )+import GHC.Hs                  ( HsParsedModule )  import qualified Language.Haskell.TH as TH 

@@ -0,0 +1,46 @@+module GHC.Rename.Doc ( rnHsDoc, rnLHsDoc, rnLDocDecl, rnDocDecl ) where++import GHC.Prelude++import GHC.Tc.Types+import GHC.Hs+import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Types.SrcLoc+import GHC.Tc.Utils.Monad (getGblEnv)+import GHC.Types.Avail+import GHC.Rename.Env++rnLHsDoc :: LHsDoc GhcPs -> RnM (LHsDoc GhcRn)+rnLHsDoc = traverse rnHsDoc++rnLDocDecl :: LDocDecl GhcPs -> RnM (LDocDecl GhcRn)+rnLDocDecl = traverse rnDocDecl++rnDocDecl :: DocDecl GhcPs -> RnM (DocDecl GhcRn)+rnDocDecl (DocCommentNext doc) = do+  doc' <- rnLHsDoc doc+  pure $ (DocCommentNext doc')+rnDocDecl (DocCommentPrev doc) = do+  doc' <- rnLHsDoc doc+  pure $ (DocCommentPrev doc')+rnDocDecl (DocCommentNamed n doc) = do+  doc' <- rnLHsDoc doc+  pure $ (DocCommentNamed n doc')+rnDocDecl (DocGroup i doc) = do+  doc' <- rnLHsDoc doc+  pure $ (DocGroup i doc')++rnHsDoc :: WithHsDocIdentifiers a GhcPs -> RnM (WithHsDocIdentifiers a GhcRn)+rnHsDoc (WithHsDocIdentifiers s ids) = do+  gre <- tcg_rdr_env <$> getGblEnv+  pure (WithHsDocIdentifiers s (rnHsDocIdentifiers gre ids))++rnHsDocIdentifiers :: GlobalRdrEnv+                  -> [Located RdrName]+                  -> [Located Name]+rnHsDocIdentifiers gre ns = concat+  [ map (L l . greNamePrintableName . gre_name) (lookupGRE_RdrName c gre)+  | L l rdr_name <- ns+  , c <- dataTcOccs rdr_name+  ]

@@ -1047,8 +1047,25 @@   = do { mb_name <- lookupOccRn_maybe rdr_name        ; case mb_name of              Just name -> return name-             Nothing   -> lookup_demoted rdr_name }+             Nothing   ->+               if occName rdr_name == occName eqTyCon_RDR -- See Note [eqTyCon (~) compatibility fallback]+               then eqTyConName <$ addDiagnostic TcRnTypeEqualityOutOfScope+               else lookup_demoted rdr_name } +{- Note [eqTyCon (~) compatibility fallback]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Before GHC Proposal #371, the (~) type operator used in type equality+constraints (a~b) was considered built-in syntax.++This had two implications:++1. Users could use it without importing it from Data.Type.Equality or Prelude.+2. TypeOperators were not required to use it (it was guarded behind TypeFamilies/GADTs instead)++To ease migration and minimize breakage, we continue to support those usages+but emit appropriate warnings.+-}+ lookup_demoted :: RdrName -> RnM Name lookup_demoted rdr_name   | Just demoted_rdr <- demoteRdrName rdr_name@@ -1566,7 +1583,7 @@         extra | imp_mod == moduleName name_mod = Outputable.empty               | otherwise = text ", but defined in" <+> ppr name_mod -lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe WarningTxt+lookupImpDeprec :: ModIface -> GlobalRdrElt -> Maybe (WarningTxt GhcRn) lookupImpDeprec iface gre   = mi_warn_fn (mi_final_exts iface) (greOccName gre) `mplus`  -- Bleat if the thing,     case gre_par gre of                      -- or its parent, is warn'd@@ -1919,13 +1936,7 @@   = [rdr_name]   where     occ = rdrNameOcc rdr_name-    rdr_name_tc =-      case rdr_name of-        -- The (~) type operator is always in scope, so we need a special case-        -- for it here, or else  :info (~)  fails in GHCi.-        -- See Note [eqTyCon (~) is built-in syntax]-        Unqual occ | occNameFS occ == fsLit "~" -> eqTyCon_RDR-        _ -> setRdrNameSpace rdr_name tcName+    rdr_name_tc = setRdrNameSpace rdr_name tcName  {- Note [dataTcOccs and Exact Names]

@@ -47,7 +47,7 @@                         , genHsVar, genLHsVar, genHsApp, genHsApps                         , genAppType ) import GHC.Rename.Unbound ( reportUnboundName )-import GHC.Rename.Splice  ( rnBracket, rnSpliceExpr, checkThLocalName )+import GHC.Rename.Splice  ( rnTypedBracket, rnUntypedBracket, rnSpliceExpr, checkThLocalName ) import GHC.Rename.HsType import GHC.Rename.Pat import GHC.Driver.Session@@ -337,7 +337,8 @@  ------------------------------------------ -- Template Haskell extensions-rnExpr e@(HsBracket _ br_body) = rnBracket e br_body+rnExpr e@(HsTypedBracket _ br_body)   = rnTypedBracket e br_body+rnExpr e@(HsUntypedBracket _ br_body) = rnUntypedBracket e br_body  rnExpr (HsSpliceE _ splice) = rnSpliceExpr splice @@ -541,7 +542,8 @@     let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr     return (HsStatic fvExpr' expr', fvExpr) -{- *********************************************************************+{-+************************************************************************ *                                                                      *         Arrow notation *                                                                      *@@ -556,7 +558,8 @@ rnExpr other = pprPanic "rnExpr: unexpected expression" (ppr other)         -- HsWrap -{- *********************************************************************+{-+************************************************************************ *                                                                      *         Operator sections *                                                                      *

@@ -1,6 +1,12 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ConstraintKinds #-} module GHC.Rename.Expr where++#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+import Data.Type.Equality (type (~))+#endif+ import GHC.Types.Name import GHC.Hs import GHC.Types.Name.Set ( FreeVars )

@@ -48,6 +48,7 @@ import GHC.Driver.Session import GHC.Hs import GHC.Rename.Env+import GHC.Rename.Doc import GHC.Rename.Utils  ( mapFvRn, bindLocalNamesFV                          , typeAppErr, newLocalBndrRn, checkDupRdrNamesN                          , checkShadowedRdrNames, warnForallIdentifier )@@ -629,7 +630,7 @@  rnHsTyKi env ty@(HsOpTy _ ty1 l_op ty2)   = setSrcSpan (getLocA l_op) $-    do  { (l_op', fvs1) <- rnHsTyOp env ty l_op+    do  { (l_op', fvs1) <- rnHsTyOp env (ppr ty) l_op         ; fix   <- lookupTyFixityRn l_op'         ; (ty1', fvs2) <- rnLHsTyKi env ty1         ; (ty2', fvs3) <- rnLHsTyKi env ty2@@ -733,7 +734,8 @@  rnHsTyKi env (HsDocTy x ty haddock_doc)   = do { (ty', fvs) <- rnLHsTyKi env ty-       ; return (HsDocTy x ty' haddock_doc, fvs) }+       ; haddock_doc' <- rnLHsDoc haddock_doc+       ; return (HsDocTy x ty' haddock_doc', fvs) }  -- See Note [Renaming HsCoreTys] rnHsTyKi env (XHsType ty)@@ -822,16 +824,15 @@        ; return (L loc tyvar) }  ---------------rnHsTyOp :: Outputable a-         => RnTyKiEnv -> a -> LocatedN RdrName+rnHsTyOp :: RnTyKiEnv -> SDoc -> LocatedN RdrName          -> RnM (LocatedN Name, FreeVars) rnHsTyOp env overall_ty (L loc op)-  = do { ops_ok <- xoptM LangExt.TypeOperators-       ; op' <- rnTyVar env op-       ; unless (ops_ok || op' `hasKey` eqTyConKey) $-           addErr $ TcRnUnknownMessage $ mkPlainError noHints (opTyErr op overall_ty)-       ; let l_op' = L loc op'-       ; return (l_op', unitFV op') }+  = do { op' <- rnTyVar env op+       ; unlessXOptM LangExt.TypeOperators $+           if (op' `hasKey` eqTyConKey) -- See [eqTyCon (~) compatibility fallback] in GHC.Rename.Env+           then addDiagnostic TcRnTypeEqualityRequiresOperators+           else addErr $ TcRnIllegalTypeOperator overall_ty op+       ; return (L loc op', unitFV op') }  -------------- checkWildCard :: RnTyKiEnv@@ -1272,7 +1273,8 @@   = do { mapM_ (\(L _ (FieldOcc _ rdr_name)) -> warnForallIdentifier rdr_name) names        ; let new_names = map (fmap (lookupField fl_env)) names        ; (new_ty, fvs) <- rnLHsTyKi env ty-       ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc)+       ; haddock_doc' <- traverse rnLHsDoc haddock_doc+       ; return (L l (ConDeclField noAnn new_names new_ty haddock_doc')                 , fvs) }  lookupField :: FastStringEnv FieldLabel -> FieldOcc GhcPs -> FieldOcc GhcRn@@ -1659,11 +1661,6 @@               vcat [ text "Unused quantified type variable" <+> quotes (ppr tv)                    , inHsDocContext doc ]       addDiagnosticAt (locA loc) msg--opTyErr :: Outputable a => RdrName -> a -> SDoc-opTyErr op overall_ty-  = hang (text "Illegal operator" <+> quotes (ppr op) <+> text "in type" <+> quotes (ppr overall_ty))-         2 (text "Use TypeOperators to allow operators in types")  {- ************************************************************************

@@ -13,7 +13,7 @@ -}  module GHC.Rename.Module (-        rnSrcDecls, addTcgDUs, findSplice+        rnSrcDecls, addTcgDUs, findSplice, rnWarningTxt     ) where  import GHC.Prelude@@ -27,6 +27,7 @@ import GHC.Types.Name.Reader import GHC.Rename.HsType import GHC.Rename.Bind+import GHC.Rename.Doc import GHC.Rename.Env import GHC.Rename.Utils ( mapFvRn, bindLocalNames                         , checkDupRdrNamesN, bindLocalNamesFV@@ -37,7 +38,7 @@ import GHC.Rename.Unbound ( mkUnboundName, notInScopeErr, WhereLooking(WL_Global) ) import GHC.Rename.Names import GHC.Tc.Errors.Types-import GHC.Tc.Errors.Ppr (withHsDocContext)+import GHC.Tc.Errors.Ppr (withHsDocContext, pprScopeError ) import GHC.Tc.Gen.Annotation ( annCtxt ) import GHC.Tc.Utils.Monad @@ -68,7 +69,6 @@ import GHC.Types.Unique.Set import GHC.Data.OrdList import qualified GHC.LanguageExtensions as LangExt-import GHC.Tc.Errors.Ppr (pprScopeError)  import Control.Monad import Control.Arrow ( first )@@ -206,6 +206,7 @@    (rn_default_decls, src_fvs5) <- rnList rnDefaultDecl   default_decls ;    (rn_deriv_decls,   src_fvs6) <- rnList rnSrcDerivDecl  deriv_decls ;    (rn_splice_decls,  src_fvs7) <- rnList rnSpliceDecl    splice_decls ;+   rn_docs <- traverse rnLDocDecl docs ;     last_tcg_env <- getGblEnv ;    -- (I) Compute the results and return@@ -221,7 +222,7 @@                              hs_annds  = rn_ann_decls,                              hs_defds  = rn_default_decls,                              hs_ruleds = rn_rule_decls,-                             hs_docs   = docs } ;+                             hs_docs   = rn_docs } ;          tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_foreign_decls ;         other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;@@ -265,7 +266,7 @@ -}  -- checks that the deprecations are defined locally, and that there are no duplicates-rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM Warnings+rnSrcWarnDecls :: NameSet -> [LWarnDecls GhcPs] -> RnM (Warnings GhcRn) rnSrcWarnDecls _ []   = return NoWarnings @@ -285,13 +286,23 @@        -- ensures that the names are defined locally      = do { names <- concatMapM (lookupLocalTcNames sig_ctxt what . unLoc)                                 rdr_names-          ; return [(rdrNameOcc rdr, txt) | (rdr, _) <- names] }+          ; txt' <- rnWarningTxt txt+          ; return [(rdrNameOcc rdr, txt') | (rdr, _) <- names] }     what = text "deprecation"     warn_rdr_dups = findDupRdrNames                    $ concatMap (\(L _ (Warning _ ns _)) -> ns) decls +rnWarningTxt :: WarningTxt GhcPs -> RnM (WarningTxt GhcRn)+rnWarningTxt (WarningTxt st wst) = do+  wst' <- traverse (traverse rnHsDoc) wst+  pure (WarningTxt st wst')+rnWarningTxt (DeprecatedTxt st wst) = do+  wst' <- traverse (traverse rnHsDoc) wst+  pure (DeprecatedTxt st wst')++ findDupRdrNames :: [LocatedN RdrName] -> [NonEmpty (LocatedN RdrName)] findDupRdrNames = findDupsEq (\ x -> \ y -> rdrNameOcc (unLoc x) == rdrNameOcc (unLoc y)) @@ -444,7 +455,7 @@         "https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/semigroup-monoid"    where-    -- | Warn about unsound/non-canonical 'Applicative'/'Monad' instance+    -- Warn about unsound/non-canonical 'Applicative'/'Monad' instance     -- declarations. Specifically, the following conditions are verified:     --     -- In 'Monad' instances declarations:@@ -490,7 +501,7 @@        | otherwise = return () -    -- | Check whether Monoid(mappend) is defined in terms of+    -- Check whether Monoid(mappend) is defined in terms of     -- Semigroup((<>)) (and not the other way round). Specifically,     -- the following conditions are verified:     --@@ -529,7 +540,7 @@        | otherwise = return () -    -- | test whether MatchGroup represents a trivial \"lhsName = rhsName\"+    -- test whether MatchGroup represents a trivial \"lhsName = rhsName\"     -- binding, and return @Just rhsName@ if this is the case     isAliasMG :: MatchGroup GhcRn (LHsExpr GhcRn) -> Maybe Name     isAliasMG MG {mg_alts = (L _ [L _ (Match { m_pats = []@@ -1879,11 +1890,12 @@                 -- and the methods are already in scope          ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs+        ; docs' <- traverse rnLDocDecl docs         ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',                               tcdTyVars = tyvars', tcdFixity = fixity,                               tcdFDs = fds', tcdSigs = sigs',                               tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',-                              tcdDocs = docs, tcdCExt = all_fvs },+                              tcdDocs = docs', tcdCExt = all_fvs },                   all_fvs ) }   where     cls_doc  = ClassDeclCtx lcls@@ -2329,10 +2341,11 @@              [ text "ex_tvs:" <+> ppr ex_tvs              , text "new_ex_dqtvs':" <+> ppr new_ex_tvs ]) +        ; mb_doc' <- traverse rnLHsDoc mb_doc         ; return (decl { con_ext = noAnn                        , con_name = new_name, con_ex_tvs = new_ex_tvs                        , con_mb_cxt = new_context, con_args = new_args-                       , con_doc = mb_doc+                       , con_doc = mb_doc'                        , con_forall = forall_ }, -- Remove when #18311 is fixed                   all_fvs) }} @@ -2373,10 +2386,11 @@          ; traceRn "rnConDecl (ConDeclGADT)"             (ppr names $$ ppr outer_bndrs')+        ; new_mb_doc <- traverse rnLHsDoc mb_doc         ; return (ConDeclGADT { con_g_ext = noAnn, con_names = new_names                               , con_bndrs = L l outer_bndrs', con_mb_cxt = new_cxt                               , con_g_args = new_args, con_res_ty = new_res_ty-                              , con_doc = mb_doc },+                              , con_doc = new_mb_doc },                   all_fvs) } }  rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)

@@ -2163,14 +2163,14 @@ missingImportListWarn mod   = text "The module" <+> quotes (ppr mod) <+> text "does not have an explicit import list" -moduleWarn :: ModuleName -> WarningTxt -> SDoc+moduleWarn :: ModuleName -> WarningTxt GhcRn -> SDoc moduleWarn mod (WarningTxt _ txt)   = sep [ text "Module" <+> quotes (ppr mod) <> colon,-          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]+          nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ] moduleWarn mod (DeprecatedTxt _ txt)   = sep [ text "Module" <+> quotes (ppr mod)                                 <+> text "is deprecated:",-          nest 2 (vcat (map (ppr . sl_fs . unLoc) txt)) ]+          nest 2 (vcat (map (ppr . hsDocString . unLoc) txt)) ]  packageImportErr :: TcRnMessage packageImportErr

@@ -6,7 +6,7 @@ module GHC.Rename.Splice (         rnTopSpliceDecls,         rnSpliceType, rnSpliceExpr, rnSplicePat, rnSpliceDecl,-        rnBracket,+        rnTypedBracket, rnUntypedBracket,         checkThLocalName         , traceSplice, SpliceInfo(..)   ) where@@ -73,27 +73,30 @@ ************************************************************************ -} -rnBracket :: HsExpr GhcPs -> HsBracket GhcPs -> RnM (HsExpr GhcRn, FreeVars)-rnBracket e br_body-  = addErrCtxt (quotationCtxtDoc br_body) $-    do { -- Check that -XTemplateHaskellQuotes is enabled and available-         thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes+-- Check that -XTemplateHaskellQuotes is enabled and available+checkForTemplateHaskellQuotes :: HsExpr GhcPs ->  RnM ()+checkForTemplateHaskellQuotes e =+    do { thQuotesEnabled <- xoptM LangExt.TemplateHaskellQuotes        ; unless thQuotesEnabled $            failWith ( TcRnUnknownMessage $ mkPlainError noHints $ vcat                       [ text "Syntax error on" <+> ppr e                       , text ("Perhaps you intended to use TemplateHaskell"                               ++ " or TemplateHaskellQuotes") ] )+       } +rnTypedBracket :: HsExpr GhcPs -> LHsExpr GhcPs -> RnM (HsExpr GhcRn, FreeVars)+rnTypedBracket e br_body+  = addErrCtxt (typedQuotationCtxtDoc br_body) $+    do { checkForTemplateHaskellQuotes e+          -- Check for nested brackets        ; cur_stage <- getStage        ; case cur_stage of-           { Splice Typed   -> checkTc (isTypedBracket br_body)-                                       illegalUntypedBracket-           ; Splice Untyped -> checkTc (not (isTypedBracket br_body))-                                       illegalTypedBracket+           { Splice Typed   -> return ()+           ; Splice Untyped -> failWithTc illegalTypedBracket            ; RunSplice _    ->                -- See Note [RunSplice ThLevel] in GHC.Tc.Types.-               pprPanic "rnBracket: Renaming bracket when running a splice"+               pprPanic "rnTypedBracket: Renaming typed bracket when running a splice"                         (ppr e)            ; Comp           -> return ()            ; Brack {}       -> failWithTc illegalBracket@@ -102,26 +105,48 @@          -- Brackets are desugared to code that mentions the TH package        ; recordThUse -       ; case isTypedBracket br_body of-            True  -> do { traceRn "Renaming typed TH bracket" empty-                        ; (body', fvs_e) <--                          setStage (Brack cur_stage RnPendingTyped) $-                                   rn_bracket cur_stage br_body-                        ; return (HsBracket noAnn body', fvs_e) }+       ; traceRn "Renaming typed TH bracket" empty+       ; (body', fvs_e) <- setStage (Brack cur_stage RnPendingTyped) $ rnLExpr br_body -            False -> do { traceRn "Renaming untyped TH bracket" empty-                        ; ps_var <- newMutVar []-                        ; (body', fvs_e) <--                          -- See Note [Rebindable syntax and Template Haskell]-                          unsetXOptM LangExt.RebindableSyntax $-                          setStage (Brack cur_stage (RnPendingUntyped ps_var)) $-                                   rn_bracket cur_stage br_body-                        ; pendings <- readMutVar ps_var-                        ; return (HsRnBracketOut noExtField body' pendings, fvs_e) }+       ; return (HsTypedBracket noExtField body', fvs_e)+        } -rn_bracket :: ThStage -> HsBracket GhcPs -> RnM (HsBracket GhcRn, FreeVars)-rn_bracket outer_stage br@(VarBr x flg rdr_name)+rnUntypedBracket :: HsExpr GhcPs -> HsQuote GhcPs -> RnM (HsExpr GhcRn, FreeVars)+rnUntypedBracket e br_body+  = addErrCtxt (untypedQuotationCtxtDoc br_body) $+    do { checkForTemplateHaskellQuotes e++         -- Check for nested brackets+       ; cur_stage <- getStage+       ; case cur_stage of+           { Splice Typed   -> failWithTc illegalUntypedBracket+           ; Splice Untyped -> return ()+           ; RunSplice _    ->+               -- See Note [RunSplice ThLevel] in GHC.Tc.Types.+               pprPanic "rnUntypedBracket: Renaming untyped bracket when running a splice"+                        (ppr e)+           ; Comp           -> return ()+           ; Brack {}       -> failWithTc illegalBracket+           }++         -- Brackets are desugared to code that mentions the TH package+       ; recordThUse++       ; traceRn "Renaming untyped TH bracket" empty+       ; ps_var <- newMutVar []+       ; (body', fvs_e) <-+         -- See Note [Rebindable syntax and Template Haskell]+         unsetXOptM LangExt.RebindableSyntax $+         setStage (Brack cur_stage (RnPendingUntyped ps_var)) $+                  rn_utbracket cur_stage br_body+       ; pendings <- readMutVar ps_var+       ; return (HsUntypedBracket pendings body', fvs_e)++       }++rn_utbracket :: ThStage -> HsQuote GhcPs -> RnM (HsQuote GhcRn, FreeVars)+rn_utbracket outer_stage br@(VarBr x flg rdr_name)   = do { name <- lookupOccRn (unLoc rdr_name)        ; check_namespace flg name        ; this_mod <- getModule@@ -137,7 +162,7 @@                              | isTopLevel top_lvl                              -> when (isExternalName name) (keepAlive name)                              | otherwise-                             -> do { traceRn "rn_bracket VarBr"+                             -> do { traceRn "rn_utbracket VarBr"                                       (ppr name <+> ppr bind_lvl                                                 <+> ppr outer_stage)                                    ; checkTc (thLevel outer_stage + 1 == bind_lvl)@@ -146,16 +171,16 @@                     }        ; return (VarBr x flg (noLocA name), unitFV name) } -rn_bracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e-                            ; return (ExpBr x e', fvs) }+rn_utbracket _ (ExpBr x e) = do { (e', fvs) <- rnLExpr e+                                ; return (ExpBr x e', fvs) } -rn_bracket _ (PatBr x p)+rn_utbracket _ (PatBr x p)   = rnPat ThPatQuote p $ \ p' -> return (PatBr x p', emptyFVs) -rn_bracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t-                              ; return (TypBr x t', fvs) }+rn_utbracket _ (TypBr x t) = do { (t', fvs) <- rnLHsType TypBrCtx t+                                ; return (TypBr x t', fvs) } -rn_bracket _ (DecBrL x decls)+rn_utbracket _ (DecBrL x decls)   = do { group <- groupDecls decls        ; gbl_env  <- getGblEnv        ; let new_gbl_env = gbl_env { tcg_dus = emptyDUs }@@ -165,7 +190,7 @@                               rnSrcDecls group                -- Discard the tcg_env; it contains only extra info about fixity-        ; traceRn "rn_bracket dec" (ppr (tcg_dus tcg_env) $$+        ; traceRn "rn_utbracket dec" (ppr (tcg_dus tcg_env) $$                    ppr (duUses (tcg_dus tcg_env)))         ; return (DecBrG x group', duUses (tcg_dus tcg_env)) }   where@@ -181,10 +206,8 @@                   }            }} -rn_bracket _ (DecBrG {}) = panic "rn_bracket: unexpected DecBrG"+rn_utbracket _ (DecBrG {}) = panic "rn_ut_bracket: unexpected DecBrG" -rn_bracket _ (TExpBr x e) = do { (e', fvs) <- rnLExpr e-                               ; return (TExpBr x e', fvs) }  -- | Ensure that we are not using a term-level name in a type-level namespace -- or vice-versa. Throws a 'TcRnIncorrectNameSpace' error if there is a problem.@@ -195,8 +218,13 @@   where     ns = nameNameSpace nm -quotationCtxtDoc :: HsBracket GhcPs -> SDoc-quotationCtxtDoc br_body+typedQuotationCtxtDoc :: LHsExpr GhcPs -> SDoc+typedQuotationCtxtDoc br_body+  = hang (text "In the Template Haskell typed quotation")+         2 (thTyBrackets . ppr $ br_body)++untypedQuotationCtxtDoc :: HsQuote GhcPs -> SDoc+untypedQuotationCtxtDoc br_body   = hang (text "In the Template Haskell quotation")          2 (ppr br_body) @@ -213,7 +241,7 @@ illegalUntypedBracket = TcRnUnknownMessage $ mkPlainError noHints $     text "Untyped brackets may only appear in untyped splices." -quotedNameStageErr :: HsBracket GhcPs -> TcRnMessage+quotedNameStageErr :: HsQuote GhcPs -> TcRnMessage quotedNameStageErr br   = TcRnUnknownMessage $ mkPlainError noHints $     sep [ text "Stage error: the non-top-level quoted name" <+> ppr br

@@ -108,6 +108,7 @@ import GHC.Types.Unique.DSet import GHC.Types.TyThing import GHC.Types.BreakInfo+import GHC.Types.Unique.Map  import GHC.Unit import GHC.Unit.Module.Graph@@ -121,7 +122,6 @@ import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List (find,intercalate)-import qualified Data.Map as Map import Control.Monad import Control.Monad.Catch as MC import Data.Array@@ -909,7 +909,7 @@  getDocs :: GhcMonad m         => Name-        -> m (Either GetDocsFailure (Maybe HsDocString, IntMap HsDocString))+        -> m (Either GetDocsFailure (Maybe [HsDoc GhcRn], IntMap (HsDoc GhcRn)))            -- TODO: What about docs for constructors etc.? getDocs name =   withSession $ \hsc_env -> do@@ -919,14 +919,14 @@          if isInteractiveModule mod            then pure (Left InteractiveName)            else do-             ModIface { mi_doc_hdr = mb_doc_hdr-                      , mi_decl_docs = DeclDocMap dmap-                      , mi_arg_docs = ArgDocMap amap-                      } <- liftIO $ hscGetModuleInterface hsc_env mod-             if isNothing mb_doc_hdr && Map.null dmap && Map.null amap-               then pure (Left (NoDocsInIface mod compiled))-               else pure (Right ( Map.lookup name dmap-                                , Map.findWithDefault mempty name amap))+             iface <- liftIO $ hscGetModuleInterface hsc_env mod+             case mi_docs iface of+               Nothing -> pure (Left (NoDocsInIface mod compiled))+               Just Docs { docs_decls = decls+                         , docs_args = args+                         } ->+                 pure (Right ( lookupUniqMap decls name+                             , fromMaybe mempty $ lookupUniqMap args name))   where     compiled =       -- TODO: Find a more direct indicator.@@ -935,16 +935,12 @@         UnhelpfulLoc {} -> True  -- | Failure modes for 'getDocs'.---- TODO: Find a way to differentiate between modules loaded without '-haddock'--- and modules that contain no docs. data GetDocsFailure      -- | 'nameModule_maybe' returned 'Nothing'.   = NameHasNoModule Name -    -- | This is probably because the module was loaded without @-haddock@,-    -- but it's also possible that the entire module contains no documentation.+    -- | The module was loaded without @-haddock@,   | NoDocsInIface       Module       Bool -- ^ 'True': The module was compiled.@@ -958,11 +954,6 @@     quotes (ppr name) <+> text "has no module where we could look for docs."   ppr (NoDocsInIface mod compiled) = vcat     [ text "Can't find any documentation for" <+> ppr mod <> char '.'-    , text "This is probably because the module was"-        <+> text (if compiled then "compiled" else "loaded")-        <+> text "without '-haddock',"-    , text "but it's also possible that the module contains no documentation."-    , text ""     , if compiled         then text "Try re-compiling with '-haddock'."         else text "Try running ':set -haddock' and :load the file again."

@@ -96,7 +96,7 @@ bcPrepExpr app@StgOpApp{} = pure app  bcPrepAlt :: StgAlt -> BcPrepM StgAlt-bcPrepAlt (ac, bndrs, expr) = (,,) ac bndrs <$> bcPrepExpr expr+bcPrepAlt (GenStgAlt con bndrs rhs) = GenStgAlt con bndrs <$> bcPrepExpr rhs  bcPrepBind :: StgBinding -> BcPrepM StgBinding -- explicitly match all constructors so we get a warning if we miss any@@ -126,8 +126,7 @@ -- Is this Id a not-necessarily-lifted join point? -- See Note [Not-necessarily-lifted join points], step 1 isNNLJoinPoint :: Id -> Bool-isNNLJoinPoint x = isJoinId x &&-                   Just True /= isLiftedType_maybe (idType x)+isNNLJoinPoint x = isJoinId x && mightBeUnliftedType (idType x)  -- Update an Id's type to take a Void# argument. -- Precondition: the Id is a not-necessarily-lifted join point.

@@ -374,7 +374,7 @@ -- Case alternatives -- Extend the CSE environment stgCseAlt :: CseEnv -> AltType -> OutId -> InStgAlt -> OutStgAlt-stgCseAlt env ty case_bndr (DataAlt dataCon, args, rhs)+stgCseAlt env ty case_bndr GenStgAlt{alt_con=DataAlt dataCon, alt_bndrs=args, alt_rhs=rhs}     = let (env1, args') = substBndrs env args           env2             -- To avoid dealing with unboxed sums StgCse runs after unarise and@@ -389,11 +389,11 @@             = env1             -- see Note [Case 2: CSEing case binders]           rhs' = stgCseExpr env2 rhs-      in (DataAlt dataCon, args', rhs')-stgCseAlt env _ _ (altCon, args, rhs)+      in GenStgAlt (DataAlt dataCon) args' rhs'+stgCseAlt env _ _ g@GenStgAlt{alt_con=_, alt_bndrs=args, alt_rhs=rhs}     = let (env1, args') = substBndrs env args           rhs' = stgCseExpr env1 rhs-      in (altCon, args', rhs')+      in g {alt_bndrs=args', alt_rhs=rhs'}  -- Bindings stgCseBind :: CseEnv -> InStgBinding -> (Maybe OutStgBinding, CseEnv)@@ -445,8 +445,8 @@    where     -- see Note [All alternatives are the binder]-    isBndr (_, _, StgApp f []) = f == bndr-    isBndr _                   = False+    isBndr GenStgAlt{alt_con=_,alt_bndrs=_,alt_rhs=StgApp f []} = f == bndr+    isBndr _                                                    = False   {- Note [Care with loop breakers]

@@ -124,7 +124,8 @@        return (StgTick tick e')  collectAlt :: StgAlt -> M StgAlt-collectAlt (ac, bs, e) = (ac, bs, ) <$> collectExpr e+collectAlt alt = do e' <- collectExpr $ alt_rhs alt+                    return $! alt { alt_rhs = e' }  -- | Try to find the best source position surrounding a 'StgExpr'. The -- heuristic strips ticks from the current expression until it finds one which

@@ -270,7 +270,8 @@     f (fvs,ids) (StgVarArg v) = varFVs env v (fvs, ids)  altFVs :: Env -> StgAlt -> (CgStgAlt, TopFVs, LocalFVs)-altFVs env (con,bndrs,e)+altFVs env GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=e}   | (e', top_fvs, lcl_fvs) <- exprFVs (addLocals bndrs env) e   , let lcl_fvs' = delDVarSetList lcl_fvs bndrs-  = ((con,bndrs, e'), top_fvs, lcl_fvs')+  , let newAlt   = GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=e'}+  = (newAlt, top_fvs, lcl_fvs')

@@ -82,6 +82,8 @@ It will never point to a thunk, nor will it be tagged `000` (meaning "might be a thunk"). NB: Note that the proper tag for some objects is indeed `000`. Currently this is the case for PAPs. +This works analogous to how `StrictWorkerId`s work. See also Note [Strict Worker Ids].+ Why do we care? Because if we have code like:  case strictPair of@@ -119,6 +121,8 @@ So we do our best to establish that `x` is already tagged (which it almost always is) to avoid this cost. In my benchmarks I haven't seen any cases where this causes regressions. +Note that there are similar constraints around Note [Strict Worker Ids].+ Note [How untagged pointers can end up in strict fields] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -182,6 +186,8 @@ it made the code simpler. But besides implementation complexity there isn't any reason why we couldn't be more rigourous in dealing with functions. +NB: It turned out because of #21193 option two wouldn't really have been an option anyway.+ Note [Tag inference debugging] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There is a flag -dtag-inference-checks which inserts various@@ -333,7 +339,7 @@  inferTagExpr in_env (StgCase scrut bndr ty alts)   -- Unboxed tuples get their info from the expression we scrutinise if any-  | [(DataAlt con, bndrs, rhs)] <- alts+  | [GenStgAlt{alt_con=DataAlt con, alt_bndrs=bndrs, alt_rhs=rhs}] <- alts   , isUnboxedTupleDataCon con   , Just infos <- scrut_infos bndrs   , let bndrs' = zipWithEqual "inferTagExpr" mk_bndr bndrs infos@@ -350,7 +356,9 @@     --   text "bndr:" <> ppr bndr $$     --   text "infos" <> ppr infos $$     --   text "out_bndrs" <> ppr bndrs') $-    (info, StgCase scrut' (noSig in_env bndr) ty [(DataAlt con, bndrs', rhs')])+    (info, StgCase scrut' (noSig in_env bndr) ty [GenStgAlt{ alt_con=DataAlt con+                                                           , alt_bndrs=bndrs'+                                                           , alt_rhs=rhs'}])    | null alts -- Empty case, but I might just be paranoid.   = -- pprTrace "inferCase2" empty $@@ -362,11 +370,14 @@         case_env = extendSigEnv in_env [bndr']          (infos, alts')-          = unzip [ (info, (con, bndrs', rhs'))-                  | (con, bndrs, rhs) <- alts+          = unzip [ (info, g {alt_bndrs=bndrs', alt_rhs=rhs'})+                  | g@GenStgAlt{ alt_con = con+                               , alt_bndrs = bndrs+                               , alt_rhs   = rhs+                               } <- alts                   , let (alt_env,bndrs') = addAltBndrInfo case_env con bndrs                         (info, rhs') = inferTagExpr alt_env rhs-                         ]+                  ]         alt_info = foldr combineAltInfo TagTagged infos     in ( alt_info, StgCase scrut' bndr' ty alts')   where

@@ -2,18 +2,18 @@ -- Copyright (c) 2019 Andreas Klebinger -- -{-# LANGUAGE CPP #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GADTs                      #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE RankNTypes                 #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TupleSections              #-}+{-# LANGUAGE TypeFamilies               #-}  module GHC.Stg.InferTags.Rewrite (rewriteTopBinds) where@@ -49,7 +49,6 @@ import Control.Monad import GHC.Types.Basic (CbvMark (NotMarkedCbv, MarkedCbv), isMarkedCbv, TopLevelFlag(..), isTopLevel) import GHC.Types.Var.Set- -- import GHC.Utils.Trace -- import GHC.Driver.Ppr @@ -371,10 +370,10 @@ rewriteCase _ = panic "Impossible: nodeCase"  rewriteAlt :: InferStgAlt -> RM TgStgAlt-rewriteAlt (altCon, bndrs, rhs) = do+rewriteAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs} =     withBinders NotTopLevel bndrs $ do         !rhs' <- rewriteExpr False rhs-        return $! (altCon, map fst bndrs, rhs')+        return $! alt {alt_bndrs = map fst bndrs, alt_rhs = rhs'}  rewriteLet :: InferStgExpr -> RM TgStgExpr rewriteLet (StgLet xt bind expr) = do@@ -421,7 +420,7 @@                 else f     return $! StgApp f' [] rewriteApp _ (StgApp f args)-    -- | pprTrace "rewriteAppOther" (ppr f <+> ppr args) False+    -- pprTrace "rewriteAppOther" (ppr f <+> ppr args) False     -- = undefined     | Just marks <- idCbvMarks_maybe f     , relevant_marks <- dropWhileEndLE (not . isMarkedCbv) marks@@ -450,9 +449,9 @@ mkSeq :: Id -> Id -> TgStgExpr -> TgStgExpr mkSeq id bndr !expr =     -- pprTrace "mkSeq" (ppr (id,bndr)) $-    let altTy = mkStgAltTypeFromStgAlts bndr [(DEFAULT, [], panic "Not used")]-    in-    StgCase (StgApp id []) bndr altTy [(DEFAULT, [], expr)]+    let altTy = mkStgAltTypeFromStgAlts bndr alt+        alt   = [GenStgAlt {alt_con = DEFAULT, alt_bndrs = [], alt_rhs = expr}]+    in StgCase (StgApp id []) bndr altTy alt  -- `mkSeqs args vs mkExpr` will force all vs, and construct -- an argument list args' where each v is replaced by it's evaluated

@@ -249,5 +249,7 @@         Just bind' -> pure (StgLetNoEscape noExtFieldSilent bind' body')  liftAlt :: LlStgAlt -> LiftM OutStgAlt-liftAlt (con, infos, rhs) = withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->-  (,,) con bndrs' <$> liftExpr rhs+liftAlt alt@GenStgAlt{alt_con=_, alt_bndrs=infos, alt_rhs=rhs} =+  withSubstBndrs (map binderInfoBndr infos) $ \bndrs' ->+    do !rhs' <- liftExpr rhs+       return $! alt {alt_bndrs = bndrs', alt_rhs = rhs'}

@@ -333,8 +333,8 @@     n :* cd = idDemandInfo bndr  tagSkeletonAlt :: CgStgAlt -> (Skeleton, IdSet, LlStgAlt)-tagSkeletonAlt (con, bndrs, rhs)-  = (alt_skel, arg_occs, (con, map BoringBinder bndrs, rhs'))+tagSkeletonAlt old@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs}+  = (alt_skel, arg_occs, old {alt_bndrs=fmap BoringBinder bndrs, alt_rhs=rhs'})   where     (alt_skel, alt_arg_occs, rhs') = tagSkeletonExpr rhs     arg_occs = alt_arg_occs `delVarSetList` bndrs

@@ -245,15 +245,20 @@  lintAlt     :: (OutputablePass a, BinderP a ~ Id)-    => (AltCon, [Id], GenStgExpr a) -> LintM ()+    => GenStgAlt a -> LintM () -lintAlt (DEFAULT, _, rhs) =-    lintStgExpr rhs+lintAlt GenStgAlt{ alt_con   = DEFAULT+                 , alt_bndrs = _+                 , alt_rhs   = rhs} = lintStgExpr rhs -lintAlt (LitAlt _, _, rhs) =-    lintStgExpr rhs+lintAlt GenStgAlt{ alt_con   = LitAlt _+                 , alt_bndrs = _+                 , alt_rhs   = rhs} = lintStgExpr rhs -lintAlt (DataAlt _, bndrs, rhs) = do+lintAlt GenStgAlt{ alt_con   = DataAlt _+                 , alt_bndrs = bndrs+                 , alt_rhs   = rhs} =+  do     mapM_ checkPostUnariseBndr bndrs     addInScopeVars bndrs (lintStgExpr rhs) 

@@ -164,5 +164,4 @@     stat_alts alts      `combineSE`     countOne StgCases   where-    stat_alts alts-        = combineSEs (map statExpr [ e | (_,_,e) <- alts ])+    stat_alts = combineSEs . fmap (statExpr . alt_rhs)

@@ -447,7 +447,9 @@          -> [OutStgArg] -- non-void args          -> InId -> AltType -> [InStgAlt] -> UniqSM OutStgExpr -elimCase rho args bndr (MultiValAlt _) [(_, bndrs, rhs)]+elimCase rho args bndr (MultiValAlt _) [GenStgAlt{ alt_con   = _+                                                 , alt_bndrs = bndrs+                                                 , alt_rhs   = rhs}]   = do let rho1 = extendRho rho bndr (MultiVal args)            rho2              | isUnboxedTupleBndr bndr@@ -479,47 +481,55 @@ --------------------------------------------------------------------------------  unariseAlts :: UnariseEnv -> AltType -> InId -> [StgAlt] -> UniqSM [StgAlt]-unariseAlts rho (MultiValAlt n) bndr [(DEFAULT, [], e)]+unariseAlts rho (MultiValAlt n) bndr [GenStgAlt{ alt_con   = DEFAULT+                                               , alt_bndrs = []+                                               , alt_rhs   = e}]   | isUnboxedTupleBndr bndr   = do (rho', ys) <- unariseConArgBinder rho bndr-       e' <- unariseExpr rho' e-       return [(DataAlt (tupleDataCon Unboxed n), ys, e')]+       !e' <- unariseExpr rho' e+       return [GenStgAlt (DataAlt (tupleDataCon Unboxed n)) ys e'] -unariseAlts rho (MultiValAlt n) bndr [(DataAlt _, ys, e)]+unariseAlts rho (MultiValAlt n) bndr [GenStgAlt{ alt_con   = DataAlt _+                                               , alt_bndrs = ys+                                               , alt_rhs   = e}]   | isUnboxedTupleBndr bndr   = do (rho', ys1) <- unariseConArgBinders rho ys        massert (ys1 `lengthIs` n)        let rho'' = extendRho rho' bndr (MultiVal (map StgVarArg ys1))-       e' <- unariseExpr rho'' e-       return [(DataAlt (tupleDataCon Unboxed n), ys1, e')]+       !e' <- unariseExpr rho'' e+       return [GenStgAlt (DataAlt (tupleDataCon Unboxed n)) ys1 e']  unariseAlts _ (MultiValAlt _) bndr alts   | isUnboxedTupleBndr bndr   = pprPanic "unariseExpr: strange multi val alts" (pprPanicAlts alts)  -- In this case we don't need to scrutinize the tag bit-unariseAlts rho (MultiValAlt _) bndr [(DEFAULT, _, rhs)]+unariseAlts rho (MultiValAlt _) bndr [GenStgAlt{ alt_con    = DEFAULT+                                               , alt_bndrs = []+                                               , alt_rhs   = rhs}]   | isUnboxedSumBndr bndr   = do (rho_sum_bndrs, sum_bndrs) <- unariseConArgBinder rho bndr        rhs' <- unariseExpr rho_sum_bndrs rhs-       return [(DataAlt (tupleDataCon Unboxed (length sum_bndrs)), sum_bndrs, rhs')]+       return [GenStgAlt (DataAlt (tupleDataCon Unboxed (length sum_bndrs))) sum_bndrs rhs']  unariseAlts rho (MultiValAlt _) bndr alts   | isUnboxedSumBndr bndr   = do (rho_sum_bndrs, scrt_bndrs@(tag_bndr : real_bndrs)) <- unariseConArgBinder rho bndr        alts' <- unariseSumAlts rho_sum_bndrs (map StgVarArg real_bndrs) alts        let inner_case = StgCase (StgApp tag_bndr []) tag_bndr tagAltTy alts'-       return [ (DataAlt (tupleDataCon Unboxed (length scrt_bndrs)),-                 scrt_bndrs,-                 inner_case) ]+       return [GenStgAlt{ alt_con   = DataAlt (tupleDataCon Unboxed (length scrt_bndrs))+                        , alt_bndrs = scrt_bndrs+                        , alt_rhs   = inner_case+                        }]  unariseAlts rho _ _ alts   = mapM (\alt -> unariseAlt rho alt) alts  unariseAlt :: UnariseEnv -> StgAlt -> UniqSM StgAlt-unariseAlt rho (con, xs, e)+unariseAlt rho alt@GenStgAlt{alt_con=_,alt_bndrs=xs,alt_rhs=e}   = do (rho', xs') <- unariseConArgBinders rho xs-       (con, xs',) <$> unariseExpr rho' e+       !e' <- unariseExpr rho' e+       return $! alt {alt_bndrs = xs', alt_rhs = e'}  -------------------------------------------------------------------------------- @@ -537,13 +547,16 @@               -> [StgArg] -- sum components _excluding_ the tag bit.               -> StgAlt   -- original alternative with sum LHS               -> UniqSM StgAlt-unariseSumAlt rho _ (DEFAULT, _, e)-  = ( DEFAULT, [], ) <$> unariseExpr rho e+unariseSumAlt rho _ GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=e}+  = GenStgAlt DEFAULT mempty <$> unariseExpr rho e -unariseSumAlt rho args (DataAlt sumCon, bs, e)-  = do let rho' = mapSumIdBinders bs args rho-       e' <- unariseExpr rho' e-       return ( LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon))), [], e' )+unariseSumAlt rho args GenStgAlt{ alt_con   = DataAlt sumCon+                                , alt_bndrs = bs+                                , alt_rhs   = e+                                }+  = do let rho'     = mapSumIdBinders bs args rho+           lit_case = LitAlt (LitNumber LitNumInt (fromIntegral (dataConTag sumCon)))+       GenStgAlt lit_case mempty <$> unariseExpr rho' e  unariseSumAlt _ scrt alt   = pprPanic "unariseSumAlt" (ppr scrt $$ pprPanicAlt alt)@@ -840,12 +853,12 @@ -- Since they are exhaustive, we can replace one with DEFAULT, to avoid -- generating a final test. Remember, the DEFAULT comes first if it exists. mkDefaultLitAlt [] = pprPanic "elimUbxSumExpr.mkDefaultAlt" (text "Empty alts")-mkDefaultLitAlt alts@((DEFAULT, _, _) : _) = alts-mkDefaultLitAlt ((LitAlt{}, [], rhs) : alts) = (DEFAULT, [], rhs) : alts+mkDefaultLitAlt alts@(GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=_} : _)   = alts+mkDefaultLitAlt (alt@GenStgAlt{alt_con=LitAlt{}, alt_bndrs=[]} : alts) = alt {alt_con = DEFAULT} : alts mkDefaultLitAlt alts = pprPanic "mkDefaultLitAlt" (text "Not a lit alt:" <+> pprPanicAlts alts) -pprPanicAlts :: (Outputable a, Outputable b, OutputablePass pass) => [(a,b,GenStgExpr pass)] -> SDoc+pprPanicAlts :: OutputablePass pass => [GenStgAlt pass] -> SDoc pprPanicAlts alts = ppr (map pprPanicAlt alts) -pprPanicAlt :: (Outputable a, Outputable b, OutputablePass pass) => (a,b,GenStgExpr pass) -> SDoc-pprPanicAlt (c,b,e) = ppr (c,b,pprStgExpr panicStgPprOpts e)+pprPanicAlt :: OutputablePass pass => GenStgAlt pass -> SDoc+pprPanicAlt GenStgAlt{alt_con=c,alt_bndrs=b,alt_rhs=e} = ppr (c,b,pprStgExpr panicStgPprOpts e)

@@ -42,10 +42,13 @@  -- | Extract the default case alternative -- findDefaultStg :: [Alt b] -> ([Alt b], Maybe (Expr b))-findDefaultStg :: [GenStgAlt p] -> ([(AltCon, [BinderP p], GenStgExpr p)],-                       Maybe (GenStgExpr p))-findDefaultStg ((DEFAULT, args, rhs) : alts) = assert( null args ) (alts, Just rhs)-findDefaultStg alts                        =                     (alts, Nothing)+findDefaultStg+  :: [GenStgAlt p]+  -> ([GenStgAlt p], Maybe (GenStgExpr p))+findDefaultStg (GenStgAlt{ alt_con    = DEFAULT+                         , alt_bndrs  = args+                         , alt_rhs    = rhs} : alts) = assert( null args ) (alts, Just rhs)+findDefaultStg alts                                  = (alts, Nothing)  mkStgAltTypeFromStgAlts :: forall p. Id -> [GenStgAlt p] -> AltType mkStgAltTypeFromStgAlts bndr alts@@ -80,7 +83,7 @@    -- grabbing the one from a constructor alternative    -- if one exists.    look_for_better_tycon-        | (((DataAlt con) ,_, _) : _) <- data_alts =+        | (DataAlt con : _) <- alt_con <$> data_alts =                 AlgAlt (dataConTyCon con)         | otherwise =                 assert(null data_alts)

@@ -884,11 +884,11 @@          -- given an alt, return a discr and code for it.         codeAlt :: CgStgAlt -> BcM (Discr, BCInstrList)-        codeAlt (DEFAULT, _, rhs)+        codeAlt GenStgAlt{alt_con=DEFAULT,alt_bndrs=_,alt_rhs=rhs}            = do rhs_code <- schemeE d_alts s p_alts rhs                 return (NoDiscr, rhs_code) -        codeAlt alt@(_, bndrs, rhs)+        codeAlt alt@GenStgAlt{alt_con=_, alt_bndrs=bndrs, alt_rhs=rhs}            -- primitive or nullary constructor alt: no need to UNPACK            | null real_bndrs = do                 rhs_code <- schemeE d_alts s p_alts rhs@@ -939,24 +939,25 @@            where              real_bndrs = filterOut isTyVar bndrs -        my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}-        my_discr (DataAlt dc, _, _)-           | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc-           = NoDiscr-           | otherwise-           = DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))-        my_discr (LitAlt l, _, _)-           = case l of LitNumber LitNumInt i  -> DiscrI (fromInteger i)-                       LitNumber LitNumWord w -> DiscrW (fromInteger w)-                       LitFloat r   -> DiscrF (fromRational r)-                       LitDouble r  -> DiscrD (fromRational r)-                       LitChar i    -> DiscrI (ord i)-                       _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l)+        my_discr alt = case alt_con alt of+            DEFAULT    -> NoDiscr {-shouldn't really happen-}+            DataAlt dc+              | isUnboxedTupleDataCon dc || isUnboxedSumDataCon dc+              -> NoDiscr+              | otherwise+              -> DiscrP (fromIntegral (dataConTag dc - fIRST_TAG))+            LitAlt l -> case l of+              LitNumber LitNumInt i  -> DiscrI (fromInteger i)+              LitNumber LitNumWord w -> DiscrW (fromInteger w)+              LitFloat r             -> DiscrF (fromRational r)+              LitDouble r            -> DiscrD (fromRational r)+              LitChar i              -> DiscrI (ord i)+              _ -> pprPanic "schemeE(StgCase).my_discr" (ppr l)          maybe_ncons            | not isAlgCase = Nothing            | otherwise-           = case [dc | (DataAlt dc, _, _) <- alts] of+           = case [dc | DataAlt dc <- alt_con <$> alts] of                 []     -> Nothing                 (dc:_) -> Just (tyConFamilySize (dataConTyCon dc)) 

@@ -15,8 +15,6 @@  import GHC.Prelude as Prelude -import GHC.Driver.Backend- import GHC.StgToCmm.Prof (initCostCentres, ldvEnter) import GHC.StgToCmm.Monad import GHC.StgToCmm.Env@@ -183,12 +181,11 @@         -- emit either a CmmString literal or dump the string in a file and emit a         -- CmmFileEmbed literal.         -- See Note [Embedding large binary blobs] in GHC.CmmToAsm.Ppr-        let bin_blob_threshold = stgToCmmBinBlobThresh cfg-            isNCG    = platformDefaultBackend (stgToCmmPlatform cfg) == NCG-            isSmall  = fromIntegral (BS.length str) <= bin_blob_threshold-            asString = bin_blob_threshold == 0 || isSmall+        let asString = case stgToCmmBinBlobThresh cfg of+              Just bin_blob_threshold -> fromIntegral (BS.length str) <= bin_blob_threshold+              Nothing                -> True -            (lit,decl) = if not isNCG || asString+            (lit,decl) = if asString               then mkByteStringCLit label str               else mkFileEmbedLit label $ unsafePerformIO $ do                      bFile <- newTempName logger tmpfs (stgToCmmTmpDir cfg) TFL_CurrentModule ".dat"

@@ -212,7 +212,7 @@                )  cgRhs id (StgRhsCon cc con mn _ts args)-  = withNewTickyCounterCon (idName id) con $+  = withNewTickyCounterCon id con mn $     buildDynCon id mn True cc con (assertNonVoidStgArgs args)       -- con args are always non-void,       -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise@@ -223,14 +223,16 @@     checkFunctionArgTags (text "TagCheck Failed: Rhs of" <> ppr id) id args     profile <- getProfile     check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig-    mkRhsClosure profile check_tags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body-+    use_std_ap_thunk <- stgToCmmTickyAP <$> getStgToCmmConfig+    mkRhsClosure profile use_std_ap_thunk check_tags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body  ------------------------------------------------------------------------ --              Non-constructor right hand sides ------------------------------------------------------------------------ -mkRhsClosure :: Profile -> Bool+mkRhsClosure :: Profile+             -> Bool                            -- Omit AP Thunks to improve profiling+             -> Bool                            -- Lint tag inference checks              -> Id -> CostCentreStack              -> [NonVoid Id]                    -- Free vars              -> UpdateFlag@@ -274,7 +276,7 @@ -}  ---------- See Note [Selectors] -------------------mkRhsClosure    profile _check_tags bndr _cc+mkRhsClosure    profile _ _check_tags bndr _cc                 [NonVoid the_fv]                -- Just one free var                 upd_flag                -- Updatable thunk                 []                      -- A thunk@@ -283,7 +285,9 @@   , StgCase (StgApp scrutinee [{-no args-}])          _   -- ignore bndr          (AlgAlt _)-         [(DataAlt _, params, sel_expr)] <- strip expr+         [GenStgAlt{ alt_con   = DataAlt _+                   , alt_bndrs = params+                   , alt_rhs   = sel_expr}] <- strip expr   , StgApp selectee [{-no args-}] <- strip sel_expr   , the_fv == scrutinee                -- Scrutinee is the only free variable @@ -307,7 +311,7 @@     in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]  ---------- See Note [Ap thunks] -------------------mkRhsClosure    profile check_tags bndr _cc+mkRhsClosure    profile use_std_ap check_tags bndr _cc                 fvs                 upd_flag                 []                      -- No args; a thunk@@ -316,7 +320,8 @@   -- We are looking for an "ApThunk"; see data con ApThunk in GHC.StgToCmm.Closure   -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)   -- So the xi will all be free variables-  | args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and+  | use_std_ap+  , args `lengthIs` (n_fvs-1)  -- This happens only if the fun_id and                                -- args are all distinct local variables                                -- The "-1" is for fun_id     -- Missed opportunity:   (f x x) is not detected@@ -340,7 +345,7 @@     payload = StgVarArg fun_id : args  ---------- Default case -------------------mkRhsClosure profile _check_tags bndr cc fvs upd_flag args body+mkRhsClosure profile _use_ap _check_tags bndr cc fvs upd_flag args body   = do  { let lf_info = mkClosureLFInfo (profilePlatform profile) bndr NotTopLevel fvs upd_flag args         ; (id_info, reg) <- rhsIdInfo bndr lf_info         ; return (id_info, gen_code lf_info reg) }@@ -404,13 +409,13 @@        }  where  gen_code reg  -- AHA!  A STANDARD-FORM THUNK-  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $+  = withNewTickyCounterStdThunk (lfUpdatable lf_info) (bndr) payload $     do   {     -- LAY OUT THE OBJECT     mod_name <- getModuleName-  ; cfg      <- getStgToCmmConfig-  ; let profile  = stgToCmmProfile  cfg-  ; let platform = stgToCmmPlatform cfg+  ; profile  <- getProfile+  ; platform <- getPlatform+  ; let         header = if isLFThunk lf_info then ThunkHeader else StdHeader         (tot_wds, ptr_wds, payload_w_offsets)             = mkVirtHeapOffsets profile header@@ -476,7 +481,8 @@   = withNewTickyCounterThunk         (isStaticClosure cl_info)         (closureUpdReqd cl_info)-        (closureName cl_info) $+        (closureName cl_info)+        (map fst fv_details) $     emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $       \(_, node, _) -> thunkCode cl_info fv_details cc node body    where@@ -488,7 +494,7 @@         arity = length args     in     -- See Note [OneShotInfo overview] in GHC.Types.Basic.-    withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info)+    withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info) (map fst fv_details)         nv_args $ do {          ; let

@@ -65,6 +65,7 @@         cafBlackHoleInfoTable,         indStaticInfoTable,         staticClosureNeedsLink,+        mkClosureInfoTableLabel     ) where  import GHC.Prelude@@ -642,7 +643,7 @@  data ClosureInfo   = ClosureInfo {-        closureName :: !Name,           -- The thing bound to this closure+        closureName :: !Id,           -- The thing bound to this closure            -- we don't really need this field: it's only used in generating            -- code for ticky and profiling, and we could pass the information            -- around separately, but it doesn't do much harm to keep it here.@@ -679,13 +680,12 @@               -> String         -- String descriptor               -> ClosureInfo mkClosureInfo profile is_static id lf_info tot_wds ptr_wds val_descr-  = ClosureInfo { closureName      = name+  = ClosureInfo { closureName      = id                 , closureLFInfo    = lf_info                 , closureInfoLabel = info_lbl   -- These three fields are                 , closureSMRep     = sm_rep     -- (almost) an info table                 , closureProf      = prof }     -- (we don't have an SRT yet)   where-    name       = idName id     sm_rep     = mkHeapRep profile is_static ptr_wds nonptr_wds (lfClosureType lf_info)     prof       = mkProfilingInfo profile id val_descr     nonptr_wds = tot_wds - ptr_wds@@ -839,6 +839,7 @@   | platformTablesNextToCode platform = toInfoLbl  platform . closureInfoLabel   | otherwise                         = toEntryLbl platform . closureInfoLabel +-- | Get the info table label for a *thunk*. mkClosureInfoTableLabel :: Platform -> Id -> LambdaFormInfo -> CLabel mkClosureInfoTableLabel platform id lf_info   = case lf_info of

@@ -212,7 +212,8 @@           ; let ticky_name | actually_bound = Just binder                            | otherwise = Nothing -          ; checkConArgsDyn (text "TagCheck failed - con_alloc:" <> ppr binder) con (map fromNonVoid args)+          ; checkConArgsDyn (hang (text "TagCheck failed on constructor application.") 4 $+                                   text "On binder:" <> ppr binder $$ text "Constructor:" <> ppr con) con (map fromNonVoid args)           ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info                                           use_cc blame_cc args_w_offsets           ; return (mkRhsInit platform reg lf_info hp_plus_n) }

@@ -17,7 +17,7 @@          bindArgsToRegs, bindToReg, rebindToReg,         bindArgToReg, idToReg,-        getCgIdInfo,+        getCgIdInfo, getCgInfo_maybe,         maybeLetNoEscape,         ) where @@ -44,6 +44,9 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain +import GHC.Builtin.Names (getUnique)++ ------------------------------------- --        Manipulating CgIdInfo -------------------------------------@@ -149,6 +152,12 @@           else               cgLookupPanic id -- Bug         }}}++-- | Retrieve cg info for a name if it already exists.+getCgInfo_maybe :: Name -> FCode (Maybe CgIdInfo)+getCgInfo_maybe name+  = do  { local_binds <- getBinds -- Try local bindings first+        ; return $ lookupVarEnv_Directly local_binds (getUnique name) }  cgLookupPanic :: Id -> FCode a cgLookupPanic id

@@ -216,7 +216,7 @@   = do platform <- getPlatform        return ( lneIdInfo platform bndr args, code )   where-   code = forkLneBody $ withNewTickyCounterLNE (idName bndr) args $ do+   code = forkLneBody $ withNewTickyCounterLNE bndr args $ do             { restoreCurrentCostCentre cc_slot             ; arg_regs <- bindArgsToRegs args             ; void $ noEscapeHeapCheck arg_regs (tickyEnterLNE >> cgExpr body) }@@ -459,7 +459,7 @@  cgCase (StgApp v []) _ (PrimAlt _) alts   | isVoidRep (idPrimRep v)  -- See Note [Scrutinising VoidRep]-  , [(DEFAULT, _, rhs)] <- alts+  , [GenStgAlt{alt_con=DEFAULT, alt_bndrs=_, alt_rhs=rhs}] <- alts   = cgExpr rhs  {- Note [Dodgy unsafeCoerce 1]@@ -652,9 +652,10 @@ chooseReturnBndrs bndr (PrimAlt _) _alts   = assertNonVoidIds [bndr] -chooseReturnBndrs _bndr (MultiValAlt n) [(_, ids, _)]+chooseReturnBndrs _bndr (MultiValAlt n) [alt]   = assertPpr (ids `lengthIs` n) (ppr n $$ ppr ids $$ ppr _bndr) $     assertNonVoidIds ids     -- 'bndr' is not assigned!+    where ids = alt_bndrs alt  chooseReturnBndrs bndr (AlgAlt _) _alts   = assertNonVoidIds [bndr]  -- Only 'bndr' is assigned@@ -669,11 +670,11 @@ cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]        -> FCode ReturnKind -- At this point the result of the case are in the binders-cgAlts gc_plan _bndr PolyAlt [(_, _, rhs)]-  = maybeAltHeapCheck gc_plan (cgExpr rhs)+cgAlts gc_plan _bndr PolyAlt [alt]+  = maybeAltHeapCheck gc_plan (cgExpr $ alt_rhs alt) -cgAlts gc_plan _bndr (MultiValAlt _) [(_, _, rhs)]-  = maybeAltHeapCheck gc_plan (cgExpr rhs)+cgAlts gc_plan _bndr (MultiValAlt _) [alt]+  = maybeAltHeapCheck gc_plan (cgExpr $ alt_rhs alt)         -- Here bndrs are *already* in scope, so don't rebind them  cgAlts gc_plan bndr (PrimAlt _) alts@@ -942,7 +943,7 @@   let     base_reg = idToReg platform bndr     cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)-    cg_alt (con, bndrs, rhs)+    cg_alt GenStgAlt{alt_con=con, alt_bndrs=bndrs, alt_rhs=rhs}       = getCodeScoped             $         maybeAltHeapCheck gc_plan $         do { _ <- bindConArgs con base_reg (assertNonVoidIds bndrs)

@@ -1,7 +0,0 @@-module GHC.StgToCmm.Expr where--import GHC.Cmm.Expr-import GHC.StgToCmm.Monad-import GHC.Types.Literal--cgLit :: Literal -> FCode CmmExpr

@@ -1661,7 +1661,7 @@     CmmMachOp (mop rep (wordWidth platform)) [CmmMachOp (mop (wordWidth platform) rep) [arg]]     where [arg] = args -  -- | These primops are implemented by CallishMachOps, because they sometimes+  -- These primops are implemented by CallishMachOps, because they sometimes   -- turn into foreign calls depending on the backend.   opCallish :: [CmmExpr] -> CallishMachOp -> PrimopCmmEmit   opCallish args prim = opIntoRegs $ \[res] -> emitPrimCall [res] prim args@@ -1683,7 +1683,7 @@       PW4 -> opCallish args callish       PW8 -> opTranslate args $ mkMop W64 -  -- | Basically a "manual" case, rather than one of the common repetitive forms+  -- Basically a "manual" case, rather than one of the common repetitive forms   -- above. The results are a parameter to the returned function so we know the   -- choice of variant never depends on them.   opCallishHandledLater

@@ -35,12 +35,14 @@ import GHC.Utils.Panic.Plain (panic) import GHC.Stg.Syntax import GHC.StgToCmm.Closure+import GHC.Cmm.Switch (mkSwitchTargets)+import GHC.Cmm.Info (cmmGetClosureType) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Types.Basic import GHC.Data.FastString (mkFastString)-import GHC.Cmm.Info (cmmGetClosureType)-import GHC.Cmm.Utils (mkWordCLit) +import qualified Data.Map as M+ -- | Check all arguments marked as already tagged for a function -- are tagged by inserting runtime checks. checkFunctionArgTags :: SDoc -> Id -> [Id] -> FCode ()@@ -91,21 +93,43 @@   -- If there is no tag check if we are dealing with a PAP   ; emitLabel lno_tag   ; emitComment (mkFastString "closereTypeCheck")-  ; align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig-  ; profile <- getProfile-  ; let closure_ty = cmmGetClosureType profile align_check fun-  ; ty_reg <- newTemp (bWord platform)-  ; emitAssign (CmmLocal ty_reg) closure_ty-  ; emit $ mkCbranch (cmmEqWord platform-                        (CmmReg $ CmmLocal ty_reg)-                        (CmmLit $ mkWordCLit platform PAP))-                      lret lbarf (Just True)+  ; needsArgTag fun lbarf lret    ; emitLabel lbarf   ; emitBarf ("Tag inference failed on:" ++ onWhat)   ; emitLabel lret   } +-- | Jump to the first block if the argument closure is subject+--   to tagging requirements. Otherwise jump to the 2nd one.+needsArgTag :: CmmExpr -> BlockId -> BlockId -> FCode ()+needsArgTag closure fail lpass = do+  profile <- getProfile+  align_check <- stgToCmmAlignCheck <$> getStgToCmmConfig+  let clo_ty_e = cmmGetClosureType profile align_check closure+  -- The ENTER macro doesn't evaluate FUN/PAP/BCO objects. So we+  -- have to accept them not being tagged. See #21193+  -- See Note [TagInfo of functions]+  let targets = mkSwitchTargets+        False+        (INVALID_OBJECT, N_CLOSURE_TYPES)+        (Just fail)+        (M.fromList [(PAP,lpass)+                    ,(BCO,lpass)+                    ,(FUN,lpass)+                    ,(FUN_1_0,lpass)+                    ,(FUN_0_1,lpass)+                    ,(FUN_2_0,lpass)+                    ,(FUN_1_1,lpass)+                    ,(FUN_0_2,lpass)+                    ,(FUN_STATIC,lpass)+                    ])++  emit $ mkSwitch clo_ty_e targets++  emit $ mkBranch lpass++ emitArgTagCheck :: SDoc -> [CbvMark] -> [Id] -> FCode () emitArgTagCheck info marks args = whenCheckTags $ do   mod <- getModuleName@@ -138,7 +162,7 @@       if taggedCgInfo info           then return ()           else case (cg_loc info) of-            CmmLoc loc -> emitTagAssertion (showPprUnsafe msg) loc+            CmmLoc loc -> emitTagAssertion (showPprUnsafe $ msg <+> text "arg:" <> ppr arg) loc             LneLoc {} -> panic "LNE-arg"  -- Check that argument is properly tagged.

@@ -115,8 +115,6 @@  import GHC.Prelude -import GHC.Driver.Session- import GHC.Platform import GHC.Platform.Profile @@ -135,6 +133,7 @@ import GHC.Cmm.CLabel import GHC.Runtime.Heap.Layout + import GHC.Types.Name import GHC.Types.Id import GHC.Types.Basic@@ -154,6 +153,11 @@ import Data.Maybe import qualified Data.Char import Control.Monad ( when, unless )+import GHC.Types.Id.Info+import GHC.Utils.Trace+import GHC.StgToCmm.Env (getCgInfo_maybe)+import Data.Coerce (coerce)+import GHC.Utils.Json  ----------------------------------------------------------------------------- --@@ -161,23 +165,73 @@ -- ----------------------------------------------------------------------------- +-- | Number of arguments for a ticky counter.+--+-- Ticky currently treats args to constructor allocations differently than those for functions/LNE bindings.+tickyArgArity :: TickyClosureType -> Int+tickyArgArity (TickyFun _ _fvs args) = length args+tickyArgArity (TickyLNE args) = length args+tickyArgArity (TickyCon{}) = 0+tickyArgArity (TickyThunk{}) = 0++tickyArgDesc :: TickyClosureType -> String+tickyArgDesc arg_info =+  case arg_info of+    TickyFun _ _fvs args -> map (showTypeCategory . idType . fromNonVoid) args+    TickyLNE args -> map (showTypeCategory . idType . fromNonVoid) args+    TickyThunk{} -> ""+    TickyCon{} -> ""++tickyFvDesc :: TickyClosureType -> String+tickyFvDesc arg_info =+  case arg_info of+    TickyFun _ fvs _args -> map (showTypeCategory . idType . fromNonVoid) fvs+    TickyLNE{} -> ""+    TickyThunk _ _ fvs -> map (showTypeCategory . stgArgType) fvs+    TickyCon{} -> ""++instance ToJson TickyClosureType where+    json info = case info of+      (TickyFun {})   -> mkInfo (tickyFvDesc info) (tickyArgDesc info) "fun"+      (TickyLNE {})   -> mkInfo []                 (tickyArgDesc info) "lne"+      (TickyThunk uf _ _) -> mkInfo (tickyFvDesc info) []              ("thk" ++ if uf then "_u" else "")+      (TickyCon{})    -> mkInfo []                 []                  "con"+      where+        mkInfo :: String -> String -> String -> JsonDoc+        mkInfo fvs args ty =+          JSObject+              [("type", json "entCntr")+              ,("subTy", json ty)+              ,("fvs_c", json (length fvs))+              ,("fvs" , json fvs)+              ,("args", json args)+              ]++tickyEntryDesc :: (SDocContext -> TickyClosureType -> String)+tickyEntryDesc ctxt = renderWithContext ctxt . renderJSON . json+ data TickyClosureType     = TickyFun         Bool -- True <-> single entry+        [NonVoid Id] -- ^ FVs+        [NonVoid Id] -- ^ Args     | TickyCon         DataCon -- the allocated constructor+        ConstructorNumber     | TickyThunk         Bool -- True <-> updateable         Bool -- True <-> standard thunk (AP or selector), has no entry counter+        [StgArg] -- ^ FVS, StgArg because for thunks these can also be literals.     | TickyLNE+        [NonVoid Id] -- ^ Args -withNewTickyCounterFun :: Bool -> Name  -> [NonVoid Id] -> FCode a -> FCode a-withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry)+withNewTickyCounterFun :: Bool -> Id -> [NonVoid Id] -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounterFun single_entry f fvs args = withNewTickyCounter (TickyFun single_entry fvs args) f -withNewTickyCounterLNE :: Name  -> [NonVoid Id] -> FCode a -> FCode a+withNewTickyCounterLNE :: Id  ->  [NonVoid Id] -> FCode a -> FCode a withNewTickyCounterLNE nm args code = do   b <- isEnabled stgToCmmTickyLNE-  if not b then code else withNewTickyCounter TickyLNE nm args code+  if not b then code else withNewTickyCounter (TickyLNE args) nm code  thunkHasCounter :: Bool -> FCode Bool thunkHasCounter isStatic = (not isStatic &&) <$> isEnabled stgToCmmTickyDynThunk@@ -185,46 +239,50 @@ withNewTickyCounterThunk   :: Bool -- ^ static   -> Bool -- ^ updateable-  -> Name+  -> Id+  -> [NonVoid Id] -- ^ Free vars   -> FCode a   -> FCode a-withNewTickyCounterThunk isStatic isUpdatable name code = do+withNewTickyCounterThunk isStatic isUpdatable name fvs code = do     has_ctr <- thunkHasCounter isStatic     if not has_ctr       then code-      else withNewTickyCounter (TickyThunk isUpdatable False) name [] code+      else withNewTickyCounter (TickyThunk isUpdatable False (map StgVarArg $ coerce fvs)) name code  withNewTickyCounterStdThunk   :: Bool -- ^ updateable-  -> Name+  -> Id+  -> [StgArg] -- ^ Free vars + function   -> FCode a   -> FCode a-withNewTickyCounterStdThunk isUpdatable name code = do+withNewTickyCounterStdThunk isUpdatable name fvs code = do     has_ctr <- thunkHasCounter False     if not has_ctr       then code-      else withNewTickyCounter (TickyThunk isUpdatable True) name [] code+      else withNewTickyCounter (TickyThunk isUpdatable True fvs) name code  withNewTickyCounterCon-  :: Name+  :: Id   -> DataCon+  -> ConstructorNumber   -> FCode a   -> FCode a-withNewTickyCounterCon name datacon code = do+withNewTickyCounterCon name datacon info code = do     has_ctr <- thunkHasCounter False     if not has_ctr       then code-      else withNewTickyCounter (TickyCon datacon) name [] code+      else withNewTickyCounter (TickyCon datacon info) name code  -- args does not include the void arguments-withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a-withNewTickyCounter cloType name args m = do-  lbl <- emitTickyCounter cloType name args+withNewTickyCounter :: TickyClosureType -> Id -> FCode a -> FCode a+withNewTickyCounter cloType name m = do+  lbl <- emitTickyCounter cloType name   setTickyCtrLabel lbl m -emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel-emitTickyCounter cloType name args-  = let ctr_lbl = mkRednCountsLabel name in+emitTickyCounter :: TickyClosureType -> Id -> FCode CLabel+emitTickyCounter cloType tickee+  = let name = idName tickee in+    let ctr_lbl = mkRednCountsLabel name in     (>> return ctr_lbl) $     ifTicky $ do         { cfg    <- getStgToCmmConfig@@ -239,23 +297,52 @@               ppr_for_ticky_name :: SDoc               ppr_for_ticky_name =                 let ext = case cloType of-                              TickyFun single_entry -> parens $ hcat $ punctuate comma $+                              TickyFun single_entry _ _-> parens $ hcat $ punctuate comma $                                   [text "fun"] ++ [text "se"|single_entry]-                              TickyCon datacon -> parens (text "con:" <+> ppr (dataConName datacon))-                              TickyThunk upd std -> parens $ hcat $ punctuate comma $+                              TickyCon datacon _cn -> parens (text "con:" <+> ppr (dataConName datacon))+                              TickyThunk upd std _-> parens $ hcat $ punctuate comma $                                   [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]-                              TickyLNE | isInternalName name -> parens (text "LNE")-                                       | otherwise -> panic "emitTickyCounter: how is this an external LNE?"+                              TickyLNE _ | isInternalName name -> parens (text "LNE")+                                         | otherwise -> panic "emitTickyCounter: how is this an external LNE?"                     p = case hasHaskellName parent of                             -- NB the default "top" ticky ctr does not                             -- have a Haskell name                           Just pname -> text "in" <+> ppr (nameUnique pname)                           _ -> empty                 in pprTickyName mod_name name <+> ext <+> p+        ; this_mod <- getModuleName+        ; let t = case cloType of+                    TickyCon {} -> "C"+                    TickyFun {} -> "F"+                    TickyThunk {} -> "T"+                    TickyLNE {} -> "L"+        ; info_lbl <- case cloType of+                            TickyCon dc mn -> case mn of+                                               NoNumber -> return $! CmmLabel $ mkConInfoTableLabel (dataConName dc) DefinitionSite+                                               (Numbered n) -> return $! CmmLabel $ mkConInfoTableLabel (dataConName dc) (UsageSite this_mod n)+                            TickyFun {} ->+                              return $! CmmLabel $ mkInfoTableLabel name NoCafRefs +                            TickyThunk _ std_thunk _fvs+                              | not std_thunk+                              -> return $! CmmLabel $ mkInfoTableLabel name NoCafRefs+                              -- IPE Maps have no entry for std thunks.+                              | otherwise+                              -> do+                                    lf_info <- getCgInfo_maybe name+                                    profile <- getProfile+                                    case lf_info of+                                      Just (CgIdInfo { cg_lf = cg_lf })+                                          | isLFThunk cg_lf+                                          -> return $! CmmLabel $ mkClosureInfoTableLabel (profilePlatform profile) tickee cg_lf+                                      _   -> pprTraceDebug "tickyThunkUnknown" (text t <> colon <> ppr name <+> ppr (mkInfoTableLabel name NoCafRefs))+                                            return $! zeroCLit platform++                            TickyLNE {} -> return $! zeroCLit platform+         ; let ctx = defaultSDocContext {sdocPprDebug = True}         ; fun_descr_lit <- newStringCLit $ renderWithContext ctx ppr_for_ticky_name-        ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args+        ; arg_descr_lit <- newStringCLit $ tickyEntryDesc ctx cloType         ; emitDataLits ctr_lbl         -- Must match layout of rts/include/rts/Ticky.h's StgEntCounter         --@@ -263,10 +350,11 @@         -- before, but the code generator wasn't handling that         -- properly and it led to chaos, panic and disorder.             [ mkIntCLit platform 0,               -- registered?-              mkIntCLit platform (length args),   -- Arity+              mkIntCLit platform (tickyArgArity cloType),   -- Arity               mkIntCLit platform 0,               -- Heap allocated for this thing               fun_descr_lit,               arg_descr_lit,+              info_lbl,               zeroCLit platform,          -- Entries into this thing               zeroCLit platform,          -- Heap allocated by this thing               zeroCLit platform           -- Link to next StgEntCounter

@@ -88,7 +88,7 @@ 3.  Add the derived bindings, generating InstInfos -} -data EarlyDerivSpec = InferTheta (DerivSpec [ThetaOrigin])+data EarlyDerivSpec = InferTheta (DerivSpec ThetaSpec)                     | GivenTheta (DerivSpec ThetaType)         -- InferTheta ds => the context for the instance should be inferred         --      In this case ds_theta is the list of all the sets of@@ -102,7 +102,7 @@         -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer  splitEarlyDerivSpec :: [EarlyDerivSpec]-                    -> ([DerivSpec [ThetaOrigin]], [DerivSpec ThetaType])+                    -> ([DerivSpec ThetaSpec], [DerivSpec ThetaType]) splitEarlyDerivSpec [] = ([],[]) splitEarlyDerivSpec (InferTheta spec : specs) =     case splitEarlyDerivSpec specs of (is, gs) -> (spec : is, gs)@@ -197,72 +197,67 @@         ; traceTc "tcDeriving" (ppr early_specs)          ; let (infer_specs, given_specs) = splitEarlyDerivSpec early_specs-        ; insts1 <- mapM genInst given_specs-        ; insts2 <- mapM genInst infer_specs+        ; famInsts1 <- concatMapM genFamInsts given_specs+        ; famInsts2 <- concatMapM genFamInsts infer_specs+        ; let famInsts = famInsts1 ++ famInsts2          ; dflags <- getDynFlags         ; logger <- getLogger -        ; let (_, deriv_stuff, fvs) = unzip3 (insts1 ++ insts2)-        ; loc <- getSrcSpanM-        ; let (binds, famInsts) = genAuxBinds dflags loc-                                    (unionManyBags deriv_stuff)--        ; let mk_inst_infos1 = map fstOf3 insts1-        ; inst_infos1 <- apply_inst_infos mk_inst_infos1 given_specs-           -- We must put all the derived type family instances (from both           -- infer_specs and given_specs) in the local instance environment           -- before proceeding, or else simplifyInstanceContexts might           -- get stuck if it has to reason about any of those family instances.           -- See Note [Staging of tcDeriving]-        ; tcExtendLocalFamInstEnv (bagToList famInsts) $+        ; tcExtendLocalFamInstEnv famInsts $           -- NB: only call tcExtendLocalFamInstEnv once, as it performs           -- validity checking for all of the family instances you give it.           -- If the family instances have errors, calling it twice will result           -- in duplicate error messages! -     do {-        -- the stand-alone derived instances (@inst_infos1@) are used when+     do { given_inst_binds <- mapM genInstBinds given_specs++        ; let given_inst_infos = map fstOf3 given_inst_binds++        -- the stand-alone derived instances (@given_inst_infos@) are used when         -- inferring the contexts for "deriving" clauses' instances         -- (@infer_specs@)-        ; final_specs <- extendLocalInstEnv (map iSpec inst_infos1) $-                         simplifyInstanceContexts infer_specs+        ; final_infer_specs <-+            extendLocalInstEnv (map iSpec given_inst_infos) $+            simplifyInstanceContexts infer_specs+        ; infer_inst_binds <- mapM genInstBinds final_infer_specs -        ; let mk_inst_infos2 = map fstOf3 insts2-        ; inst_infos2 <- apply_inst_infos mk_inst_infos2 final_specs-        ; let inst_infos = inst_infos1 ++ inst_infos2+        ; let (_, aux_specs, fvs) = unzip3 (given_inst_binds ++ infer_inst_binds)+        ; loc <- getSrcSpanM+        ; let aux_binds = genAuxBinds dflags loc (unionManyBags aux_specs) -        ; (inst_info, rn_binds, rn_dus) <- renameDeriv inst_infos binds+        ; let infer_inst_infos = map fstOf3 infer_inst_binds+        ; let inst_infos = given_inst_infos ++ infer_inst_infos +        ; (inst_info, rn_aux_binds, rn_dus) <- renameDeriv inst_infos aux_binds+         ; unless (isEmptyBag inst_info) $              liftIO (putDumpFileMaybe logger Opt_D_dump_deriv "Derived instances"                         FormatHaskell-                        (ddump_deriving inst_info rn_binds famInsts))+                        (ddump_deriving inst_info rn_aux_binds famInsts))          ; gbl_env <- tcExtendLocalInstEnv (map iSpec (bagToList inst_info))                                           getGblEnv         ; let all_dus = rn_dus `plusDU` usesOnly (NameSet.mkFVs $ concat fvs)-        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_binds) } }+        ; return (addTcgDUs gbl_env all_dus, inst_info, rn_aux_binds) } }   where     ddump_deriving :: Bag (InstInfo GhcRn) -> HsValBinds GhcRn-                   -> Bag FamInst             -- ^ Rep type family instances+                   -> [FamInst]               -- Associated type family instances                    -> SDoc-    ddump_deriving inst_infos extra_binds repFamInsts+    ddump_deriving inst_infos extra_binds famInsts       =    hang (text "Derived class instances:")               2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") (bagToList inst_infos))                  $$ ppr extra_binds)         $$ hangP (text "Derived type family instances:")-             (vcat (map pprRepTy (bagToList repFamInsts)))+             (vcat (map pprRepTy famInsts))      hangP s x = text "" $$ hang s 2 x -    -- Apply the suspended computations given by genInst calls.-    -- See Note [Staging of tcDeriving]-    apply_inst_infos :: [ThetaType -> TcM (InstInfo GhcPs)]-                     -> [DerivSpec ThetaType] -> TcM [InstInfo GhcPs]-    apply_inst_infos = zipWithM (\f ds -> f (ds_theta ds))- -- Prints the representable type family instance pprRepTy :: FamInst -> SDoc pprRepTy fi@(FamInst { fi_tys = lhs })@@ -359,32 +354,18 @@ it needed in the environment in order to properly simplify instance like the C N instance above. -To avoid this scenario, we carefully structure the order of events in-tcDeriving. We first call genInst on the standalone derived instance specs and-the instance specs obtained from deriving clauses. Note that the return type of-genInst is a triple:--    TcM (ThetaType -> TcM (InstInfo RdrName), BagDerivStuff, Maybe Name)--The type family instances are in the BagDerivStuff. The first field of the-triple is a suspended computation which, given an instance context, produces-the rest of the instance. The fact that it is suspended is important, because-right now, we don't have ThetaTypes for the instances that use deriving clauses-(only the standalone-derived ones).--Now we can collect the type family instances and extend the local instance-environment. At this point, it is safe to run simplifyInstanceContexts on the-deriving-clause instance specs, which gives us the ThetaTypes for the-deriving-clause instances. Now we can feed all the ThetaTypes to the-suspended computations and obtain our InstInfos, at which point-tcDeriving is done.+To avoid this scenario, we generate things in tcDeriving in a specific order: -An alternative design would be to split up genInst so that the-family instances are generated separately from the InstInfos. But this would-require carving up a lot of the GHC deriving internals to accommodate the-change. On the other hand, we can keep all of the InstInfo and type family-instance logic together in genInst simply by converting genInst to-continuation-returning style, so we opt for that route.+1. First, we generate all of the associated type family instances for derived+   instances (using `genFamInsts`).+2. Next, we extend the local instance environment with these type family+   instances.+3. Then, we generate the instance bindings for derived instances+   (using `genInstBinds`).+4. Finally, for instances generated with `deriving` clauses, we infer the+   instance contexts (using `simplifyInstanceContexts`). At this point, we+   already have the necessary type family instances in scope (from step (2)),+   so this is safe to do.  Note [Why we don't pass rep_tc into deriveTyData] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1156,14 +1137,40 @@ mkEqnHelp overlap_mode tvs cls cls_args deriv_ctxt deriv_strat = do   is_boot <- tcIsHsBootOrSig   when is_boot $ bale_out DerivErrBootFileFound++  let pred = mkClassPred cls cls_args+  skol_info <- mkSkolemInfo (DerivSkol pred)+  (tvs', cls_args', deriv_strat') <-+    skolemise_when_inferring_context skol_info deriv_ctxt+  let deriv_env = DerivEnv+                    { denv_overlap_mode = overlap_mode+                    , denv_tvs          = tvs'+                    , denv_cls          = cls+                    , denv_inst_tys     = cls_args'+                    , denv_ctxt         = deriv_ctxt+                    , denv_skol_info    = skol_info+                    , denv_strat        = deriv_strat' }   runReaderT mk_eqn deriv_env   where-    deriv_env = DerivEnv { denv_overlap_mode = overlap_mode-                         , denv_tvs          = tvs-                         , denv_cls          = cls-                         , denv_inst_tys     = cls_args-                         , denv_ctxt         = deriv_ctxt-                         , denv_strat        = deriv_strat }+    skolemise_when_inferring_context ::+         SkolemInfo -> DerivContext+      -> TcM ([TcTyVar], [TcType], Maybe (DerivStrategy GhcTc))+    skolemise_when_inferring_context skol_info deriv_ctxt =+      case deriv_ctxt of+        -- In order to infer an instance context, we must later make use of+        -- the constraint solving machinery, which expects TcTyVars rather+        -- than TyVars. We skolemise the type variables with non-overlappable+        -- (vanilla) skolems.+        -- See Note [Overlap and deriving] in GHC.Tc.Deriv.Infer.+        InferContext{} -> do+          (skol_subst, tvs') <- tcInstSkolTyVars skol_info tvs+          let cls_args'    = substTys skol_subst cls_args+              deriv_strat' = fmap (mapDerivStrategy (substTy skol_subst))+                                  deriv_strat+          pure (tvs', cls_args', deriv_strat')+        -- If the instance context is supplied, we don't need to skolemise+        -- at all.+        SupplyContext{} -> pure (tvs, cls_args, deriv_strat)      bale_out =       failWithTc . TcRnCannotDeriveInstance cls cls_args deriv_strat NoGeneralizedNewtypeDeriving@@ -1327,7 +1334,9 @@                 , denv_tvs          = tvs                 , denv_cls          = cls                 , denv_inst_tys     = inst_tys-                , denv_ctxt         = deriv_ctxt } <- ask+                , denv_ctxt         = deriv_ctxt+                , denv_skol_info    = skol_info } <- ask+       user_ctxt <- askDerivUserTypeCtxt        doDerivInstErrorChecks1 mechanism        loc       <- lift getSrcSpanM        dfun_name <- lift $ newDFunName cls inst_tys loc@@ -1340,6 +1349,8 @@                    , ds_name = dfun_name, ds_tvs = tvs'                    , ds_cls = cls, ds_tys = inst_tys'                    , ds_theta = inferred_constraints+                   , ds_skol_info = skol_info+                   , ds_user_ctxt = user_ctxt                    , ds_overlap = overlap_mode                    , ds_standalone_wildcard = wildcard                    , ds_mechanism = mechanism' } }@@ -1350,6 +1361,8 @@                    , ds_name = dfun_name, ds_tvs = tvs                    , ds_cls = cls, ds_tys = inst_tys                    , ds_theta = theta+                   , ds_skol_info = skol_info+                   , ds_user_ctxt = user_ctxt                    , ds_overlap = overlap_mode                    , ds_standalone_wildcard = Nothing                    , ds_mechanism = mechanism }@@ -1361,17 +1374,17 @@        let isDeriveAnyClassEnabled =              deriveAnyClassEnabled (xopt LangExt.DeriveAnyClass dflags)        checkOriginativeSideConditions dit >>= \case-         CanDeriveStock gen_fn -> mk_eqn_from_mechanism $-                                  DerivSpecStock { dsm_stock_dit    = dit-                                                 , dsm_stock_gen_fn = gen_fn }-         StockClassError why   -> derivingThingFailWith NoGeneralizedNewtypeDeriving why-         CanDeriveAnyClass     -> derivingThingFailWith NoGeneralizedNewtypeDeriving-                                    (DerivErrNotStockDeriveable isDeriveAnyClassEnabled)+         CanDeriveStock gen_fns -> mk_eqn_from_mechanism $+                                   DerivSpecStock { dsm_stock_dit     = dit+                                                  , dsm_stock_gen_fns = gen_fns }+         StockClassError why    -> derivingThingFailWith NoGeneralizedNewtypeDeriving why+         CanDeriveAnyClass      -> derivingThingFailWith NoGeneralizedNewtypeDeriving+                                     (DerivErrNotStockDeriveable isDeriveAnyClassEnabled)          -- In the 'NonDerivableClass' case we can't derive with either stock or anyclass          -- so we /don't want/ to suggest the user to enabled 'DeriveAnyClass', that's          -- why we pass 'YesDeriveAnyClassEnabled', so that GHC won't attempt to suggest it.-         NonDerivableClass     -> derivingThingFailWith NoGeneralizedNewtypeDeriving-                                    (DerivErrNotStockDeriveable YesDeriveAnyClassEnabled)+         NonDerivableClass      -> derivingThingFailWith NoGeneralizedNewtypeDeriving+                                     (DerivErrNotStockDeriveable YesDeriveAnyClassEnabled)  mk_eqn_anyclass :: DerivM EarlyDerivSpec mk_eqn_anyclass@@ -1446,12 +1459,12 @@             = DerivErrNotStockDeriveable isDeriveAnyClassEnabled        checkOriginativeSideConditions dit >>= \case-        NonDerivableClass     -> derivingThingFailWith NoGeneralizedNewtypeDeriving dac_error-        StockClassError why   -> derivingThingFailWith NoGeneralizedNewtypeDeriving why-        CanDeriveStock gen_fn -> mk_eqn_from_mechanism $-                                 DerivSpecStock { dsm_stock_dit    = dit-                                                , dsm_stock_gen_fn = gen_fn }-        CanDeriveAnyClass     -> mk_eqn_from_mechanism DerivSpecAnyClass+        NonDerivableClass      -> derivingThingFailWith NoGeneralizedNewtypeDeriving dac_error+        StockClassError why    -> derivingThingFailWith NoGeneralizedNewtypeDeriving why+        CanDeriveStock gen_fns -> mk_eqn_from_mechanism $+                                  DerivSpecStock { dsm_stock_dit     = dit+                                                 , dsm_stock_gen_fns = gen_fns }+        CanDeriveAnyClass      -> mk_eqn_from_mechanism DerivSpecAnyClass  {- ************************************************************************@@ -1607,9 +1620,9 @@                         $ TcRnDerivingDefaults cls                  mk_eqn_from_mechanism DerivSpecAnyClass                -- CanDeriveStock-               CanDeriveStock gen_fn -> mk_eqn_from_mechanism $-                                        DerivSpecStock { dsm_stock_dit    = dit-                                                       , dsm_stock_gen_fn = gen_fn }+               CanDeriveStock gen_fns -> mk_eqn_from_mechanism $+                                         DerivSpecStock { dsm_stock_dit     = dit+                                                        , dsm_stock_gen_fns = gen_fns }  {- Note [Recursive newtypes]@@ -1816,32 +1829,31 @@ \end{itemize} -} --- Generate the InstInfo for the required instance--- plus any auxiliary bindings required-genInst :: DerivSpec theta-        -> TcM (ThetaType -> TcM (InstInfo GhcPs), BagDerivStuff, [Name])--- We must use continuation-returning style here to get the order in which we--- typecheck family instances and derived instances right.--- See Note [Staging of tcDeriving]-genInst spec@(DS { ds_tvs = tvs, ds_mechanism = mechanism-                 , ds_tys = tys, ds_cls = clas, ds_loc = loc-                 , ds_standalone_wildcard = wildcard })-  = do (meth_binds, meth_sigs, deriv_stuff, unusedNames)-         <- set_span_and_ctxt $-            genDerivStuff mechanism loc clas tys tvs-       let mk_inst_info theta = set_span_and_ctxt $ do-             inst_spec <- newDerivClsInst theta spec-             doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism-             traceTc "newder" (ppr inst_spec)-             return $ InstInfo-                       { iSpec   = inst_spec-                       , iBinds  = InstBindings-                                     { ib_binds = meth_binds-                                     , ib_tyvars = map Var.varName tvs-                                     , ib_pragmas = meth_sigs-                                     , ib_extensions = extensions-                                     , ib_derived = True } }-       return (mk_inst_info, deriv_stuff, unusedNames)+-- | Generate the 'InstInfo' for the required instance,+-- plus any auxiliary bindings required (see @Note [Auxiliary binders]@ in+-- "GHC.Tc.Deriv.Generate") and any additional free variables+-- that should be marked (see @Note [Deriving and unused record selectors]@+-- in "GHC.Tc.Deriv.Utils").+genInstBinds :: DerivSpec ThetaType+             -> TcM (InstInfo GhcPs, Bag AuxBindSpec, [Name])+genInstBinds spec@(DS { ds_tvs = tyvars, ds_mechanism = mechanism+                      , ds_tys = inst_tys, ds_theta = theta, ds_cls = clas+                      , ds_loc = loc, ds_standalone_wildcard = wildcard })+  = set_spec_span_and_ctxt spec $+    do (meth_binds, meth_sigs, aux_specs, unusedNames) <- gen_inst_binds+       inst_spec <- newDerivClsInst spec+       doDerivInstErrorChecks2 clas inst_spec theta wildcard mechanism+       traceTc "newder" (ppr inst_spec)+       let inst_info =+             InstInfo+               { iSpec   = inst_spec+               , iBinds  = InstBindings+                             { ib_binds = meth_binds+                             , ib_tyvars = map Var.varName tyvars+                             , ib_pragmas = meth_sigs+                             , ib_extensions = extensions+                             , ib_derived = True } }+       return (inst_info, aux_specs, unusedNames)   where     extensions :: [LangExt.Extension]     extensions@@ -1860,9 +1872,76 @@       | otherwise       = [] -    set_span_and_ctxt :: TcM a -> TcM a-    set_span_and_ctxt = setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)+    gen_inst_binds :: TcM (LHsBinds GhcPs, [LSig GhcPs], Bag AuxBindSpec, [Name])+    gen_inst_binds+      = case mechanism of+          -- See Note [Bindings for Generalised Newtype Deriving]+          DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty}+            -> gen_newtype_or_via rhs_ty +          -- Try a stock deriver+          DerivSpecStock { dsm_stock_dit = dit+                         , dsm_stock_gen_fns =+                             StockGenFns { stock_gen_binds = gen_fn } }+            -> gen_fn loc dit++          -- Try DeriveAnyClass+          DerivSpecAnyClass+            -> return (emptyBag, [], emptyBag, [])+               -- No method bindings, signatures, auxiliary bindings or free+               -- variable names are needed. The only interesting work happens when+               -- defaulting associated type family instances (see the+               -- DeriveSpecAnyClass case in genFamInsts below).++          -- Try DerivingVia+          DerivSpecVia{dsm_via_ty = via_ty}+            -> gen_newtype_or_via via_ty++    gen_newtype_or_via ty = do+      let (binds, sigs) = gen_Newtype_binds loc clas tyvars inst_tys ty+      return (binds, sigs, emptyBag, [])++-- | Generate the associated type family instances for a derived instance.+genFamInsts :: DerivSpec theta -> TcM [FamInst]+genFamInsts spec@(DS { ds_tvs = tyvars, ds_mechanism = mechanism+                     , ds_tys = inst_tys, ds_cls = clas, ds_loc = loc })+  = set_spec_span_and_ctxt spec $+    case mechanism of+      -- See Note [GND and associated type families]+      DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty}+        -> gen_newtype_or_via rhs_ty++      -- Try a stock deriver+      DerivSpecStock { dsm_stock_dit = dit+                     , dsm_stock_gen_fns =+                         StockGenFns { stock_gen_fam_insts = gen_fn } }+        -> gen_fn loc dit++      -- See Note [DeriveAnyClass and default family instances]+      DerivSpecAnyClass -> do+        let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)+            mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env+        dflags <- getDynFlags+        tyfam_insts <-+          -- canDeriveAnyClass should ensure that this code can't be reached+          -- unless -XDeriveAnyClass is enabled.+          assertPpr (xopt LangExt.DeriveAnyClass dflags)+                    (ppr "genFamInsts: bad derived class" <+> ppr clas) $+          mapM (tcATDefault loc mini_subst emptyNameSet)+               (classATItems clas)+        pure $ concat tyfam_insts++      -- Try DerivingVia+      DerivSpecVia{dsm_via_ty = via_ty}+        -> gen_newtype_or_via via_ty+  where+    gen_newtype_or_via ty = gen_Newtype_fam_insts loc clas tyvars inst_tys ty++-- Set the SrcSpan and error context for an action that uses a DerivSpec.+set_spec_span_and_ctxt :: DerivSpec theta -> TcM a -> TcM a+set_spec_span_and_ctxt (DS{ ds_loc = loc, ds_cls = clas, ds_tys = tys }) =+  setSrcSpan loc . addErrCtxt (instDeclCtxt3 clas tys)+ -- Checks: -- -- * All of the data constructors for a data type are in scope for a@@ -2004,47 +2083,6 @@   err <- derivingThingErrM newtype_deriving msg   lift $ failWithTc err -genDerivStuff :: DerivSpecMechanism -> SrcSpan -> Class-              -> [Type] -> [TyVar]-              -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff, [Name])-genDerivStuff mechanism loc clas inst_tys tyvars-  = case mechanism of-      -- See Note [Bindings for Generalised Newtype Deriving]-      DerivSpecNewtype { dsm_newtype_rep_ty = rhs_ty}-        -> gen_newtype_or_via rhs_ty--      -- Try a stock deriver-      DerivSpecStock { dsm_stock_dit    = dit-                     , dsm_stock_gen_fn = gen_fn }-        -> gen_fn loc inst_tys dit--      -- Try DeriveAnyClass-      DerivSpecAnyClass -> do-        let mini_env   = mkVarEnv (classTyVars clas `zip` inst_tys)-            mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env-        dflags <- getDynFlags-        tyfam_insts <--          -- canDeriveAnyClass should ensure that this code can't be reached-          -- unless -XDeriveAnyClass is enabled.-          assertPpr (xopt LangExt.DeriveAnyClass dflags)-                    (ppr "genDerivStuff: bad derived class" <+> ppr clas) $-          mapM (tcATDefault loc mini_subst emptyNameSet)-               (classATItems clas)-        return ( emptyBag, [] -- No method bindings are needed...-               , listToBag (map DerivFamInst (concat tyfam_insts))-               -- ...but we may need to generate binding for associated type-               -- family default instances.-               -- See Note [DeriveAnyClass and default family instances]-               , [] )--      -- Try DerivingVia-      DerivSpecVia{dsm_via_ty = via_ty}-        -> gen_newtype_or_via via_ty-  where-    gen_newtype_or_via ty = do-      (binds, sigs, faminsts) <- gen_Newtype_binds loc clas tyvars inst_tys ty-      return (binds, sigs, faminsts, [])- {- Note [Bindings for Generalised Newtype Deriving] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2058,7 +2096,7 @@   instance (C [a], Eq a) => C (N a) where      f = coerce (f :: [a] -> [a]) -This generates a cast for each method, but allows the superclasse to+This generates a cast for each method, but allows the superclasses to be worked out in the usual way.  In this case the superclass (Eq (N a)) will be solved by the explicit Eq (N a) instance.  We do *not* create the superclasses by casting the superclass dictionaries for the