ghc-lib 0.20221001 → 0.20221101

raw patch · 103 files changed

+3716/−2764 lines, 103 filesdep ~ghc-lib-parserPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghc-lib-parser

API changes (from Hackage documentation)

Files

• compiler/GHC.hs +4/−2
• compiler/GHC/Cmm/ContFlowOpt.hs +8/−5
• compiler/GHC/Cmm/Info/Build.hs +48/−25
• compiler/GHC/Cmm/Lint.hs +17/−4
• compiler/GHC/Cmm/Parser.y +10/−6
• compiler/GHC/Cmm/Pipeline.hs +1/−1
• compiler/GHC/Cmm/Utils.hs +2/−1
• compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +20/−12
• compiler/GHC/CmmToAsm/AArch64/Ppr.hs +1/−1
• compiler/GHC/CmmToAsm/BlockLayout.hs +17/−14
• compiler/GHC/CmmToAsm/Dwarf/Types.hs +2/−2
• compiler/GHC/CmmToAsm/PPC/Instr.hs +8/−5
• compiler/GHC/CmmToAsm/X86/CodeGen.hs +3/−18
• compiler/GHC/CmmToAsm/X86/Ppr.hs +2/−24
• compiler/GHC/CmmToC.hs +11/−11
• compiler/GHC/CmmToLlvm/Base.hs +1/−1
• compiler/GHC/Core/Opt/CSE.hs +1/−1
• compiler/GHC/Core/Opt/CprAnal.hs +4/−1
• compiler/GHC/Core/Opt/DmdAnal.hs +43/−0
• compiler/GHC/Core/Opt/Exitify.hs +26/−2
• compiler/GHC/Core/Opt/Pipeline.hs +53/−27
• compiler/GHC/Core/Opt/SetLevels.hs +8/−17
• compiler/GHC/Core/Opt/SpecConstr.hs +96/−72
• compiler/GHC/Core/Opt/Specialise.hs +265/−71
• compiler/GHC/CoreToStg.hs +67/−54
• compiler/GHC/Driver/Backpack.hs +4/−3
• compiler/GHC/Driver/CodeOutput.hs +11/−18
• compiler/GHC/Driver/Config/Core/Opt/Simplify.hs +24/−30
• compiler/GHC/Driver/Config/CoreToStg.hs +16/−0
• compiler/GHC/Driver/GenerateCgIPEStub.hs +4/−6
• compiler/GHC/Driver/Main.hs +234/−80
• compiler/GHC/Driver/Make.hs +91/−21
• compiler/GHC/Driver/Pipeline.hs +23/−16
• compiler/GHC/Driver/Pipeline/Execute.hs +29/−179
• compiler/GHC/HsToCore/Coverage.hs +1/−1
• compiler/GHC/HsToCore/Foreign/C.hs +6/−6
• compiler/GHC/HsToCore/Monad.hs +1/−1
• compiler/GHC/HsToCore/Quote.hs +13/−13
• compiler/GHC/HsToCore/Utils.hs +1/−1
• compiler/GHC/Iface/Ext/Ast.hs +8/−6
• compiler/GHC/Iface/Ext/Binary.hs +4/−4
• compiler/GHC/Iface/Ext/Types.hs +20/−20
• compiler/GHC/Iface/Load.hs +4/−0
• compiler/GHC/Iface/Make.hs +30/−15
• compiler/GHC/Iface/Recomp.hs +16/−2
• compiler/GHC/Iface/Tidy.hs +7/−8
• compiler/GHC/Iface/Tidy/StaticPtrTable.hs +2/−2
• compiler/GHC/IfaceToCore.hs +49/−2
• compiler/GHC/Linker/ExtraObj.hs +6/−6
• compiler/GHC/Linker/Loader.hs +37/−3
• compiler/GHC/Linker/Windows.hs +1/−3
• compiler/GHC/Rename/HsType.hs +12/−8
• compiler/GHC/Rename/Module.hs +13/−5
• compiler/GHC/Rename/Names.hs +8/−9
• compiler/GHC/Rename/Unbound.hs +1/−2
• compiler/GHC/Rename/Utils.hs +7/−7
• compiler/GHC/Runtime/Eval.hs +6/−6
• compiler/GHC/Runtime/Heap/Inspect.hs +8/−5
• compiler/GHC/Stg/CSE.hs +11/−4
• compiler/GHC/Stg/InferTags.hs +4/−5
• compiler/GHC/Stg/InferTags/Rewrite.hs +43/−3
• compiler/GHC/Stg/Lift/Monad.hs +2/−2
• compiler/GHC/Stg/Lint.hs +39/−11
• compiler/GHC/Stg/Pipeline.hs +11/−2
• compiler/GHC/Stg/Unarise.hs +2/−0
• compiler/GHC/StgToByteCode.hs +24/−15
• compiler/GHC/StgToCmm/Bind.hs +39/−1
• compiler/GHC/StgToCmm/Heap.hs +10/−8
• compiler/GHC/StgToCmm/InfoTableProv.hs +144/−0
• compiler/GHC/StgToCmm/Prim.hs +21/−60
• compiler/GHC/StgToCmm/Prof.hs +11/−38
• compiler/GHC/StgToCmm/Utils.hs +5/−5
• compiler/GHC/SysTools/Cpp.hs +234/−0
• compiler/GHC/SysTools/Process.hs +0/−4
• compiler/GHC/Tc/Deriv.hs +3/−4
• compiler/GHC/Tc/Deriv/Generate.hs +19/−22
• compiler/GHC/Tc/Deriv/Generics.hs +8/−5
• compiler/GHC/Tc/Errors.hs +18/−28
• compiler/GHC/Tc/Gen/Default.hs +6/−6
• compiler/GHC/Tc/Gen/Head.hs +2/−3
• compiler/GHC/Tc/Gen/HsType.hs +12/−9
• compiler/GHC/Tc/Gen/Splice.hs +41/−78
• compiler/GHC/Tc/Instance/Class.hs +4/−4
• compiler/GHC/Tc/Module.hs +3/−3
• compiler/GHC/Tc/Solver/Canonical.hs +15/−5
• compiler/GHC/Tc/TyCl.hs +78/−90
• compiler/GHC/Tc/Utils/Backpack.hs +1/−1
• compiler/GHC/Tc/Utils/Env.hs +1/−1
• compiler/GHC/Tc/Utils/Monad.hs +14/−8
• compiler/GHC/Tc/Utils/TcMType.hs +11/−11
• compiler/GHC/Tc/Validity.hs +10/−4
• compiler/GHC/ThToHs.hs +83/−115
• ghc-lib.cabal +7/−2
• ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl +3/−0
• ghc-lib/stage0/compiler/build/primop-code-size.hs-incl +3/−0
• ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +3/−0
• ghc-lib/stage0/compiler/build/primop-list.hs-incl +3/−0
• ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl +3/−0
• ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +27/−24
• ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +3/−0
• ghc-lib/stage0/compiler/build/primop-tag.hs-incl +1314/−1311
• ghc-lib/stage0/lib/llvm-targets +3/−0
• ghc-lib/stage0/rts/build/include/ghcautoconf.h +3/−7

@@ -929,7 +929,8 @@   -- See Note [DynFlags consistency]   let (dflags', warnings) = makeDynFlagsConsistent dflags   let diag_opts = initDiagOpts dflags-  liftIO $ handleFlagWarnings logger diag_opts (map (Warn WarningWithoutFlag) warnings)+      print_config = initPrintConfig dflags+  liftIO $ handleFlagWarnings logger print_config diag_opts (map (Warn WarningWithoutFlag) warnings)   return dflags'  checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags@@ -939,7 +940,8 @@   if xopt LangExt.StaticPointers dflags0   then do     let diag_opts = initDiagOpts dflags0-    liftIO $ printOrThrowDiagnostics logger diag_opts $ singleMessage+        print_config = initPrintConfig dflags0+    liftIO $ printOrThrowDiagnostics logger print_config diag_opts $ singleMessage       $ fmap GhcDriverMessage       $ mkPlainMsgEnvelope diag_opts interactiveSrcSpan DriverStaticPointersNotSupported     return $ xopt_unset dflags0 LangExt.StaticPointers

@@ -1,6 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Cmm.ContFlowOpt     ( cmmCfgOpts@@ -21,8 +20,10 @@ import GHC.Cmm.Utils import GHC.Cmm.Switch (mapSwitchTargets, switchTargetsToList) import GHC.Data.Maybe-import GHC.Utils.Panic+import GHC.Platform import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic  import Control.Monad @@ -422,9 +423,9 @@     add_preds block env = foldr add env (successors block)       where add lbl env = mapInsertWith (+) lbl 1 env --- Removing unreachable blocks-removeUnreachableBlocksProc :: CmmDecl -> CmmDecl-removeUnreachableBlocksProc proc@(CmmProc info lbl live g)+-- Remove unreachable blocks from procs+removeUnreachableBlocksProc :: Platform -> CmmDecl -> CmmDecl+removeUnreachableBlocksProc _ proc@(CmmProc info lbl live g)    | used_blocks `lengthLessThan` mapSize (toBlockMap g)    = CmmProc info' lbl live g'    | otherwise@@ -446,3 +447,5 @@       used_lbls :: LabelSet      used_lbls = setFromList $ map entryLabel used_blocks+removeUnreachableBlocksProc platform data'@(CmmData _ _) =+    pprPanic "removeUnreachableBlocksProc: passed data declaration instead of procedure" (pdoc platform data')

@@ -576,7 +576,7 @@   -> CAFSet cafAnalData platform st = case st of    CmmStaticsRaw _lbl _data           -> Set.empty-   CmmStatics _lbl _itbl _ccs payload ->+   CmmStatics _lbl _itbl _ccs payload _extras ->        foldl' analyzeStatic Set.empty payload      where        analyzeStatic s lit =@@ -741,7 +741,9 @@ getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFfyLabel)] getLabelledBlocks platform decl = case decl of    CmmData _ (CmmStaticsRaw _ _)    -> []-   CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFfyLabel platform lbl) ]+   CmmData _ (CmmStatics lbl info _ _ _) -> [ (DeclLabel lbl, mkCAFfyLabel platform lbl)+                                            | not (isThunkRep (cit_rep info))+                                            ]    CmmProc top_info _ _ _           -> [ (BlockLabel blockId, caf_lbl)                                        | (blockId, info) <- mapToList (info_tbls top_info)                                        , let rep = cit_rep info@@ -786,29 +788,49 @@   graph :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]   graph = stronglyConnCompFromEdgedVerticesOrd nodes --- | Get @(Label, CAFfyLabel, Set CAFfyLabel)@ for each CAF block.--- The @Set CafLabel@ represents the set of CAFfy things which this CAF's code+-- | Get @(Maybe Label, CAFfyLabel, Set CAFfyLabel)@ for each CAF block.+-- The @Set CAFfyLabel@ represents the set of CAFfy things which this CAF's code -- depends upon. ----- CAFs are treated differently from other labelled blocks:+--  - The 'Label' represents the entry code of the closure. This may be+--    'Nothing' if it is a standard closure type (e.g. @stg_unpack_cstring@; see+--    Note [unpack_cstring closures] in StgStdThunks.cmm).+--  - The 'CAFLabel' is the label of the CAF closure.+--  - The @Set CAFLabel@ is the set of CAFfy closures which should be included+--    in the closure's SRT. --+-- Note that CAFs are treated differently from other labelled blocks:+-- --  - we never shortcut a reference to a CAF to the contents of its --    SRT, since the point of SRTs is to keep CAFs alive. -- --  - CAFs therefore don't take part in the dependency analysis in depAnalSRTs. --    instead we generate their SRTs after everything else.----getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFfyLabel, Set CAFfyLabel)]-getCAFs platform cafEnv decls =-  [ (g_entry g, mkCAFfyLabel platform topLbl, cafs)-  | CmmProc top_info topLbl _ g <- decls-  , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]-  , let rep = cit_rep info-  , isStaticRep rep && isThunkRep rep-  , Just cafs <- [mapLookup (g_entry g) cafEnv]-  ]+getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Maybe Label, CAFfyLabel, Set CAFfyLabel)]+getCAFs platform cafEnv = mapMaybe getCAFLabel+  where+    getCAFLabel :: CmmDecl -> Maybe (Maybe Label, CAFfyLabel, Set CAFfyLabel) +    getCAFLabel (CmmProc top_info top_lbl _ g)+      | Just info <- mapLookup (g_entry g) (info_tbls top_info)+      , let rep = cit_rep info+      , isStaticRep rep && isThunkRep rep+      , Just cafs <- mapLookup (g_entry g) cafEnv+      = Just (Just (g_entry g), mkCAFfyLabel platform top_lbl, cafs) +      | otherwise+      = Nothing++    getCAFLabel (CmmData _ (CmmStatics top_lbl info _ccs _payload _extras))+      | isThunkRep (cit_rep info)+      = Just (Nothing, mkCAFfyLabel platform top_lbl, Set.empty)++      | otherwise+      = Nothing++    getCAFLabel (CmmData _ (CmmStaticsRaw _lbl _payload))+      = Nothing+ -- | Get the list of blocks that correspond to the entry points for -- @FUN_STATIC@ closures.  These are the blocks for which if we have an -- SRT we can merge it with the static closure. [FUN]@@ -882,7 +904,7 @@               pprPanic "doSRTs" (text "Proc in static data list:" <+> pdoc platform decl)             CmmData _ static ->               case static of-                CmmStatics lbl _ _ _ -> (lbl, set)+                CmmStatics lbl _ _ _ _ -> (lbl, set)                 CmmStaticsRaw lbl _ -> (lbl, set)        (proc_envs, procss) = unzip procs@@ -902,7 +924,7 @@     sccs :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]     sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls -    cafsWithSRTs :: [(Label, CAFfyLabel, Set CAFfyLabel)]+    cafsWithSRTs :: [(Maybe Label, CAFfyLabel, Set CAFfyLabel)]     cafsWithSRTs = getCAFs platform cafEnv decls    srtTraceM "doSRTs" (text "data:"            <+> pdoc platform data_ $$@@ -925,7 +947,7 @@         flip runStateT moduleSRTInfo $ do           nonCAFs <- mapM (doSCC cfg staticFuns static_data_env) sccs           cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->-            oneSRT cfg staticFuns [BlockLabel l] [cafLbl]+            oneSRT cfg staticFuns (map BlockLabel (maybeToList l)) [cafLbl]                    True{-is a CAF-} cafs static_data_env           return (nonCAFs ++ cAFs) @@ -1221,15 +1243,15 @@         ( [CmmDeclSRTs] -- The SRT object(s)         , SRTEntry      -- label to use in the info table         )-buildSRTChain _ [] = panic "buildSRT: empty" buildSRTChain profile cafSet =   case splitAt mAX_SRT_SIZE cafSet of+    ([], _) -> panic "buildSRT: empty"     (these, []) -> do       (decl,lbl) <- buildSRT profile these       return ([decl], lbl)-    (these,those) -> do-      (rest, rest_lbl) <- buildSRTChain profile (head these : those)-      (decl,lbl) <- buildSRT profile (rest_lbl : tail these)+    (this:these,those) -> do+      (rest, rest_lbl) <- buildSRTChain profile (this : those)+      (decl,lbl) <- buildSRT profile (rest_lbl : these)       return (decl:rest, lbl)   where     mAX_SRT_SIZE = 16@@ -1248,6 +1270,7 @@         [] -- no padding         [mkIntCLit platform 0] -- link field         [] -- no saved info+        [] -- no extras   return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)  -- | Update info tables with references to their SRTs. Also generate@@ -1263,10 +1286,10 @@ updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics))   = [CmmData s (CmmStaticsRaw lbl statics)] -updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))+updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload extras))   = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))]   where-    field_lits = mkStaticClosureFields profile itbl ccs caffy payload+    field_lits = mkStaticClosureFields profile itbl ccs caffy payload extras  updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)   | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]@@ -1296,7 +1319,7 @@             Just srtEntries -> srtTrace "maybeStaticFun" (pdoc (profilePlatform profile) res)               (info_tbl { cit_rep = new_rep }, res)               where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]-          fields = mkStaticClosureFields profile info_tbl ccs caffy srtEntries+          fields = mkStaticClosureFields profile info_tbl ccs caffy srtEntries []           new_rep = case cit_rep of              HeapRep sta ptrs nptrs ty ->                HeapRep sta (ptrs + length srtEntries) nptrs ty

@@ -50,7 +50,8 @@ runCmmLint :: OutputableP Platform a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc runCmmLint platform l p =    case unCL (l p) platform of-     Left err -> Just (vcat [text "Cmm lint error:",+     Left err -> Just (withPprStyle defaultDumpStyle $ vcat+                            [text "Cmm lint error:",                              nest 2 err,                              text "Program was:",                              nest 2 (pdoc platform p)])@@ -173,9 +174,21 @@             platform <- getPlatform             erep <- lintCmmExpr expr             let reg_ty = cmmRegType platform reg-            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)-                then return ()-                else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty+            unless (compat_regs erep reg_ty) $+              cmmLintAssignErr (CmmAssign reg expr) erep reg_ty+    where+      compat_regs :: CmmType -> CmmType -> Bool+      compat_regs ty1 ty2+        -- As noted in #22297, SIMD vector registers can be used for+        -- multiple different purposes, e.g. xmm1 can be used to hold 4 Floats,+        -- or 4 Int32s, or 2 Word64s, ...+        -- To allow this, we relax the check: we only ensure that the widths+        -- match, until we can find a more robust solution.+        | isVecType ty1+        , isVecType ty2+        = typeWidth ty1 == typeWidth ty2+        | otherwise+        = cmmEqType_ignoring_ptrhood ty1 ty2    CmmStore l r _alignment -> do             _ <- lintCmmExpr l

@@ -224,6 +224,7 @@ import GHC.StgToCmm.Ticky import GHC.StgToCmm.Prof import GHC.StgToCmm.Bind  ( emitBlackHoleCode, emitUpdateFrame )+import GHC.StgToCmm.InfoTableProv  import GHC.Cmm.Opt import GHC.Cmm.Graph@@ -434,7 +435,7 @@                         mkStaticClosure profile (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)                          -- mkForeignLabel because these are only used                          -- for CHARLIKE and INTLIKE closures in the RTS.-                        dontCareCCS (map getLit lits) [] [] [] } }+                        dontCareCCS (map getLit lits) [] [] [] [] } }         -- arrays of closures required for the CHARLIKE & INTLIKE arrays  lits    :: { [CmmParse CmmExpr] }@@ -449,7 +450,7 @@                          platform <- getPlatform;                          ctx      <- getContext;                          formals <- sequence (fromMaybe [] $3);-                         withName (showSDocOneLine ctx (pprCLabel platform CStyle entry_ret_label))+                         withName (showSDocOneLine ctx (pprCLabel platform entry_ret_label))                            $4;                          return (entry_ret_label, info, stk_formals, formals) }                      let do_layout = isJust $3@@ -1247,7 +1248,7 @@ staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () staticClosure pkg cl_label info payload   = do profile <- getProfile-       let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []+       let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] []        code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits  foreignCall@@ -1517,9 +1518,12 @@         let fcode = do               ((), cmm) <- getCmm $ unEC code "global" (initEnv (pdProfile pdConfig)) [] >> 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+              let used_info+                    | do_ipe    = map (cmmInfoTableToInfoProvEnt this_mod) (mapMaybe topInfoTable cmm)+                    | otherwise = []+                    where+                      do_ipe = stgToCmmInfoTableMap $ cmmpStgToCmmConfig cmmpConfig+              ((), cmm2) <- getCmm $ emitIpeBufferListNode this_mod used_info               return (cmm ++ cmm2, used_info)             (cmm, _) = runC (cmmpStgToCmmConfig cmmpConfig) fstate st fcode             (warnings,errors) = getPsMessages pst

@@ -156,7 +156,7 @@            return $ if cmmOptControlFlow cfg                     then map (cmmCfgOptsProc splitting_proc_points) g                     else g-      g <- return (map removeUnreachableBlocksProc g)+      g <- return $ map (removeUnreachableBlocksProc platform) g            -- See Note [unreachable blocks]       dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g 

@@ -113,7 +113,7 @@    AddrRep          -> bWord platform    FloatRep         -> f32    DoubleRep        -> f64-   (VecRep len rep) -> vec len (primElemRepCmmType rep)+   VecRep len rep   -> vec len (primElemRepCmmType rep)  slotCmmType :: Platform -> SlotTy -> CmmType slotCmmType platform = \case@@ -123,6 +123,7 @@    Word64Slot      -> b64    FloatSlot       -> f32    DoubleSlot      -> f64+   VecSlot l e     -> vec l (primElemRepCmmType e)  primElemRepCmmType :: PrimElemRep -> CmmType primElemRepCmmType Int8ElemRep   = b8

@@ -664,10 +664,11 @@         -- See Note [Signed arithmetic on AArch64].         negate code w reg = do             let w' = opRegWidth w+            (reg', code_sx) <- signExtendReg w w' reg             return $ Any (intFormat w) $ \dst ->                 code `appOL`-                signExtendReg w w' reg `snocOL`-                NEG (OpReg w' dst) (OpReg w' reg) `appOL`+                code_sx `snocOL`+                NEG (OpReg w' dst) (OpReg w' reg') `appOL`                 truncateReg w' w dst          ss_conv from to reg code =@@ -817,15 +818,17 @@               -- should be performed.               let w' = opRegWidth w                   signExt r-                    | not is_signed  = nilOL+                    | not is_signed  = return (r, nilOL)                     | otherwise      = signExtendReg w w' r+              (reg_x_sx, code_x_sx) <- signExt reg_x+              (reg_y_sx, code_y_sx) <- signExt reg_y               return $ Any (intFormat w) $ \dst ->                   code_x `appOL`                   code_y `appOL`                   -- sign-extend both operands-                  signExt reg_x `appOL`-                  signExt reg_y `appOL`-                  op (OpReg w' dst) (OpReg w' reg_x) (OpReg w' reg_y) `appOL`+                  code_x_sx `appOL`+                  code_y_sx `appOL`+                  op (OpReg w' dst) (OpReg w' reg_x_sx) (OpReg w' reg_y_sx) `appOL`                   truncateReg w' w dst -- truncate back to the operand's original width            floatOp w op = do@@ -1021,16 +1024,21 @@  -- | Instructions to sign-extend the value in the given register from width @w@ -- up to width @w'@.-signExtendReg :: Width -> Width -> Reg -> OrdList Instr+signExtendReg :: Width -> Width -> Reg -> NatM (Reg, OrdList Instr) signExtendReg w w' r =     case w of-      W64 -> nilOL+      W64 -> noop       W32-        | w' == W32 -> nilOL-        | otherwise -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)-      W16           -> unitOL $ SXTH (OpReg w' r) (OpReg w' r)-      W8            -> unitOL $ SXTB (OpReg w' r) (OpReg w' r)+        | w' == W32 -> noop+        | otherwise -> extend SXTH+      W16           -> extend SXTH+      W8            -> extend SXTB       _             -> panic "intOp"+  where+    noop = return (r, nilOL)+    extend instr = do+        r' <- getNewRegNat II64+        return (r', unitOL $ instr (OpReg w' r') (OpReg w' r))  -- | Instructions to truncate the value in the given register from width @w@ -- down to width @w'@.

@@ -195,7 +195,7 @@     text "@object"   where     functionOkInfoTable = platformTablesNextToCode platform &&-      isInfoTableLabel lbl && not (isConInfoTableLabel lbl)+      isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl)  -- this is called pprTypeAndSizeDecl in PPC.Ppr pprTypeDecl :: Platform -> CLabel -> SDoc

@@ -13,7 +13,7 @@     ( sequenceTop, backendMaintainsCfg) where -import GHC.Prelude+import GHC.Prelude hiding (head, init, last, tail)  import GHC.Platform @@ -42,6 +42,9 @@ import GHC.Utils.Misc  import Data.List (sortOn, sortBy, nub)+import qualified Data.List as Partial (head, tail)+import Data.List.NonEmpty (nonEmpty)+import qualified Data.List.NonEmpty as NE import Data.Foldable (toList) import qualified Data.Set as Set import Data.STRef@@ -354,7 +357,7 @@ breakChainAt :: BlockId -> BlockChain              -> (BlockChain,BlockChain) breakChainAt bid (BlockChain blks)-    | not (bid == head rblks)+    | not (bid == Partial.head rblks)     = panic "Block not in chain"     | otherwise     = (BlockChain (toOL lblks),@@ -493,7 +496,7 @@         merge :: forall s. [CfgEdge] -> LabelMap (Point s BlockChain) -> ST s BlockChain         merge [] chains = do             chains' <- mapM find =<< (nub <$> (mapM repr $ mapElems chains)) :: ST s [BlockChain]-            return $ foldl' chainConcat (head chains') (tail chains')+            return $ foldl' chainConcat (Partial.head chains') (Partial.tail chains')         merge ((CfgEdge from to _):edges) chains         --   | pprTrace "merge" (ppr (from,to) <> ppr chains) False         --   = undefined@@ -593,8 +596,8 @@             toChain <- readSTRef toRef             let newChain = chainConcat fromChain toChain             ref <- newSTRef newChain-            let start = head $ takeL 1 newChain-            let end = head $ takeR 1 newChain+            let start = Partial.head $ takeL 1 newChain+            let end = Partial.head $ takeR 1 newChain             -- chains <- sequence $ mapMap readSTRef chainStarts             -- pprTraceM "pre-fuse chains:" $ ppr chains             buildNext@@ -772,13 +775,13 @@ dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i]           -> [GenBasicBlock i] dropJumps _    [] = []-dropJumps info ((BasicBlock lbl ins):todo)-    | not . null $ ins --This can happen because of shortcutting-    , [dest] <- jumpDestsOfInstr (last ins)-    , ((BasicBlock nextLbl _) : _) <- todo+dropJumps info (BasicBlock lbl ins:todo)+    | Just ins <- nonEmpty ins --This can happen because of shortcutting+    , [dest] <- jumpDestsOfInstr (NE.last ins)+    , BasicBlock nextLbl _ : _ <- todo     , not (mapMember dest info)     , nextLbl == dest-    = BasicBlock lbl (init ins) : dropJumps info todo+    = BasicBlock lbl (NE.init ins) : dropJumps info todo     | otherwise     = BasicBlock lbl ins : dropJumps info todo @@ -869,10 +872,10 @@             ((target,info):_)               | length successors > 2 || edgeWeight info <= 0 -> []               | otherwise -> [target]-          | otherwise-          = case jumpDestsOfInstr (last instrs) of-                [one] -> [one]-                _many -> []+          | Just instr <- lastMaybe instrs+          , [one] <- jumpDestsOfInstr instr+          = [one]+          | otherwise = []   seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)]

@@ -163,8 +163,8 @@ -- | Print a CLabel name in a ".stringz \"LABEL\"" pprLabelString :: Platform -> CLabel -> SDoc pprLabelString platform label =-   pprString'                         -- we don't need to escape the string as labels don't contain exotic characters-    $ pprCLabel platform CStyle label -- pretty-print as C label (foreign labels may be printed differently in Asm)+   pprString'                  -- we don't need to escape the string as labels don't contain exotic characters+    $ pprCLabel platform label -- pretty-print as C label (foreign labels may be printed differently in Asm)  -- | Prints assembler data corresponding to DWARF info records. Note -- that the binary format of this is parameterized in @abbrevDecls@ and

@@ -33,7 +33,7 @@    ) where -import GHC.Prelude+import GHC.Prelude hiding (head, init, last, tail)  import GHC.CmmToAsm.PPC.Regs import GHC.CmmToAsm.PPC.Cond@@ -58,6 +58,8 @@ import GHC.Types.Unique.FM (listToUFM, lookupUFM) import GHC.Types.Unique.Supply +import Data.Foldable (toList)+import qualified Data.List.NonEmpty as NE import Data.Maybe (fromMaybe)  @@ -679,10 +681,11 @@         -> [NatBasicBlock Instr]         -> [NatBasicBlock Instr] makeFarBranches info_env blocks-    | last blockAddresses < nearLimit = blocks-    | otherwise = zipWith handleBlock blockAddresses blocks+    | NE.last blockAddresses < nearLimit = blocks+    | otherwise = zipWith handleBlock blockAddressList blocks     where-        blockAddresses = scanl (+) 0 $ map blockLen blocks+        blockAddresses = NE.scanl (+) 0 $ map blockLen blocks+        blockAddressList = toList blockAddresses         blockLen (BasicBlock _ instrs) = length instrs          handleBlock addr (BasicBlock id instrs)@@ -703,4 +706,4 @@         -- to calculate things exactly         nearLimit = 7000 - mapSize info_env * maxRetInfoTableSizeW -        blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses+        blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddressList

@@ -2928,25 +2928,10 @@         let op = OpAddr (AddrBaseIndex (EABaseReg tableReg)                                        (EAIndex reg (platformWordSizeInBytes platform)) (ImmInt 0)) -        offsetReg <- getNewRegNat (intFormat (platformWordWidth platform))-        return $ if is32bit || os == OSDarwin-                 then e_code `appOL` t_code `appOL` toOL [+        return $ e_code `appOL` t_code `appOL` toOL [                                 ADD (intFormat (platformWordWidth platform)) op (OpReg tableReg),                                 JMP_TBL (OpReg tableReg) ids rosection lbl                        ]-                 else -- HACK: On x86_64 binutils<2.17 is only able to generate-                      -- PC32 relocations, hence we only get 32-bit offsets in-                      -- the jump table. As these offsets are always negative-                      -- we need to properly sign extend them to 64-bit. This-                      -- hack should be removed in conjunction with the hack in-                      -- PprMach.hs/pprDataItem once binutils 2.17 is standard.-                      e_code `appOL` t_code `appOL` toOL [-                               MOVSxL II32 op (OpReg offsetReg),-                               ADD (intFormat (platformWordWidth platform))-                                   (OpReg offsetReg)-                                   (OpReg tableReg),-                               JMP_TBL (OpReg tableReg) ids rosection lbl-                       ]   else do         (reg,e_code) <- getSomeReg indexExpr         lbl <- getNewLabelNat@@ -3353,9 +3338,9 @@     invert bs   where     invert :: [NatBasicBlock Instr] -> [NatBasicBlock Instr]-    invert ((BasicBlock lbl1 ins@(_:_:_xs)):b2@(BasicBlock lbl2 _):bs)+    invert (BasicBlock lbl1 ins:b2@(BasicBlock lbl2 _):bs)       | --pprTrace "Block" (ppr lbl1) True,-        (jmp1,jmp2) <- last2 ins+        Just (jmp1,jmp2) <- last2 ins       , JXX cond1 target1 <- jmp1       , target1 == lbl2       --, pprTrace "CutChance" (ppr b1) True

@@ -254,7 +254,7 @@     but mess up with the relocation. https://phabricator.haskell.org/D4730     -}     functionOkInfoTable = platformTablesNextToCode platform &&-      isInfoTableLabel lbl && not (isConInfoTableLabel lbl)+      isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl)   pprTypeDecl :: Platform -> CLabel -> SDoc@@ -532,29 +532,7 @@                           <> int (fromIntegral                               (fromIntegral (x `shiftR` 32) :: Word32))]                   _ -> panic "X86.Ppr.ppr_item: no match for II64"-               | otherwise ->-                  [text "\t.quad\t" <> pprImm platform imm]-              _-               | target32Bit platform ->-                  [text "\t.quad\t" <> pprImm platform imm]-               | otherwise ->-                  -- x86_64: binutils can't handle the R_X86_64_PC64-                  -- relocation type, which means we can't do-                  -- pc-relative 64-bit addresses. Fortunately we're-                  -- assuming the small memory model, in which all such-                  -- offsets will fit into 32 bits, so we have to stick-                  -- to 32-bit offset fields and modify the RTS-                  -- appropriately-                  ---                  -- See Note [x86-64-relative] in rts/include/rts/storage/InfoTables.h-                  ---                  case lit of-                  -- A relative relocation:-                  CmmLabelDiffOff _ _ _ _ ->-                      [text "\t.long\t" <> pprImm platform imm,-                       text "\t.long\t0"]-                  _ ->-                      [text "\t.quad\t" <> pprImm platform imm]+              _ -> [text "\t.quad\t" <> pprImm platform imm]   asmComment :: SDoc -> SDoc

@@ -88,7 +88,7 @@            blankLine,            extern_decls,            (if (externallyVisibleCLabel clbl)-                    then mkFN_ else mkIF_) (pprCLabel platform CStyle clbl) <+> lbrace,+                    then mkFN_ else mkIF_) (pprCLabel platform clbl) <+> lbrace,            nest 8 temp_decls,            vcat (map (pprBBlock platform) blocks),            rbrace ]@@ -110,14 +110,14 @@   (CmmData section (CmmStaticsRaw lbl [CmmString str])) ->     pprExternDecl platform lbl $$     hcat [-      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform CStyle lbl,+      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform lbl,       text "[] = ", pprStringInCStyle str, semi     ]    (CmmData section (CmmStaticsRaw lbl [CmmUninitialised size])) ->     pprExternDecl platform lbl $$     hcat [-      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform CStyle lbl,+      pprLocalness lbl, pprConstness (isSecConstant section), text "char ", pprCLabel platform lbl,       brackets (int size), semi     ] @@ -153,7 +153,7 @@   = -- TODO: align closures only     pprExternDecl platform lbl $$     hcat [ pprLocalness lbl, pprConstness is_ro, text "StgWord"-         , space, pprCLabel platform CStyle lbl, text "[]"+         , space, pprCLabel platform lbl, text "[]"          -- See Note [StgWord alignment]          , pprAlignment (wordWidth platform)          , text "= {" ]@@ -245,7 +245,7 @@             case fn of               CmmLit (CmmLabel lbl)                 | StdCallConv <- cconv ->-                    pprCall platform (pprCLabel platform CStyle lbl) cconv hresults hargs+                    pprCall platform (pprCLabel platform lbl) cconv hresults hargs                         -- stdcall functions must be declared with                         -- a function type, otherwise the C compiler                         -- doesn't add the @n suffix to the label.  We@@ -254,7 +254,7 @@                 | CmmNeverReturns <- ret ->                     pprCall platform cast_fn cconv hresults hargs <> semi <> text "__builtin_unreachable();"                 | not (isMathFun lbl) ->-                    pprForeignCall platform (pprCLabel platform CStyle lbl) cconv hresults hargs+                    pprForeignCall platform (pprCLabel platform lbl) cconv hresults hargs               _ ->                     pprCall platform cast_fn cconv hresults hargs <> semi                         -- for a dynamic call, no declaration is necessary.@@ -595,7 +595,7 @@         -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i      where-        pprCLabelAddr lbl = char '&' <> pprCLabel platform CStyle lbl+        pprCLabelAddr lbl = char '&' <> pprCLabel platform lbl  pprLit1 :: Platform -> CmmLit -> SDoc pprLit1 platform lit = case lit of@@ -1208,7 +1208,7 @@   | not (needsCDecl lbl) = empty   | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz   | otherwise =-        hcat [ visibility, label_type lbl , lparen, pprCLabel platform CStyle lbl, text ");"+        hcat [ visibility, label_type lbl , lparen, pprCLabel platform lbl, text ");"              -- occasionally useful to see label type              -- , text "/* ", pprDebugCLabel lbl, text " */"              ]@@ -1231,7 +1231,7 @@   -- we must generate an appropriate prototype for it, so that the C compiler will   -- add the @n suffix to the label (#2276)   stdcall_decl sz =-        text "extern __attribute__((stdcall)) void " <> pprCLabel platform CStyle lbl+        text "extern __attribute__((stdcall)) void " <> pprCLabel platform lbl         <> parens (commafy (replicate (sz `quot` platformWordSizeInBytes platform) (machRep_U_CType platform (wordWidth platform))))         <> semi @@ -1501,8 +1501,8 @@     <> 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 ]+    body = vcat [ pprCLabel platform lbl <> text " ();" | lbl <- lbls ]+    decls = vcat [ text "void" <+> pprCLabel platform lbl <> text " (void);" | lbl <- lbls ]     attribute = case initOrFini of                   IsInitArray -> text "constructor"                   IsFiniArray -> text "destructor"

@@ -440,7 +440,7 @@ strCLabel_llvm lbl = do     ctx <- llvmCgContext <$> getConfig     platform <- getPlatform-    let sdoc = pprCLabel platform CStyle lbl+    let sdoc = pprCLabel platform lbl         str = Outp.showSDocOneLine ctx sdoc     return (fsLit str) 

@@ -817,7 +817,7 @@    W y z   -> e2  In the simplifier we use cheapEqExpr, because it is called a lot.-But here in CSE we use the full eqExpr.  After all, two alternatives usually+But here in CSE we use the full eqCoreExpr.  After all, two alternatives usually differ near the root, so it probably isn't expensive to compare the full alternative.  It seems like the same kind of thing that CSE is supposed to be doing, which is why I put it here.

@@ -553,12 +553,15 @@      *workers*, because their transformers need to adapt to CPR for their      arguments in 'cprTransformDataConWork' to enable Note [Nested CPR].      Better keep it all in this module! The alternative would be that-     'GHC.Types.Id.Make' depends on DmdAnal.+     'GHC.Types.Id.Make' depends on CprAnal.   3. In the future, Nested CPR could take a better account of incoming args      in cprAnalApp and do some beta-reduction on the fly, like !1866 did. If      any of those args had the CPR property, then we'd even get Nested CPR for      DataCon wrapper calls, for free. Not so if we simply give the wrapper a      single CPR sig in 'GHC.Types.Id.Make.mkDataConRep'!++DmdAnal also looks through the wrapper's unfolding:+See Note [DmdAnal for DataCon wrappers].  Note [Trimming to mAX_CPR_SIZE] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -985,6 +985,10 @@   | isDataConWorkId var   = -- pprTraceWith "dmdTransform:DataCon" (\ty -> ppr var $$ ppr sd $$ ppr ty) $     dmdTransformDataConSig (idArity var) sd+  -- See Note [DmdAnal for DataCon wrappers]+  | isDataConWrapId var, let rhs = uf_tmpl (realIdUnfolding var)+  , WithDmdType dmd_ty _rhs' <- dmdAnal env sd rhs+  = dmd_ty   -- Dictionary component selectors   -- Used to be controlled by a flag.   -- See #18429 for some perf measurements.@@ -1387,6 +1391,45 @@ (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 [DmdAnal for DataCon wrappers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We give DataCon wrappers a (necessarily flat) demand signature in+`GHC.Types.Id.Make.mkDataConRep`, so that passes such as the Simplifier can+exploit it via the call to `GHC.Core.Opt.Simplify.Utils.isStrictArgInfo` in+`GHC.Core.Opt.Simplify.Iteration.rebuildCall`. But during DmdAnal, we *ignore*+the demand signature of a DataCon wrapper, and instead analyse its unfolding at+every call site.++The reason is that DataCon *worker*s have very precise demand transformers,+computed by `dmdTransformDataConSig`. It would be awkward if DataCon *wrappers*+would behave much less precisely during DmdAnal. Example:++   data T1 = MkT1 { get_x1 :: Int,  get_y1 :: Int }+   data T2 = MkT2 { get_x2 :: !Int, get_y2 :: Int }+   f1 x y = get_x1 (MkT1 x y)+   f2 x y = get_x2 (MkT2 x y)++Here `MkT1` has no wrapper. `get_x1` puts a demand `!P(1!L,A)` on its argument,+and `dmdTransformDataConSig` will transform that demand to an absent demand on+`y` in `f1` and an unboxing demand on `x`.+But `MkT2` has a wrapper (to evaluate the first field). If demand analysis deals+with `MkT2` only through its demand signature, demand signatures can't transform+an incoming demand `P(1!L,A)` in a useful way, so we won't get an absent demand+on `y` in `f2` or see that `x` can be unboxed. That's a serious loss.++The example above will not actually occur, because $WMkT2 would be inlined.+Nevertheless, we can get interesting sub-demands on DataCon wrapper+applications in boring contexts; see T22241.++You might worry about the efficiency cost of demand-analysing datacon wrappers+at every call site. But in fact they are inlined /anyway/ in the Final phase,+which happens before DmdAnal, so few wrappers remain. And analysing the+unfoldings for the remaining calls (which are those in a boring context) will be+exactly as (in)efficent as if we'd inlined those calls. It turns out to be not+measurable in practice.++See also Note [CPR for DataCon wrappers] in `GHC.Core.Opt.CprAnal`.  Note [Boxity for bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -62,7 +62,7 @@     goTopLvl (Rec pairs) = Rec (map (second (go in_scope_toplvl)) pairs)       -- Top-level bindings are never join points -    in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds+    in_scope_toplvl = emptyInScopeSet `extendInScopeSetBndrs` binds      go :: InScopeSet -> CoreExpr -> CoreExpr     go _    e@(Var{})       = e@@ -94,7 +94,7 @@       | otherwise   = Let (Rec pairs') body'       where         is_join_rec = any (isJoinId . fst) pairs-        in_scope'   = in_scope `extendInScopeSetList` bindersOf (Rec pairs)+        in_scope'   = in_scope `extendInScopeSetBind` (Rec pairs)         pairs'      = mapSnd (go in_scope') pairs         body'       = go in_scope' body @@ -433,6 +433,7 @@ Exit join points, recognizable using `isExitJoinId` are join points with an occurrence in a recursive group, and can be recognized (after the occurrence analyzer ran!) using `isExitJoinId`.+ This function detects joinpoints with `occ_in_lam (idOccinfo id) == True`, because the lambdas of a non-recursive join point are not considered for `occ_in_lam`.  For example, in the following code, `j1` is /not/ marked@@ -445,6 +446,29 @@ * In `preInlineUnconditionally` directly. * In `simplLetUnfolding` we simply give exit join points no unfolding, which   prevents inlining in `postInlineUnconditionally` and call sites.++But see Note [Be selective about not-inlining exit join points]++Note [Be selective about not-inlining exit join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we follow "do not inline exit join points" mantra throughout,+some bad things happen.++* We can lose CPR information: see #21148++* We get useless clutter (#22084) that+  - makes the program bigger (including duplicated code #20739), and+  - adds extra jumps (and maybe stack saves) at runtime++So instead we follow "do not inline exit join points" for a /single run/+of the simplifier, right after Exitification.  That should give a+sufficient chance for used-once things to inline, but subsequent runs+will inline them back in.  (Annoyingly, as things stand, only with -O2+is there a subsequent run, but that might change, and it's not a huge+deal anyway.)++This is controlled by the Simplifier's sm_keep_exits flag; see+GHC.Core.Opt.Pipeline.  Note [Placement of the exitification pass] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -15,7 +15,7 @@ import GHC.Driver.Env import GHC.Driver.Config.Core.Lint ( endPass ) import GHC.Driver.Config.Core.Opt.LiberateCase ( initLiberateCaseOpts )-import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode, initGentleSimplMode )+import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyOpts, initSimplMode ) import GHC.Driver.Config.Core.Opt.WorkWrap ( initWorkWrapOpts ) import GHC.Driver.Config.Core.Rules ( initRuleOpts ) import GHC.Platform.Ways  ( hasWay, Way(WayProf) )@@ -28,6 +28,7 @@ import GHC.Core.Lint    ( lintAnnots ) import GHC.Core.Lint.Interactive ( interactiveInScope ) import GHC.Core.Opt.Simplify ( simplifyExpr, simplifyPgm )+import GHC.Core.Opt.Simplify.Env( SimplMode(..) ) import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.Monad import GHC.Core.Opt.Pipeline.Types@@ -154,32 +155,45 @@     maybe_strictness_before _       = CoreDoNothing -    simpl_phase phase name iter-      = CoreDoPasses-      $   [ maybe_strictness_before phase-          , CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter-                             (initSimplMode dflags phase name) rule_base-          , maybe_rule_check phase ]--    -- Run GHC's internal simplification phase, after all rules have run.-    -- See Note [Compiler phases] in GHC.Types.Basic-    simplify name = simpl_phase FinalPhase name max_iter+    ----------------------------+    base_simpl_mode :: SimplMode+    base_simpl_mode = initSimplMode dflags -    -- initial simplify: mk specialiser happy: minimum effort please+    -- gentle_mode: make specialiser happy: minimum effort please     -- See Note [Inline in InitialPhase]     -- See Note [RULEs enabled in InitialPhase]-    simpl_gently = CoreDoSimplify $ initSimplifyOpts dflags extra_vars max_iter-                                    (initGentleSimplMode dflags) rule_base+    gentle_mode = base_simpl_mode { sm_names     = ["Gentle"]+                                  , sm_phase     = InitialPhase+                                  , sm_case_case = False } +    simpl_mode phase name+      = base_simpl_mode { sm_names = [name], sm_phase = phase }++    keep_exits :: SimplMode -> SimplMode+    -- See Note [Be selective about not-inlining exit join points]+    -- in GHC.Core.Opt.Exitify+    keep_exits mode = mode { sm_keep_exits = True }++    ----------------------------+    run_simplifier mode iter+      = CoreDoSimplify $ initSimplifyOpts dflags extra_vars iter mode rule_base++    simpl_phase phase name iter = CoreDoPasses $+                                  [ maybe_strictness_before phase+                                  , run_simplifier (simpl_mode phase name) iter+                                  , maybe_rule_check phase ]++    -- Run GHC's internal simplification phase, after all rules have run.+    -- See Note [Compiler phases] in GHC.Types.Basic+    simpl_gently          = run_simplifier gentle_mode  max_iter+    simplify_final   name = run_simplifier (             simpl_mode FinalPhase name) max_iter+    simpl_keep_exits name = run_simplifier (keep_exits $ simpl_mode FinalPhase name) max_iter++    ----------------------------     dmd_cpr_ww = if ww_on then [CoreDoDemand True,CoreDoCpr,CoreDoWorkerWrapper]                           else [CoreDoDemand False] -- NB: No CPR! See Note [Don't change boxity without worker/wrapper]  -    demand_analyser = (CoreDoPasses (-                           dmd_cpr_ww ++-                           [simplify "post-worker-wrapper"]-                           ))-     -- Static forms are moved to the top level with the FloatOut pass.     -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.     static_ptrs_float_outwards =@@ -269,14 +283,16 @@          runWhen call_arity $ CoreDoPasses             [ CoreDoCallArity-            , simplify "post-call-arity"+            , simplify_final "post-call-arity"             ],          -- Strictness analysis-        runWhen strictness demand_analyser,+        runWhen strictness $ CoreDoPasses+            (dmd_cpr_ww ++ [simplify_final "post-worker-wrapper"]),          runWhen exitification CoreDoExitify,             -- See Note [Placement of the exitification pass]+            -- in GHC.Core.Opt.Exitify          runWhen full_laziness $            CoreDoFloatOutwards FloatOutSwitches {@@ -298,7 +314,17 @@          runWhen do_float_in CoreDoFloatInwards, -        simplify "final",  -- Final tidy-up+        -- Final tidy-up run of the simplifier+        simpl_keep_exits "final tidy up",+            -- Keep exit join point because this is the first+            -- Simplifier run after Exitify. Subsequent runs will+            -- re-inline those exit join points; their work is done.+            -- See Note [Be selective about not-inlining exit join points]+            -- in GHC.Core.Opt.Exitify+            --+            -- Annoyingly, we only /have/ a subsequent run with -O2.  With+            -- plain -O we'll still have those exit join points hanging around.+            -- Oh well.          maybe_rule_check FinalPhase, @@ -308,31 +334,31 @@                 -- Case-liberation for -O2.  This should be after                 -- strictness analysis and the simplification which follows it.         runWhen liberate_case $ CoreDoPasses-           [ CoreLiberateCase, simplify "post-liberate-case" ],+           [ CoreLiberateCase, simplify_final "post-liberate-case" ],            -- Run the simplifier after LiberateCase to vastly            -- reduce the possibility of shadowing            -- Reason: see Note [Shadowing] in GHC.Core.Opt.SpecConstr          runWhen spec_constr $ CoreDoPasses-           [ CoreDoSpecConstr, simplify "post-spec-constr"],+           [ CoreDoSpecConstr, simplify_final "post-spec-constr"],            -- See Note [Simplify after SpecConstr]          maybe_rule_check FinalPhase,          runWhen late_specialise $ CoreDoPasses-           [ CoreDoSpecialising, simplify "post-late-spec"],+           [ CoreDoSpecialising, simplify_final "post-late-spec"],          -- LiberateCase can yield new CSE opportunities because it peels         -- off one layer of a recursive function (concretely, I saw this         -- in wheel-sieve1), and I'm guessing that SpecConstr can too         -- And CSE is a very cheap pass. So it seems worth doing here.         runWhen ((liberate_case || spec_constr) && cse) $ CoreDoPasses-           [ CoreCSE, simplify "post-final-cse" ],+           [ CoreCSE, simplify_final "post-final-cse" ],          ---------  End of -O2 passes --------------          runWhen late_dmd_anal $ CoreDoPasses (-            dmd_cpr_ww ++ [simplify "post-late-ww"]+            dmd_cpr_ww ++ [simplify_final "post-late-ww"]           ),          -- Final run of the demand_analyser, ensures that one-shot thunks are

@@ -51,17 +51,6 @@   The simplifier tries to get rid of occurrences of x, in favour of wild,   in the hope that there will only be one remaining occurrence of x, namely   the scrutinee of the case, and we can inline it.--  This can only work if @wild@ is an unrestricted binder. Indeed, even with the-  extended typing rule (in the linter) for case expressions, if-       case x of wild % 1 { p -> e}-  is well-typed, then-       case x of wild % 1 { p -> e[wild\x] }-  is only well-typed if @e[wild\x] = e@ (that is, if @wild@ is not used in @e@-  at all). In which case, it is, of course, pointless to do the substitution-  anyway. So for a linear binder (and really anything which isn't unrestricted),-  doing this substitution would either produce ill-typed terms or be the-  identity. -}  module GHC.Core.Opt.SetLevels (@@ -82,7 +71,7 @@                         , exprOkForSpeculation                         , exprIsTopLevelBindable                         , collectMakeStaticArgs-                        , mkLamTypes+                        , mkLamTypes, extendInScopeSetBndrs                         ) import GHC.Core.Opt.Arity   ( exprBotStrictness_maybe, isOneShotBndr ) import GHC.Core.FVs     -- all of it@@ -106,7 +95,7 @@ import GHC.Types.Demand       ( DmdSig, prependArgsDmdSig ) import GHC.Types.Cpr          ( CprSig, prependArgsCprSig ) import GHC.Types.Name         ( getOccName, mkSystemVarName )-import GHC.Types.Name.Occurrence ( occNameString )+import GHC.Types.Name.Occurrence ( occNameFS ) import GHC.Types.Unique       ( hasKey ) import GHC.Types.Tickish      ( tickishIsCode ) import GHC.Types.Unique.Supply@@ -1566,7 +1555,7 @@        , le_subst     = mkEmptySubst in_scope_toplvl        , le_env       = emptyVarEnv }   where-    in_scope_toplvl = emptyInScopeSet `extendInScopeSetList` bindersOfBinds binds+    in_scope_toplvl = emptyInScopeSet `extendInScopeSetBndrs` binds       -- The Simplifier (see Note [Glomming] in GHC.Core.Opt.OccurAnal) and       -- the specialiser (see Note [Top level scope] in GHC.Core.Opt.Specialise)       -- may both produce top-level bindings where an early binding refers@@ -1602,7 +1591,9 @@                   -> LevelEnv extendCaseBndrEnv le@(LE { le_subst = subst, le_env = id_env })                   case_bndr (Var scrut_var)-    | Many <- varMult case_bndr+  -- We could use OccurAnal. scrutBinderSwap_maybe here, and perhaps+  -- get a bit more floating.  But we didn't in the past and it's+  -- an unforced change, so I'm leaving it.   = le { le_subst   = extendSubstWithVar subst case_bndr scrut_var        , le_env     = add_id id_env (case_bndr, scrut_var) } extendCaseBndrEnv env _ _ = env@@ -1706,9 +1697,9 @@      mk_poly_bndr bndr uniq = transferPolyIdInfo bndr abs_vars $ -- Note [transferPolyIdInfo] in GHC.Types.Id                              transfer_join_info bndr $-                             mkSysLocal (mkFastString str) uniq (idMult bndr) poly_ty+                             mkSysLocal str uniq (idMult bndr) poly_ty                            where-                             str     = "poly_" ++ occNameString (getOccName bndr)+                             str     = fsLit "poly_" `appendFS` occNameFS (getOccName bndr)                              poly_ty = mkLamTypes abs_vars (substTyUnchecked subst (idType bndr))      -- If we are floating a join point to top level, it stops being

@@ -35,6 +35,7 @@ import GHC.Core.FVs     ( exprsFreeVarsList, exprFreeVars ) import GHC.Core.Opt.Monad import GHC.Core.Opt.WorkWrap.Utils+import GHC.Core.Opt.OccurAnal( scrutBinderSwap_maybe ) import GHC.Core.DataCon import GHC.Core.Class( classTyVars ) import GHC.Core.Coercion hiding( substCo )@@ -881,7 +882,7 @@    , sc_count     :: !(Maybe Int)   -- ^ Max # of specialisations for any one function. Nothing => no limit.-  -- See Note [Avoiding exponential blowup].+  -- See Note [Avoiding exponential blowup] and decreaseSpecCount    , sc_recursive :: !Int   -- ^ Max # of specialisations over recursive type. Stops@@ -952,8 +953,7 @@                        sc_vals        = emptyVarEnv,                        sc_annotations = anns }) }   where-    init_subst = mkEmptySubst $ mkInScopeSet $ mkVarSet $-                 bindersOfBinds (mg_binds guts)+    init_subst = mkEmptySubst $ mkInScopeSetBndrs (mg_binds guts)         -- Acccount for top-level bindings that are not in dependency order;         -- see Note [Glomming] in GHC.Core.Opt.OccurAnal         -- Easiest thing is to bring all the top level binders into scope at once,@@ -1073,8 +1073,8 @@    = (env2, alt_bndrs')  where    live_case_bndr = not (isDeadBinder case_bndr)-   env1 | Var v <- stripTicksTopE (const True) scrut-                         = extendValEnv env v cval+   env1 | Just (v, mco) <- scrutBinderSwap_maybe scrut+        , isReflMCo mco  = extendValEnv env v cval         | otherwise      = env  -- See Note [Add scrutinee to ValueEnv too]    env2 | live_case_bndr = extendValEnv env1 case_bndr cval         | otherwise      = env1@@ -1098,17 +1098,21 @@  decreaseSpecCount :: ScEnv -> Int -> ScEnv -- See Note [Avoiding exponential blowup]-decreaseSpecCount env n_specs+decreaseSpecCount env _n_specs   = env { sc_force = False   -- See Note [Forcing specialisation]-        , sc_opts = (sc_opts env)-            { sc_count = case sc_count $ sc_opts env of-                       Nothing -> Nothing-                       Just n  -> Just $! (n `div` (n_specs + 1))+        , sc_opts = opts { sc_count = case sc_count opts of+                             Nothing -> Nothing+                             Just n  -> Just $! dec n             }         }-        -- The "+1" takes account of the original function;-        -- See Note [Avoiding exponential blowup]+  where+    opts  = sc_opts env+    dec n = n `div` 2  -- See Note [Avoiding exponential blowup] +    -- Or:   n `div` (n_specs + 1)+    -- See the historical note part of Note [Avoiding exponential blowup]+    -- The "+1" takes account of the original function;+ --------------------------------------------------- -- See Note [Forcing specialisation] ignoreType    :: ScEnv -> Type   -> Bool@@ -1164,6 +1168,10 @@ and 'b' with 'c' in the code.  The use of 'b' in the ValueEnv came from outside the case.  See #4908 for the live example. +It's very like the binder-swap story, so we use scrutBinderSwap_maybe+to identify suitable scrutinees -- but only if there is no cast+(isReflMCo) because that's all that the ValueEnv allows.+ Note [Avoiding exponential blowup] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The sc_count field of the ScEnv says how many times we are prepared to@@ -1183,9 +1191,20 @@ specialisation of each, because we also have the original we'll get 2^n copies of $j3, which is not good. -So when recursively specialising we divide the sc_count by the number of-copies we are making at this level, including the original.+So when recursively specialising we divide the sc_count (the maximum+number of specialisations, in the ScEnv) by two.  You might think that+gives us n*(n/2)*(n/4)... copies of the innnermost thing, which is+still exponential the depth.  But we use integer division, rounding+down, so if the starting sc_count is 3, we'll get 3 -> 1 -> 0, and+stop.  In fact, simply subtracting 1 would be good enough, for the same+reason. +Historical note: in the past we divided by (n_specs+1), where n_specs+is the number of specialisations at this level; but that gets us down+to zero jolly quickly, which I found led to some regressions.  (An+example is nofib/spectral/fibheaps, the getMin' function inside the+outer function $sfibToList, which has several interesting call+patterns.)  ************************************************************************ *                                                                      *@@ -1512,8 +1531,10 @@                 scrut_occ = case con of                                DataAlt dc -- See Note [Do not specialise evals]                                   | not (single_alt && all deadArgOcc arg_occs)-                                  -> ScrutOcc (unitUFM dc arg_occs)-                               _  -> UnkOcc+                                  -> -- pprTrace "sc_alt1" (ppr b' $$ ppr con $$ ppr bs $$ ppr arg_occs) $+                                     ScrutOcc (unitUFM dc arg_occs)+                               _  -> -- pprTrace "sc_alt1" (ppr b' $$ ppr con $$ ppr bs $$ ppr arg_occs) $+                                     UnkOcc           ; return (usg', b_occ `combineOcc` scrut_occ, Alt con bs2 rhs') }  @@ -1792,16 +1813,19 @@   , 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) $-    do  { (boring_call, new_pats) <- callsToNewPats env fn spec_info arg_occs all_calls+    do  { (boring_call, pats_discarded, new_pats)+             <- callsToNewPats env fn spec_info arg_occs all_calls          ; let n_pats = length new_pats---        ; if (not (null new_pats) || isJust mb_unspec) then---            pprTrace "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns"---                                        , text "mb_unspec" <+> ppr (isJust mb_unspec)---                                        , text "arg_occs" <+> ppr arg_occs---                                        , text "good pats" <+> ppr new_pats])  $---               return ()---          else return ()+--        ; when (not (null new_pats) || isJust mb_unspec) $+--          pprTraceM "specialise" (vcat [ ppr fn <+> text "with" <+> int n_pats <+> text "good patterns"+--                                       , text "boring_call:" <+> ppr boring_call+--                                       , text "pats_discarded:" <+> ppr pats_discarded+--                                       , text "old spec_count" <+> ppr spec_count+--                                       , text "spec count limit" <+> ppr (sc_count (sc_opts env))+--                                       , text "mb_unspec" <+> ppr (isJust mb_unspec)+--                                       , text "arg_occs" <+> ppr arg_occs+--                                       , text "new_pats" <+> ppr new_pats])          ; let spec_env = decreaseSpecCount env n_pats         ; (spec_usgs, new_specs) <- mapAndUnzipM (spec_one spec_env fn arg_bndrs body)@@ -1810,7 +1834,7 @@          ; let spec_usg = combineUsages spec_usgs -              unspec_rhs_needed = boring_call || isExportedId fn+              unspec_rhs_needed = pats_discarded || boring_call || isExportedId fn                -- If there were any boring calls among the seeds (= all_calls), then those               -- calls will call the un-specialised function.  So we should use the seeds@@ -1821,15 +1845,14 @@                                -> (spec_usg `combineUsage` rhs_usg, Nothing)                   _            -> (spec_usg,                      mb_unspec) ---        ; pprTrace "specialise return }"---             (vcat [ ppr fn---                   , text "boring_call:" <+> ppr boring_call---                   , text "new calls:" <+> ppr (scu_calls new_usg)]) $---          return ()+--        ; pprTraceM "specialise return }" $+--          vcat [ ppr fn+--               , text "unspec_rhs_needed:" <+> ppr unspec_rhs_needed+--               , text "new calls:" <+> ppr (scu_calls new_usg)] -          ; return (new_usg, SI { si_specs     = new_specs ++ specs-                                , si_n_specs   = spec_count + n_pats-                                , si_mb_unspec = mb_unspec' }) }+        ; return (new_usg, SI { si_specs     = new_specs ++ specs+                              , si_n_specs   = spec_count + n_pats+                              , si_mb_unspec = mb_unspec' }) }    | otherwise  -- No calls, inactive, or not a function                -- Behave as if there was a single, boring call@@ -1872,7 +1895,9 @@  spec_one env fn arg_bndrs body (call_pat, rule_number)   | CP { cp_qvars = qvars, cp_args = pats, cp_strict_args = cbv_args } <- call_pat-  = do  { spec_uniq <- getUniqueM+  = do  { -- pprTraceM "spec_one {" (ppr fn <+> ppr pats)++        ; spec_uniq <- getUniqueM         ; let env1 = extendScSubstList (extendScInScope env qvars)                                        (arg_bndrs `zip` pats)               (body_env, extra_bndrs) = extendBndrs env1 (dropList pats arg_bndrs)@@ -1898,9 +1923,6 @@         -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env)         ; (spec_usg, spec_body) <- scExpr body_env body ---      ; pprTrace "done spec_one }" (ppr fn $$ ppr (scu_calls spec_usg)) $---        return ()-                 -- And build the results         ; (qvars', pats') <- generaliseDictPats qvars pats         ; let spec_body_ty   = exprType spec_body@@ -1944,21 +1966,22 @@                                   fn_name qvars' pats' rule_rhs                            -- See Note [Transfer activation] -        -- ; pprTraceM "spec_one {" (vcat [ text "function:" <+> ppr fn <+> braces (ppr (idUnique fn))-        --                               , text "sc_count:" <+> ppr (sc_count env)-        --                               , text "pats:" <+> ppr pats-        --                               , text "call_pat:" <+> ppr call_pat-        --                               , text "-->" <+> ppr spec_name-        --                               , text "bndrs" <+> ppr arg_bndrs-        --                               , text "extra_bndrs" <+> ppr extra_bndrs-        --                               , text "cbv_args" <+> ppr cbv_args-        --                               , text "spec_lam_args" <+> ppr spec_lam_args-        --                               , text "spec_call_args" <+> ppr spec_call_args-        --                               , text "rule_rhs" <+> ppr rule_rhs-        --                               , text "adds_void_worker_arg" <+> ppr add_void_arg-        --                               , text "body" <+> ppr body-        --                               , text "spec_rhs" <+> ppr spec_rhs-        --                               , text "how_bound" <+> ppr (sc_how_bound env) ])+--        ; pprTraceM "spec_one end }" $+--          vcat [ text "function:" <+> ppr fn <+> braces (ppr (idUnique fn))+--               , text "pats:" <+> ppr pats+--               , text "call_pat:" <+> ppr call_pat+--               , text "-->" <+> ppr spec_name+--               , text "bndrs" <+> ppr arg_bndrs+--               , text "extra_bndrs" <+> ppr extra_bndrs+--               , text "cbv_args" <+> ppr cbv_args+--               , text "spec_lam_args" <+> ppr spec_lam_args+--               , text "spec_call_args" <+> ppr spec_call_args+--               , text "rule_rhs" <+> ppr rule_rhs+--               , text "adds_void_worker_arg" <+> ppr add_void_arg+----               , text "body" <+> ppr body+----               , text "spec_rhs" <+> ppr spec_rhs+----               , text "how_bound" <+> ppr (sc_how_bound env) ]+--               ]         ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule                                , os_id = spec_id                                , os_rhs = spec_rhs }) }@@ -2328,7 +2351,9 @@ callsToNewPats :: ScEnv -> Id                -> SpecInfo                -> [ArgOcc] -> [Call]-               -> UniqSM (Bool, [CallPat])+               -> UniqSM ( Bool        -- At least one boring call+                         , Bool        -- Patterns were discarded+                         , [CallPat] ) -- Patterns to specialise -- Result has no duplicate patterns, -- nor ones mentioned in si_specs (hence "new" patterns) -- Bool indicates that there was at least one boring pattern@@ -2360,12 +2385,11 @@                 -- Discard specialisations if there are too many of them               (pats_were_discarded, trimmed_pats) = trim_pats env fn spec_info small_pats ---        ; pprTrace "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls---                                       , text "done_specs:" <+> ppr (map os_pat done_specs)---                                       , text "good_pats:" <+> ppr good_pats ]) $---          return ()+--        ; pprTraceM "callsToPats" (vcat [ text "calls to" <+> ppr fn <> colon <+> ppr calls+--                                        , text "done_specs:" <+> ppr (map os_pat done_specs)+--                                        , text "trimmed_pats:" <+> ppr trimmed_pats ]) -        ; return (have_boring_call || pats_were_discarded, trimmed_pats) }+        ; return (have_boring_call, pats_were_discarded, trimmed_pats) }           -- If any of the calls does not give rise to a specialisation, either           -- because it is boring, or because there are too many specialisations,           -- return a flag to say so, so that we know to keep the original function.@@ -2474,29 +2498,29 @@               sanitise id   = updateIdTypeAndMult expandTypeSynonyms id                 -- See Note [Free type variables of the qvar types] -              -- Bad coercion variables: see Note [SpecConstr and casts]-              bad_covars :: CoVarSet++        -- Check for bad coercion variables: see Note [SpecConstr and casts]+        ; let bad_covars :: CoVarSet               bad_covars = mapUnionVarSet get_bad_covars pats               get_bad_covars :: CoreArg -> CoVarSet               get_bad_covars (Type ty) = filterVarSet bad_covar (tyCoVarsOfType ty)               get_bad_covars _         = emptyVarSet               bad_covar v = isId v && not (is_in_scope v) -        ; -- pprTrace "callToPats"  (ppr args $$ ppr bndr_occs) $-          warnPprTrace (not (isEmptyVarSet bad_covars))+        ; warnPprTrace (not (isEmptyVarSet bad_covars))               "SpecConstr: bad covars"               (ppr bad_covars $$ ppr call) $+           if interesting && isEmptyVarSet bad_covars-          then do-              -- pprTraceM "callToPatsOut" (-              --         text "fn:" <+> ppr fn $$-              --         text "args:" <+> ppr args $$-              --         text "in_scope:" <+> ppr in_scope $$-              --         -- text "in_scope:" <+> ppr in_scope $$-              --         text "pat_fvs:" <+> ppr pat_fvs-              --       )-              --   ppr (CP { cp_qvars = qvars', cp_args = pats })) >>-              return (Just (CP { cp_qvars = qvars', cp_args = pats, cp_strict_args = concat cbv_ids }))+          then do { let cp_res = CP { cp_qvars = qvars', cp_args = pats+                                    , cp_strict_args = concat cbv_ids }+--                  ; pprTraceM "callToPatsOut" $+--                    vcat [ text "fn:" <+> ppr fn+--                         , text "args:" <+> ppr args+--                         , text "bndr_occs:" <+> ppr bndr_occs+--                         , text "pat_fvs:" <+> ppr pat_fvs+--                         , text "cp_res:" <+> ppr cp_res ]+                  ; return (Just cp_res) }           else return Nothing }      -- argToPat takes an actual argument, and returns an abstracted

@@ -15,9 +15,7 @@ import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Core.Rules ( initRuleOpts ) -import GHC.Tc.Utils.TcType hiding( substTy )--import GHC.Core.Type  hiding( substTy, extendTvSubstList, zapSubst )+import GHC.Core.Type  hiding( substTy, substCo, extendTvSubst, zapSubst ) import GHC.Core.Multiplicity import GHC.Core.Predicate import GHC.Core.Coercion( Coercion )@@ -25,12 +23,15 @@ import qualified GHC.Core.Subst as Core import GHC.Core.Unfold.Make import GHC.Core+import GHC.Core.Make      ( mkLitRubbish )+import GHC.Core.Unify     ( tcMatchTy ) import GHC.Core.Rules import GHC.Core.Utils     ( exprIsTrivial                           , mkCast, exprType-                          , stripTicksTop )+                          , stripTicksTop, mkInScopeSetBndrs ) import GHC.Core.FVs-import GHC.Core.TyCo.Rep (TyCoBinder (..))+import GHC.Core.TyCo.Rep ( TyCoBinder (..) )+import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) import GHC.Core.Opt.Arity( collectBindersPushingCo )  import GHC.Builtin.Types  ( unboxedUnitTy )@@ -531,6 +532,48 @@         f :: Eq [(a,b)] => ...  +Note [Specialisation and overlapping instances]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Here is at tricky case (see a comment in MR !8916):++    module A where+      class C a where+        meth :: a -> String+      instance {-# OVERLAPPABLE #-} C (Maybe a) where+        meth _ = "Maybe"++      {-# SPECIALISE f :: Maybe a -> Bool -> String #-}+      f :: C a => a -> Bool -> String+      f a True = f a False+      f a _    = meth a++    module B where+      import A++      instance C (Maybe Int) where+        meth _ = "Int"++      main = putStrLn $ f (Just 42 :: Maybe Int) True++Running main without optimisations yields "Int", the correct answer.+Activating optimisations yields "Maybe" due to a rewrite rule in module+A generated by the SPECIALISE pragma:++    RULE "USPEC f" forall a (d :: C a). f @a d = $sf++In B we get the call (f @(Maybe Int) (d :: C (Maybe Int))), and+that rewrites to $sf, but that isn't really right.++Overlapping instances mean that `C (Maybe Int)` is not a singleton+type: there two distinct dictionaries that have this type.  And that+spells trouble for specialistion, which really asssumes singleton+types.++For now, we just accept this problem, but it may bite us one day.+One solution would be to decline to expose any specialisation rules+to an importing module -- but that seems a bit drastic.++ ************************************************************************ *                                                                      * \subsubsection{The new specialiser}@@ -603,8 +646,10 @@               -- accidentally re-use a unique that's already in use               -- Easiest thing is to do it all at once, as if all the top-level               -- decls were mutually recursive-       ; let top_env = SE { se_subst = Core.mkEmptySubst $ mkInScopeSetList $-                                       bindersOfBinds binds+       ; let top_env = SE { se_subst = Core.mkEmptySubst $+                                        mkInScopeSetBndrs binds+                                      --    mkInScopeSetList $+                                      --  bindersOfBinds binds                           , se_module = this_mod                           , se_dflags = dflags } @@ -802,8 +847,12 @@  canSpecImport :: DynFlags -> Id -> Maybe CoreExpr canSpecImport dflags fn+  | isDataConWrapId fn+  = Nothing   -- Don't specialise data-con wrappers, even if they+              -- have dict args; there is no benefit.+   | CoreUnfolding { uf_tmpl = rhs } <- unf-    -- See Note [Specialising imported functions] point (1).+    -- CoreUnfolding: see Note [Specialising imported functions] point (1).   , isAnyInlinePragma (idInlinePragma fn)     -- See Note [Specialising imported functions] point (2).   = Just rhs@@ -1506,12 +1555,12 @@    | otherwise   -- No calls or RHS doesn't fit our preconceptions   = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me)-          "Missed specialisation opportunity" (ppr fn $$ _trace_doc) $+          "Missed specialisation opportunity for" (ppr fn $$ trace_doc) $           -- Note [Specialisation shape]     -- pprTrace "specCalls: none" (ppr fn <+> ppr calls_for_me) $     return ([], [], emptyUDs)   where-    _trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ]+    trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ]      fn_type   = idType fn     fn_arity  = idArity fn@@ -1575,9 +1624,17 @@              else         do { -- Run the specialiser on the specialised RHS              -- The "1" suffix is before we maybe add the void arg-           ; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs1 ++ leftover_bndrs) rhs_body-           ; let spec_fn_ty1 = exprType spec_rhs1+           ; (rhs_body', rhs_uds) <- specExpr rhs_env2 rhs_body+                -- Add the { d1' = dx1; d2' = dx2 } usage stuff+                -- to the rhs_uds; see Note [Specialising Calls]+           ; let rhs_uds_w_dx   = dx_binds `consDictBinds` rhs_uds+                 spec_rhs_bndrs = spec_bndrs1 ++ leftover_bndrs+                 (spec_uds, dumped_dbs) = dumpUDs spec_rhs_bndrs rhs_uds_w_dx+                 spec_rhs1 = mkLams spec_rhs_bndrs $+                             wrapDictBindsE dumped_dbs rhs_body' +                 spec_fn_ty1 = exprType spec_rhs1+                  -- Maybe add a void arg to the specialised function,                  -- to avoid unlifted bindings                  -- See Note [Specialisations Must Be Lifted]@@ -1610,15 +1667,14 @@                                     herald fn rule_bndrs rule_lhs_args                                     (mkVarApps (Var spec_fn) spec_bndrs) -                -- Add the { d1' = dx1; d2' = dx2 } usage stuff-                -- See Note [Specialising Calls]-                spec_uds = foldr consDictBind rhs_uds dx_binds-                 simpl_opts = initSimpleOpts dflags                  --------------------------------------                 -- Add a suitable unfolding; see Note [Inline specialisations]-                spec_unf = specUnfolding simpl_opts spec_bndrs (`mkApps` spec_args)+                -- The wrap_unf_body applies the original unfolding to the specialised+                -- arguments, not forgetting to wrap the dx_binds around the outside (#22358)+                wrap_unf_body body = foldr (Let . db_bind) (body `mkApps` spec_args) dx_binds+                spec_unf = specUnfolding simpl_opts spec_bndrs wrap_unf_body                                          rule_lhs_args fn_unf                  spec_inl_prag@@ -1796,12 +1852,24 @@     {-# RULE "SPEC f @Int" forall x. f @Int x $dShow = $sf #-}  This doesn’t save us much, since the arg would be removed later by-worker/wrapper, anyway, but it’s easy to do. Note, however, that we-only drop dead arguments if:+worker/wrapper, anyway, but it’s easy to do. -  1. We don’t specialise on them.-  2. They come before an argument we do specialise on.+Wrinkles +* Note that we only drop dead arguments if:+    1. We don’t specialise on them.+    2. They come before an argument we do specialise on.+  Doing the latter would require eta-expanding the RULE, which could+  make it match less often, so it’s not worth it. Doing the former could+  be more useful --- it would stop us from generating pointless+  specialisations --- but it’s more involved to implement and unclear if+  it actually provides much benefit in practice.++* If the function has a stable unfolding, specHeader has to come up with+  arguments to pass to that stable unfolding, when building the stable+  unfolding of the specialised function: this is the last field in specHeader's+  big result tuple.+   The right thing to do is to produce a LitRubbish; it should rapidly   disappear.  Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let. @@ -2251,11 +2319,11 @@   ppr (SpecDict d) = text "SpecDict" <+> ppr d   ppr UnspecArg    = text "UnspecArg" -specArgFreeVars :: SpecArg -> VarSet-specArgFreeVars (SpecType ty) = tyCoVarsOfType ty-specArgFreeVars (SpecDict dx) = exprFreeVars dx-specArgFreeVars UnspecType    = emptyVarSet-specArgFreeVars UnspecArg     = emptyVarSet+specArgFreeIds :: SpecArg -> IdSet+specArgFreeIds (SpecType {}) = emptyVarSet+specArgFreeIds (SpecDict dx) = exprFreeIds dx+specArgFreeIds UnspecType    = emptyVarSet+specArgFreeIds UnspecArg     = emptyVarSet  isSpecDict :: SpecArg -> Bool isSpecDict (SpecDict {}) = True@@ -2325,24 +2393,33 @@               , [OutBndr]    -- Binders for $sf               , [DictBind]   -- Auxiliary dictionary bindings               , [OutExpr]    -- Specialised arguments for unfolding-                             -- Same length as "args for LHS of rule"+                             -- Same length as "Args for LHS of rule"               )  -- We want to specialise on type 'T1', and so we must construct a substitution -- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding -- details.-specHeader env (bndr : bndrs) (SpecType t : args)-  = do { let env' = extendTvSubstList env [(bndr, t)]-       ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)-            <- specHeader env' bndrs args+specHeader env (bndr : bndrs) (SpecType ty : args)+  = do { -- Find qvars, the type variables to add to the binders for the rule+         -- Namely those free in `ty` that aren't in scope+         -- See (MP2) in Note [Specialising polymorphic dictionaries]+         let in_scope = Core.getSubstInScope (se_subst env)+             qvars    = scopedSort $+                        filterOut (`elemInScopeSet` in_scope) $+                        tyCoVarsOfTypeList ty+             (env1, qvars') = substBndrs env qvars+             ty'            = substTy env1 ty+             env2           = extendTvSubst env1 bndr ty'+       ; (useful, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)+            <- specHeader env2 bndrs args        ; pure ( useful-              , env''+              , env3               , leftover_bndrs-              , rule_bs-              , Type t : rule_es-              , bs'+              , qvars' ++ rule_bs+              , Type ty' : rule_es+              , qvars' ++ bs'               , dx-              , Type t : spec_args+              , Type ty' : spec_args               )        } @@ -2369,6 +2446,7 @@ -- a wildcard binder to match the dictionary (See Note [Specialising Calls] for -- the nitty-gritty), as a LHS rule and unfolding details. specHeader env (bndr : bndrs) (SpecDict d : args)+  | not (isDeadBinder bndr)   = do { (env1, bndr') <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]        ; let (env2, dx_bind, spec_dict) = bindAuxiliaryDict env1 bndr bndr' d        ; (_, env3, leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)@@ -2385,29 +2463,44 @@               )        } --- Finally, we have the unspecialised argument 'i'. We need to produce--- a binder, LHS and RHS argument for the RULE, and a binder for the--- specialised body.+-- Finally, we don't want to specialise on this argument 'i':+--   - It's an UnSpecArg, or+--   - It's a dead dictionary+-- We need to produce a binder, LHS and RHS argument for the RULE, and+-- a binder for the specialised body. -- -- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is -- why 'i' doesn't appear in our RULE above. But we have no guarantee that -- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so -- this case must be here.-specHeader env (bndr : bndrs) (UnspecArg : args)+specHeader env (bndr : bndrs) (_ : args)+    -- The "_" can be UnSpecArg, or SpecDict where the bndr is dead   = do { -- see Note [Zap occ info in rule binders]          let (env', bndr') = substBndr env (zapIdOccInfo bndr)        ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)              <- specHeader env' bndrs args++       ; let bndr_ty = idType bndr'++             -- See Note [Drop dead args from specialisations]+             -- C.f. GHC.Core.Opt.WorkWrap.Utils.mk_absent_let+             (mb_spec_bndr, spec_arg)+                | isDeadBinder bndr+                , Just lit_expr <- mkLitRubbish bndr_ty+                = (Nothing, lit_expr)+                | otherwise+                = (Just bndr', varToCoreExpr bndr')+        ; pure ( useful               , env''               , leftover_bndrs               , bndr' : rule_bs               , varToCoreExpr bndr' : rule_es-              , if isDeadBinder bndr-                  then bs' -- see Note [Drop dead args from specialisations]-                  else bndr' : bs'+              , case mb_spec_bndr of+                  Just b' -> b' : bs'+                  Nothing -> bs'               , dx-              , varToCoreExpr bndr' : spec_args+              , spec_arg : spec_args               )        } @@ -2533,6 +2626,88 @@  So the DictBinds in (ud_binds :: OrdList DictBind) may contain non-dictionary bindings too.++Note [Specialising polymorphic dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    class M a where { foo :: a -> Int }++    instance M (ST s) where ...+    -- dMST :: forall s. M (ST s)++    wimwam :: forall a. M a => a -> Int+    wimwam = /\a \(d::M a). body++    f :: ST s -> Int+    f = /\s \(x::ST s). wimwam @(ST s) (dMST @s) dx + 1++We'd like to specialise wimwam at (ST s), thus+    $swimwam :: forall s. ST s -> Int+    $swimwam = /\s. body[ST s/a, (dMST @s)/d]++    RULE forall s (d :: M (ST s)).+         wimwam @(ST s) d = $swimwam @s++Here are the moving parts:++(MP1) We must /not/ dump the CallInfo+        CIS wimwam (CI { ci_key = [@(ST s), dMST @s]+                       , ci_fvs = {dMST} })+      when we come to the /\s.  Instead, we simply let it continue to float+      upwards. Hence ci_fvs is an IdSet, listing the /Ids/ that+      are free in the call, but not the /TyVars/.  Hence using specArgFreeIds+      in singleCall.++  NB to be fully kosher we should explicitly quantifying the CallInfo+  over 's', but we don't bother.  This would matter if there was an+  enclosing binding of the same 's', which I don't expect to happen.++(MP2) When we come to specialise the call, we must remember to quantify+      over 's'.  That is done in the SpecType case of specHeader, where+      we add 's' (called qvars) to the binders of the RULE and the specialised+      function.++(MP3) If we have f :: forall m. Monoid m => blah, and two calls+        (f @(Endo b)      (d :: Monoid (Endo b))+        (f @(Endo (c->c)) (d :: Monoid (Endo (c->c)))+      we want to generate a specialisation only for the first.  The second+      is just a substitution instance of the first, with no greater specialisation.+      Hence the call to `remove_dups` in `filterCalls`.++All this arose in #13873, in the unexpected form that a SPECIALISE+pragma made the program slower!  The reason was that the specialised+function $sinsertWith arising from the pragma looked rather like `f`+above, and failed to specialise a call in its body like wimwam.+Without the pragma, the original call to `insertWith` was completely+monomorpic, and specialised in one go.++Wrinkles.++* With -XOverlappingInstances you might worry about this:+    class C a where ...+    instance C (Maybe Int) where ...   -- $df1 :: C (Maybe Int)+    instance C (Maybe a)   where ...   -- $df2 :: forall a. C (Maybe a)++    f :: C a => blah+    f = rhs++    g = /\a.  ...(f @(Maybe a) ($df2 a))...+    h = ...f @(Maybe Int) $df1++  There are two calls to f, but with different evidence.  This patch will+  combine them into one.  But it's OK: this code will never arise unless you+  use -XIncoherentInstances.  Even with -XOverlappingInstances, GHC tries hard+  to keep dictionaries as singleton types.  But that goes out of the window+  with -XIncoherentInstances -- and that is true even with ordianry type-class+  specialisation (at least if any inlining has taken place).++  GHC makes very few guarantees when you use -XIncoherentInstances, and its+  not worth crippling the normal case for the incoherent corner.  (The best+  thing might be to switch off specialisation altogether if incoherence is+  involved... but incoherence is a property of an instance, not a class, so+  it's a hard test to make.)++  But see Note [Specialisation and overlapping instances]. -}  instance Outputable DictBind where@@ -2571,8 +2746,9 @@ data CallInfo   = CI { ci_key  :: [SpecArg]   -- All arguments        , ci_fvs  :: IdSet       -- Free Ids of the ci_key call-                                -- _not_ including the main id itself, of course+                                -- /not/ including the main id itself, of course                                 -- NB: excluding tyvars:+                                --     See Note [Specialising polymorphic dictionaries]     }  type DictExpr = CoreExpr@@ -2618,17 +2794,12 @@ singleCall id args   = MkUD {ud_binds = emptyFDBs,           ud_calls = unitDVarEnv id $ CIS id $-                     unitBag (CI { ci_key  = args -- used to be tys+                     unitBag (CI { ci_key  = args                                  , ci_fvs  = call_fvs }) }   where-    call_fvs = foldr (unionVarSet . specArgFreeVars) emptyVarSet args-        -- The type args (tys) are guaranteed to be part of the dictionary-        -- types, because they are just the constrained types,-        -- and the dictionary is therefore sure to be bound-        -- inside the binding for any type variables free in the type;-        -- hence it's safe to neglect tyvars free in tys when making-        -- the free-var set for this call-        -- BUT I don't trust this reasoning; play safe and include tys_fvs+    call_fvs = foldr (unionVarSet . specArgFreeIds) emptyVarSet args+        -- specArgFreeIds: we specifically look for free Ids, not TyVars+        --    see (MP1) in Note [Specialising polymorphic dictionaries]         --         -- We don't include the 'id' itself. @@ -2880,11 +3051,6 @@   = uds { ud_binds = FDB { fdb_binds = binds `appOL`        (toOL dbs)                          , fdb_bndrs = bs    `extendVarSetList` bindersOfDictBinds dbs } } -consDictBind :: DictBind -> UsageDetails -> UsageDetails-consDictBind db uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs=bs}}-  = uds { ud_binds = FDB { fdb_binds = db `consOL` binds-                         , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }- consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails consDictBinds dbs uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}}   = uds { ud_binds = FDB{ fdb_binds = toOL dbs `appOL` binds@@ -2951,15 +3117,15 @@  ---------------------- filterCalls :: CallInfoSet -> FloatedDictBinds -> [CallInfo]--- Remove dominated calls+-- Remove dominated calls (Note [Specialising polymorphic dictionaries]) -- and loopy DFuns (Note [Avoiding loops (DFuns)]) filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs })   | isDFunId fn  -- Note [Avoiding loops (DFuns)] applies only to DFuns-  = filter ok_call unfiltered_calls+  = filter ok_call de_dupd_calls   | otherwise         -- Do not apply it to non-DFuns-  = unfiltered_calls  -- See Note [Avoiding loops (non-DFuns)]+  = de_dupd_calls  -- See Note [Avoiding loops (non-DFuns)]   where-    unfiltered_calls = bagToList call_bag+    de_dupd_calls = remove_dups call_bag      dump_set = foldl' go (unitVarSet fn) dbs       -- This dump-set could also be computed by splitDictBinds@@ -2973,6 +3139,31 @@      ok_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` dump_set +remove_dups :: Bag CallInfo -> [CallInfo]+-- Calls involving more generic instances beat more specific ones.+-- See (MP3) in Note [Specialising polymorphic dictionaries]+remove_dups calls = foldr add [] calls+  where+    add :: CallInfo -> [CallInfo] -> [CallInfo]+    add ci [] = [ci]+    add ci1 (ci2:cis) | ci2 `beats_or_same` ci1 = ci2:cis+                      | ci1 `beats_or_same` ci2 = ci1:cis+                      | otherwise               = ci2 : add ci1 cis++beats_or_same :: CallInfo -> CallInfo -> Bool+beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 })+  = go args1 args2+  where+    go [] _ = True+    go (arg1:args1) (arg2:args2) = go_arg arg1 arg2 && go args1 args2+    go (_:_)        []           = False++    go_arg (SpecType ty1) (SpecType ty2) = isJust (tcMatchTy ty1 ty2)+    go_arg UnspecType     UnspecType     = True+    go_arg (SpecDict {})  (SpecDict {})  = True+    go_arg UnspecArg      UnspecArg      = True+    go_arg _              _              = False+ ---------------------- splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, OrdList DictBind, IdSet) -- splitDictBinds dbs bndrs returns@@ -3003,15 +3194,18 @@  ---------------------- deleteCallsMentioning :: VarSet -> CallDetails -> CallDetails--- Remove calls *mentioning* bs in any way-deleteCallsMentioning bs calls+-- Remove calls mentioning any Id in bndrs+-- NB: The call is allowed to mention TyVars in bndrs+--     Note [Specialising polymorphic dictionaries]+--     ci_fvs are just the free /Ids/+deleteCallsMentioning bndrs calls   = mapDVarEnv (ciSetFilter keep_call) calls   where-    keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bs+    keep_call (CI { ci_fvs = fvs }) = fvs `disjointVarSet` bndrs  deleteCallsFor :: [Id] -> CallDetails -> CallDetails--- Remove calls *for* bs-deleteCallsFor bs calls = delDVarEnvList calls bs+-- Remove calls *for* bndrs+deleteCallsFor bndrs calls = delDVarEnvList calls bndrs  {- ************************************************************************@@ -3034,9 +3228,9 @@                               (ys, uds2) <- mapAndCombineSM f xs                               return (y:ys, uds1 `thenUDs` uds2) -extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv-extendTvSubstList env tv_binds-  = env { se_subst = Core.extendTvSubstList (se_subst env) tv_binds }+extendTvSubst :: SpecEnv -> TyVar -> Type -> SpecEnv+extendTvSubst env tv ty+  = env { se_subst = Core.extendTvSubst (se_subst env) tv ty }  extendInScope :: SpecEnv -> OutId -> SpecEnv extendInScope env@(SE { se_subst = subst }) bndr

@@ -14,13 +14,10 @@ -- And, as we have the info in hand, we may convert some lets to -- let-no-escapes. -module GHC.CoreToStg ( coreToStg ) where+module GHC.CoreToStg ( CoreToStgOpts (..), coreToStg ) where  import GHC.Prelude -import GHC.Driver.Session-import GHC.Driver.Config.Stg.Debug- import GHC.Core import GHC.Core.Utils   ( exprType, findDefault, isJoinBind                         , exprIsTickedString_maybe )@@ -50,6 +47,7 @@  import GHC.Unit.Module import GHC.Data.FastString+import GHC.Platform        ( Platform ) import GHC.Platform.Ways import GHC.Builtin.PrimOps ( PrimCall(..), primOpWrapperId ) @@ -62,7 +60,6 @@  import Control.Monad (ap) import Data.Maybe (fromMaybe)-import Data.Tuple (swap)  -- Note [Live vs free] -- ~~~~~~~~~~~~~~~~~~~@@ -235,24 +232,29 @@ -- --------------------------------------------------------------  -coreToStg :: DynFlags -> Module -> ModLocation -> CoreProgram+coreToStg :: CoreToStgOpts -> Module -> ModLocation -> CoreProgram           -> ([StgTopBinding], InfoTableProvMap, CollectedCCs)-coreToStg dflags this_mod ml pgm+coreToStg opts@CoreToStgOpts+  { coreToStg_ways = ways+  , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs+  , coreToStg_InfoTableMap = opt_InfoTableMap+  , coreToStg_stgDebugOpts = stgDebugOpts+  } this_mod ml pgm   = (pgm'', denv, final_ccs)   where     (_, (local_ccs, local_cc_stacks), pgm')-      = coreTopBindsToStg dflags this_mod emptyVarEnv emptyCollectedCCs pgm+      = coreTopBindsToStg opts this_mod emptyVarEnv emptyCollectedCCs pgm      -- See Note [Mapping Info Tables to Source Positions]-    (!pgm'', !denv) =-        if gopt Opt_InfoTableMap dflags-          then collectDebugInformation (initStgDebugOpts dflags) ml pgm'-          else (pgm', emptyInfoTableProvMap)+    (!pgm'', !denv)+      | opt_InfoTableMap+      = collectDebugInformation stgDebugOpts ml pgm'+      | otherwise = (pgm', emptyInfoTableProvMap) -    prof = ways dflags `hasWay` WayProf+    prof = hasWay ways WayProf      final_ccs-      | prof && gopt Opt_AutoSccsOnIndividualCafs dflags+      | prof && opt_AutoSccsOnIndividualCafs       = (local_ccs,local_cc_stacks)  -- don't need "all CAFs" CC       | prof       = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks)@@ -262,7 +264,7 @@     (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod  coreTopBindsToStg-    :: DynFlags+    :: CoreToStgOpts     -> Module     -> IdEnv HowBound           -- environment for the bindings     -> CollectedCCs@@ -271,17 +273,17 @@  coreTopBindsToStg _      _        env ccs []   = (env, ccs, [])-coreTopBindsToStg dflags this_mod env ccs (b:bs)+coreTopBindsToStg opts this_mod env ccs (b:bs)   | NonRec _ rhs <- b, isTyCoArg rhs-  = coreTopBindsToStg dflags this_mod env1 ccs1 bs+  = coreTopBindsToStg opts this_mod env1 ccs1 bs   | otherwise   = (env2, ccs2, b':bs')   where-    (env1, ccs1, b' ) = coreTopBindToStg dflags this_mod env ccs b-    (env2, ccs2, bs') = coreTopBindsToStg dflags this_mod env1 ccs1 bs+    (env1, ccs1, b' ) = coreTopBindToStg opts this_mod env ccs b+    (env2, ccs2, bs') = coreTopBindsToStg opts this_mod env1 ccs1 bs  coreTopBindToStg-        :: DynFlags+        :: CoreToStgOpts         -> Module         -> IdEnv HowBound         -> CollectedCCs@@ -297,16 +299,18 @@         how_bound = LetBound TopLet 0     in (env', ccs, StgTopStringLit id str) -coreTopBindToStg dflags this_mod env ccs (NonRec id rhs)+coreTopBindToStg opts@CoreToStgOpts+  { coreToStg_platform = platform+  } this_mod env ccs (NonRec id rhs)   = let         env'      = extendVarEnv env id how_bound         how_bound = LetBound TopLet $! manifestArity rhs -        (stg_rhs, ccs') =-            initCts dflags env $-              coreToTopStgRhs dflags ccs this_mod (id,rhs)+        (ccs', (id', stg_rhs)) =+            initCts platform env $+              coreToTopStgRhs opts this_mod ccs (id,rhs) -        bind = StgTopLifted $ StgNonRec id stg_rhs+        bind = StgTopLifted $ StgNonRec id' stg_rhs     in       -- NB: previously the assertion printed 'rhs' and 'bind'       --     as well as 'id', but that led to a black hole@@ -314,42 +318,38 @@       --     assertion again!     (env', ccs', bind) -coreTopBindToStg dflags this_mod env ccs (Rec pairs)+coreTopBindToStg opts@CoreToStgOpts+  { coreToStg_platform = platform+  } this_mod env ccs (Rec pairs)   = assert (not (null pairs)) $     let-        binders = map fst pairs-         extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)                      | (b, rhs) <- pairs ]         env' = extendVarEnvList env extra_env'          -- generate StgTopBindings and CAF cost centres created for CAFs         (ccs', stg_rhss)-          = initCts dflags env' $-              mapAccumLM (\ccs rhs -> swap <$> coreToTopStgRhs dflags ccs this_mod rhs)-                         ccs-                         pairs-        bind = StgTopLifted $ StgRec (zip binders stg_rhss)+          = initCts platform env' $ mapAccumLM (coreToTopStgRhs opts this_mod) ccs pairs+        bind = StgTopLifted $ StgRec stg_rhss     in     (env', ccs', bind)  coreToTopStgRhs-        :: DynFlags-        -> CollectedCCs+        :: CoreToStgOpts         -> Module+        -> CollectedCCs         -> (Id,CoreExpr)-        -> CtsM (StgRhs, CollectedCCs)+        -> CtsM (CollectedCCs, (Id, StgRhs)) -coreToTopStgRhs dflags ccs this_mod (bndr, rhs)+coreToTopStgRhs opts this_mod ccs (bndr, rhs)   = do { new_rhs <- coreToPreStgRhs rhs         ; let (stg_rhs, ccs') =-               mkTopStgRhs dflags this_mod ccs bndr new_rhs+               mkTopStgRhs opts this_mod ccs bndr new_rhs              stg_arity =                stgRhsArity stg_rhs -       ; return (assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs,-                 ccs') }+       ; pure (ccs', (bndr, assertPpr (arity_ok stg_arity) (mk_arity_msg stg_arity) stg_rhs)) }   where         -- It's vital that the arity on a top-level Id matches         -- the arity of the generated STG binding, else an importing@@ -616,7 +616,7 @@         -- or foreign call.         -- Wanted: a better solution than this hacky warning -    platform <- targetPlatform <$> getDynFlags+    platform <- getPlatform     let         arg_rep = typePrimRep (exprType arg)         stg_arg_rep = typePrimRep (stgArgType stg_arg)@@ -708,10 +708,14 @@  -- Generate a top-level RHS. Any new cost centres generated for CAFs will be -- appended to `CollectedCCs` argument.-mkTopStgRhs :: DynFlags -> Module -> CollectedCCs+mkTopStgRhs :: CoreToStgOpts -> Module -> CollectedCCs             -> Id -> PreStgRhs -> (StgRhs, CollectedCCs) -mkTopStgRhs dflags this_mod ccs bndr (PreStgRhs bndrs rhs)+mkTopStgRhs CoreToStgOpts+  { coreToStg_platform = platform+  , coreToStg_ExternalDynamicRefs = opt_ExternalDynamicRefs+  , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs+  } this_mod ccs bndr (PreStgRhs bndrs rhs)   | not (null bndrs)   = -- The list of arguments is non-empty, so not CAF     ( StgRhsClosure noExtFieldSilent@@ -724,14 +728,14 @@   -- so this is not a function binding   | StgConApp con mn args _ <- unticked_rhs   , -- Dynamic StgConApps are updatable-    not (isDllConApp (targetPlatform dflags) (gopt Opt_ExternalDynamicRefs dflags) this_mod con args)+    not (isDllConApp platform opt_ExternalDynamicRefs this_mod con args)   = -- CorePrep does this right, but just to make sure     assertPpr (not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con))               (ppr bndr $$ ppr con $$ ppr args)     ( StgRhsCon dontCareCCS con mn ticks args, ccs )    -- Otherwise it's a CAF, see Note [Cost-centre initialization plan].-  | gopt Opt_AutoSccsOnIndividualCafs dflags+  | opt_AutoSccsOnIndividualCafs   = ( StgRhsClosure noExtFieldSilent                     caf_ccs                     upd_flag [] rhs@@ -855,7 +859,7 @@ -- *down*.  newtype CtsM a = CtsM-    { unCtsM :: DynFlags -- Needed for checking for bad coercions in coreToStgArgs+    { unCtsM :: Platform -- Needed for checking for bad coercions in coreToStgArgs              -> IdEnv HowBound              -> a     }@@ -893,8 +897,8 @@  -- The std monad functions: -initCts :: DynFlags -> IdEnv HowBound -> CtsM a -> a-initCts dflags env m = unCtsM m dflags env+initCts :: Platform -> IdEnv HowBound -> CtsM a -> a+initCts platform env m = unCtsM m platform env   @@ -905,8 +909,8 @@ returnCts e = CtsM $ \_ _ -> e  thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b-thenCts m k = CtsM $ \dflags env-  -> unCtsM (k (unCtsM m dflags env)) dflags env+thenCts m k = CtsM $ \platform env+  -> unCtsM (k (unCtsM m platform env)) platform env  instance Applicative CtsM where     pure = returnCts@@ -915,15 +919,15 @@ instance Monad CtsM where     (>>=)  = thenCts -instance HasDynFlags CtsM where-    getDynFlags = CtsM $ \dflags _ -> dflags+getPlatform :: CtsM Platform+getPlatform = CtsM const  -- Functions specific to this monad:  extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a extendVarEnvCts ids_w_howbound expr-   =    CtsM $   \dflags env-   -> unCtsM expr dflags (extendVarEnvList env ids_w_howbound)+   =    CtsM $   \platform env+   -> unCtsM expr platform (extendVarEnvList env ids_w_howbound)  lookupVarCts :: Id -> CtsM HowBound lookupVarCts v = CtsM $ \_ env -> lookupBinding env v@@ -995,3 +999,12 @@ stgArity _ (LetBound _ arity) = arity stgArity f ImportBound        = idArity f stgArity _ LambdaBound        = 0++data CoreToStgOpts = CoreToStgOpts+  { coreToStg_platform :: Platform+  , coreToStg_ways :: Ways+  , coreToStg_AutoSccsOnIndividualCafs :: Bool+  , coreToStg_InfoTableMap :: Bool+  , coreToStg_ExternalDynamicRefs :: Bool+  , coreToStg_stgDebugOpts :: StgDebugOpts+  }

@@ -106,8 +106,9 @@                         -- Not doing so caused #20396.     -- Cribbed from: preprocessFile / GHC.Driver.Pipeline     liftIO $ checkProcessArgsResult unhandled_flags-    liftIO $ printOrThrowDiagnostics logger (initDiagOpts dflags) (GhcPsMessage <$> p_warns)-    liftIO $ handleFlagWarnings logger (initDiagOpts dflags) warns+    let print_config = initPrintConfig dflags+    liftIO $ printOrThrowDiagnostics logger print_config (initDiagOpts dflags) (GhcPsMessage <$> p_warns)+    liftIO $ handleFlagWarnings logger print_config (initDiagOpts dflags) warns     -- TODO: Preprocessing not implemented      buf <- liftIO $ hGetStringBuffer src_filename@@ -340,7 +341,7 @@         -- Compile relevant only         hsc_env <- getSession         let home_mod_infos = eltsUDFM (hsc_HPT hsc_env)-            linkables = map (expectJust "bkp link" . hm_linkable)+            linkables = map (expectJust "bkp link" . homeModInfoObject)                       . filter ((==HsSrcFile) . mi_hsc_src . hm_iface)                       $ home_mod_infos             getOfiles LM{ linkableUnlinked = us } = map nameOfObject (filter isObject us)

@@ -330,7 +330,7 @@  = {-# SCC profilingInitCode #-}    initializerCStub platform fn_name decls body  where-   pdocC = pprCLabel platform CStyle+   pdocC = pprCLabel platform    fn_name = mkInitializerStubLabel this_mod "prof_init"    decls = vcat         $  map emit_cc_decl local_CCs@@ -369,24 +369,17 @@   :: Bool            -- is Opt_InfoTableMap enabled or not   -> Platform   -> Module-  -> [InfoProvEnt]   -> CStub-ipInitCode do_info_table platform this_mod ents+ipInitCode do_info_table platform this_mod   | not do_info_table = mempty-  | otherwise = initializerCStub platform fn_nm decls body+  | otherwise = initializerCStub platform fn_nm ipe_buffer_decl 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)-   local_ipe_list_label = text "local_ipe_" <> ppr this_mod-   emit_ipe_list ipes =-      text "static InfoProvEnt *" <> local_ipe_list_label <> text "[] ="-      <+> braces (vcat $ [ pprCLabel platform CStyle (mkIPELabel ipe) <> comma-                         | ipe <- ipes-                         ] ++ [text "NULL"])-      <> semi++   body = text "registerInfoProvList" <> parens (text "&" <> ipe_buffer_label) <> semi++   ipe_buffer_label = pprCLabel platform (mkIPELabel this_mod)++   ipe_buffer_decl =+       text "extern IpeBufferListNode" <+> ipe_buffer_label <> text ";"+

@@ -2,7 +2,6 @@   ( initSimplifyExprOpts   , initSimplifyOpts   , initSimplMode-  , initGentleSimplMode   ) where  import GHC.Prelude@@ -27,12 +26,13 @@ initSimplifyExprOpts :: DynFlags -> InteractiveContext -> SimplifyExprOpts initSimplifyExprOpts dflags ic = SimplifyExprOpts   { se_fam_inst = snd $ ic_instances ic-  , se_mode = (initSimplMode dflags InitialPhase "GHCi")-    { sm_inline = False-      -- Do not do any inlining, in case we expose some-      -- unboxed tuple stuff that confuses the bytecode++  , se_mode = (initSimplMode dflags) { sm_names = ["GHCi"]+                                     , sm_inline = False }+      -- sm_inline: do not do any inlining, in case we expose+      -- some unboxed tuple stuff that confuses the bytecode       -- interpreter-    }+   , se_top_env_cfg = TopEnvConfig     { te_history_size = historySize dflags     , te_tick_factor = simplTickFactor dflags@@ -57,31 +57,25 @@     }   in opts -initSimplMode :: DynFlags -> CompilerPhase -> String -> SimplMode-initSimplMode dflags phase name = SimplMode-  { sm_names = [name]-  , sm_phase = phase-  , sm_rules = gopt Opt_EnableRewriteRules dflags-  , sm_eta_expand = gopt Opt_DoLambdaEtaExpansion dflags-  , sm_cast_swizzle = True-  , sm_inline = True-  , sm_uf_opts = unfoldingOpts dflags-  , sm_case_case = True-  , sm_pre_inline = gopt Opt_SimplPreInlining dflags-  , sm_float_enable = floatEnable dflags+initSimplMode :: DynFlags -> SimplMode+initSimplMode dflags = SimplMode+  { sm_names = ["Unknown simplifier run"]  -- Always overriden+  , sm_phase = InitialPhase+  , sm_rules            = gopt Opt_EnableRewriteRules dflags+  , sm_eta_expand       = gopt Opt_DoLambdaEtaExpansion dflags+  , sm_pre_inline       = gopt Opt_SimplPreInlining dflags   , sm_do_eta_reduction = gopt Opt_DoEtaReduction dflags-  , sm_arity_opts = initArityOpts dflags-  , sm_rule_opts = initRuleOpts dflags-  , sm_case_folding = gopt Opt_CaseFolding dflags-  , sm_case_merge = gopt Opt_CaseMerge dflags-  , sm_co_opt_opts = initOptCoercionOpts dflags-  }--initGentleSimplMode :: DynFlags -> SimplMode-initGentleSimplMode dflags = (initSimplMode dflags InitialPhase "Gentle")-  { -- Don't do case-of-case transformations.-    -- This makes full laziness work better-    sm_case_case = False+  , sm_uf_opts          = unfoldingOpts dflags+  , sm_float_enable     = floatEnable dflags+  , sm_arity_opts       = initArityOpts dflags+  , sm_rule_opts        = initRuleOpts dflags+  , sm_case_folding     = gopt Opt_CaseFolding dflags+  , sm_case_merge       = gopt Opt_CaseMerge dflags+  , sm_co_opt_opts      = initOptCoercionOpts dflags+  , sm_cast_swizzle = True+  , sm_inline       = True+  , sm_case_case    = True+  , sm_keep_exits   = False   }  floatEnable :: DynFlags -> FloatEnable

@@ -0,0 +1,16 @@+module GHC.Driver.Config.CoreToStg where++import GHC.Driver.Config.Stg.Debug+import GHC.Driver.Session++import GHC.CoreToStg++initCoreToStgOpts :: DynFlags -> CoreToStgOpts+initCoreToStgOpts dflags = CoreToStgOpts+  { coreToStg_platform = targetPlatform dflags+  , coreToStg_ways = ways dflags+  , coreToStg_AutoSccsOnIndividualCafs = gopt Opt_AutoSccsOnIndividualCafs dflags+  , coreToStg_InfoTableMap = gopt Opt_InfoTableMap dflags+  , coreToStg_ExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags+  , coreToStg_stgDebugOpts = initStgDebugOpts dflags+  }

@@ -26,11 +26,9 @@ import GHC.Settings (Platform, platformUnregisterised) import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState) import GHC.StgToCmm.Prof (initInfoTableProv)-import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)-import GHC.Stg.InferTags.TagSig (TagSig)+import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos) import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation) import GHC.Types.Name.Set (NonCaffySet)-import GHC.Types.Name.Env (NameEnv) import GHC.Types.Tickish (GenTickish (SourceNote)) import GHC.Unit.Types (Module) import GHC.Utils.Misc@@ -180,8 +178,8 @@     remembered in a `Maybe`. -} -generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> NameEnv TagSig -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CgInfos-generateCgIPEStub hsc_env this_mod denv tag_sigs s = do+generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CmmCgInfos+generateCgIPEStub hsc_env this_mod denv s = do   let dflags   = hsc_dflags hsc_env       platform = targetPlatform dflags       logger   = hsc_logger hsc_env@@ -200,7 +198,7 @@   (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline logger cmm_cfg (emptySRT this_mod) ipeCmmGroup   Stream.yield ipeCmmGroupSRTs -  return CgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub, cgTagSigs = tag_sigs}+  return CmmCgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub}   where     collect :: Platform -> [(Label, CmmInfoTable, Maybe IpeSourceLocation)] -> CmmGroupSRTs -> IO ([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs)     collect platform acc cmmGroupSRTs = do

@@ -3,6 +3,8 @@  {-# LANGUAGE NondecreasingIndentation #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeApplications #-}  {-# OPTIONS_GHC -fprof-auto-top #-} @@ -46,11 +48,16 @@     , Messager, batchMsg, batchMultiMsg     , HscBackendAction (..), HscRecompStatus (..)     , initModDetails+    , initWholeCoreBindings     , hscMaybeWriteIface     , hscCompileCmmFile      , hscGenHardCode     , hscInteractive+    , mkCgInteractiveGuts+    , CgInteractiveGuts+    , generateByteCode+    , generateFreshByteCode      -- * Running passes separately     , hscRecompStatus@@ -116,6 +123,7 @@ import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyExprOpts ) import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO ) import GHC.Driver.Config.Core.Lint.Interactive ( lintInteractiveExpr )+import GHC.Driver.Config.CoreToStg import GHC.Driver.Config.CoreToStg.Prep import GHC.Driver.Config.Logger   (initLogFlags) import GHC.Driver.Config.Parser   (initParserOpts)@@ -146,7 +154,7 @@  import GHC.StgToByteCode    ( byteCodeGen ) -import GHC.IfaceToCore  ( typecheckIface )+import GHC.IfaceToCore  ( typecheckIface, typecheckWholeCoreBindings )  import GHC.Iface.Load   ( ifaceStats, writeIface ) import GHC.Iface.Make@@ -186,15 +194,14 @@ import GHC.Tc.Utils.Zonk    ( ZonkFlexi (DefaultFlexi) )  import GHC.Stg.Syntax-import GHC.Stg.Pipeline ( stg2stg )-import GHC.Stg.InferTags+import GHC.Stg.Pipeline ( stg2stg, StgCgInfos )  import GHC.Builtin.Utils import GHC.Builtin.Names import GHC.Builtin.Uniques ( mkPseudoUniqueE )  import qualified GHC.StgToCmm as StgToCmm ( codeGen )-import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)+import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos)  import GHC.Cmm import GHC.Cmm.Info.Build@@ -261,15 +268,24 @@ import Data.IORef import System.FilePath as FilePath import System.Directory-import System.IO (fixIO) import qualified Data.Set as S import Data.Set (Set) import Data.Functor import Control.DeepSeq (force) import Data.Bifunctor (first) import Data.List.NonEmpty (NonEmpty ((:|)))+import GHC.Unit.Module.WholeCoreBindings+import GHC.Types.TypeEnv+import System.IO+import {-# SOURCE #-} GHC.Driver.Pipeline+import Data.Time +import System.IO.Unsafe ( unsafeInterleaveIO )+import GHC.Iface.Env ( trace_if )+import GHC.Stg.InferTags.TagSig (seqTagSig)+import GHC.Types.Unique.FM + {- ********************************************************************** %*                                                                      *                 Initialisation@@ -367,9 +383,10 @@ handleWarnings :: Hsc () handleWarnings = do     diag_opts <- initDiagOpts <$> getDynFlags+    print_config <- initPrintConfig <$> getDynFlags     logger <- getLogger     w <- getDiagnostics-    liftIO $ printOrThrowDiagnostics logger diag_opts w+    liftIO $ printOrThrowDiagnostics logger print_config diag_opts w     clearDiagnostics  -- | log warning in the monad, and if there are errors then@@ -387,7 +404,7 @@     logDiagnostics (GhcPsMessage <$> warnings)     logger <- getLogger     let (wWarns, wErrs) = partitionMessages warnings-    liftIO $ printMessages logger diag_opts wWarns+    liftIO $ printMessages logger NoDiagnosticOpts diag_opts wWarns     throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs  -- | Deal with errors and warnings returned by a compilation step@@ -674,7 +691,7 @@                     Nothing -> hscParse' mod_summary             tc_result0 <- tcRnModule' mod_summary keep_rn' hpm             if hsc_src == HsigFile-                then do (iface, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary+                then do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary                         ioMsgMaybe $ hoistTcRnMessage $                             tcRnMergeSignatures hsc_env hpm tc_result0 iface                 else return tc_result0@@ -804,7 +821,7 @@                 -> HscEnv                 -> ModSummary                 -> Maybe ModIface-                -> Maybe Linkable+                -> HomeModLinkable                 -> (Int,Int)                 -> IO HscRecompStatus hscRecompStatus@@ -833,26 +850,60 @@         if not (backendGeneratesCode (backend lcl_dflags)) then             -- No need for a linkable, we're good to go           do msg $ UpToDate-             return $ HscUpToDate checked_iface Nothing+             return $ HscUpToDate checked_iface emptyHomeModInfoLinkable         else           -- Do need linkable           do-            -- Check to see whether the expected build products already exist.-            -- If they don't exists then we trigger recompilation.-            recomp_linkable_result <- case () of-               -- Interpreter can use either already loaded bytecode or loaded object code-               _ | backendCanReuseLoadedCode (backend lcl_dflags) -> do-                     let res = checkByteCode old_linkable-                     case res of-                       UpToDateItem _ -> pure res-                       _ -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary-                 -- Need object files for making object files-                 | backendWritesFiles (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary-                 | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags)+            -- 1. Just check whether we have bytecode/object linkables and then+            -- we will decide if we need them or not.+            bc_linkable <- checkByteCode checked_iface mod_summary (homeMod_bytecode old_linkable)+            obj_linkable <- liftIO $ checkObjects lcl_dflags (homeMod_object old_linkable) mod_summary+            trace_if (hsc_logger hsc_env) (vcat [text "BCO linkable", nest 2 (ppr bc_linkable), text "Object Linkable", ppr obj_linkable])++            let just_bc = justBytecode <$> bc_linkable+                just_o  = justObjects  <$> obj_linkable+                _maybe_both_os = case (bc_linkable, obj_linkable) of+                            (UpToDateItem bc, UpToDateItem o) -> UpToDateItem (bytecodeAndObjects bc o)+                            -- If missing object code, just say we need to recompile because of object code.+                            (_, OutOfDateItem reason _) -> OutOfDateItem reason Nothing+                            -- If just missing byte code, just use the object code+                            -- so you should use -fprefer-byte-code with -fwrite-if-simplified-core or you'll+                            -- end up using bytecode on recompilation+                            (_, UpToDateItem {} ) -> just_o++                definitely_both_os = case (bc_linkable, obj_linkable) of+                            (UpToDateItem bc, UpToDateItem o) -> UpToDateItem (bytecodeAndObjects bc o)+                            -- If missing object code, just say we need to recompile because of object code.+                            (_, OutOfDateItem reason _) -> OutOfDateItem reason Nothing+                            -- If just missing byte code, just use the object code+                            -- so you should use -fprefer-byte-code with -fwrite-if-simplified-core or you'll+                            -- end up using bytecode on recompilation+                            (OutOfDateItem reason _,  _ ) -> OutOfDateItem reason Nothing++--            pprTraceM "recomp" (ppr just_bc <+> ppr just_o)+            -- 2. Decide which of the products we will need+            let recomp_linkable_result = case () of+                  _ | backendCanReuseLoadedCode (backend lcl_dflags) ->+                        case bc_linkable of+                          -- If bytecode is available for Interactive then don't load object code+                          UpToDateItem _ -> just_bc+                          _ -> case obj_linkable of+                                  -- If o is availabe, then just use that+                                  UpToDateItem _ -> just_o+                                  _ -> outOfDateItemBecause MissingBytecode Nothing+                     -- Need object files for making object files+                     | backendWritesFiles (backend lcl_dflags) ->+                        if gopt Opt_ByteCodeAndObjectCode lcl_dflags+                          -- We say we are going to write both, so recompile unless we have both+                          then definitely_both_os+                          -- Only load the object file unless we are saying we need to produce both.+                          -- Unless we do this then you can end up using byte-code for a module you specify -fobject-code for.+                          else just_o+                     | otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags)             case recomp_linkable_result of               UpToDateItem linkable -> do                 msg $ UpToDate-                return $ HscUpToDate checked_iface $ Just linkable+                return $ HscUpToDate checked_iface $ linkable               OutOfDateItem reason _ -> do                 msg $ NeedsRecompile reason                 return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface@@ -892,14 +943,24 @@ -- | Check to see if we can reuse the old linkable, by this point we will -- have just checked that the old interface matches up with the source hash, so -- no need to check that again here-checkByteCode :: Maybe Linkable -> MaybeValidated Linkable-checkByteCode mb_old_linkable =+checkByteCode :: ModIface -> ModSummary -> Maybe Linkable -> IO (MaybeValidated Linkable)+checkByteCode iface mod_sum mb_old_linkable =   case mb_old_linkable of     Just old_linkable       | not (isObjectLinkable old_linkable)-      -> UpToDateItem old_linkable-    _ -> outOfDateItemBecause MissingBytecode Nothing+      -> return $ (UpToDateItem old_linkable)+    _ -> loadByteCode iface mod_sum +loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated Linkable)+loadByteCode iface mod_sum = do+    let+      this_mod   = ms_mod mod_sum+      if_date    = fromJust $ ms_iface_date mod_sum+    case mi_extra_decls iface of+      Just extra_decls -> do+          let fi = WholeCoreBindings extra_decls this_mod (ms_location mod_sum)+          return (UpToDateItem (LM if_date this_mod [CoreBindings fi]))+      _ -> return $ outOfDateItemBecause MissingBytecode Nothing -------------------------------------------------------------- -- Compilers --------------------------------------------------------------@@ -907,11 +968,11 @@  -- Knot tying!  See Note [Knot-tying typecheckIface] -- See Note [ModDetails and --make mode]-initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails-initModDetails hsc_env mod_summary iface =+initModDetails :: HscEnv -> ModIface -> IO ModDetails+initModDetails hsc_env iface =   fixIO $ \details' -> do-    let act hpt  = addToHpt hpt (ms_mod_name mod_summary)-                                (HomeModInfo iface details' Nothing)+    let act hpt  = addToHpt hpt (moduleName $ mi_module iface)+                                (HomeModInfo iface details' emptyHomeModInfoLinkable)     let !hsc_env' = hscUpdateHPT act hsc_env     -- NB: This result is actually not that useful     -- in one-shot mode, since we're not going to do@@ -919,6 +980,29 @@     -- in make mode, since this HMI will go into the HPT.     genModDetails hsc_env' iface +-- Hydrate any WholeCoreBindings linkables into BCOs+initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable+initWholeCoreBindings hsc_env mod_iface details (LM utc_time this_mod uls) = LM utc_time this_mod <$> mapM go uls+  where+    go (CoreBindings fi) = do+        let act hpt  = addToHpt hpt (moduleName $ mi_module mod_iface)+                                (HomeModInfo mod_iface details emptyHomeModInfoLinkable)+        types_var <- newIORef (md_types details)+        let kv = knotVarsFromModuleEnv (mkModuleEnv [(this_mod, types_var)])+        let hsc_env' = hscUpdateHPT act hsc_env { hsc_type_env_vars = kv }+        core_binds <- initIfaceCheck (text "l") hsc_env' $ typecheckWholeCoreBindings types_var fi+        -- MP: The NoStubs here is only from (I think) the TH `qAddForeignFilePath` feature but it's a bit unclear what to do+        -- with these files, do we have to read and serialise the foreign file? I will leave it for now until someone+        -- reports a bug.+        let cgi_guts = CgInteractiveGuts this_mod core_binds (typeEnvTyCons (md_types details)) NoStubs Nothing []+        -- The bytecode generation itself is lazy because otherwise even when doing+        -- recompilation checking the bytecode will be generated (which slows things down a lot)+        -- the laziness is OK because generateByteCode just depends on things already loaded+        -- in the interface file.+        LoadedBCOs <$> (unsafeInterleaveIO $ do+                  trace_if (hsc_logger hsc_env) (text "Generating ByteCode for" <+> (ppr this_mod))+                  generateByteCode hsc_env cgi_guts (wcb_mod_location fi))+    go ul = return ul  {- Note [ModDetails and --make mode]@@ -986,6 +1070,7 @@   let bcknd  = backend dflags       hsc_src = ms_hsc_src summary       diag_opts = initDiagOpts dflags+      print_config = initPrintConfig dflags    -- Desugar, if appropriate   --@@ -1000,7 +1085,7 @@    -- Report the warnings from both typechecking and desugar together   w <- getDiagnostics-  liftIO $ printOrThrowDiagnostics logger diag_opts (unionMessages tc_warnings w)+  liftIO $ printOrThrowDiagnostics logger print_config diag_opts (unionMessages tc_warnings w)   clearDiagnostics    -- Simplify, if appropriate, and (whether we simplified or not) generate an@@ -1018,7 +1103,7 @@                 {-# SCC "GHC.Driver.Main.mkPartialIface" #-}                 -- This `force` saves 2M residency in test T10370                 -- See Note [Avoiding space leaks in toIface*] for details.-                force (mkPartialIface hsc_env details summary simplified_guts)+                force (mkPartialIface hsc_env (cg_binds cg_guts) details summary simplified_guts)            return HscRecomp { hscs_guts = cg_guts,                              hscs_mod_location = ms_location summary,@@ -1026,11 +1111,29 @@                              hscs_old_iface_hash = mb_old_hash                            } -      -- We are not generating code, so we can skip simplification+      Just desugared_guts | gopt Opt_WriteIfSimplifiedCore dflags -> do+          -- If -fno-code is enabled (hence we fall through to this case)+          -- Running the simplifier once is necessary before doing byte code generation+          -- in order to inline data con wrappers but we honour whatever level of simplificication the+          -- user requested. See #22008 for some discussion.+          plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)+          simplified_guts <- hscSimplify' plugins desugared_guts+          (cg_guts, _) <-+              liftIO $ hscTidy hsc_env simplified_guts++          (iface, _details) <- liftIO $+            hscSimpleIface hsc_env (Just $ cg_binds cg_guts) tc_result summary++          liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary)++          return $ HscUpdate iface+++      -- We are not generating code or writing an interface with simplified core so we can skip simplification       -- and generate a simple interface.       _ -> do         (iface, _details) <- liftIO $-          hscSimpleIface hsc_env tc_result summary+          hscSimpleIface hsc_env Nothing tc_result summary          liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary) @@ -1558,7 +1661,7 @@ -- may call it on modules using Trustworthy or Unsafe flags so as to allow -- warning flags for safety to function correctly. See Note [Safe Haskell -- Inference].-markUnsafeInfer :: Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv+markUnsafeInfer :: forall e . Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv markUnsafeInfer tcg_env whyUnsafe = do     dflags <- getDynFlags @@ -1587,7 +1690,9 @@     whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"                          , text "Reason:"                          , nest 4 $ (vcat $ badFlags df) $+$-                                    (vcat $ pprMsgEnvelopeBagWithLoc (getMessages whyUnsafe)) $+$+                                    -- MP: Using defaultDiagnosticOpts here is not right but it's also not right to handle these+                                    -- unsafety error messages in an unstructured manner.+                                    (vcat $ pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @e) (getMessages whyUnsafe)) $+$                                     (vcat $ badInsts $ tcg_insts tcg_env)                          ]     badFlags df   = concatMap (badFlag df) unsafeFlagsForInfer@@ -1642,16 +1747,18 @@ -- | Generate a stripped down interface file, e.g. for boot files or when ghci -- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc] hscSimpleIface :: HscEnv+               -> Maybe CoreProgram                -> TcGblEnv                -> ModSummary                -> IO (ModIface, ModDetails)-hscSimpleIface hsc_env tc_result summary-    = runHsc hsc_env $ hscSimpleIface' tc_result summary+hscSimpleIface hsc_env mb_core_program tc_result summary+    = runHsc hsc_env $ hscSimpleIface' mb_core_program tc_result summary -hscSimpleIface' :: TcGblEnv+hscSimpleIface' :: Maybe CoreProgram+                -> TcGblEnv                 -> ModSummary                 -> Hsc (ModIface, ModDetails)-hscSimpleIface' tc_result summary = do+hscSimpleIface' mb_core_program tc_result summary = do     hsc_env   <- getHscEnv     logger    <- getLogger     details   <- liftIO $ mkBootModDetailsTc logger tc_result@@ -1659,7 +1766,7 @@     new_iface         <- {-# SCC "MkFinalIface" #-}            liftIO $-               mkIfaceTc hsc_env safe_mode details summary tc_result+               mkIfaceTc hsc_env safe_mode details summary mb_core_program tc_result     -- And the answer is ...     liftIO $ dumpIfaceStats hsc_env     return (new_iface, details)@@ -1670,7 +1777,7 @@  -- | Compile to hard-code. hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath-               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe CgInfos)+               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos )                 -- ^ @Just f@ <=> _stub.c is f hscGenHardCode hsc_env cgguts location output_filename = do         let CgGuts{ -- This is the last use of the ModGuts in a compilation.@@ -1720,11 +1827,16 @@             this_mod location late_cc_binds data_tycons          -----------------  Convert to STG -------------------        (stg_binds, denv, (caf_ccs, caf_cc_stacks))+        (stg_binds, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos)             <- {-# SCC "CoreToStg" #-}                withTiming logger                    (text "CoreToStg"<+>brackets (ppr this_mod))-                   (\(a, b, (c,d)) -> a `seqList` b `seq` c `seqList` d `seqList` ())+                   (\(a, b, (c,d), tag_env) ->+                        a `seqList`+                        b `seq`+                        c `seqList`+                        d `seqList`+                        (seqEltsUFM (seqTagSig) tag_env))                    (myCoreToStg logger dflags (hsc_IC hsc_env) False this_mod location prepd_binds)          let cost_centre_info =@@ -1763,29 +1875,43 @@             let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init                                                   `appendStubC` cgIPEStub st -            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cg_infos)+            (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos)                 <- {-# SCC "codeOutput" #-}                   codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename location                   foreign_stubs foreign_files dependencies rawcmms1-            return (output_filename, stub_c_exists, foreign_fps, Just cg_infos)+            return  ( output_filename, stub_c_exists, foreign_fps+                    , Just stg_cg_infos, Just cmm_cg_infos)  +-- The part of CgGuts that we need for HscInteractive+data CgInteractiveGuts = CgInteractiveGuts { cgi_module :: Module+                                           , cgi_binds  :: CoreProgram+                                           , cgi_tycons :: [TyCon]+                                           , cgi_foreign :: ForeignStubs+                                           , cgi_modBreaks ::  Maybe ModBreaks+                                           , cgi_spt_entries :: [SptEntry]+                                           }++mkCgInteractiveGuts :: CgGuts -> CgInteractiveGuts+mkCgInteractiveGuts CgGuts{cg_module, cg_binds, cg_tycons, cg_foreign, cg_modBreaks, cg_spt_entries}+  = CgInteractiveGuts cg_module cg_binds cg_tycons cg_foreign cg_modBreaks cg_spt_entries+ hscInteractive :: HscEnv-               -> CgGuts+               -> CgInteractiveGuts                -> ModLocation                -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]) hscInteractive hsc_env cgguts location = do     let dflags = hsc_dflags hsc_env     let logger = hsc_logger hsc_env     let tmpfs  = hsc_tmpfs hsc_env-    let CgGuts{ -- This is the last use of the ModGuts in a compilation.+    let CgInteractiveGuts{ -- This is the last use of the ModGuts in a compilation.                 -- From now on, we just use the bits we need.-               cg_module   = this_mod,-               cg_binds    = core_binds,-               cg_tycons   = tycons,-               cg_foreign  = foreign_stubs,-               cg_modBreaks = mod_breaks,-               cg_spt_entries = spt_entries } = cgguts+               cgi_module   = this_mod,+               cgi_binds    = core_binds,+               cgi_tycons   = tycons,+               cgi_foreign  = foreign_stubs,+               cgi_modBreaks = mod_breaks,+               cgi_spt_entries = spt_entries } = cgguts          data_tycons = filter isDataTyCon tycons         -- cg_tycons includes newtypes, for the benefit of External Core,@@ -1802,7 +1928,9 @@         (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))         this_mod location core_binds data_tycons -    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)+    -- The stg cg info only provides a runtime benfit, but is not requires so we just+    -- omit it here+    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _ignore_stg_cg_infos)       <- {-# SCC "CoreToStg" #-}           myCoreToStg logger dflags (hsc_IC hsc_env) True this_mod location prepd_binds     -----------------  Generate byte code ------------------@@ -1812,6 +1940,32 @@         <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs     return (istub_c_exists, comp_bc, spt_entries) +generateByteCode :: HscEnv+  -> CgInteractiveGuts+  -> ModLocation+  -> IO [Unlinked]+generateByteCode hsc_env cgguts mod_location = do+  (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location++  stub_o <- case hasStub of+            Nothing -> return []+            Just stub_c -> do+                stub_o <- compileForeign hsc_env LangC stub_c+                return [DotO stub_o]++  let hs_unlinked = [BCOs comp_bc spt_entries]+  return (hs_unlinked ++ stub_o)++generateFreshByteCode :: HscEnv+  -> ModuleName+  -> CgInteractiveGuts+  -> ModLocation+  -> IO Linkable+generateFreshByteCode hsc_env mod_name cgguts mod_location = do+  ul <- generateByteCode hsc_env cgguts mod_location+  unlinked_time <- getCurrentTime+  let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name) ul+  return linkable ------------------------------  hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)@@ -1831,7 +1985,7 @@         mod_name = mkModuleName $ "Cmm$" ++ original_filename         cmm_mod = mkHomeModule home_unit mod_name         cmmpConfig = initCmmParserConfig dflags-    (cmm, ents) <- ioMsgMaybe+    (cmm, ipe_ents) <- ioMsgMaybe                $ do                   (warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())                                        $ parseCmmFile cmmpConfig cmm_mod home_unit filename@@ -1857,10 +2011,11 @@           Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup)           Just h  -> h           dflags Nothing (Stream.yield cmmgroup) -        let foreign_stubs _ =-              let ip_init   = ipInitCode do_info_table platform cmm_mod ents-              in NoStubs `appendStubC` ip_init-+        let foreign_stubs _+              | not $ null ipe_ents =+                  let ip_init = ipInitCode do_info_table platform cmm_mod+                  in NoStubs `appendStubC` ip_init+              | otherwise     = NoStubs         (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)           <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty              rawCmms@@ -1896,7 +2051,7 @@           -> CollectedCCs           -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs           -> HpcInfo-          -> IO (Stream IO CmmGroupSRTs CgInfos)+          -> IO (Stream IO CmmGroupSRTs CmmCgInfos)          -- Note we produce a 'Stream' of CmmGroups, so that the          -- backend can be run incrementally.  Otherwise it generates all          -- the C-- up front, which has a significant space cost.@@ -1907,13 +2062,10 @@         hooks      = hsc_hooks  hsc_env         tmpfs      = hsc_tmpfs  hsc_env         platform   = targetPlatform dflags--    -- Do tag inference on optimized STG-    (!stg_post_infer,export_tag_info) <--        {-# SCC "StgTagFields" #-} inferTags dflags logger this_mod stg_binds_w_fvs+        stg_ppr_opts = (initStgPprOpts dflags)      putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG-        (pprGenStgTopBindings (initStgPprOpts dflags) stg_post_infer)+        (pprGenStgTopBindings stg_ppr_opts stg_binds_w_fvs)      let stg_to_cmm dflags mod = case stgToCmmHook hooks of                         Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod)@@ -1921,8 +2073,8 @@      let cmm_stream :: Stream IO CmmGroup ModuleLFInfos         -- See Note [Forcing of stg_binds]-        cmm_stream = stg_post_infer `seqList` {-# SCC "StgToCmm" #-}-            stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_post_infer hpc_info+        cmm_stream = stg_binds_w_fvs `seqList` {-# SCC "StgToCmm" #-}+            stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info          -- codegen consumes a stream of CmmGroup, and produces a new         -- stream of CmmGroup (not necessarily synchronised: one@@ -1953,7 +2105,7 @@             putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)           return a -    return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv export_tag_info pipeline_stream+    return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv pipeline_stream  myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext                 -> Bool@@ -1961,7 +2113,8 @@                 -> IO ( Id                       , [CgStgTopBinding]                       , InfoTableProvMap-                      , CollectedCCs )+                      , CollectedCCs+                      , StgCgInfos ) myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do     {- Create a temporary binding (just because myCoreToStg needs a        binding for the stg2stg step) -}@@ -1969,7 +2122,7 @@                                 (mkPseudoUniqueE 0)                                 Many                                 (exprType prepd_expr)-    (stg_binds, prov_map, collected_ccs) <-+    (stg_binds, prov_map, collected_ccs, stg_cg_infos) <-        myCoreToStg logger                    dflags                    ictxt@@ -1977,20 +2130,21 @@                    this_mod                    ml                    [NonRec bco_tmp_id prepd_expr]-    return (bco_tmp_id, stg_binds, prov_map, collected_ccs)+    return (bco_tmp_id, stg_binds, prov_map, collected_ccs, stg_cg_infos)  myCoreToStg :: Logger -> DynFlags -> InteractiveContext             -> Bool             -> Module -> ModLocation -> CoreProgram             -> IO ( [CgStgTopBinding] -- output program                   , InfoTableProvMap-                  , CollectedCCs )  -- CAF cost centre info (declared and used)+                  , CollectedCCs -- CAF cost centre info (declared and used)+                  , StgCgInfos ) myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do     let (stg_binds, denv, cost_centre_info)          = {-# SCC "Core2Stg" #-}-           coreToStg dflags this_mod ml prepd_binds+           coreToStg (initCoreToStgOpts dflags) this_mod ml prepd_binds -    stg_binds_with_fvs+    (stg_binds_with_fvs,stg_cg_info)         <- {-# SCC "Stg2Stg" #-}            stg2stg logger (interactiveInScope ictxt) (initStgPipelineOpts dflags for_bytecode)                    this_mod stg_binds@@ -1998,7 +2152,7 @@     putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG         (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_with_fvs) -    return (stg_binds_with_fvs, denv, cost_centre_info)+    return (stg_binds_with_fvs, denv, cost_centre_info, stg_cg_info)  {- ********************************************************************** %*                                                                      *@@ -2149,7 +2303,7 @@         (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))         this_mod iNTERACTIVELoc core_binds data_tycons -    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks)+    (stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _stg_cg_info)         <- {-# SCC "CoreToStg" #-}            liftIO $ myCoreToStg (hsc_logger hsc_env)                                 (hsc_dflags hsc_env)@@ -2327,7 +2481,7 @@   -- on, print now   unless (logHasDumpFlag logger Opt_D_dump_simpl) $     putDumpFileMaybe logger Opt_D_dump_rules-      (renderWithContext defaultSDocContext (ppr CoreTidy <+> text "rules"))+      "Tidy Core rules"       FormatText       (pprRulesForUser tidy_rules) @@ -2387,7 +2541,7 @@                                       ml_hie_file  = panic "hscCompileCoreExpr':ml_hie_file" }           ; let ictxt = hsc_IC hsc_env-         ; (binding_id, stg_expr, _, _) <-+         ; (binding_id, stg_expr, _, _, _stg_cg_info) <-              myCoreToStgExpr logger                              dflags                              ictxt

@@ -448,7 +448,7 @@ addHmiToCache c (HomeModInfo i _ l) = iface_addToCache c (CachedIface i l)  data CachedIface = CachedIface { cached_modiface :: !ModIface-                               , cached_linkable :: !(Maybe Linkable) }+                               , cached_linkable :: !HomeModLinkable }  noIfaceCache :: Maybe ModIfaceCache noIfaceCache = Nothing@@ -833,7 +833,7 @@            linkable'                 | Just ms <- lookupUFM ms_map modl                 , mi_src_hash iface /= ms_hs_hash ms-                = Nothing+                = emptyHomeModInfoLinkable                 | otherwise                 = linkable @@ -1270,7 +1270,7 @@             -> IO HomeModInfo upsweep_mod hsc_env mHscMessage old_hmi summary mod_index nmods =  do   hmi <- compileOne' mHscMessage hsc_env summary-          mod_index nmods (hm_iface <$> old_hmi) (old_hmi >>= hm_linkable)+          mod_index nmods (hm_iface <$> old_hmi) (maybe emptyHomeModInfoLinkable hm_linkable old_hmi)    -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module   -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I@@ -1278,7 +1278,7 @@   -- This function only does anything if the linkable produced is a BCO, which only happens with the   -- bytecode backend, no need to guard against the backend type additionally.   addSptEntries (hscUpdateHPT (\hpt -> addToHpt hpt (ms_mod_name summary) hmi) hsc_env)-                (hm_linkable hmi)+                (homeModInfoByteCode hmi)    return hmi @@ -1328,10 +1328,12 @@ that is imported by a module that uses template haskell, to generate object code. -The flavour of generated object code is chosen by defaultObjectTarget for the-target platform. It would likely be faster to generate bytecode, but this is not-supported on all platforms(?Please Confirm?), and does not support the entirety-of GHC haskell. See #1257.+The flavour of the generated code depends on whether `-fprefer-byte-code` is enabled+or not in the module which needs the code generation. If the module requires byte-code then+dependencies will generate byte-code, otherwise they will generate object files.+In the case where some modules require byte-code and some object files, both are+generated by enabling `-fbyte-code-and-object-code`, the test "fat015" tests these+configurations.  The object files (and interface files if -fwrite-interface is disabled) produced for template haskell are written to temporary files.@@ -1756,6 +1758,12 @@ enableCodeGenForTH logger tmpfs unit_env =   enableCodeGenWhen logger tmpfs TFL_CurrentModule TFL_GhcSession unit_env ++data CodeGenEnable = EnableByteCode | EnableObject | EnableByteCodeAndObject deriving (Eq, Show, Ord)++instance Outputable CodeGenEnable where+  ppr = text . show+ -- | Helper used to implement 'enableCodeGenForTH'. -- In particular, this enables -- unoptimized code generation for all modules that meet some@@ -1781,7 +1789,7 @@         , ms_hsc_src = HsSrcFile         , ms_hspp_opts = dflags         } <- ms-      , mkNodeKey n `Set.member` needs_codegen_set =+      , Just enable_spec <- mkNodeKey n `Map.lookup` needs_codegen_map =       if | nocode_enable ms -> do                let new_temp_file suf dynsuf = do                      tn <- newTempName logger tmpfs (tmpDir dflags) staticLife suf@@ -1800,18 +1808,32 @@                                , (ml_obj_file ms_location, ml_dyn_obj_file ms_location))                    else (,) <$> (new_temp_file (hiSuf_ dflags) (dynHiSuf_ dflags))                             <*> (new_temp_file (objectSuf_ dflags) (dynObjectSuf_ dflags))+               let new_dflags = case enable_spec of+                                  EnableByteCode -> dflags { backend = interpreterBackend }+                                  EnableObject   -> dflags { backend = defaultBackendOf ms }+                                  EnableByteCodeAndObject -> (gopt_set dflags Opt_ByteCodeAndObjectCode) { backend = defaultBackendOf ms}                let ms' = ms                      { ms_location =                          ms_location { ml_hi_file = hi_file                                      , ml_obj_file = o_file                                      , ml_dyn_hi_file = dyn_hi_file                                      , ml_dyn_obj_file = dyn_o_file }-                     , ms_hspp_opts = updOptLevel 0 $ dflags {backend = defaultBackendOf ms}+                     , ms_hspp_opts = updOptLevel 0 $ new_dflags                      }                -- Recursive call to catch the other cases                enable_code_gen (ModuleNode deps ms')-         | dynamic_too_enable ms -> do++         -- If -fprefer-byte-code then satisfy dependency by enabling bytecode (if normal object not enough)+         -- we only get to this case if the default backend is already generating object files, but we need dynamic+         -- objects+         | bytecode_and_enable enable_spec ms -> do                let ms' = ms+                     { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_ByteCodeAndObjectCode+                     }+               -- Recursive call to catch the other cases+               enable_code_gen (ModuleNode deps ms')+         | dynamic_too_enable enable_spec ms -> do+               let ms' = ms                      { ms_hspp_opts = gopt_set (ms_hspp_opts ms) Opt_BuildDynamicToo                      }                -- Recursive call to catch the other cases@@ -1833,18 +1855,40 @@       -- can't compile anything anyway! See #16219.       isHomeUnitDefinite (ue_unitHomeUnit (ms_unitid ms) unit_env) +    bytecode_and_enable enable_spec ms =+      -- In the situation where we **would** need to enable dynamic-too+      -- IF we had decided we needed objects+      dynamic_too_enable EnableObject ms+        -- but we prefer to use bytecode rather than objects+        && prefer_bytecode+        -- and we haven't already turned it on+        && not generate_both+      where+        lcl_dflags   = ms_hspp_opts ms+        prefer_bytecode = case enable_spec of+                            EnableByteCodeAndObject -> True+                            EnableByteCode -> True+                            EnableObject -> False++        generate_both   = gopt Opt_ByteCodeAndObjectCode lcl_dflags+     -- #8180 - when using TemplateHaskell, switch on -dynamic-too so     -- the linker can correctly load the object files.  This isn't necessary     -- when using -fexternal-interpreter.-    dynamic_too_enable ms+    dynamic_too_enable enable_spec ms       = hostIsDynamic && internalInterpreter &&             not isDynWay && not isProfWay &&  not dyn_too_enabled+              && enable_object       where        lcl_dflags   = ms_hspp_opts ms        internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)-       dyn_too_enabled =  (gopt Opt_BuildDynamicToo lcl_dflags)+       dyn_too_enabled = gopt Opt_BuildDynamicToo lcl_dflags        isDynWay    = hasWay (ways lcl_dflags) WayDyn        isProfWay   = hasWay (ways lcl_dflags) WayProf+       enable_object = case enable_spec of+                            EnableByteCode -> False+                            EnableByteCodeAndObject -> True+                            EnableObject -> True      -- #16331 - when no "internal interpreter" is available but we     -- need to process some TemplateHaskell or QuasiQuotes, we automatically@@ -1854,19 +1898,44 @@        lcl_dflags   = ms_hspp_opts ms        internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags) +    (mg, lookup_node) = moduleGraphNodes False mod_graph +    mk_needed_set roots = Set.fromList $ map (mkNodeKey . node_payload) $ reachablesG mg (map (expectJust "needs_th" . lookup_node) roots) +    needs_obj_set, needs_bc_set :: Set.Set NodeKey+    needs_obj_set = mk_needed_set need_obj_set -    (mg, lookup_node) = moduleGraphNodes False mod_graph-    needs_codegen_set = Set.fromList $ map (mkNodeKey . node_payload) $ reachablesG mg (map (expectJust "needs_th" . lookup_node) has_th_set)+    needs_bc_set = mk_needed_set need_bc_set +    -- A map which tells us how to enable code generation for a NodeKey+    needs_codegen_map :: Map.Map NodeKey CodeGenEnable+    needs_codegen_map =+      -- Another option here would be to just produce object code, rather than both object and+      -- byte code+      Map.unionWith (\_ _ -> EnableByteCodeAndObject)+        (Map.fromList $ [(m, EnableObject) | m <- Set.toList needs_obj_set])+        (Map.fromList $ [(m, EnableByteCode) | m <- Set.toList needs_bc_set]) -    has_th_set =-      [ mkNodeKey mn-      | mn@(ModuleNode _ ms) <- mod_graph-      , isTemplateHaskellOrQQNonBoot ms-      ]+    -- The direct dependencies of modules which require object code+    need_obj_set =+      concat+        -- Note we don't need object code for a module if it uses TemplateHaskell itself. Only+        -- it's dependencies.+        [ deps+        | (ModuleNode deps ms) <- mod_graph+        , isTemplateHaskellOrQQNonBoot ms+        , not (gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms))+        ] +    -- The direct dependencies of modules which require byte code+    need_bc_set =+      concat+        [ deps+        | (ModuleNode deps ms) <- mod_graph+        , isTemplateHaskellOrQQNonBoot ms+        , gopt Opt_UseBytecodeRatherThanObjects (ms_hspp_opts ms)+        ]+ -- | Populate the Downsweep cache with the root modules. mkRootMap   :: [ModSummary]@@ -2338,7 +2407,8 @@ wrapAction hsc_env k = do   let lcl_logger = hsc_logger hsc_env       lcl_dynflags = hsc_dflags hsc_env-  let logg err = printMessages lcl_logger (initDiagOpts lcl_dynflags) (srcErrorMessages err)+      print_config = initPrintConfig lcl_dynflags+  let logg err = printMessages lcl_logger print_config (initDiagOpts lcl_dynflags) (srcErrorMessages err)   -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle   -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches`   -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to

@@ -7,6 +7,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeApplications #-}  ----------------------------------------------------------------------------- --@@ -71,6 +73,7 @@ import GHC.Platform.Ways  import GHC.SysTools+import GHC.SysTools.Cpp import GHC.Utils.TmpFs  import GHC.Linker.ExtraObj@@ -161,7 +164,8 @@     to_driver_messages :: Messages GhcMessage -> Messages DriverMessage     to_driver_messages msgs = case traverse to_driver_message msgs of       Nothing    -> pprPanic "non-driver message in preprocess"-                             (vcat $ pprMsgEnvelopeBagWithLoc (getMessages msgs))+                             -- MP: Default config is fine here as it's just in a panic.+                             (vcat $ pprMsgEnvelopeBagWithLoc (defaultDiagnosticOpts @GhcMessage) (getMessages msgs))       Just msgs' -> msgs'      to_driver_message = \case@@ -209,7 +213,7 @@            -> Int             -- ^ module N ...            -> Int             -- ^ ... of M            -> Maybe ModIface  -- ^ old interface, if we have one-           -> Maybe Linkable  -- ^ old linkable, if we have one+           -> HomeModLinkable  -- ^ old linkable, if we have one            -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful  compileOne = compileOne' (Just batchMsg)@@ -220,7 +224,7 @@             -> Int             -- ^ module N ...             -> Int             -- ^ ... of M             -> Maybe ModIface  -- ^ old interface, if we have one-            -> Maybe Linkable  -- ^ old linkable, if we have one+            -> HomeModLinkable             -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful  compileOne' mHscMessage@@ -243,8 +247,9 @@    let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, upd_summary, status)    (iface, linkable) <- runPipeline (hsc_hooks hsc_env) pipeline    -- See Note [ModDetails and --make mode]-   details <- initModDetails plugin_hsc_env upd_summary iface-   return $! HomeModInfo iface details linkable+   details <- initModDetails plugin_hsc_env iface+   linkable' <- traverse (initWholeCoreBindings plugin_hsc_env iface details) (homeMod_bytecode linkable)+   return $! HomeModInfo iface details (linkable { homeMod_bytecode = linkable' })   where lcl_dflags  = ms_hspp_opts summary        location    = ms_location summary@@ -405,7 +410,7 @@                           $ home_mod_infos              -- the linkables to link-            linkables = map (expectJust "link".hm_linkable) home_mod_infos+            linkables = map (expectJust "link". homeModInfoObject) home_mod_infos          debugTraceMsg logger 3 (text "link: linkables are ..." $$ vcat (map ppr linkables)) @@ -688,8 +693,9 @@             -- Reparse with original hsc_env so that we don't get duplicated options             use (T_FileArgs hsc_env pp_fn) -  liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3))-  liftIO (handleFlagWarnings (hsc_logger hsc_env) (initDiagOpts dflags3) warns3)+  let print_config = initPrintConfig dflags3+  liftIO (printOrThrowDiagnostics (hsc_logger hsc_env) print_config (initDiagOpts dflags3) (GhcPsMessage <$> p_warns3))+  liftIO (handleFlagWarnings (hsc_logger hsc_env) print_config (initDiagOpts dflags3) warns3)   return (dflags3, pp_fn)  @@ -710,7 +716,7 @@            $ phaseIfFlag hsc_env flag def action  -- | The complete compilation pipeline, from start to finish-fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, Maybe Linkable)+fullPipeline :: P m => PipeEnv -> HscEnv -> FilePath -> HscSource -> m (ModIface, HomeModLinkable) fullPipeline pipe_env hsc_env pp_fn src_flavour = do   (dflags, input_fn) <- preprocessPipeline pipe_env hsc_env pp_fn   let hsc_env' = hscSetFlags dflags hsc_env@@ -719,7 +725,7 @@   hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status)  -- | Everything after preprocess-hscPipeline :: P m => PipeEnv ->  ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, Maybe Linkable)+hscPipeline :: P m => PipeEnv ->  ((HscEnv, ModSummary, HscRecompStatus)) -> m (ModIface, HomeModLinkable) hscPipeline pipe_env (hsc_env_with_plugins, mod_sum, hsc_recomp_status) = do   case hsc_recomp_status of     HscUpToDate iface mb_linkable -> return (iface, mb_linkable)@@ -728,7 +734,7 @@       hscBackendAction <- use (T_HscPostTc hsc_env_with_plugins mod_sum tc_result warnings mb_old_hash )       hscBackendPipeline pipe_env hsc_env_with_plugins mod_sum hscBackendAction -hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, Maybe Linkable)+hscBackendPipeline :: P m => PipeEnv -> HscEnv -> ModSummary -> HscBackendAction -> m (ModIface, HomeModLinkable) hscBackendPipeline pipe_env hsc_env mod_sum result =   if backendGeneratesCode (backend (hsc_dflags hsc_env)) then     do@@ -739,8 +745,8 @@       return res   else     case result of-      HscUpdate iface ->  return (iface, Nothing)-      HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing) <*> pure Nothing+      HscUpdate iface ->  return (iface, emptyHomeModInfoLinkable)+      HscRecomp {} -> (,) <$> liftIO (mkFullIface hsc_env (hscs_partial_iface result) Nothing Nothing) <*> pure emptyHomeModInfoLinkable     -- TODO: Why is there not a linkable?     -- Interpreter -> (,) <$> use (T_IO (mkFullIface hsc_env (hscs_partial_iface result) Nothing)) <*> pure Nothing @@ -749,7 +755,7 @@   -> HscEnv   -> ModSummary   -> HscBackendAction-  -> m (ModIface, Maybe Linkable)+  -> m (ModIface, HomeModLinkable) hscGenBackendPipeline pipe_env hsc_env mod_sum result = do   let mod_name = moduleName (ms_mod mod_sum)       src_flavour = (ms_hsc_src mod_sum)@@ -764,7 +770,8 @@         unlinked_time <- liftIO (liftIO getCurrentTime)         final_unlinked <- DotO <$> use (T_MergeForeign pipe_env hsc_env o_fp fos)         let !linkable = LM unlinked_time (ms_mod mod_sum) [final_unlinked]-        return (Just linkable)+        -- Add the object linkable to the potential bytecode linkable which was generated in HscBackend.+        return (mlinkable { homeMod_object = Just linkable })   return (miface, final_linkable)  asPipeline :: P m => Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> m (Maybe ObjFile)@@ -860,7 +867,7 @@    as :: P m => Bool -> m (Maybe FilePath)    as use_cpp = asPipeline use_cpp pipe_env hsc_env Nothing input_fn -   objFromLinkable (_, Just (LM _ _ [DotO lnk])) = Just lnk+   objFromLinkable (_, homeMod_object -> Just (LM _ _ [DotO lnk])) = Just lnk    objFromLinkable _ = Nothing  

@@ -26,7 +26,6 @@ import GHC.Types.SourceFile import GHC.Unit.Module.Status import GHC.Unit.Module.ModIface-import GHC.Linker.Types import GHC.Driver.Backend import GHC.Driver.Session import GHC.Driver.CmdLine@@ -57,7 +56,6 @@ import GHC.Unit.Home import GHC.Data.Maybe import GHC.Iface.Make-import Data.Time import GHC.Driver.Config.Parser import GHC.Parser.Header import GHC.Data.StringBuffer@@ -67,9 +65,8 @@ import Data.IORef import GHC.Types.Name.Env import GHC.Platform.Ways-import GHC.Platform.ArchOS import GHC.Driver.LlvmConfigCache (readLlvmConfigCache)-import GHC.CmmToLlvm.Config (llvmVersionList, LlvmTarget (..), LlvmConfig (..))+import GHC.CmmToLlvm.Config (LlvmTarget (..), LlvmConfig (..)) import {-# SOURCE #-} GHC.Driver.Pipeline (compileForeign, compileEmptyStub) import GHC.Settings import System.IO@@ -81,8 +78,10 @@ import GHC.Driver.Env.KnotVars import GHC.Driver.Config.Finder import GHC.Rename.Names+import GHC.SysTools.Cpp  import Language.Haskell.Syntax.Module.Name+import GHC.Unit.Home.ModInfo  newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a }   deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO)@@ -122,7 +121,10 @@         (hsc_tmpfs hsc_env)         (hsc_dflags hsc_env)         (hsc_unit_env hsc_env)-        False{-not raw-}+        (CppOpts+          { cppUseCc       = True+          , cppLinePragmas = True+          })         input_fn output_fn   return output_fn runPhase (T_Cmm pipe_env hsc_env input_fn) = do@@ -504,7 +506,7 @@                    -> HscSource                    -> ModLocation                    -> HscBackendAction-                   -> IO ([FilePath], ModIface, Maybe Linkable, FilePath)+                   -> IO ([FilePath], ModIface, HomeModLinkable, FilePath) runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do   let dflags = hsc_dflags hsc_env       logger = hsc_logger hsc_env@@ -526,7 +528,7 @@                HsBootFile -> touchObjectFile logger dflags o_file                HsSrcFile -> panic "HscUpdate not relevant for HscSrcFile" -             return ([], iface, Nothing, o_file)+             return ([], iface, emptyHomeModInfoLinkable, o_file)       HscRecomp { hscs_guts = cgguts,                   hscs_mod_location = mod_location,                   hscs_partial_iface = partial_iface,@@ -537,13 +539,22 @@            else if backendWritesFiles (backend dflags) then              do               output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)-              (outputFilename, mStub, foreign_files, mb_cg_infos) <-+              (outputFilename, mStub, foreign_files, stg_infos, cg_infos) <-+                 hscGenHardCode hsc_env cgguts mod_location output_fn-              final_iface <- mkFullIface hsc_env partial_iface mb_cg_infos+              final_iface <- mkFullIface hsc_env partial_iface stg_infos cg_infos                -- See Note [Writing interface files]               hscMaybeWriteIface logger dflags False final_iface mb_old_iface_hash mod_location+              mlinkable <-+                if backendGeneratesCode (backend dflags) && gopt Opt_ByteCodeAndObjectCode dflags+                  then do+                    bc <- generateFreshByteCode hsc_env mod_name (mkCgInteractiveGuts cgguts) mod_location+                    return $ emptyHomeModInfoLinkable { homeMod_bytecode = Just bc } +                  else return emptyHomeModInfoLinkable++               stub_o <- mapM (compileStub hsc_env) mStub               foreign_os <-                 mapM (uncurry (compileForeign hsc_env)) foreign_files@@ -553,28 +564,16 @@               -- have some way to do before the object file is produced               -- In future we can split up the driver logic more so that this function               -- is in TPipeline and in this branch we can invoke the rest of the backend phase.-              return (fos, final_iface, Nothing, outputFilename)+              return (fos, final_iface, mlinkable, outputFilename)             else               -- In interpreted mode the regular codeGen backend is not run so we               -- generate a interface without codeGen info.             do-              final_iface <- mkFullIface hsc_env partial_iface Nothing+              final_iface <- mkFullIface hsc_env partial_iface Nothing Nothing               hscMaybeWriteIface logger dflags True final_iface mb_old_iface_hash location--              (hasStub, comp_bc, spt_entries) <- hscInteractive hsc_env cgguts mod_location--              stub_o <- case hasStub of-                        Nothing -> return []-                        Just stub_c -> do-                            stub_o <- compileStub hsc_env stub_c-                            return [DotO stub_o]--              let hs_unlinked = [BCOs comp_bc spt_entries]-              unlinked_time <- getCurrentTime-              let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name)-                             (hs_unlinked ++ stub_o)-              return ([], final_iface, Just linkable, panic "interpreter")+              bc <- generateFreshByteCode hsc_env mod_name (mkCgInteractiveGuts cgguts) mod_location+              return ([], final_iface, emptyHomeModInfoLinkable { homeMod_bytecode = Just bc } , panic "interpreter")   runUnlitPhase :: HscEnv -> FilePath -> FilePath -> IO FilePath@@ -624,7 +623,10 @@            (hsc_tmpfs hsc_env)            (hsc_dflags hsc_env)            (hsc_unit_env hsc_env)-           True{-raw-}+           (CppOpts+              { cppUseCc       = False+              , cppLinePragmas = True+              })            input_fn output_fn   return output_fn @@ -717,7 +719,7 @@   let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) }    status <- hscRecompStatus (Just msg) plugin_hsc_env mod_summary-                        Nothing Nothing (1, 1)+                        Nothing emptyHomeModInfoLinkable (1, 1)    return (plugin_hsc_env, mod_summary, status) @@ -957,142 +959,6 @@                 ArchRISCV64 -> "lp64d"                 _           -> "" ---- Note [Filepaths and Multiple Home Units]-offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs-offsetIncludePaths dflags (IncludeSpecs incs quotes impl) =-     let go = map (augmentByWorkingDirectory dflags)-     in IncludeSpecs (go incs) (go quotes) (go impl)--- -------------------------------------------------------------------------------- Running CPP---- | Run CPP------ UnitEnv is needed to compute MIN_VERSION macros-doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> Bool -> FilePath -> FilePath -> IO ()-doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do-    let hscpp_opts = picPOpts dflags-    let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags)-    let unit_state = ue_units unit_env-    pkg_include_dirs <- mayThrowUnitErr-                        (collectIncludeDirs <$> preloadUnitsInfo unit_env)-    -- MP: This is not quite right, the headers which are supposed to be installed in-    -- the package might not be the same as the provided include paths, but it's a close-    -- enough approximation for things to work. A proper solution would be to have to declare which paths should-    -- be propagated to dependent packages.-    let home_pkg_deps =-         [homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env]-        dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps]--    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []-          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs-                                                    ++ concatMap includePathsGlobal dep_pkg_extra_inputs)-    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []-          (includePathsQuote cmdline_include_paths ++-           includePathsQuoteImplicit cmdline_include_paths)-    let include_paths = include_paths_quote ++ include_paths_global--    let verbFlags = getVerbFlags dflags--    let cpp_prog args | raw       = GHC.SysTools.runCpp logger dflags args-                      | otherwise = GHC.SysTools.runCc Nothing logger tmpfs dflags-                                        (GHC.SysTools.Option "-E" : args)--    let platform   = targetPlatform dflags-        targetArch = stringEncodeArch $ platformArch platform-        targetOS = stringEncodeOS $ platformOS platform-        isWindows = platformOS platform == OSMinGW32-    let target_defs =-          [ "-D" ++ HOST_OS     ++ "_BUILD_OS",-            "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH",-            "-D" ++ targetOS    ++ "_HOST_OS",-            "-D" ++ targetArch  ++ "_HOST_ARCH" ]-        -- remember, in code we *compile*, the HOST is the same our TARGET,-        -- and BUILD is the same as our HOST.--    let io_manager_defs =-          [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] ++-          [ "-D__IO_MANAGER_MIO__=1"               ]--    let sse_defs =-          [ "-D__SSE__"      | isSseEnabled      platform ] ++-          [ "-D__SSE2__"     | isSse2Enabled     platform ] ++-          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]--    let avx_defs =-          [ "-D__AVX__"      | isAvxEnabled      dflags ] ++-          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] ++-          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] ++-          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] ++-          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] ++-          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]--    backend_defs <- applyCDefs (backendCDefs $ backend dflags) logger dflags--    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]-    -- Default CPP defines in Haskell source-    ghcVersionH <- getGhcVersionPathName dflags unit_env-    let hsSourceCppOpts = [ "-include", ghcVersionH ]--    -- MIN_VERSION macros-    let uids = explicitUnits unit_state-        pkgs = mapMaybe (lookupUnit unit_state . fst) uids-    mb_macro_include <--        if not (null pkgs) && gopt Opt_VersionMacros dflags-            then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h"-                    writeFile macro_stub (generatePackageVersionMacros pkgs)-                    -- Include version macros for every *exposed* package.-                    -- Without -hide-all-packages and with a package database-                    -- size of 1000 packages, it takes cpp an estimated 2-                    -- milliseconds to process this file. See #10970-                    -- comment 8.-                    return [GHC.SysTools.FileOption "-include" macro_stub]-            else return []--    cpp_prog       (   map GHC.SysTools.Option verbFlags-                    ++ map GHC.SysTools.Option include_paths-                    ++ map GHC.SysTools.Option hsSourceCppOpts-                    ++ map GHC.SysTools.Option target_defs-                    ++ map GHC.SysTools.Option backend_defs-                    ++ map GHC.SysTools.Option th_defs-                    ++ map GHC.SysTools.Option hscpp_opts-                    ++ map GHC.SysTools.Option sse_defs-                    ++ map GHC.SysTools.Option avx_defs-                    ++ map GHC.SysTools.Option io_manager_defs-                    ++ mb_macro_include-        -- Set the language mode to assembler-with-cpp when preprocessing. This-        -- alleviates some of the C99 macro rules relating to whitespace and the hash-        -- operator, which we tend to abuse. Clang in particular is not very happy-        -- about this.-                    ++ [ GHC.SysTools.Option     "-x"-                       , GHC.SysTools.Option     "assembler-with-cpp"-                       , GHC.SysTools.Option     input_fn-        -- We hackily use Option instead of FileOption here, so that the file-        -- name is not back-slashed on Windows.  cpp is capable of-        -- dealing with / in filenames, so it works fine.  Furthermore-        -- if we put in backslashes, cpp outputs #line directives-        -- with *double* backslashes.   And that in turn means that-        -- our error messages get double backslashes in them.-        -- In due course we should arrange that the lexer deals-        -- with these \\ escapes properly.-                       , GHC.SysTools.Option     "-o"-                       , GHC.SysTools.FileOption "" output_fn-                       ])--applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String]-applyCDefs NoCDefs _ _ = return []-applyCDefs LlvmCDefs logger dflags = do-    llvmVer <- figureLlvmVersion logger dflags-    return $ case fmap llvmVersionList llvmVer of-               Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]-               Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]-               _ -> []-  where-    format (major, minor)-      | minor >= 100 = error "backendCDefs: Unsupported minor version"-      | otherwise = show (100 * major + minor :: Int) -- Contract is Int-- -- | What phase to run after one of the backend code generators has run hscPostBackendPhase :: HscSource -> Backend -> Phase hscPostBackendPhase HsBootFile _    =  StopLn@@ -1282,22 +1148,6 @@ touchObjectFile logger dflags path = do   createDirectoryIfMissing True $ takeDirectory path   GHC.SysTools.touch logger dflags "Touching object file" path---- | Find out path to @ghcversion.h@ file-getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath-getGhcVersionPathName dflags unit_env = do-  candidates <- case ghcVersionFile dflags of-    Just path -> return [path]-    Nothing -> do-        ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])-        return ((</> "ghcversion.h") <$> collectIncludeDirs ps)--  found <- filterM doesFileExist candidates-  case found of-      []    -> throwGhcExceptionIO (InstallationError-                                    ("ghcversion.h missing; tried: "-                                      ++ intercalate ", " candidates))-      (x:_) -> return x  -- Note [-fPIC for assembler] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -126,7 +126,7 @@                   tickboxes                 ])) <> semi -    tickboxes = pprCLabel platform CStyle (mkHpcTicksLabel $ this_mod)+    tickboxes = pprCLabel platform (mkHpcTicksLabel $ this_mod)      module_name  = hcat (map (text.charToC) $ BS.unpack $                          bytesFS (moduleNameFS (moduleName this_mod)))

@@ -423,7 +423,7 @@   arg_cname n stg_ty         | libffi    = char '*' <> parens (stg_ty <> char '*') <>                       text "args" <> brackets (int (n-1))-        | otherwise = text ('a':show n)+        | otherwise = char 'a' <> int n    -- generate a libffi-style stub if this is a "wrapper" and libffi is enabled   libffi = platformMisc_libFFI (platformMisc dflags) && isNothing maybe_target@@ -552,16 +552,16 @@      ]  mkHObj :: Type -> SDoc-mkHObj t = text "rts_mk" <> text (showFFIType t)+mkHObj t = text "rts_mk" <> showFFIType t  unpackHObj :: Type -> SDoc-unpackHObj t = text "rts_get" <> text (showFFIType t)+unpackHObj t = text "rts_get" <> showFFIType t  showStgType :: Type -> SDoc-showStgType t = text "Hs" <> text (showFFIType t)+showStgType t = text "Hs" <> showFFIType t -showFFIType :: Type -> String-showFFIType t = getOccString (getName (typeTyCon t))+showFFIType :: Type -> SDoc+showFFIType t = ftext (occNameFS (getOccName (typeTyCon t)))  typeTyCon :: Type -> TyCon typeTyCon ty

@@ -317,7 +317,7 @@          thing_inside        ; case mb_ret of            Just ret -> pure ret-           Nothing  -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) }+           Nothing  -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLocDefault (getErrorMessages msgs)) }  mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv          -> IORef (Messages DsMessage) -> IORef CostCentreState

@@ -744,7 +744,7 @@       MkC cc' <- repCCallConv cc       MkC s' <- repSafety s       cis' <- conv_cimportspec cis-      MkC str <- coreStringLit (static ++ chStr ++ cis')+      MkC str <- coreStringLit (mkFastString (static ++ chStr ++ cis'))       dec <- rep2 forImpDName [cc', s', str, name', typ']       return (locA loc, dec)  where@@ -818,7 +818,7 @@                          ; tm_bndrs' <- repListM ruleBndrTyConName                                                 repRuleBndr                                                 tm_bndrs-                         ; n'   <- coreStringLit $ unpackFS $ unLoc n+                         ; n'   <- coreStringLit $ unLoc n                          ; act' <- repPhases act                          ; lhs' <- repLE lhs                          ; rhs' <- repLE rhs@@ -1861,7 +1861,7 @@       ; return (locA loc, ipb) }  rep_implicit_param_name :: HsIPName -> MetaM (Core String)-rep_implicit_param_name (HsIPName name) = coreStringLit (unpackFS name)+rep_implicit_param_name (HsIPName name) = coreStringLit name  rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))] -- Assumes: all the binders of the binding are already in the meta-env@@ -2195,8 +2195,8 @@         ; rep2_nwDsM mkNameLName [occ,uni] }   where       mod = assert (isExternalName name) nameModule name-      name_mod = moduleNameString (moduleName mod)-      name_pkg = unitString (moduleUnit mod)+      name_mod = moduleNameFS (moduleName mod)+      name_pkg = unitFS (moduleUnit mod)       name_occ = nameOccName name       mk_varg | isDataOcc name_occ = mkNameG_dName               | isVarOcc  name_occ = mkNameG_vName@@ -2235,10 +2235,10 @@                       gensym_app (MkC (Lam id body')) }  nameLit :: Name -> DsM (Core String)-nameLit n = coreStringLit (occNameString (nameOccName n))+nameLit n = coreStringLit (occNameFS (nameOccName n))  occNameLit :: OccName -> MetaM (Core String)-occNameLit name = coreStringLit (occNameString name)+occNameLit name = coreStringLit (occNameFS name)   -- %*********************************************************************@@ -2416,7 +2416,7 @@     coreModNameM :: MetaM (Core (Maybe TH.ModName))     coreModNameM = case maybeModName of       Just m -> do-        MkC s <- coreStringLit (moduleNameString m)+        MkC s <- coreStringLit (moduleNameFS m)         mName <- rep2_nw mkModNameName [s]         coreJust modNameTyConName mName       _ -> coreNothing modNameTyConName@@ -2950,17 +2950,17 @@  repOverLabel :: FastString -> MetaM (Core (M TH.Exp)) repOverLabel fs = do-                    (MkC s) <- coreStringLit $ unpackFS fs+                    MkC s <- coreStringLit fs                     rep2 labelEName [s]  repGetField :: Core (M TH.Exp) -> FastString -> MetaM (Core (M TH.Exp)) repGetField (MkC exp) fs = do-  MkC s <- coreStringLit $ unpackFS fs+  MkC s <- coreStringLit fs   rep2 getFieldEName [exp,s]  repProjection :: NonEmpty FastString -> MetaM (Core (M TH.Exp)) repProjection fs = do-  MkC xs <- coreListNonEmpty stringTy <$> mapM (coreStringLit . unpackFS) fs+  MkC xs <- coreListNonEmpty stringTy <$> mapM coreStringLit fs   rep2 projectionEName [xs]  ------------ Lists -------------------@@ -3004,8 +3004,8 @@ nonEmptyCoreList' :: NonEmpty (Core a) -> Core [a] nonEmptyCoreList' xs@(MkC x:|_) = MkC (mkListExpr (exprType x) (toList $ fmap unC xs)) -coreStringLit :: MonadThings m => String -> m (Core String)-coreStringLit s = do { z <- mkStringExpr s; return(MkC z) }+coreStringLit :: MonadThings m => FastString -> m (Core String)+coreStringLit s = do { z <- mkStringExprFS s; return (MkC z) }  ------------------- Maybe ------------------ 

@@ -821,7 +821,7 @@ mkLHsPatTup :: [LPat GhcTc] -> LPat GhcTc mkLHsPatTup []     = noLocA $ mkVanillaTuplePat [] Boxed mkLHsPatTup [lpat] = lpat-mkLHsPatTup lpats  = L (getLoc (head lpats)) $+mkLHsPatTup lpats@(L l _:_)  = L l $                      mkVanillaTuplePat lpats Boxed  mkVanillaTuplePat :: [LPat GhcTc] -> Boxity -> Pat GhcTc

@@ -23,7 +23,7 @@  import GHC.Utils.Outputable(ppr) -import GHC.Prelude+import GHC.Prelude hiding ( head, init, last, tail )  import GHC.Types.Avail            ( Avails ) import GHC.Data.Bag               ( Bag, bagToList )@@ -71,7 +71,8 @@ import Data.Data                  ( Data, Typeable ) import Data.Foldable              ( toList ) import Data.Functor.Identity      ( Identity(..) )-import Data.List.NonEmpty         ( NonEmpty(..) )+import Data.List.NonEmpty         ( NonEmpty(..), nonEmpty )+import qualified Data.List.NonEmpty as NE import Data.Void                  ( Void, absurd ) import Control.Monad              ( forM_ ) import Control.Monad.Trans.State.Strict@@ -334,10 +335,11 @@         Nothing -> pure ()         Just c -> forM_ (classSCSelIds c) $ \v ->           addUnlocatedEvBind v (EvidenceVarBind (EvInstBind True (className c)) ModuleScope Nothing)-    let spanFile file children = case children of-          [] -> realSrcLocSpan (mkRealSrcLoc file 1 1)-          _ -> mkRealSrcSpan (realSrcSpanStart $ nodeSpan $ head children)-                             (realSrcSpanEnd   $ nodeSpan $ last children)+    let spanFile file children = case nonEmpty children of+          Nothing -> realSrcLocSpan (mkRealSrcLoc file 1 1)+          Just children -> mkRealSrcSpan+              (realSrcSpanStart $ nodeSpan (NE.head children))+              (realSrcSpanEnd   $ nodeSpan (NE.last children))          flat_asts = concat           [ tasts

@@ -339,10 +339,10 @@ putHieName :: BinHandle -> HieName -> IO () putHieName bh (ExternalName mod occ span) = do   putByte bh 0-  put_ bh (mod, occ, span)+  put_ bh (mod, occ, BinSrcSpan span) putHieName bh (LocalName occName span) = do   putByte bh 1-  put_ bh (occName, span)+  put_ bh (occName, BinSrcSpan span) putHieName bh (KnownKeyName uniq) = do   putByte bh 2   put_ bh $ unpkUnique uniq@@ -353,10 +353,10 @@   case t of     0 -> do       (modu, occ, span) <- get bh-      return $ ExternalName modu occ span+      return $ ExternalName modu occ $ unBinSrcSpan span     1 -> do       (occ, span) <- get bh-      return $ LocalName occ span+      return $ LocalName occ $ unBinSrcSpan span     2 -> do       (c,i) <- get bh       return $ KnownKeyName $ mkUnique c i

@@ -251,12 +251,12 @@ instance Binary (HieAST TypeIndex) where   put_ bh ast = do     put_ bh $ sourcedNodeInfo ast-    put_ bh $ nodeSpan ast+    put_ bh $ BinSpan $ nodeSpan ast     put_ bh $ nodeChildren ast    get bh = Node     <$> get bh-    <*> get bh+    <*> (unBinSpan <$> get bh)     <*> get bh  instance Outputable a => Outputable (HieAST a) where@@ -486,19 +486,19 @@     putByte bh 3     put_ bh bt     put_ bh sc-    put_ bh msp+    put_ bh $ BinSpan <$> msp   put_ bh (PatternBind a b c) = do     putByte bh 4     put_ bh a     put_ bh b-    put_ bh c+    put_ bh $ BinSpan <$> c   put_ bh (ClassTyDecl sp) = do     putByte bh 5-    put_ bh sp+    put_ bh $ BinSpan <$> sp   put_ bh (Decl a b) = do     putByte bh 6     put_ bh a-    put_ bh b+    put_ bh $ BinSpan <$> b   put_ bh (TyVarBind a b) = do     putByte bh 7     put_ bh a@@ -506,13 +506,13 @@   put_ bh (RecField a b) = do     putByte bh 8     put_ bh a-    put_ bh b+    put_ bh $ BinSpan <$> b   put_ bh MatchBind = putByte bh 9   put_ bh (EvidenceVarBind a b c) = do     putByte bh 10     put_ bh a     put_ bh b-    put_ bh c+    put_ bh $ BinSpan <$> c   put_ bh EvidenceVarUse = putByte bh 11    get bh = do@@ -521,14 +521,14 @@       0 -> return Use       1 -> IEThing <$> get bh       2 -> return TyDecl-      3 -> ValBind <$> get bh <*> get bh <*> get bh-      4 -> PatternBind <$> get bh <*> get bh <*> get bh-      5 -> ClassTyDecl <$> get bh-      6 -> Decl <$> get bh <*> get bh+      3 -> ValBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh)+      4 -> PatternBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh)+      5 -> ClassTyDecl <$> (fmap unBinSpan <$> get bh)+      6 -> Decl <$> get bh <*> (fmap unBinSpan <$> get bh)       7 -> TyVarBind <$> get bh <*> get bh-      8 -> RecField <$> get bh <*> get bh+      8 -> RecField <$> get bh <*> (fmap unBinSpan <$> get bh)       9 -> return MatchBind-      10 -> EvidenceVarBind <$> get bh <*> get bh <*> get bh+      10 -> EvidenceVarBind <$> get bh <*> get bh <*> (fmap unBinSpan <$> get bh)       11 -> return EvidenceVarUse       _ -> panic "Binary ContextInfo: invalid tag" @@ -679,14 +679,14 @@   put_ bh NoScope = putByte bh 0   put_ bh (LocalScope span) = do     putByte bh 1-    put_ bh span+    put_ bh $ BinSpan span   put_ bh ModuleScope = putByte bh 2    get bh = do     (t :: Word8) <- get bh     case t of       0 -> return NoScope-      1 -> LocalScope <$> get bh+      1 -> LocalScope . unBinSpan <$> get bh       2 -> return ModuleScope       _ -> panic "Binary Scope: invalid tag" @@ -732,13 +732,13 @@   put_ bh (UnresolvedScope ns span) = do     putByte bh 1     put_ bh ns-    put_ bh span+    put_ bh (BinSpan <$> span)    get bh = do     (t :: Word8) <- get bh     case t of       0 -> ResolvedScopes <$> get bh-      1 -> UnresolvedScope <$> get bh <*> get bh+      1 -> UnresolvedScope <$> get bh <*> (fmap unBinSpan <$> get bh)       _ -> panic "Binary TyVarScope: invalid tag"  -- | `Name`'s get converted into `HieName`'s before being written into @.hie@@@ -781,5 +781,5 @@   | isKnownKeyName name = KnownKeyName (nameUnique name)   | isExternalName name = ExternalName (nameModule name)                                        (nameOccName name)-                                       (nameSrcSpan name)-  | otherwise = LocalName (nameOccName name) (nameSrcSpan name)+                                       (removeBufSpan $ nameSrcSpan name)+  | otherwise = LocalName (nameOccName name) (removeBufSpan $ nameSrcSpan name)

@@ -1126,6 +1126,10 @@         , vcat (map pprIfaceAnnotation (mi_anns iface))         , pprFixities (mi_fixities iface)         , vcat [ppr ver $$ nest 2 (ppr decl) | (ver,decl) <- mi_decls iface]+        , case mi_extra_decls iface of+            Nothing -> empty+            Just eds -> text "extra decls:"+                          $$ nest 2 (vcat ([ppr bs | bs <- eds]))         , vcat (map ppr (mi_insts iface))         , vcat (map ppr (mi_fam_insts iface))         , vcat (map ppr (mi_rules iface))

@@ -23,7 +23,7 @@  import GHC.Hs -import GHC.StgToCmm.Types (CgInfos (..))+import GHC.StgToCmm.Types (CmmCgInfos (..))  import GHC.Tc.Utils.TcType import GHC.Tc.Utils.Monad@@ -99,6 +99,7 @@ import Data.List ( findIndex, mapAccumL, sortBy ) import Data.Ord import Data.IORef+import GHC.Stg.Pipeline (StgCgInfos)   {-@@ -110,11 +111,12 @@ -}  mkPartialIface :: HscEnv+               -> CoreProgram                -> ModDetails                -> ModSummary                -> ModGuts                -> PartialModIface-mkPartialIface hsc_env mod_details mod_summary+mkPartialIface hsc_env core_prog mod_details mod_summary   ModGuts{ mg_module       = this_mod          , mg_hsc_src      = hsc_src          , mg_usages       = usages@@ -128,22 +130,22 @@          , mg_trust_pkg    = self_trust          , mg_docs         = docs          }-  = mkIface_ hsc_env this_mod hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust+  = mkIface_ hsc_env this_mod core_prog hsc_src used_th deps rdr_env fix_env warns hpc_info self_trust              safe_mode usages docs mod_summary mod_details  -- | Fully instantiate an interface. Adds fingerprints and potentially code -- generator produced information. ----- CgInfos is not available when not generating code (-fno-code), or when not+-- CmmCgInfos is not available when not generating code (-fno-code), or when not -- generating interface pragmas (-fomit-interface-pragmas). See also -- Note [Conveying CAF-info and LFInfo between modules] in GHC.StgToCmm.Types.-mkFullIface :: HscEnv -> PartialModIface -> Maybe CgInfos -> IO ModIface-mkFullIface hsc_env partial_iface mb_cg_infos = do+mkFullIface :: HscEnv -> PartialModIface -> Maybe StgCgInfos -> Maybe CmmCgInfos -> IO ModIface+mkFullIface hsc_env partial_iface mb_stg_infos mb_cmm_infos = do     let decls           | gopt Opt_OmitInterfacePragmas (hsc_dflags hsc_env)           = mi_decls partial_iface           | otherwise-          = updateDecl (mi_decls partial_iface) mb_cg_infos+          = updateDecl (mi_decls partial_iface) mb_stg_infos mb_cmm_infos      full_iface <-       {-# SCC "addFingerprints" #-}@@ -156,11 +158,16 @@      return full_iface -updateDecl :: [IfaceDecl] -> Maybe CgInfos -> [IfaceDecl]-updateDecl decls Nothing = decls-updateDecl decls (Just CgInfos{ cgNonCafs = NonCaffySet non_cafs, cgLFInfos = lf_infos, cgTagSigs = tag_sigs })+updateDecl :: [IfaceDecl] -> Maybe StgCgInfos -> Maybe CmmCgInfos -> [IfaceDecl]+updateDecl decls Nothing Nothing = decls+updateDecl decls m_stg_infos m_cmm_infos   = map update_decl decls   where+    (non_cafs,lf_infos) = maybe (mempty, mempty)+                                (\cmm_info -> (ncs_nameSet (cgNonCafs cmm_info), cgLFInfos cmm_info))+                                m_cmm_infos+    tag_sigs = fromMaybe mempty m_stg_infos+     update_decl (IfaceId nm ty details infos)       | let not_caffy = elemNameSet nm non_cafs       , let mb_lf_info = lookupNameEnv lf_infos nm@@ -178,6 +185,9 @@     update_decl decl       = decl +++ -- | Make an interface from the results of typechecking only.  Useful -- for non-optimising compilation, or where we aren't generating any -- object code at all ('NoBackend').@@ -185,9 +195,10 @@           -> SafeHaskellMode    -- The safe haskell mode           -> ModDetails         -- gotten from mkBootModDetails, probably           -> ModSummary+          -> Maybe CoreProgram           -> TcGblEnv           -- Usages, deprecations, etc           -> IO ModIface-mkIfaceTc hsc_env safe_mode mod_details mod_summary+mkIfaceTc hsc_env safe_mode mod_details mod_summary mb_program   tc_result@TcGblEnv{ tcg_mod = this_mod,                       tcg_src = hsc_src,                       tcg_imports = imports,@@ -228,16 +239,16 @@           docs <- extractDocs (ms_hspp_opts mod_summary) tc_result            let partial_iface = mkIface_ hsc_env-                   this_mod hsc_src+                   this_mod (fromMaybe [] mb_program) hsc_src                    used_th deps rdr_env                    fix_env warns hpc_info                    (imp_trust_own_pkg imports) safe_mode usages                    docs mod_summary                    mod_details -          mkFullIface hsc_env partial_iface Nothing+          mkFullIface hsc_env partial_iface Nothing Nothing -mkIface_ :: HscEnv -> Module -> HscSource+mkIface_ :: HscEnv -> Module -> CoreProgram -> HscSource          -> Bool -> Dependencies -> GlobalRdrEnv          -> NameEnv FixItem -> Warnings GhcRn -> HpcInfo          -> Bool@@ -248,7 +259,7 @@          -> ModDetails          -> PartialModIface mkIface_ hsc_env-         this_mod hsc_src used_th deps rdr_env fix_env src_warns+         this_mod core_prog hsc_src used_th deps rdr_env fix_env src_warns          hpc_info pkg_trust_req safe_mode usages          docs mod_summary          ModDetails{  md_insts     = insts,@@ -268,6 +279,9 @@         semantic_mod = homeModuleNameInstantiation home_unit (moduleName this_mod)         entities = typeEnvElts type_env         show_linear_types = xopt LangExt.LinearTypes (hsc_dflags hsc_env)++        extra_decls = if gopt Opt_WriteIfSimplifiedCore dflags then Just [ toIfaceTopBind b | b <- core_prog ]+                                                               else Nothing         decls  = [ tyThingToIfaceDecl show_linear_types entity                  | entity <- entities,                    let name = getName entity,@@ -319,6 +333,7 @@           mi_globals     = maybeGlobalRdrEnv rdr_env,           mi_used_th     = used_th,           mi_decls       = decls,+          mi_extra_decls = extra_decls,           mi_hpc         = isHpcUsed hpc_info,           mi_trust       = trust_info,           mi_trust_pkg   = pkg_trust_req,

@@ -70,7 +70,7 @@ import GHC.Unit.Module.Deps  import Control.Monad-import Data.List (sortBy, sort)+import Data.List (sortBy, sort, sortOn) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Word (Word64)@@ -137,6 +137,10 @@       -- ^ The old item, if it exists   deriving (Functor) +instance Outputable a => Outputable (MaybeValidated a) where+  ppr (UpToDateItem a) = text "UpToDate" <+> ppr a+  ppr (OutOfDateItem r _) = text "OutOfDate: " <+> ppr r+ outOfDateItemBecause :: RecompReason -> Maybe a -> MaybeValidated a outOfDateItemBecause reason item = OutOfDateItem (RecompBecause reason) item @@ -1197,6 +1201,16 @@        sorted_decls = Map.elems $ Map.fromList $                           [(getOccName d, e) | e@(_, d) <- decls_w_hashes] +       -- This key is safe because mi_extra_decls contains tidied things.+       getOcc (IfGblTopBndr b) = getOccName b+       getOcc (IfLclTopBndr fs _ _ _) = mkVarOccFS fs++       binding_key (IfaceNonRec b _) = IfaceNonRec (getOcc b) ()+       binding_key (IfaceRec bs) = IfaceRec (map (\(b, _) -> (getOcc b, ())) bs)++       sorted_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]+       sorted_extra_decls = sortOn binding_key <$> mi_extra_decls iface0+    -- the flag hash depends on:    --   - (some of) dflags    -- it returns two hashes, one that shouldn't change@@ -1254,7 +1268,7 @@       , mi_fix_fn      = fix_fn       , mi_hash_fn     = lookupOccEnv local_env       }-    final_iface = iface0 { mi_decls = sorted_decls, mi_final_exts = final_iface_exts }+    final_iface = iface0 { mi_decls = sorted_decls, mi_extra_decls = sorted_extra_decls, mi_final_exts = final_iface_exts }    --    return final_iface 

@@ -380,9 +380,10 @@                           }) = do    let implicit_binds = concatMap getImplicitBinds tcs+      all_binds = implicit_binds ++ binds -  (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+  (unfold_env, tidy_occ_env) <- chooseExternalIds opts mod all_binds imp_rules+  let (trimmed_binds, trimmed_rules) = findExternalRules opts all_binds imp_rules unfold_env    (tidy_env, tidy_binds) <- tidyTopBinds unfold_env boot_exports tidy_occ_env trimmed_binds @@ -419,7 +420,7 @@       tidy_rules     = tidyRules tidy_env trimmed_rules        -- See Note [Injecting implicit bindings]-      all_tidy_binds = implicit_binds ++ tidy_binds'+      all_tidy_binds = tidy_binds'        -- Get the TyCons to generate code for.  Careful!  We must use       -- the untidied TyCons here, because we need@@ -646,12 +647,11 @@ chooseExternalIds :: TidyOpts                   -> Module                   -> [CoreBind]-                  -> [CoreBind]                   -> [CoreRule]                   -> IO (UnfoldEnv, TidyOccEnv)                   -- Step 1 from the notes above -chooseExternalIds opts mod binds implicit_binds imp_id_rules+chooseExternalIds opts mod 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 }@@ -680,10 +680,9 @@   rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules    binders          = map fst $ flattenBinds binds-  implicit_binders = bindersOfBinds implicit_binds   binder_set       = mkVarSet binders -  avoids   = [getOccName name | bndr <- binders ++ implicit_binders,+  avoids   = [getOccName name | bndr <- binders,                                 let name = idName bndr,                                 isExternalName name ]                 -- In computing our "avoids" list, we must include@@ -1010,7 +1009,7 @@                 -- See Note [Which rules to expose]      is_external_id id = case lookupVarEnv unfold_env id of-                          Just (name, _) -> isExternalName name+                          Just (name, _) -> isExternalName name && not (isImplicitId id)                           Nothing        -> False      trim_binds :: [CoreBind]

@@ -249,11 +249,11 @@         [  text "static StgWord64 k" <> int i <> text "[2] = "            <> pprFingerprint fp <> semi         $$ text "extern StgPtr "-           <> (pprCLabel platform CStyle $ mkClosureLabel (idName n) (idCafInfo n)) <> semi+           <> (pprCLabel platform $ mkClosureLabel (idName n) (idCafInfo n)) <> semi         $$ text "hs_spt_insert" <> parens              (hcat $ punctuate comma                 [ char 'k' <> int i-                , char '&' <> pprCLabel platform CStyle (mkClosureLabel (idName n) (idCafInfo n))+                , char '&' <> pprCLabel platform (mkClosureLabel (idName n) (idCafInfo n))                 ]              )         <> semi

@@ -11,10 +11,12 @@ {-# LANGUAGE FlexibleContexts #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# LANGUAGE TupleSections #-}  module GHC.IfaceToCore (         tcLookupImported_maybe,         importDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface,+        typecheckWholeCoreBindings,         typecheckIfacesForMerging,         typecheckIfaceForInstantiate,         tcIfaceDecl, tcIfaceDecls,@@ -22,7 +24,7 @@         tcIfaceAnnotations, tcIfaceCompleteMatches,         tcIfaceExpr,    -- Desired by HERMIT (#7683)         tcIfaceGlobal,-        tcIfaceOneShot+        tcIfaceOneShot, tcTopIfaceBindings,  ) where  import GHC.Prelude@@ -118,6 +120,9 @@ import Control.Monad import GHC.Parser.Annotation import GHC.Driver.Env.KnotVars+import GHC.Unit.Module.WholeCoreBindings+import Data.IORef+import Data.Foldable  {- This module takes@@ -234,6 +239,12 @@                               }     } +typecheckWholeCoreBindings :: IORef TypeEnv ->  WholeCoreBindings -> IfG [CoreBind]+typecheckWholeCoreBindings type_var (WholeCoreBindings prepd_binding this_mod _) =+  initIfaceLcl this_mod (text "typecheckWholeCoreBindings") NotBoot $ do+    tcTopIfaceBindings type_var prepd_binding++ {- ************************************************************************ *                                                                      *@@ -892,6 +903,42 @@      tc_pr (nm, b) = do { id <- forkM (ppr nm) (tcIfaceExtId nm)                         ; return (nm, idType id, b) } +tcTopIfaceBindings :: IORef TypeEnv -> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]+          -> IfL [CoreBind]+tcTopIfaceBindings ty_var ver_decls+   = do+      int <- mapM tcTopBinders  ver_decls+      let all_ids :: [Id] = concatMap toList int+      liftIO $ modifyIORef ty_var (flip extendTypeEnvList (map AnId all_ids))++      extendIfaceIdEnv all_ids $ mapM (tc_iface_bindings) int++tcTopBinders :: IfaceBindingX a IfaceTopBndrInfo -> IfL (IfaceBindingX a Id)+tcTopBinders = traverse mk_top_id++tc_iface_bindings ::  IfaceBindingX IfaceMaybeRhs Id -> IfL CoreBind+tc_iface_bindings (IfaceNonRec b rhs) = do+    rhs' <- tc_iface_binding b rhs+    return $ NonRec b rhs'+tc_iface_bindings (IfaceRec bs) = do+  rs <- mapM (\(b, rhs) -> (b,) <$> tc_iface_binding b rhs) bs+  return (Rec rs)++-- | See Note [Interface File with Core: Sharing RHSs]+tc_iface_binding :: Id -> IfaceMaybeRhs -> IfL CoreExpr+tc_iface_binding i IfUseUnfoldingRhs = return (unfoldingTemplate $ realIdUnfolding i)+tc_iface_binding _ (IfRhs rhs) = tcIfaceExpr rhs++mk_top_id :: IfaceTopBndrInfo -> IfL Id+mk_top_id (IfGblTopBndr gbl_name) = tcIfaceExtId gbl_name+mk_top_id (IfLclTopBndr raw_name iface_type info details) = do+   name <- newIfaceName (mkVarOccFS raw_name)+   ty <- tcIfaceType iface_type+   info' <- tcIdInfo False TopLevel name ty info+   details' <- tcIdDetails ty details+   let new_id = mkGlobalId details' name ty info'+   return new_id+ tcIfaceDecls :: Bool           -> [(Fingerprint, IfaceDecl)]           -> IfL [(Name,TyThing)]@@ -1847,7 +1894,7 @@          { mb_thing <- importDecl name   -- It's imported; go get it         ; case mb_thing of-            Failed err      -> failIfM err+            Failed err      -> failIfM (ppr name <+> err)             Succeeded thing -> return thing         }}} 

@@ -124,13 +124,13 @@         text " __conf.rts_opts_enabled = "             <> text (show (rtsOptsEnabled dflags)) <> semi,         text " __conf.rts_opts_suggestions = "-            <> text (if rtsOptsSuggestions dflags-                        then "true"-                        else "false") <> semi,+            <> (if rtsOptsSuggestions dflags+                then text "true"+                else text "false") <> semi,         text "__conf.keep_cafs = "-            <> text (if gopt Opt_KeepCAFs dflags-                       then "true"-                       else "false") <> semi,+            <> (if gopt Opt_KeepCAFs dflags+                then text "true"+                else text "false") <> semi,         case rtsOpts dflags of             Nothing   -> Outputable.empty             Just opts -> text "    __conf.rts_opts= " <>

@@ -77,6 +77,7 @@ import GHC.Unit.Finder import GHC.Unit.Module import GHC.Unit.Module.ModIface+import GHC.Unit.Module.WholeCoreBindings import GHC.Unit.Module.Deps import GHC.Unit.Home.ModInfo import GHC.Unit.State as Packages@@ -840,11 +841,17 @@      while_linking_expr = text "while linking an interpreted expression" -        -- This one is a build-system bug +    -- See Note [Using Byte Code rather than Object Code for Template Haskell]+    homeModLinkable :: DynFlags -> HomeModInfo -> Maybe Linkable+    homeModLinkable dflags hmi =+      if gopt Opt_UseBytecodeRatherThanObjects dflags+        then homeModInfoByteCode hmi <|> homeModInfoObject hmi+        else homeModInfoObject hmi   <|> homeModInfoByteCode hmi+     get_linkable osuf mod      -- A home-package module         | Just mod_info <- lookupHugByModule mod (hsc_HUG hsc_env)-        = adjust_linkable (Maybes.expectJust "getLinkDeps" (hm_linkable mod_info))+        = adjust_linkable (Maybes.expectJust "getLinkDeps" (homeModLinkable dflags mod_info))         | otherwise         = do    -- It's not in the HPT because we are in one shot mode,                 -- so use the Finder to get a ModLocation...@@ -889,8 +896,35 @@             adjust_ul _ (DotA fp) = panic ("adjust_ul DotA " ++ show fp)             adjust_ul _ (DotDLL fp) = panic ("adjust_ul DotDLL " ++ show fp)             adjust_ul _ l@(BCOs {}) = return l+            adjust_ul _ l@LoadedBCOs{} = return l+            adjust_ul _ (CoreBindings (WholeCoreBindings _ mod _))     = pprPanic "Unhydrated core bindings" (ppr mod) +{-+Note [Using Byte Code rather than Object Code for Template Haskell]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The `-fprefer-byte-code` flag allows a user to specify that they want to use+byte code (if availble) rather than object code for home module dependenices+when executing Template Haskell splices.++Why might you want to use byte code rather than object code?++* Producing object code is much slower than producing byte code (for example if you're using -fno-code)+* Linking many large object files, which happens once per splice, is quite expensive. (#21700)++So we allow the user to choose to use byte code rather than object files if they want to avoid these+two pitfalls.++When using `-fprefer-byte-code` you have to arrange to have the byte code availble.+In normal --make mode it will not be produced unless you enable `-fbyte-code-and-object-code`.+See Note [Home module build products] for some more information about that.++The only other place where the flag is consulted is when enabling code generation+with `-fno-code`, which does so to anticipate what decision we will make at the+splice point about what we would prefer.++-}+ {- **********************************************************************                Loading a Decls statement@@ -1133,7 +1167,7 @@             unlinkeds                = concatMap linkableUnlinked new_bcos              cbcs :: [CompiledByteCode]-            cbcs      = map byteCodeOfObject unlinkeds+            cbcs      = concatMap byteCodeOfObject unlinkeds               ies        = map bc_itbls cbcs

@@ -50,10 +50,8 @@            newTempName logger tmpfs (tmpDir dflags) TFL_GhcSession (objectSuf dflags)           writeFile rc_filename $-             "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"+             "1 24 MOVEABLE PURE \"" ++ manifest_filename ++ "\"\n"                -- magic numbers :-)-               -- show is a bit hackish above, but we need to escape the-               -- backslashes in the path.           runWindres logger dflags $ map GHC.SysTools.Option $                ["--input="++rc_filename,

@@ -57,7 +57,7 @@ import GHC.Rename.Unbound ( notInScopeErr, WhereLooking(WL_LocalOnly) ) import GHC.Tc.Errors.Types import GHC.Tc.Errors.Ppr ( pprScopeError-                         , inHsDocContext, withHsDocContext, pprHsDocContext )+                         , inHsDocContext, pprHsDocContext ) import GHC.Tc.Utils.Monad import GHC.Types.Name.Reader import GHC.Builtin.Names@@ -622,8 +622,9 @@  rnHsTyKi env (HsTyVar _ ip (L loc rdr_name))   = do { when (isRnKindLevel env && isRdrTyVar rdr_name) $-         unlessXOptM LangExt.PolyKinds $ addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $-         withHsDocContext (rtke_ctxt env) $+         unlessXOptM LangExt.PolyKinds $ addErr $+         TcRnWithHsDocContext (rtke_ctxt env) $+         mkTcRnUnknownMessage $ mkPlainError noHints $          vcat [ text "Unexpected kind variable" <+> quotes (ppr rdr_name)               , text "Perhaps you intended to use PolyKinds" ]            -- Any type variable at the kind level is illegal without the use@@ -760,8 +761,9 @@       mb_name <- lookupLocalOccRn_maybe rdr_name       -- TODO: refactor this to avoid mkTcRnUnknownMessage       when (isNothing mb_name) $-        addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $-          withHsDocContext (rtke_ctxt env) $+        addErr $+          TcRnWithHsDocContext (rtke_ctxt env) $+          mkTcRnUnknownMessage $ mkPlainError noHints $           pprScopeError rdr_name (notInScopeErr WL_LocalOnly rdr_name)  rnHsTyKi env ty@(HsExplicitListTy _ ip tys)@@ -860,7 +862,8 @@               -> Maybe BadAnonWildcardContext               -> RnM () checkWildCard env mb_name (Just bad)-  = addErr $ TcRnIllegalWildcardInType mb_name bad (Just $ rtke_ctxt env)+  = addErr $ TcRnWithHsDocContext (rtke_ctxt env) $+             TcRnIllegalWildcardInType mb_name bad checkWildCard _ _ Nothing   = return () @@ -1658,8 +1661,9 @@  badKindSigErr :: HsDocContext -> LHsType GhcPs -> TcM () badKindSigErr doc (L loc ty)-  = setSrcSpanA loc $ addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $-    withHsDocContext doc $+  = setSrcSpanA loc $ addErr $+    TcRnWithHsDocContext doc $+    mkTcRnUnknownMessage $ mkPlainError noHints $     hang (text "Illegal kind signature:" <+> quotes (ppr ty))        2 (text "Perhaps you intended to use KindSignatures") 

@@ -38,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, pprScopeError )+import GHC.Tc.Errors.Ppr (pprScopeError) import GHC.Tc.Gen.Annotation ( annCtxt ) import GHC.Tc.Utils.Monad @@ -618,7 +618,8 @@                Just (L _ cls) -> Right cls                Nothing        -> Left                  ( getLocA head_ty'-                 , hang (text "Illegal head of an instance declaration:"+                 , mkTcRnUnknownMessage $ mkPlainError noHints $+                   hang (text "Illegal head of an instance declaration:"                            <+> quotes (ppr head_ty'))                       2 (vcat [ text "Instance heads must be of the form"                               , nest 2 $ text "C ty_1 ... ty_n"@@ -681,7 +682,7 @@     -- reach the typechecker, lest we encounter different errors that are     -- hopelessly confusing (such as the one in #16114).     bail_out (l, err_msg) = do-      addErrAt l $ mkTcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg)+      addErrAt l $ TcRnWithHsDocContext ctxt err_msg       pure $ mkUnboundName (mkTcOccFS (fsLit "<class>"))  rnFamEqn :: HsDocContext@@ -1839,7 +1840,8 @@                           , tcdDataDefn = defn'                           , tcdDExt     = rn_info }, fvs) } } -rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls,+rnTyClDecl (ClassDecl { tcdLayout = layout,+                        tcdCtxt = context, tcdLName = lcls,                         tcdTyVars = tyvars, tcdFixity = fixity,                         tcdFDs = fds, tcdSigs = sigs,                         tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs,@@ -1893,7 +1895,8 @@          ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs         ; docs' <- traverse rnLDocDecl docs-        ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls',+        ; return (ClassDecl { tcdLayout = rnLayoutInfo layout,+                              tcdCtxt = context', tcdLName = lcls',                               tcdTyVars = tyvars', tcdFixity = fixity,                               tcdFDs = fds', tcdSigs = sigs',                               tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs',@@ -1901,6 +1904,11 @@                   all_fvs ) }   where     cls_doc  = ClassDeclCtx lcls++rnLayoutInfo :: LayoutInfo GhcPs -> LayoutInfo GhcRn+rnLayoutInfo (ExplicitBraces ob cb) = ExplicitBraces ob cb+rnLayoutInfo (VirtualBraces n) = VirtualBraces n+rnLayoutInfo NoLayoutInfo = NoLayoutInfo  -- Does the data type declaration include a CUSK? data_decl_has_cusk :: LHsQTyVars (GhcPass p) -> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> RnM Bool

@@ -30,7 +30,7 @@         ImportDeclUsage     ) where -import GHC.Prelude+import GHC.Prelude hiding ( head, init, last, tail )  import GHC.Driver.Env import GHC.Driver.Session@@ -755,7 +755,7 @@     -- This establishes INVARIANT 1 of GlobalRdrEnvs     add_gre env gre       | not (null dups)    -- Same OccName defined twice-      = do { addDupDeclErr (gre : dups); return env }+      = do { addDupDeclErr (gre :| dups); return env }        | otherwise       = return (extendGlobalRdrEnv env gre)@@ -2153,10 +2153,9 @@ illegalImportItemErr :: SDoc illegalImportItemErr = text "Illegal import item" -addDupDeclErr :: [GlobalRdrElt] -> TcRn ()-addDupDeclErr [] = panic "addDupDeclErr: empty list"-addDupDeclErr gres@(gre : _)-  = addErrAt (getSrcSpan (last sorted_names)) $ mkTcRnUnknownMessage $ mkPlainError noHints $+addDupDeclErr :: NonEmpty GlobalRdrElt -> TcRn ()+addDupDeclErr gres@(gre :| _)+  = addErrAt (getSrcSpan (NE.last sorted_names)) $ mkTcRnUnknownMessage $ mkPlainError noHints $     -- Report the error at the later location     vcat [text "Multiple declarations of" <+>              quotes (ppr (greOccName gre)),@@ -2164,11 +2163,11 @@              -- latter might not be in scope in the RdrEnv and so will              -- be printed qualified.           text "Declared at:" <+>-                   vcat (map (ppr . nameSrcLoc) sorted_names)]+                   vcat (toList $ ppr . nameSrcLoc <$> sorted_names)]   where     sorted_names =-      sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan)-             (map greMangledName gres)+      NE.sortBy (SrcLoc.leftmost_smallest `on` nameSrcSpan)+             (fmap greMangledName gres)   

@@ -328,8 +328,7 @@       | otherwise                             = True     where       hpt_uniques = map fst (udfmToList hpt)-      is_last_loaded_mod _ []         = False-      is_last_loaded_mod modnam uniqs = last uniqs == getUnique modnam+      is_last_loaded_mod modnam uniqs = lastMaybe uniqs == Just (getUnique modnam)       glob_mods = nub [ mod                      | gre <- globalRdrEnvElts global_env                      , (mod, _) <- qualsInScope gre

@@ -43,7 +43,6 @@ import GHC.Hs import GHC.Types.Name.Reader import GHC.Tc.Errors.Types-import GHC.Tc.Errors.Ppr (withHsDocContext) import GHC.Tc.Utils.Env import GHC.Tc.Utils.Monad import GHC.Types.Error@@ -204,7 +203,9 @@   let bndrs = sig_ty_bndrs ty   in case find ((==) InferredSpec . hsTyVarBndrFlag) bndrs of     Nothing -> return ()-    Just _  -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt msg)+    Just _  -> addErr $+      TcRnWithHsDocContext ctxt $+      mkTcRnUnknownMessage $ mkPlainError noHints msg   where     sig_ty_bndrs :: LHsSigType GhcPs -> [HsTyVarBndr Specificity GhcPs]     sig_ty_bndrs (L _ (HsSig{sig_bndrs = outer_bndrs}))@@ -287,7 +288,7 @@ --   "GHC.Rename.Module" and 'renameSig' in "GHC.Rename.Bind"). --   See @Note [No nested foralls or contexts in instance types]@ in --   "GHC.Hs.Type".-noNestedForallsContextsErr :: SDoc -> LHsType GhcRn -> Maybe (SrcSpan, SDoc)+noNestedForallsContextsErr :: SDoc -> LHsType GhcRn -> Maybe (SrcSpan, TcRnMessage) noNestedForallsContextsErr what lty =   case ignoreParens lty of     L l (HsForAllTy { hst_tele = tele })@@ -296,9 +297,7 @@          -- types of terms, so we give a slightly more descriptive error          -- message in the event that they contain visible dependent          -- quantification (currently only allowed in kinds).-      -> Just (locA l, vcat [ text "Illegal visible, dependent quantification" <+>-                              text "in the type of a term"-                            , text "(GHC does not yet support this)" ])+      -> Just (locA l, TcRnVDQInTermType Nothing)       |  HsForAllInvis{} <- tele       -> Just (locA l, nested_foralls_contexts_err)     L l (HsQualTy {})@@ -306,6 +305,7 @@     _ -> Nothing   where     nested_foralls_contexts_err =+      mkTcRnUnknownMessage $ mkPlainError noHints $       what <+> text "cannot contain nested"       <+> quotes forAllLit <> text "s or contexts" @@ -313,7 +313,7 @@ addNoNestedForallsContextsErr :: HsDocContext -> SDoc -> LHsType GhcRn -> RnM () addNoNestedForallsContextsErr ctxt what lty =   whenIsJust (noNestedForallsContextsErr what lty) $ \(l, err_msg) ->-    addErrAt l $ mkTcRnUnknownMessage $ mkPlainError noHints (withHsDocContext ctxt err_msg)+    addErrAt l $ TcRnWithHsDocContext ctxt err_msg  {- ************************************************************************

@@ -62,7 +62,6 @@ import GHCi.RemoteTypes import GHC.ByteCode.Types -import GHC.Linker.Types import GHC.Linker.Loader as Loader  import GHC.Hs@@ -1242,17 +1241,18 @@ showModule :: GhcMonad m => ModSummary -> m String showModule mod_summary =     withSession $ \hsc_env -> do-        interpreted <- moduleIsBootOrNotObjectLinkable mod_summary         let dflags = hsc_dflags hsc_env+        let interpreted =+              case lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) of+               Nothing       -> panic "missing linkable"+               Just mod_info -> isJust (homeModInfoByteCode mod_info)  && isNothing (homeModInfoObject mod_info)         return (showSDoc dflags $ showModMsg dflags interpreted (ModuleNode [] mod_summary))  moduleIsBootOrNotObjectLinkable :: GhcMonad m => ModSummary -> m Bool moduleIsBootOrNotObjectLinkable mod_summary = withSession $ \hsc_env ->-  case lookupHpt (hsc_HPT hsc_env) (ms_mod_name mod_summary) of+  case lookupHug (hsc_HUG hsc_env) (ms_unitid mod_summary) (ms_mod_name mod_summary) of         Nothing       -> panic "missing linkable"-        Just mod_info -> return $ case hm_linkable mod_info of-          Nothing       -> True-          Just linkable -> not (isObjectLinkable linkable)+        Just mod_info -> return . isNothing $ homeModInfoByteCode mod_info  ---------------------------------------------------------------------------- -- RTTI primitives

@@ -23,7 +23,7 @@      constrClosToName -- exported to use in test T4891  ) where -import GHC.Prelude+import GHC.Prelude hiding (head, init, last, tail) import GHC.Platform  import GHC.Runtime.Interpreter as GHCi@@ -67,6 +67,8 @@ import Control.Monad import Data.Maybe import Data.List ((\\))+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE import GHC.Exts import qualified Data.Sequence as Seq import Data.Sequence (viewl, ViewL(..))@@ -431,13 +433,14 @@    --Note pprinting of list terms is not lazy    ppr_list :: Precedence -> Term -> m SDoc    ppr_list p (Term{subTerms=[h,t]}) = do-       let elems      = h : getListTerms t-           isConsLast = not (termType (last elems) `eqType` termType h)+       let elems      = h :| getListTerms t+           elemList   = toList elems+           isConsLast = not (termType (NE.last elems) `eqType` termType h)            is_string  = all (isCharTy . ty) elems            chars = [ chr (fromIntegral w)-                   | Term{subTerms=[Prim{valRaw=[w]}]} <- elems ]+                   | Term{subTerms=[Prim{valRaw=[w]}]} <- elemList ] -       print_elems <- mapM (y cons_prec) elems+       print_elems <- mapM (y cons_prec) elemList        if is_string         then return (Ppr.doubleQuotes (Ppr.text chars))         else if isConsLast

@@ -117,6 +117,11 @@     , sam_lit :: LiteralMap a     } +-- TODO(22292): derive+instance Functor StgArgMap where+    fmap f SAM { sam_var = varm, sam_lit = litm } = SAM+      { sam_var = fmap f varm, sam_lit = fmap f litm }+ instance TrieMap StgArgMap where     type Key StgArgMap = StgArg     emptyTM  = SAM { sam_var = emptyTM@@ -126,13 +131,16 @@     alterTM  (StgVarArg var) f m = m { sam_var = sam_var m |> xtDFreeVar var f }     alterTM  (StgLitArg lit) f m = m { sam_lit = sam_lit m |> alterTM lit f }     foldTM k m = foldTM k (sam_var m) . foldTM k (sam_lit m)-    mapTM f (SAM {sam_var = varm, sam_lit = litm}) =-        SAM { sam_var = mapTM f varm, sam_lit = mapTM f litm }     filterTM f (SAM {sam_var = varm, sam_lit = litm}) =         SAM { sam_var = filterTM f varm, sam_lit = filterTM f litm }  newtype ConAppMap a = CAM { un_cam :: DNameEnv (ListMap StgArgMap a) } +-- TODO(22292): derive+instance Functor ConAppMap where+    fmap f = CAM . fmap (fmap f) . un_cam+    {-# INLINE fmap #-}+ instance TrieMap ConAppMap where     type Key ConAppMap = (DataCon, [StgArg])     emptyTM  = CAM emptyTM@@ -140,8 +148,7 @@     alterTM  (dataCon, args) f m =         m { un_cam = un_cam m |> xtDNamed dataCon |>> alterTM args f }     foldTM k = un_cam >.> foldTM (foldTM k)-    mapTM f  = un_cam >.> mapTM (mapTM f) >.> CAM-    filterTM f = un_cam >.> mapTM (filterTM f) >.> CAM+    filterTM f = un_cam >.> fmap (filterTM f) >.> CAM  ----------------- -- The CSE Env --

@@ -27,7 +27,6 @@ import GHC.Stg.InferTags.Rewrite (rewriteTopBinds) import Data.Maybe import GHC.Types.Name.Env (mkNameEnv, NameEnv)-import GHC.Driver.Config.Stg.Ppr import GHC.Driver.Session import GHC.Utils.Logger import qualified GHC.Unit.Types@@ -217,17 +216,17 @@ --           -> CollectedCCs --           -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs --           -> HpcInfo---           -> IO (Stream IO CmmGroupSRTs CgInfos)+--           -> IO (Stream IO CmmGroupSRTs CmmCgInfos) --          -- Note we produce a 'Stream' of CmmGroups, so that the --          -- backend can be run incrementally.  Otherwise it generates all --          -- the C-- up front, which has a significant space cost.-inferTags :: DynFlags -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)-inferTags dflags logger this_mod stg_binds = do+inferTags :: StgPprOpts -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig)+inferTags ppr_opts logger this_mod stg_binds = do      -- Annotate binders with tag information.     let (!stg_binds_w_tags) = {-# SCC "StgTagFields" #-}                                         inferTagsAnal stg_binds-    putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_w_tags)+    putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings ppr_opts stg_binds_w_tags)      let export_tag_info = collectExportInfo stg_binds_w_tags 

@@ -30,7 +30,7 @@ import GHC.Types.Unique.FM import GHC.Types.RepType import GHC.Types.Var.Set-import GHC.Unit.Types      ( Module )+import GHC.Unit.Types  import GHC.Core.DataCon import GHC.Core            ( AltCon(..) )@@ -215,9 +215,49 @@     setFVs old_fvs     return r +{- Note [Tag inference for interactive contexts]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When compiling bytecode we call myCoreToStg to get STG code first.+myCoreToStg in turn calls out to stg2stg which runs the STG to STG+passes followed by free variables analysis and the tag inference pass including+it's rewriting phase at the end.+Running tag inference is important as it upholds Note [Strict Field Invariant].+While code executed by GHCi doesn't take advantage of the SFI it can call into+compiled code which does. So it must still make sure that the SFI is upheld.+See also #21083 and #22042.++However there one important difference in code generation for GHCi and regular+compilation. When compiling an entire module (not a GHCi expression), we call+`stg2stg` on the entire module which allows us to build up a map which is guaranteed+to have an entry for every binder in the current module.+For non-interactive compilation the tag inference rewrite pass takes advantage+of this by building up a map from binders to their tag signatures.++When compiling a GHCi expression on the other hand we invoke stg2stg separately+for each expression on the prompt. This means in GHCi for a sequence of:+    > let x = True+    > let y = StrictJust x+We first run stg2stg for `[x = True]`. And then again for [y = StrictJust x]`.++While computing the tag signature for `y` during tag inference inferConTag will check+if `x` is already tagged by looking up the tagsig of `x` in the binder->signature mapping.+However since this mapping isn't persistent between stg2stg+invocations the lookup will fail. This isn't a correctness issue since it's always+safe to assume a binding isn't tagged and that's what we do in such cases.++However for non-interactive mode we *don't* want to do this. Since in non-interactive mode+we have all binders of the module available for each invocation we can expect the binder->signature+mapping to be complete and all lookups to succeed. This means in non-interactive contexts a failed lookup+indicates a bug in the tag inference implementation.+For this reason we assert that we are running in interactive mode if a lookup fails.+-} isTagged :: Id -> RM Bool isTagged v = do     this_mod <- getMod+    -- See Note [Tag inference for interactive contexts]+    let lookupDefault v = assertPpr (isInteractiveModule this_mod)+                                    (text "unknown Id:" <> ppr this_mod <+> ppr v)+                                    (TagSig TagDunno)     case nameIsLocalOrFrom this_mod (idName v) of         True             | Just Unlifted <- typeLevity_maybe (idType v)@@ -226,8 +266,8 @@             -> return True             | otherwise -> do -- Local binding                 !s <- getMap-                let !sig = lookupWithDefaultUFM s (pprPanic "unknown Id:" (ppr v)) v-                return $! case sig of+                let !sig = lookupWithDefaultUFM s (lookupDefault v) v+                return $ case sig of                     TagSig info ->                         case info of                             TagDunno -> False

@@ -276,13 +276,13 @@ withLiftedBndr :: DIdSet -> Id -> (Id -> LiftM a) -> LiftM a withLiftedBndr abs_ids bndr inner = do   uniq <- getUniqueM-  let str = "$l" ++ occNameString (getOccName bndr)+  let str = fsLit "$l" `appendFS` occNameFS (getOccName bndr)   let ty = mkLamTypes (dVarSetElems abs_ids) (idType bndr)   let bndr'         -- See Note [transferPolyIdInfo] in GHC.Types.Id. We need to do this at least         -- for arity information.         = transferPolyIdInfo bndr (dVarSetElems abs_ids)-        . mkSysLocal (mkFastString str) uniq Many+        . mkSysLocal str uniq Many         $ ty   LiftM $ RWS.local     (\e -> e

@@ -46,10 +46,19 @@   t_1 :: TYPE r_1, ..., t_n :: TYPE r_n   s_1 :: TYPE p_1, ..., a_n :: TYPE p_n -Then we must check that each r_i is compatible with s_i. Compatibility-is weaker than on-the-nose equality: for example, IntRep and WordRep are-compatible. See Note [Bad unsafe coercion] in GHC.Core.Lint.+Before unarisation, we must check that each r_i is compatible with s_i.+Compatibility is weaker than on-the-nose equality: for example,+IntRep and WordRep are compatible. See Note [Bad unsafe coercion] in GHC.Core.Lint. +After unarisation, a single type might correspond to multiple arguments, e.g.++  (# Int# | Bool #) :: TYPE (SumRep '[ IntRep, LiftedRep ])++will result in two arguments: [Int# :: TYPE 'IntRep, Bool :: TYPE LiftedRep]+This means post unarise we potentially have to match up multiple arguments with+the reps of a single argument in the type's definition, because the type of the function+is *not* in unarised form.+ Wrinkle: it can sometimes happen that an argument type in the type of the function does not have a fixed runtime representation, i.e. there is an r_i such that runtimeRepPrimRep r_i crashes.@@ -119,7 +128,7 @@ import GHC.Utils.Misc import GHC.Core.Multiplicity (scaledThing) import GHC.Settings (Platform)-import GHC.Core.TyCon (primRepCompatible)+import GHC.Core.TyCon (primRepCompatible, primRepsCompatible) import GHC.Utils.Panic.Plain (panic)  lintStgTopBindings :: forall a . (OutputablePass a, BinderP a ~ Id)@@ -332,14 +341,18 @@ lintStgAppReps fun args = do   lf <- getLintFlags   let platform = lf_platform lf+       (fun_arg_tys, _res) = splitFunTys (idType fun)-      fun_arg_tys' = map (scaledThing ) fun_arg_tys :: [Type]+      fun_arg_tys' = map scaledThing fun_arg_tys :: [Type]++      -- Might be "wrongly" typed as polymorphic. See #21399+      -- In these cases typePrimRep_maybe will return Nothing+      -- and we abort kind checking.       fun_arg_tys_reps, actual_arg_reps :: [Maybe [PrimRep]]       fun_arg_tys_reps = map typePrimRep_maybe fun_arg_tys'       actual_arg_reps = map (typePrimRep_maybe . stgArgType) args        match_args :: [Maybe [PrimRep]] -> [Maybe [PrimRep]] -> LintM ()-      -- Might be wrongly typed as polymorphic. See #21399       match_args (Nothing:_) _   = return ()       match_args (_) (Nothing:_) = return ()       match_args (Just actual_rep:actual_reps_left) (Just expected_rep:expected_reps_left)@@ -353,21 +366,36 @@          -- Some reps are compatible *even* if they are not the same. E.g. IntRep and WordRep.         -- We check for that here with primRepCompatible-        | and $ zipWith (primRepCompatible platform) actual_rep expected_rep+        | primRepsCompatible platform actual_rep expected_rep         = match_args actual_reps_left expected_reps_left +        -- We might distribute args from within one unboxed sum over multiple+        -- single rep args. This means we might need to match up things like:+        -- [Just [WordRep, LiftedRep]] with [Just [WordRep],Just [LiftedRep]]+        -- which happens here.+        -- See Note [Linting StgApp].+        | Just (actual,actuals) <- getOneRep actual_rep actual_reps_left+        , Just (expected,expecteds) <- getOneRep expected_rep expected_reps_left+        , primRepCompatible platform actual expected+        = match_args actuals expecteds+         | otherwise = addErrL $ hang (text "Function type reps and function argument reps mismatched") 2 $             (text "In application " <> ppr fun <+> ppr args $$-              text "argument rep:" <> ppr actual_rep $$-              text "expected rep:" <> ppr expected_rep $$+              text "argument rep:" <> ppr actual_arg_reps $$+              text "expected rep:" <> ppr fun_arg_tys_reps $$               -- text "expected reps:" <> ppr arg_ty_reps $$               text "unarised?:" <> ppr (lf_unarised lf))         where           isVoidRep [] = True           isVoidRep [VoidRep] = True           isVoidRep _ = False--          -- n_arg_ty_reps = length arg_ty_reps+          -- Try to strip one non-void arg rep from the current argument type returning+          -- the remaining list of arguments. We return Nothing for invalid input which+          -- will result in a lint failure in match_args.+          getOneRep :: [PrimRep] -> [Maybe [PrimRep]] -> Maybe (PrimRep, [Maybe [PrimRep]])+          getOneRep [] _rest = Nothing -- Void rep args are invalid at this point.+          getOneRep [rep] rest = Just (rep,rest) -- A single arg rep arg+          getOneRep (rep:reps) rest = Just (rep,Just reps:rest) -- Multi rep arg.        match_args _ _ = return () -- Functions are allowed to be over/under applied. 

@@ -13,6 +13,7 @@   ( StgPipelineOpts (..)   , StgToDo (..)   , stg2stg+  , StgCgInfos   ) where  import GHC.Prelude@@ -39,6 +40,9 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Reader import GHC.Settings (Platform)+import GHC.Stg.InferTags (inferTags)+import GHC.Types.Name.Env (NameEnv)+import GHC.Stg.InferTags.TagSig (TagSig)  data StgPipelineOpts = StgPipelineOpts   { stgPipeline_phases      :: ![StgToDo]@@ -52,6 +56,10 @@ newtype StgM a = StgM { _unStgM :: ReaderT Char IO a }   deriving (Functor, Applicative, Monad, MonadIO) +-- | Information to be exposed in interface files which is produced+-- by the stg2stg passes.+type StgCgInfos = NameEnv TagSig+ instance MonadUnique StgM where   getUniqueSupplyM = StgM $ do { mask <- ask                                ; liftIO $! mkSplitUniqSupply mask}@@ -66,7 +74,7 @@         -> StgPipelineOpts         -> Module                    -- ^ module being compiled         -> [StgTopBinding]           -- ^ input program-        -> IO [CgStgTopBinding]        -- output program+        -> IO ([CgStgTopBinding], StgCgInfos) -- output program stg2stg logger extra_vars opts this_mod binds   = do  { dump_when Opt_D_dump_stg_from_core "Initial STG:" binds         ; showPass logger "Stg2Stg"@@ -85,7 +93,8 @@           -- This pass will also augment each closure with non-global free variables           -- annotations (which is used by code generator to compute offsets into closures)         ; let binds_sorted_with_fvs = depSortWithAnnotStgPgm this_mod binds'-        ; return binds_sorted_with_fvs+        -- See Note [Tag inference for interactive contexts]+        ; inferTags (stgPipeline_pprOpts opts) logger this_mod binds_sorted_with_fvs    }    where

@@ -694,6 +694,8 @@ ubxSumRubbishArg Word64Slot = StgLitArg (LitNumber LitNumWord64 0) ubxSumRubbishArg FloatSlot  = StgLitArg (LitFloat 0) ubxSumRubbishArg DoubleSlot = StgLitArg (LitDouble 0)+ubxSumRubbishArg (VecSlot n e) = StgLitArg (LitRubbish vec_rep)+  where vec_rep = primRepToRuntimeRep (VecRep n e)  -------------------------------------------------------------------------------- 

@@ -1299,10 +1299,11 @@          push_args    = concatOL pushs_arg          !d_after_args = d0 + wordsToBytes platform a_reps_sizeW          a_reps_pushed_RAW-            | null a_reps_pushed_r_to_l || not (isVoidRep (head a_reps_pushed_r_to_l))-            = panic "GHC.StgToByteCode.generateCCall: missing or invalid World token?"+            | x:xs <- a_reps_pushed_r_to_l+            , isVoidRep x+            = reverse xs             | otherwise-            = reverse (tail a_reps_pushed_r_to_l)+            = panic "GHC.StgToByteCode.generateCCall: missing or invalid World token?"           -- Now: a_reps_pushed_RAW are the reps which are actually on the stack.          -- push_args is the code to do that.@@ -1371,9 +1372,8 @@          -- Get the arg reps, zapping the leading Addr# in the dynamic case          a_reps --  | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???"                 | is_static = a_reps_pushed_RAW-                | otherwise = if null a_reps_pushed_RAW-                              then panic "GHC.StgToByteCode.generateCCall: dyn with no args"-                              else tail a_reps_pushed_RAW+                | _:xs <- a_reps_pushed_RAW = xs+                | otherwise = panic "GHC.StgToByteCode.generateCCall: dyn with no args"           -- push the Addr#          (push_Addr, d_after_Addr)@@ -1669,10 +1669,21 @@         case lookupVarEnv topStrings var of             Just ptr -> pushAtom d p $ StgLitArg $ mkLitWord platform $               fromIntegral $ ptrToWordPtr $ fromRemotePtr ptr-            Nothing -> do-                let sz = idSizeCon platform var-                massert (sz == wordSize platform)-                return (unitOL (PUSH_G (getName var)), sz)+            Nothing+              -- PUSH_G doesn't tag constructors. So we use PACK here+              -- if we are dealing with nullary constructor.+              | Just con <- isDataConWorkId_maybe var+              -> do+                  massert (sz == wordSize platform)+                  massert (isNullaryRepDataCon con)+                  return (unitOL (PACK con 0), sz)+              | otherwise+              -> do+                  let+                  massert (sz == wordSize platform)+                  return (unitOL (PUSH_G (getName var)), sz)+              where+                !sz = idSizeCon platform var   pushAtom _ _ (StgLitArg lit) = pushLiteral True lit@@ -1846,11 +1857,9 @@          testEQ NoDiscr    _          = panic "mkMultiBranch NoDiscr"           -- None of these will be needed if there are no non-default alts-         (init_lo, init_hi)-            | null notd_ways-            = panic "mkMultiBranch: awesome foursome"-            | otherwise-            = case fst (head notd_ways) of+         (init_lo, init_hi) = case notd_ways of+            [] -> panic "mkMultiBranch: awesome foursome"+            (discr, _):_ -> case discr of                 DiscrI _ -> ( DiscrI minBound,  DiscrI maxBound )                 DiscrW _ -> ( DiscrW minBound,  DiscrW maxBound )                 DiscrF _ -> ( DiscrF minF,      DiscrF maxF )

@@ -25,6 +25,8 @@ import GHC.Platform import GHC.Platform.Profile +import GHC.Builtin.Names (unpackCStringName, unpackCStringUtf8Name)+ import GHC.StgToCmm.Config import GHC.StgToCmm.Expr import GHC.StgToCmm.Monad@@ -87,6 +89,9 @@       lf_info       = mkClosureLFInfo platform id TopLevel [] upd_flag args   in (cg_id_info, gen_code lf_info closure_label)   where++  gen_code :: LambdaFormInfo -> CLabel -> FCode ()+   -- special case for a indirection (f = g).  We create an IND_STATIC   -- closure pointing directly to the indirectee.  This is exactly   -- what the CAF will eventually evaluate to anyway, we're just@@ -101,10 +106,43 @@   -- concurrent/should_run/4030 fails, for instance.   --   gen_code _ closure_label-    | StgApp f [] <- body, null args, isNonRec rec+    | StgApp f [] <- body+    , null args+    , isNonRec rec     = do          cg_info <- getCgIdInfo f          emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)]++  -- Emit standard stg_unpack_cstring closures for top-level unpackCString# thunks.+  --+  -- Note that we do not do this for thunks enclosured in code ticks (e.g. hpc+  -- ticks) since we want to ensure that these ticks are not lost (e.g.+  -- resulting in Strings being reported by hpc as uncovered). However, we+  -- don't worry about standard profiling ticks since unpackCString tends not+  -- be terribly interesting in profiles. See Note [unpack_cstring closures] in+  -- StgStdThunks.cmm.+  gen_code _ closure_label+    | null args+    , StgApp f [arg] <- stripStgTicksTopE (not . tickishIsCode) body+    , Just unpack <- is_string_unpack_op f+    = do arg' <- getArgAmode (NonVoid arg)+         case arg' of+           CmmLit lit -> do+             let info = CmmInfoTable+                   { cit_lbl = unpack+                   , cit_rep = HeapRep True 0 1 Thunk+                   , cit_prof = NoProfilingInfo+                   , cit_srt = Nothing+                   , cit_clo = Nothing+                   }+             emitDecl $ CmmData (Section Data closure_label) $+                 CmmStatics closure_label info ccs [] [lit]+           _ -> panic "cgTopRhsClosure.gen_code"+    where+      is_string_unpack_op f+        | idName f == unpackCStringName     = Just mkRtsUnpackCStringLabel+        | idName f == unpackCStringUtf8Name = Just mkRtsUnpackCStringUtf8Label+        | otherwise                         = Nothing    gen_code lf_info _closure_label    = do { profile <- getProfile

@@ -161,19 +161,20 @@ --              Layout of static closures ----------------------------------------------------------- --- Make a static closure, adding on any extra padding needed for CAFs,--- and adding a static link field if necessary.-+-- | Make a static closure, adding on any extra padding needed for CAFs, and+-- adding a static link field if necessary. mkStaticClosureFields         :: Profile         -> CmmInfoTable         -> CostCentreStack         -> CafInfo-        -> [CmmLit]             -- Payload+        -> [CmmLit]             -- ^ Payload+        -> [CmmLit]             -- ^ Extra non-pointers that go to the end of the closure.+                                -- See Note [unpack_cstring closures] in StgStdThunks.cmm.         -> [CmmLit]             -- The full closure-mkStaticClosureFields profile info_tbl ccs caf_refs payload+mkStaticClosureFields profile info_tbl ccs caf_refs payload extras   = mkStaticClosure profile info_lbl ccs payload padding-        static_link_field saved_info_field+        static_link_field saved_info_field extras   where     platform = profilePlatform profile     info_lbl = cit_lbl info_tbl@@ -218,14 +219,15 @@                                       -- in rts/sm/Storage.h  mkStaticClosure :: Profile -> CLabel -> CostCentreStack -> [CmmLit]-  -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]-mkStaticClosure profile info_lbl ccs payload padding static_link_field saved_info_field+  -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]+mkStaticClosure profile info_lbl ccs payload padding static_link_field saved_info_field extras   =  [CmmLabel info_lbl]   ++ staticProfHdr profile ccs   ++ payload   ++ padding   ++ static_link_field   ++ saved_info_field+  ++ extras  ----------------------------------------------------------- --              Heap overflow checking

@@ -0,0 +1,144 @@+module GHC.StgToCmm.InfoTableProv (emitIpeBufferListNode) where++import GHC.Prelude+import GHC.Platform+import GHC.Unit.Module+import GHC.Utils.Outputable+import GHC.Types.SrcLoc (pprUserRealSpan, srcSpanFile)+import GHC.Data.FastString (unpackFS)++import GHC.Cmm.CLabel+import GHC.Cmm.Expr+import GHC.Cmm.Utils+import GHC.StgToCmm.Config+import GHC.StgToCmm.Lit (newByteStringCLit)+import GHC.StgToCmm.Monad+import GHC.StgToCmm.Utils++import GHC.Data.ShortText (ShortText)+import qualified GHC.Data.ShortText as ST++import qualified Data.Map.Strict as M+import Control.Monad.Trans.State.Strict+import qualified Data.ByteString as BS+import qualified Data.ByteString.Builder as BSB+import qualified Data.ByteString.Lazy as BSL++emitIpeBufferListNode :: Module+                      -> [InfoProvEnt]+                      -> FCode ()+emitIpeBufferListNode _ [] = return ()+emitIpeBufferListNode this_mod ents = do+    cfg <- getStgToCmmConfig+    let ctx      = stgToCmmContext  cfg+        platform = stgToCmmPlatform cfg++    let (cg_ipes, strtab) = flip runState emptyStringTable $ do+            module_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (ppr this_mod)+            mapM (toCgIPE platform ctx module_name) ents++    let -- Emit the fields of an IpeBufferEntry struct.+        toIpeBufferEntry :: CgInfoProvEnt -> [CmmLit]+        toIpeBufferEntry cg_ipe =+            [ CmmLabel (ipeInfoTablePtr cg_ipe)+            , strtab_offset (ipeTableName cg_ipe)+            , strtab_offset (ipeClosureDesc cg_ipe)+            , strtab_offset (ipeTypeDesc cg_ipe)+            , strtab_offset (ipeLabel cg_ipe)+            , strtab_offset (ipeModuleName cg_ipe)+            , strtab_offset (ipeSrcFile cg_ipe)+            , strtab_offset (ipeSrcSpan cg_ipe)+            , int32 0+            ]++        int n = mkIntCLit platform n+        int32 n = CmmInt n W32+        strtab_offset (StrTabOffset n) = int32 (fromIntegral n)++    strings <- newByteStringCLit (getStringTableStrings strtab)+    let lits = [ zeroCLit platform     -- 'next' field+               , strings               -- 'strings' field+               , int $ length cg_ipes  -- 'count' field+               ] ++ concatMap toIpeBufferEntry cg_ipes+    emitDataLits (mkIPELabel this_mod) lits++toCgIPE :: Platform -> SDocContext -> StrTabOffset -> InfoProvEnt -> State StringTable CgInfoProvEnt+toCgIPE platform ctx module_name ipe = do+    table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform (infoTablePtr ipe))+    closure_desc <- lookupStringTable $ ST.pack $ show (infoProvEntClosureType ipe)+    type_desc <- lookupStringTable $ ST.pack $ infoTableType ipe+    let label_str = maybe "" snd (infoTableProv ipe)+    let (src_loc_file, src_loc_span) =+            case infoTableProv ipe of+              Nothing -> ("", "")+              Just (span, _) ->+                  let file = unpackFS $ srcSpanFile span+                      coords = renderWithContext ctx (pprUserRealSpan False span)+                  in (file, coords)+    label <- lookupStringTable $ ST.pack label_str+    src_file <- lookupStringTable $ ST.pack src_loc_file+    src_span <- lookupStringTable $ ST.pack src_loc_span+    return $ CgInfoProvEnt { ipeInfoTablePtr = infoTablePtr ipe+                           , ipeTableName = table_name+                           , ipeClosureDesc = closure_desc+                           , ipeTypeDesc = type_desc+                           , ipeLabel = label+                           , ipeModuleName = module_name+                           , ipeSrcFile = src_file+                           , ipeSrcSpan = src_span+                           }++data CgInfoProvEnt = CgInfoProvEnt+                               { ipeInfoTablePtr :: !CLabel+                               , ipeTableName :: !StrTabOffset+                               , ipeClosureDesc :: !StrTabOffset+                               , ipeTypeDesc :: !StrTabOffset+                               , ipeLabel :: !StrTabOffset+                               , ipeModuleName :: !StrTabOffset+                               , ipeSrcFile :: !StrTabOffset+                               , ipeSrcSpan :: !StrTabOffset+                               }++data StringTable = StringTable { stStrings :: DList ShortText+                               , stLength :: !Int+                               , stLookup :: !(M.Map ShortText StrTabOffset)+                               }++newtype StrTabOffset = StrTabOffset Int++emptyStringTable :: StringTable+emptyStringTable =+    StringTable { stStrings = emptyDList+                , stLength = 0+                , stLookup = M.empty+                }++getStringTableStrings :: StringTable -> BS.ByteString+getStringTableStrings st =+    BSL.toStrict $ BSB.toLazyByteString+    $ foldMap f $ dlistToList (stStrings st)+  where+    f x = BSB.shortByteString (ST.contents x) `mappend` BSB.word8 0++lookupStringTable :: ShortText -> State StringTable StrTabOffset+lookupStringTable str = state $ \st ->+    case M.lookup str (stLookup st) of+      Just off -> (off, st)+      Nothing ->+          let !st' = st { stStrings = stStrings st `snoc` str+                        , stLength  = stLength st + ST.byteLength str + 1+                        , stLookup  = M.insert str res (stLookup st)+                        }+              res = StrTabOffset (stLength st)+          in (res, st')++newtype DList a = DList ([a] -> [a])++emptyDList :: DList a+emptyDList = DList id++snoc :: DList a -> a -> DList a+snoc (DList f) x = DList (f . (x:))++dlistToList :: DList a -> [a]+dlistToList (DList f) = f []

@@ -853,7 +853,7 @@ -- SIMD primops   (VecBroadcastOp vcat n w) -> \[e] -> opIntoRegs $ \[res] -> do     checkVecCompatibility cfg vcat n w-    doVecPackOp (vecElemInjectCast platform vcat w) ty zeros (replicate n e) res+    doVecPackOp ty zeros (replicate n e) res    where     zeros :: CmmExpr     zeros = CmmLit $ CmmVec (replicate n zero)@@ -871,7 +871,7 @@     checkVecCompatibility cfg vcat n w     when (es `lengthIsNot` n) $         panic "emitPrimOp: VecPackOp has wrong number of arguments"-    doVecPackOp (vecElemInjectCast platform vcat w) ty zeros es res+    doVecPackOp ty zeros es res    where     zeros :: CmmExpr     zeros = CmmLit $ CmmVec (replicate n zero)@@ -889,14 +889,14 @@     checkVecCompatibility cfg vcat n w     when (res `lengthIsNot` n) $         panic "emitPrimOp: VecUnpackOp has wrong number of results"-    doVecUnpackOp (vecElemProjectCast platform vcat w) ty arg res+    doVecUnpackOp ty arg res    where     ty :: CmmType     ty = vecVmmType vcat n w    (VecInsertOp vcat n w) -> \[v,e,i] -> opIntoRegs $ \[res] -> do     checkVecCompatibility cfg vcat n w-    doVecInsertOp (vecElemInjectCast platform vcat w) ty v e i res+    doVecInsertOp ty v e i res    where     ty :: CmmType     ty = vecVmmType vcat n w@@ -1563,6 +1563,9 @@   CasMutVarOp -> alwaysExternal   CatchOp -> alwaysExternal   RaiseOp -> alwaysExternal+  RaiseUnderflowOp -> alwaysExternal+  RaiseOverflowOp -> alwaysExternal+  RaiseDivZeroOp -> alwaysExternal   RaiseIOOp -> alwaysExternal   MaskAsyncExceptionsOp -> alwaysExternal   MaskUninterruptibleOp -> alwaysExternal@@ -2215,31 +2218,6 @@ vecCmmCat WordVec  = cmmBits vecCmmCat FloatVec = cmmFloat -vecElemInjectCast :: Platform -> PrimOpVecCat -> Width -> Maybe MachOp-vecElemInjectCast _        FloatVec _   =  Nothing-vecElemInjectCast platform   IntVec   W8  =  Just (mo_WordTo8  platform)-vecElemInjectCast platform   IntVec   W16 =  Just (mo_WordTo16 platform)-vecElemInjectCast platform   IntVec   W32 =  Just (mo_WordTo32 platform)-vecElemInjectCast _        IntVec   W64 =  Nothing-vecElemInjectCast platform   WordVec  W8  =  Just (mo_WordTo8  platform)-vecElemInjectCast platform   WordVec  W16 =  Just (mo_WordTo16 platform)-vecElemInjectCast platform   WordVec  W32 =  Just (mo_WordTo32 platform)-vecElemInjectCast _        WordVec  W64 =  Nothing-vecElemInjectCast _        _        _   =  Nothing--vecElemProjectCast :: Platform -> PrimOpVecCat -> Width -> Maybe MachOp-vecElemProjectCast _        FloatVec _   =  Nothing-vecElemProjectCast platform   IntVec   W8  =  Just (mo_s_8ToWord  platform)-vecElemProjectCast platform   IntVec   W16 =  Just (mo_s_16ToWord platform)-vecElemProjectCast platform   IntVec   W32 =  Just (mo_s_32ToWord platform)-vecElemProjectCast _        IntVec   W64 =  Nothing-vecElemProjectCast platform   WordVec  W8  =  Just (mo_u_8ToWord  platform)-vecElemProjectCast platform   WordVec  W16 =  Just (mo_u_16ToWord platform)-vecElemProjectCast platform   WordVec  W32 =  Just (mo_u_32ToWord platform)-vecElemProjectCast _        WordVec  W64 =  Nothing-vecElemProjectCast _        _        _   =  Nothing-- -- Note [SIMD Design for the future] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Check to make sure that we can generate code for the specified vector type@@ -2302,13 +2280,12 @@ ------------------------------------------------------------------------------ -- Helpers for translating vector packing and unpacking. -doVecPackOp :: Maybe MachOp  -- Cast from element to vector component-            -> CmmType       -- Type of vector+doVecPackOp :: CmmType       -- Type of vector             -> CmmExpr       -- Initial vector             -> [CmmExpr]     -- Elements             -> CmmFormal     -- Destination for result             -> FCode ()-doVecPackOp maybe_pre_write_cast ty z es res = do+doVecPackOp ty z es res = do     dst <- newTemp ty     emitAssign (CmmLocal dst) z     vecPack dst es 0@@ -2321,31 +2298,25 @@         dst <- newTemp ty         if isFloatType (vecElemType ty)           then emitAssign (CmmLocal dst) (CmmMachOp (MO_VF_Insert len wid)-                                                    [CmmReg (CmmLocal src), cast e, iLit])+                                                    [CmmReg (CmmLocal src), e, iLit])           else emitAssign (CmmLocal dst) (CmmMachOp (MO_V_Insert len wid)-                                                    [CmmReg (CmmLocal src), cast e, iLit])+                                                    [CmmReg (CmmLocal src), e, iLit])         vecPack dst es (i + 1)       where         -- vector indices are always 32-bits         iLit = CmmLit (CmmInt (toInteger i) W32) -    cast :: CmmExpr -> CmmExpr-    cast val = case maybe_pre_write_cast of-                 Nothing   -> val-                 Just cast -> CmmMachOp cast [val]-     len :: Length     len = vecLength ty      wid :: Width     wid = typeWidth (vecElemType ty) -doVecUnpackOp :: Maybe MachOp  -- Cast from vector component to element result-              -> CmmType       -- Type of vector+doVecUnpackOp :: CmmType       -- Type of vector               -> CmmExpr       -- Vector               -> [CmmFormal]   -- Element results               -> FCode ()-doVecUnpackOp maybe_post_read_cast ty e res =+doVecUnpackOp ty e res =     vecUnpack res 0   where     vecUnpack :: [CmmFormal] -> Int -> FCode ()@@ -2354,46 +2325,36 @@      vecUnpack (r : rs) i = do         if isFloatType (vecElemType ty)-          then emitAssign (CmmLocal r) (cast (CmmMachOp (MO_VF_Extract len wid)-                                             [e, iLit]))-          else emitAssign (CmmLocal r) (cast (CmmMachOp (MO_V_Extract len wid)-                                             [e, iLit]))+          then emitAssign (CmmLocal r) (CmmMachOp (MO_VF_Extract len wid)+                                             [e, iLit])+          else emitAssign (CmmLocal r) (CmmMachOp (MO_V_Extract len wid)+                                             [e, iLit])         vecUnpack rs (i + 1)       where         -- vector indices are always 32-bits         iLit = CmmLit (CmmInt (toInteger i) W32) -    cast :: CmmExpr -> CmmExpr-    cast val = case maybe_post_read_cast of-                 Nothing   -> val-                 Just cast -> CmmMachOp cast [val]-     len :: Length     len = vecLength ty      wid :: Width     wid = typeWidth (vecElemType ty) -doVecInsertOp :: Maybe MachOp  -- Cast from element to vector component-              -> CmmType       -- Vector type+doVecInsertOp :: CmmType       -- Vector type               -> CmmExpr       -- Source vector               -> CmmExpr       -- Element               -> CmmExpr       -- Index at which to insert element               -> CmmFormal     -- Destination for result               -> FCode ()-doVecInsertOp maybe_pre_write_cast ty src e idx res = do+doVecInsertOp ty src e idx res = do     platform <- getPlatform     -- vector indices are always 32-bits     let idx' :: CmmExpr         idx' = CmmMachOp (MO_SS_Conv (wordWidth platform) W32) [idx]     if isFloatType (vecElemType ty)-      then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, cast e, idx'])-      else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, cast e, idx'])+      then emitAssign (CmmLocal res) (CmmMachOp (MO_VF_Insert len wid) [src, e, idx'])+      else emitAssign (CmmLocal res) (CmmMachOp (MO_V_Insert len wid) [src, e, idx'])   where-    cast :: CmmExpr -> CmmExpr-    cast val = case maybe_pre_write_cast of-                 Nothing   -> val-                 Just cast -> CmmMachOp cast [val]      len :: Length     len = vecLength ty

@@ -11,7 +11,7 @@         mkCCostCentre, mkCCostCentreStack,          -- infoTablePRov-        initInfoTableProv, emitInfoTableProv,+        initInfoTableProv,          -- Cost-centre Profiling         dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,@@ -32,6 +32,7 @@ import GHC.Platform.Profile import GHC.StgToCmm.Closure import GHC.StgToCmm.Config+import GHC.StgToCmm.InfoTableProv import GHC.StgToCmm.Utils import GHC.StgToCmm.Monad import GHC.StgToCmm.Lit@@ -55,7 +56,6 @@  import Control.Monad import Data.Char       (ord)-import Data.Bifunctor  (first) import GHC.Utils.Monad (whenM)  -----------------------------------------------------------------------------@@ -274,9 +274,8 @@   where    (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform -+-- | Emit info-table provenance declarations initInfoTableProv ::  [CmmInfoTable] -> InfoTableProvMap -> FCode CStub--- Emit the declarations initInfoTableProv infos itmap   = do        cfg <- getStgToCmmConfig@@ -284,42 +283,16 @@            info_table = stgToCmmInfoTableMap cfg            platform   = stgToCmmPlatform     cfg            this_mod   = stgToCmmThisModule   cfg-       -- Output the actual IPE data-       mapM_ emitInfoTableProv ents-       -- Create the C stub which initialises the IPE map-       return (ipInitCode info_table platform this_mod ents) ---- Info Table Prov stuff-emitInfoTableProv :: InfoProvEnt  -> FCode ()-emitInfoTableProv ip = do-  { cfg <- getStgToCmmConfig-  ; let mod      = infoProvModule ip-        ctx      = stgToCmmContext  cfg-        platform = stgToCmmPlatform cfg-  ; let (src, label) = maybe ("", "") (first (renderWithContext ctx . ppr)) (infoTableProv ip)-        mk_string    = newByteStringCLit . utf8EncodeByteString-  ; label <- mk_string label-  ; modl  <- newByteStringCLit (bytesFS $ moduleNameFS-                                        $ moduleName mod)+       case ents of+         [] -> return mempty+         _  -> do+           -- Emit IPE buffer+           emitIpeBufferListNode this_mod ents -  ; ty_string  <- mk_string (infoTableType ip)-  ; loc        <- mk_string src-  ; table_name <- mk_string (renderWithContext ctx-                             (pprCLabel platform CStyle (infoTablePtr ip)))-  ; closure_type <- mk_string (renderWithContext ctx-                               (text $ show $ infoProvEntClosureType ip))-  ; let-     lits = [ CmmLabel (infoTablePtr ip), -- Info table pointer-              table_name,     -- char *table_name-              closure_type,   -- char *closure_desc -- Filled in from the InfoTable-              ty_string,      -- char *ty_string-              label,          -- char *label,-              modl,           -- char *module,-              loc,            -- char *srcloc,-              zero platform   -- struct _InfoProvEnt *link-            ]-  ; emitDataLits (mkIPELabel ip) lits-  }+           -- Create the C stub which initialises the IPE map+           return (ipInitCode info_table platform this_mod)+ -- --------------------------------------------------------------------------- -- Set the current cost centre stack 

@@ -46,7 +46,7 @@         convertInfoProvMap, cmmInfoTableToInfoProvEnt   ) where -import GHC.Prelude+import GHC.Prelude hiding ( head, init, last, tail )  import GHC.Platform import GHC.StgToCmm.Monad@@ -266,7 +266,7 @@  emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode () emitDataCon lbl itbl ccs payload =-  emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload))+  emitDecl (CmmData (Section Data lbl) (CmmStatics lbl itbl ccs payload []))  ------------------------------------------------------------------------- --@@ -448,8 +448,8 @@                -> [(Literal, CmmAGraphScoped)] -- Tagged branches                -> CmmAGraphScoped              -- Default branch (always)                -> FCode ()                     -- Emit the code-emitCmmLitSwitch _scrut []       deflt = emit $ fst deflt-emitCmmLitSwitch scrut  branches deflt = do+emitCmmLitSwitch _scrut [] deflt = emit $ fst deflt+emitCmmLitSwitch scrut branches@(branch:_) deflt = do     scrut' <- assignTemp' scrut     join_lbl <- newBlockId     deflt_lbl <- label_code join_lbl deflt@@ -460,7 +460,7 @@         rep = typeWidth cmm_ty      -- We find the necessary type information in the literals in the branches-    let (signed,range) = case head branches of+    let (signed,range) = case branch of           (LitNumber nt _, _) -> (signed,range)             where               signed = litNumIsSigned nt

@@ -0,0 +1,234 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}++#include <ghcplatform.h>++module GHC.SysTools.Cpp+  ( doCpp+  , CppOpts (..)+  , getGhcVersionPathName+  , applyCDefs+  , offsetIncludePaths+  )+where++import GHC.Prelude+import GHC.Driver.Session+import GHC.Driver.Backend+import GHC.CmmToLlvm.Config+import GHC.Platform+import GHC.Platform.ArchOS++import GHC.SysTools++import GHC.Unit.Env+import GHC.Unit.Info+import GHC.Unit.State+import GHC.Unit.Types++import GHC.Utils.Logger+import GHC.Utils.TmpFs+import GHC.Utils.Panic++import Data.Version+import Data.List (intercalate)+import Data.Maybe++import Control.Monad++import System.Directory+import System.FilePath++data CppOpts = CppOpts+  { cppUseCc       :: !Bool -- ^ Use "cc -E" as preprocessor, otherwise use "cpp"+  , cppLinePragmas :: !Bool -- ^ Enable generation of LINE pragmas+  }++-- | Run CPP+--+-- UnitEnv is needed to compute MIN_VERSION macros+doCpp :: Logger -> TmpFs -> DynFlags -> UnitEnv -> CppOpts -> FilePath -> FilePath -> IO ()+doCpp logger tmpfs dflags unit_env opts input_fn output_fn = do+    let hscpp_opts = picPOpts dflags+    let cmdline_include_paths = offsetIncludePaths dflags (includePaths dflags)+    let unit_state = ue_units unit_env+    pkg_include_dirs <- mayThrowUnitErr+                        (collectIncludeDirs <$> preloadUnitsInfo unit_env)+    -- MP: This is not quite right, the headers which are supposed to be installed in+    -- the package might not be the same as the provided include paths, but it's a close+    -- enough approximation for things to work. A proper solution would be to have to declare which paths should+    -- be propagated to dependent packages.+    let home_pkg_deps =+         [homeUnitEnv_dflags . ue_findHomeUnitEnv uid $ unit_env | uid <- ue_transitiveHomeDeps (ue_currentUnit unit_env) unit_env]+        dep_pkg_extra_inputs = [offsetIncludePaths fs (includePaths fs) | fs <- home_pkg_deps]++    let include_paths_global = foldr (\ x xs -> ("-I" ++ x) : xs) []+          (includePathsGlobal cmdline_include_paths ++ pkg_include_dirs+                                                    ++ concatMap includePathsGlobal dep_pkg_extra_inputs)+    let include_paths_quote = foldr (\ x xs -> ("-iquote" ++ x) : xs) []+          (includePathsQuote cmdline_include_paths +++           includePathsQuoteImplicit cmdline_include_paths)+    let include_paths = include_paths_quote ++ include_paths_global++    let verbFlags = getVerbFlags dflags++    let cpp_prog args+          | cppUseCc opts = GHC.SysTools.runCc Nothing logger tmpfs dflags+                                               (GHC.SysTools.Option "-E" : args)+          | otherwise     = GHC.SysTools.runCpp logger dflags args++    let platform   = targetPlatform dflags+        targetArch = stringEncodeArch $ platformArch platform+        targetOS = stringEncodeOS $ platformOS platform+        isWindows = platformOS platform == OSMinGW32+    let target_defs =+          [ "-D" ++ HOST_OS     ++ "_BUILD_OS",+            "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH",+            "-D" ++ targetOS    ++ "_HOST_OS",+            "-D" ++ targetArch  ++ "_HOST_ARCH" ]+        -- remember, in code we *compile*, the HOST is the same our TARGET,+        -- and BUILD is the same as our HOST.++    let io_manager_defs =+          [ "-D__IO_MANAGER_WINIO__=1" | isWindows ] +++          [ "-D__IO_MANAGER_MIO__=1"               ]++    let sse_defs =+          [ "-D__SSE__"      | isSseEnabled      platform ] +++          [ "-D__SSE2__"     | isSse2Enabled     platform ] +++          [ "-D__SSE4_2__"   | isSse4_2Enabled   dflags ]++    let avx_defs =+          [ "-D__AVX__"      | isAvxEnabled      dflags ] +++          [ "-D__AVX2__"     | isAvx2Enabled     dflags ] +++          [ "-D__AVX512CD__" | isAvx512cdEnabled dflags ] +++          [ "-D__AVX512ER__" | isAvx512erEnabled dflags ] +++          [ "-D__AVX512F__"  | isAvx512fEnabled  dflags ] +++          [ "-D__AVX512PF__" | isAvx512pfEnabled dflags ]++    backend_defs <- applyCDefs (backendCDefs $ backend dflags) logger dflags++    let th_defs = [ "-D__GLASGOW_HASKELL_TH__" ]+    -- Default CPP defines in Haskell source+    ghcVersionH <- getGhcVersionPathName dflags unit_env+    let hsSourceCppOpts = [ "-include", ghcVersionH ]++    -- MIN_VERSION macros+    let uids = explicitUnits unit_state+        pkgs = mapMaybe (lookupUnit unit_state . fst) uids+    mb_macro_include <-+        if not (null pkgs) && gopt Opt_VersionMacros dflags+            then do macro_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "h"+                    writeFile macro_stub (generatePackageVersionMacros pkgs)+                    -- Include version macros for every *exposed* package.+                    -- Without -hide-all-packages and with a package database+                    -- size of 1000 packages, it takes cpp an estimated 2+                    -- milliseconds to process this file. See #10970+                    -- comment 8.+                    return [GHC.SysTools.FileOption "-include" macro_stub]+            else return []++    let line_pragmas+          | cppLinePragmas opts = [] -- on by default+          | otherwise           = [GHC.SysTools.Option "-P"] -- disable LINE markers++    cpp_prog       (   map GHC.SysTools.Option verbFlags+                    ++ map GHC.SysTools.Option include_paths+                    ++ map GHC.SysTools.Option hsSourceCppOpts+                    ++ map GHC.SysTools.Option target_defs+                    ++ map GHC.SysTools.Option backend_defs+                    ++ map GHC.SysTools.Option th_defs+                    ++ map GHC.SysTools.Option hscpp_opts+                    ++ map GHC.SysTools.Option sse_defs+                    ++ map GHC.SysTools.Option avx_defs+                    ++ map GHC.SysTools.Option io_manager_defs+                    ++ mb_macro_include+                    ++ line_pragmas+        -- Set the language mode to assembler-with-cpp when preprocessing. This+        -- alleviates some of the C99 macro rules relating to whitespace and the hash+        -- operator, which we tend to abuse. Clang in particular is not very happy+        -- about this.+                    ++ [ GHC.SysTools.Option     "-x"+                       , GHC.SysTools.Option     "assembler-with-cpp"+                       , GHC.SysTools.Option     input_fn+        -- We hackily use Option instead of FileOption here, so that the file+        -- name is not back-slashed on Windows.  cpp is capable of+        -- dealing with / in filenames, so it works fine.  Furthermore+        -- if we put in backslashes, cpp outputs #line directives+        -- with *double* backslashes.   And that in turn means that+        -- our error messages get double backslashes in them.+        -- In due course we should arrange that the lexer deals+        -- with these \\ escapes properly.+                       , GHC.SysTools.Option     "-o"+                       , GHC.SysTools.FileOption "" output_fn+                       ])++-- ---------------------------------------------------------------------------+-- Macros (cribbed from Cabal)++generatePackageVersionMacros :: [UnitInfo] -> String+generatePackageVersionMacros pkgs = concat+  -- Do not add any C-style comments. See #3389.+  [ generateMacros "" pkgname version+  | pkg <- pkgs+  , let version = unitPackageVersion pkg+        pkgname = map fixchar (unitPackageNameString pkg)+  ]++fixchar :: Char -> Char+fixchar '-' = '_'+fixchar c   = c++generateMacros :: String -> String -> Version -> String+generateMacros prefix name version =+  concat+  ["#define ", prefix, "VERSION_",name," ",show (showVersion version),"\n"+  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"+  ,"  (major1) <  ",major1," || \\\n"+  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"+  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"+  ,"\n\n"+  ]+  where+    take3 = \case+      (a:b:c:_) -> (a,b,c)+      _         -> error "take3"+    (major1,major2,minor) = take3 $ map show (versionBranch version) ++ repeat "0"+++-- | Find out path to @ghcversion.h@ file+getGhcVersionPathName :: DynFlags -> UnitEnv -> IO FilePath+getGhcVersionPathName dflags unit_env = do+  candidates <- case ghcVersionFile dflags of+    Just path -> return [path]+    Nothing -> do+        ps <- mayThrowUnitErr (preloadUnitsInfo' unit_env [rtsUnitId])+        return ((</> "ghcversion.h") <$> collectIncludeDirs ps)++  found <- filterM doesFileExist candidates+  case found of+      []    -> throwGhcExceptionIO (InstallationError+                                    ("ghcversion.h missing; tried: "+                                      ++ intercalate ", " candidates))+      (x:_) -> return x++applyCDefs :: DefunctionalizedCDefs -> Logger -> DynFlags -> IO [String]+applyCDefs NoCDefs _ _ = return []+applyCDefs LlvmCDefs logger dflags = do+    llvmVer <- figureLlvmVersion logger dflags+    return $ case fmap llvmVersionList llvmVer of+               Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]+               Just (m:n:_) -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,n) ]+               _ -> []+  where+    format (major, minor)+      | minor >= 100 = error "backendCDefs: Unsupported minor version"+      | otherwise = show (100 * major + minor :: Int) -- Contract is Int+++-- Note [Filepaths and Multiple Home Units]+offsetIncludePaths :: DynFlags -> IncludeSpecs -> IncludeSpecs+offsetIncludePaths dflags (IncludeSpecs incs quotes impl) =+     let go = map (augmentByWorkingDirectory dflags)+     in IncludeSpecs (go incs) (go quotes) (go impl)+

@@ -170,11 +170,7 @@     getResponseFile args = do       fp <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "rsp"       withFile fp WriteMode $ \h -> do-#if defined(mingw32_HOST_OS)-          hSetEncoding h latin1-#else           hSetEncoding h utf8-#endif           hPutStr h $ unlines $ map escape args       return fp 

@@ -201,7 +201,6 @@         ; famInsts2 <- concatMapM genFamInsts infer_specs         ; let famInsts = famInsts1 ++ famInsts2 -        ; dflags <- getDynFlags         ; logger <- getLogger            -- We must put all the derived type family instances (from both@@ -229,7 +228,7 @@          ; let (_, aux_specs, fvs) = unzip3 (given_inst_binds ++ infer_inst_binds)         ; loc <- getSrcSpanM-        ; let aux_binds = genAuxBinds dflags loc (unionManyBags aux_specs)+        ; let aux_binds = genAuxBinds loc (unionManyBags aux_specs)          ; let infer_inst_infos = map fstOf3 infer_inst_binds         ; let inst_infos = given_inst_infos ++ infer_inst_infos@@ -289,8 +288,8 @@         -- Bring the extra deriving stuff into scope         -- before renaming the instances themselves         ; traceTc "rnd" (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos))-        ; (aux_binds, aux_sigs) <- mapAndUnzipBagM return bagBinds-        ; let aux_val_binds = ValBinds NoAnnSortKey aux_binds (bagToList aux_sigs)+        ; let (aux_binds, aux_sigs) = unzipBag bagBinds+              aux_val_binds = ValBinds NoAnnSortKey aux_binds (bagToList aux_sigs)         -- Importantly, we use rnLocalValBindsLHS, not rnTopBindsLHS, to rename         -- auxiliary bindings as if they were defined locally.         -- See Note [Auxiliary binders] in GHC.Tc.Deriv.Generate.

@@ -54,7 +54,6 @@ import GHC.Types.Name import GHC.Types.SourceText -import GHC.Driver.Session import GHC.Tc.Instance.Family import GHC.Core.FamInstEnv import GHC.Builtin.Names@@ -1170,14 +1169,14 @@         where           lbl_str = unpackFS lbl           mk_read_field read_field_rdr lbl-              = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)]+              = nlHsApps read_field_rdr [nlHsLit (mkHsStringFS lbl)]           read_field               | isSym lbl_str-              = mk_read_field readSymField_RDR lbl_str+              = mk_read_field readSymField_RDR lbl               | Just (ss, '#') <- snocView lbl_str -- #14918-              = mk_read_field readFieldHash_RDR ss+              = mk_read_field readFieldHash_RDR (mkFastString ss)               | otherwise-              = mk_read_field readField_RDR lbl_str+              = mk_read_field readField_RDR lbl  {- ************************************************************************@@ -1403,7 +1402,6 @@   where     data_cons  = tyConDataCons rep_tc     n_cons     = length data_cons-    one_constr = n_cons == 1          ------------ gfoldl     gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons)@@ -1420,11 +1418,11 @@         ------------ gunfold     gunfold_bind = mkSimpleGeneratedFunBind loc                      gunfold_RDR-                     [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat]+                     [k_Pat, z_Pat, if n_cons == 1 then nlWildPat else c_Pat]                      gunfold_rhs      gunfold_rhs-        | one_constr = mk_unfold_rhs (head data_cons)   -- No need for case+        | [con] <- data_cons = mk_unfold_rhs con   -- No need for case         | otherwise  = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)                                 (map gunfold_alt data_cons) @@ -2157,9 +2155,9 @@  -- | Generate the full code for an auxiliary binding. -- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@.-genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec+genAuxBindSpecOriginal :: SrcSpan -> AuxBindSpec                        -> (LHsBind GhcPs, LSig GhcPs)-genAuxBindSpecOriginal dflags loc spec+genAuxBindSpecOriginal loc spec   = (gen_bind spec,      L loca (TypeSig noAnn [L locn (auxBindSpecRdrName spec)]            (genAuxBindSpecSig loc spec)))@@ -2184,11 +2182,10 @@       = mkHsVarBind loc dataT_RDR rhs       where         tc_name = tyConName tycon-        tc_name_string = occNameString (getOccName tc_name)-        definition_mod_name = moduleNameString (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name))-        ctx = initDefaultSDocContext dflags+        tc_name_string = occNameFS (getOccName tc_name)+        definition_mod_name = moduleNameFS (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name))         rhs = nlHsVar mkDataType_RDR-              `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (text definition_mod_name <> dot <> text tc_name_string)))+              `nlHsApp` nlHsLit (mkHsStringFS (concatFS [definition_mod_name, fsLit ".", tc_name_string]))               `nlHsApp` nlList (map nlHsVar dataC_RDRs)      gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR)@@ -2198,12 +2195,12 @@          constr_args            = [ nlHsVar dataT_RDR                            -- DataType-             , nlHsLit (mkHsString (occNameString dc_occ))  -- Constructor name+             , nlHsLit (mkHsStringFS (occNameFS dc_occ))    -- Constructor name              , nlHsIntLit (toInteger (dataConTag dc))       -- Constructor tag              , nlList  labels                               -- Field labels              , nlHsVar fixity ]                             -- Fixity -        labels   = map (nlHsLit . mkHsString . unpackFS . field_label . flLabel)+        labels   = map (nlHsLit . mkHsStringFS . field_label . flLabel)                        (dataConFieldLabels dc)         dc_occ   = getOccName dc         is_infix = isDataSymOcc dc_occ@@ -2244,9 +2241,9 @@ -- | Take a 'Bag' of 'AuxBindSpec's and generate the code for auxiliary -- bindings based on the declarative descriptions in the supplied -- 'AuxBindSpec's. See @Note [Auxiliary binders]@.-genAuxBinds :: DynFlags -> SrcSpan -> Bag AuxBindSpec+genAuxBinds :: SrcSpan -> Bag AuxBindSpec             -> Bag (LHsBind GhcPs, LSig GhcPs)-genAuxBinds dflags loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)+genAuxBinds loc = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)  where   -- Perform a CSE-like pass over the generated auxiliary bindings to avoid   -- code duplication, as described in@@ -2260,7 +2257,7 @@     case lookupOccEnv original_rdr_name_env spec_occ of       Nothing         -> ( extendOccEnv original_rdr_name_env spec_occ spec_rdr_name-           , genAuxBindSpecOriginal dflags loc spec `consBag` spec_bag )+           , genAuxBindSpecOriginal loc spec `consBag` spec_bag )       Just original_rdr_name         -> ( original_rdr_name_env            , genAuxBindSpecDup loc original_rdr_name spec `consBag` spec_bag )@@ -2364,7 +2361,7 @@                             (replicate arity nlWildPat)                             (error_Expr str) emptyLocalBinds]               else matches-   str = "Void " ++ occNameString (rdrNameOcc fun_rdr)+   str = fsLit "Void " `appendFS` occNameFS (rdrNameOcc fun_rdr)   box ::         String           -- The class involved@@ -2551,8 +2548,8 @@  -- impossible_Expr is used in case RHSs that should never happen. -- We generate these to keep the desugarer from complaining that they *might* happen!-error_Expr :: String -> LHsExpr GhcPs-error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))+error_Expr :: FastString -> LHsExpr GhcPs+error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsStringFS string))  -- illegal_Expr is used when signalling error conditions in the RHS of a derived -- method. It is currently only used by Enum.{succ,pred}

@@ -21,7 +21,7 @@    ) where -import GHC.Prelude+import GHC.Prelude hiding (head, init, last, tail)  import GHC.Hs import GHC.Core.Type@@ -62,6 +62,9 @@  import Control.Monad (mplus) import Data.List (zip4, partition)+import qualified Data.List as Partial (last)+import Data.List.NonEmpty (nonEmpty)+import qualified Data.List.NonEmpty as NE import Data.Maybe (isJust)  {-@@ -291,9 +294,9 @@       , ft_var = caseVar, ft_co_var = caseVar        -- (component_0,component_1,...,component_n)-      , ft_tup = \_ components -> if any _ccdg1_hasParam (init components)-                                  then bmbad con-                                  else foldr bmplus bmzero components+      , ft_tup = \_ components -> case nonEmpty components of+            Just components' | any _ccdg1_hasParam (NE.init components') -> bmbad con+            _ -> foldr bmplus bmzero components        -- (dom -> rng), where the head of ty is not a tuple tycon       , ft_fun = \dom rng -> -- cf #8516@@ -344,7 +347,7 @@   where     dc_inst_univs = dataConInstUnivs dc tc_args     last_dc_inst_univ = assert (not (null dc_inst_univs)) $-                        last dc_inst_univs+                        Partial.last dc_inst_univs   -- Bindings for the Generic instance

@@ -83,6 +83,7 @@ import Data.Function      ( on ) import Data.List          ( partition, sort, sortBy ) import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE import Data.Ord           ( comparing ) import qualified Data.Semigroup as S @@ -1108,7 +1109,7 @@                   (TcRnSolverReport important ErrorWithoutFlag noHints) (Just ctxt) supp          -- This will be reported at runtime, so we always want "error:" in the report, never "warning:"        ; dflags <- getDynFlags-       ; let err_msg = pprLocMsgEnvelope msg+       ; let err_msg = pprLocMsgEnvelope (initTcMessageOpts dflags) msg              err_str = showSDoc dflags $                        err_msg $$ text "(deferred type error)" @@ -1174,10 +1175,13 @@              ErrInfo                (fromMaybe empty mb_context)                (vcat $ map (pprSolverReportSupplementary hfdc) supplementary)+       ; let detailed_msg = mkDetailedMessage err_info msg        ; mkTcRnMessage            (RealSrcSpan (tcl_loc tcl_env) Strict.Nothing)-           (TcRnMessageWithInfo unit_state $ TcRnMessageDetailed err_info msg) }+           (TcRnMessageWithInfo unit_state $ detailed_msg) } ++ -- | Pretty-print supplementary information, to add to an error report. pprSolverReportSupplementary :: HoleFitDispConfig -> SolverReportSupplementary -> SDoc -- This function should be in "GHC.Tc.Errors.Ppr",@@ -2200,26 +2204,24 @@ --     and the result of evaluating ...". mk_dict_err :: HasCallStack => SolverReportErrCtxt -> (ErrorItem, ClsInstLookupResult)             -> TcM TcSolverReportMsg--- Report an overlap error if this class constraint results--- from an overlap (returning Left clas), otherwise return (Right pred)-mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped))-  | null matches  -- No matches but perhaps several unifiers-  = do { (_, rel_binds, item) <- relevantBindings True ctxt item-       ; candidate_insts <- get_candidate_instances-       ; (imp_errs, field_suggestions) <- record_field_suggestions-       ; return (cannot_resolve_msg item candidate_insts rel_binds imp_errs field_suggestions) }+mk_dict_err ctxt (item, (matches, unifiers, unsafe_overlapped)) = case (NE.nonEmpty matches, NE.nonEmpty unsafe_overlapped) of+  (Nothing, _)  -> do -- No matches but perhaps several unifiers+    { (_, rel_binds, item) <- relevantBindings True ctxt item+    ; candidate_insts <- get_candidate_instances+    ; (imp_errs, field_suggestions) <- record_field_suggestions+    ; return (cannot_resolve_msg item candidate_insts rel_binds imp_errs field_suggestions) } -  | null unsafe_overlapped   -- Some matches => overlap errors-  = return $ overlap_msg+  -- Some matches => overlap errors+  (Just matchesNE, Nothing) -> return $+    OverlappingInstances item (NE.map fst matchesNE) (getPotentialUnifiers unifiers) -  | otherwise-  = return $ safe_haskell_msg+  (Just (match :| []), Just unsafe_overlappedNE) -> return $+    UnsafeOverlap item (fst match) (NE.map fst unsafe_overlappedNE)+  (Just matches@(_ :| _), Just overlaps) -> pprPanic "mk_dict_err: multiple matches with overlap" $ vcat [ text "matches:" <+> ppr matches, text "overlaps:" <+> ppr overlaps ]   where     orig          = errorItemOrigin item     pred          = errorItemPred item     (clas, tys)   = getClassPredTys pred-    ispecs        = [ispec | (ispec, _) <- matches]-    unsafe_ispecs = [ispec | (ispec, _) <- unsafe_overlapped]      get_candidate_instances :: TcM [ClsInst]     -- See Note [Report candidate instances]@@ -2267,18 +2269,6 @@                        -> [ImportError] -> [GhcHint] -> TcSolverReportMsg     cannot_resolve_msg item candidate_insts binds imp_errs field_suggestions       = CannotResolveInstance item (getPotentialUnifiers unifiers) candidate_insts imp_errs field_suggestions binds--    -- Overlap errors.-    overlap_msg, safe_haskell_msg :: TcSolverReportMsg-    -- Normal overlap error-    overlap_msg-      = assert (not (null matches)) $ OverlappingInstances item ispecs (getPotentialUnifiers unifiers)--    -- Overlap error because of Safe Haskell (first-    -- match should be the most specific match)-    safe_haskell_msg-     = assert (matches `lengthIs` 1 && not (null unsafe_ispecs)) $-       UnsafeOverlap item ispecs unsafe_ispecs  {- Note [Report candidate instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -26,9 +26,10 @@ import GHC.Types.Error import GHC.Types.SrcLoc import GHC.Utils.Outputable-import GHC.Utils.Panic import qualified GHC.LanguageExtensions as LangExt +import Data.List.NonEmpty ( NonEmpty (..) )+ tcDefaults :: [LDefaultDecl GhcRn]            -> TcM (Maybe [Type])    -- Defaulting types to heave                                     -- into Tc monad for later use@@ -67,9 +68,9 @@          ; return (Just tau_tys) } -tcDefaults decls@(L locn (DefaultDecl _ _) : _)+tcDefaults (decl@(L locn (DefaultDecl _ _)) : decls)   = setSrcSpan (locA locn) $-    failWithTc (dupDefaultDeclErr decls)+    failWithTc (dupDefaultDeclErr (decl:|decls))   tc_default_ty :: [Class] -> LHsType GhcRn -> TcM Type@@ -103,7 +104,6 @@ defaultDeclCtxt :: SDoc defaultDeclCtxt = text "When checking the types in a default declaration" -dupDefaultDeclErr :: [LDefaultDecl GhcRn] -> TcRnMessage-dupDefaultDeclErr (L _ (DefaultDecl _ _) : dup_things)+dupDefaultDeclErr :: NonEmpty (LDefaultDecl GhcRn) -> TcRnMessage+dupDefaultDeclErr (L _ (DefaultDecl _ _) :| dup_things)   = TcRnMultipleDefaultDeclarations dup_things-dupDefaultDeclErr [] = panic "dupDefaultDeclErr []"

@@ -1099,9 +1099,8 @@         hint_msg = vcat $ map ppr hints         import_err_msg = vcat $ map ppr import_errs         info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg }-        msg = TcRnMessageWithInfo unit_state-            $ TcRnMessageDetailed info (TcRnIncorrectNameSpace nm False)-      failWithTc msg+      failWithTc $ TcRnMessageWithInfo unit_state (+              mkDetailedMessage info (TcRnIncorrectNameSpace nm False))      get_suggestions ns = do        let occ = mkOccNameFS ns (occNameFS (occName id_name))

@@ -75,7 +75,7 @@         funAppCtxt, addTyConFlavCtxt    ) where -import GHC.Prelude+import GHC.Prelude hiding ( head, init, last, tail )  import GHC.Hs import GHC.Rename.Utils@@ -130,7 +130,8 @@ import GHC.Data.Bag( unitBag )  import Data.Function ( on )-import Data.List.NonEmpty as NE( NonEmpty(..), nubBy )+import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )+import qualified Data.List.NonEmpty as NE import Data.List ( find, mapAccumL ) import Control.Monad import Data.Tuple( swap )@@ -2223,7 +2224,7 @@ -- in an unexpected place. The renamer rejects these wildcards in 'checkAnonWildcard', -- but it is possible for a wildcard to be introduced by a Template Haskell splice, -- as per #15433. To account for this, we throw a generic catch-all error message.-  = failWith $ TcRnIllegalWildcardInType Nothing reason Nothing+  = failWith $ TcRnIllegalWildcardInType Nothing reason     where       reason =         case is_extra of@@ -3169,19 +3170,19 @@ -- Push level, capture constraints, and emit an implication constraint. -- The implication constraint has a ForAllSkol ic_info, --   so that it is subject to a telescope test.-tcExplicitTKBndrsX skol_mode bndrs thing_inside-  | null bndrs-  = do { res <- thing_inside+tcExplicitTKBndrsX skol_mode bndrs thing_inside = case nonEmpty bndrs of+    Nothing -> do+       { res <- thing_inside        ; return ([], res) } -  | otherwise-  = do { (tclvl, wanted, (skol_tvs, res))+    Just bndrs1 -> do+       { (tclvl, wanted, (skol_tvs, res))              <- pushLevelAndCaptureConstraints $                 bindExplicitTKBndrsX skol_mode bndrs $                 thing_inside         -- Set up SkolemInfo for telescope test-       ; let bndr_1 = head bndrs; bndr_n = last bndrs+       ; let bndr_1 = NE.head bndrs1; bndr_n = NE.last bndrs1        ; skol_info <- mkSkolemInfo (ForAllSkol (HsTyVarBndrsRn  (unLoc <$> bndrs)))          -- Notice that we use ForAllSkol here, ignoring the enclosing          -- skol_info unlike tcImplicitTKBndrs, because the bad-telescope@@ -3488,6 +3489,8 @@ bindTyClTyVarsAndZonk :: Name -> ([TyConBinder] -> Kind -> TcM a) -> TcM a -- Like bindTyClTyVars, but in addition -- zonk the skolem TcTyVars of a PolyTcTyCon to TyVars+-- We always do this same zonking after a call to bindTyClTyVars, but+-- here we do it right away because there are no more unifications to come bindTyClTyVarsAndZonk tycon_name thing_inside   = bindTyClTyVars tycon_name $ \ tc_bndrs tc_kind ->     do { ze          <- mkEmptyZonkEnv NoFlexi

@@ -124,7 +124,7 @@ import GHC.Utils.Lexeme import GHC.Utils.Outputable import GHC.Utils.Logger-import GHC.Utils.Exception (throwIO, ErrorCall(..))+import GHC.Utils.Exception (throwIO, ErrorCall(..), SomeException(..))  import GHC.Utils.TmpFs ( newTempName, TempFileLifetime(..) ) @@ -794,16 +794,10 @@ -- Takes a m and tau and returns the type m (TExp tau) tcTExpTy :: TcType -> TcType -> TcM TcType tcTExpTy m_ty exp_ty-  = do { unless (isTauTy exp_ty) $ addErr (err_msg exp_ty)+  = do { unless (isTauTy exp_ty) $ addErr (TcRnTypedTHWithPolyType exp_ty)        ; codeCon <- tcLookupTyCon codeTyConName        ; let rep = getRuntimeRep exp_ty        ; return (mkTyConApp codeCon [rep, m_ty, exp_ty]) }-  where-    err_msg ty-      = mkTcRnUnknownMessage $ mkPlainError noHints $-      vcat [ text "Illegal polytype:" <+> ppr ty-             , text "The type of a Typed Template Haskell expression must" <+>-               text "not have any quantification." ]  quotationCtxtDoc :: LHsExpr GhcRn -> SDoc quotationCtxtDoc br_body@@ -1023,15 +1017,15 @@                ann_value = serialized            } -convertAnnotationWrapper :: ForeignHValue -> TcM (Either SDoc Serialized)+convertAnnotationWrapper :: ForeignHValue -> TcM Serialized convertAnnotationWrapper fhv = do   interp <- tcGetInterp   case interpInstance interp of-    ExternalInterp {} -> Right <$> runTH THAnnWrapper fhv+    ExternalInterp {} -> runTH THAnnWrapper fhv #if defined(HAVE_INTERNAL_INTERPRETER)     InternalInterp    -> do       annotation_wrapper <- liftIO $ wormhole interp fhv-      return $ Right $+      return $         case unsafeCoerce annotation_wrapper of            AnnotationWrapper value | let serialized = toSerialized serializeWithData value ->                -- Got the value and dictionaries: build the serialized value and@@ -1118,7 +1112,7 @@ defaultRunMeta (MetaD r)   = fmap r . runMeta' True ppr (runQResult TH.pprint convertToHsDecls runTHDec) defaultRunMeta (MetaAW r)-  = fmap r . runMeta' False (const empty) (const convertAnnotationWrapper)+  = fmap r . runMeta' False (const empty) (const $ fmap Right . convertAnnotationWrapper)     -- We turn off showing the code in meta-level exceptions because doing so exposes     -- the toAnnotationWrapper function that we slap around the user's code @@ -1188,7 +1182,7 @@ --------------- runMeta' :: Bool                 -- Whether code should be printed in the exception message          -> (hs_syn -> SDoc)                                    -- how to print the code-         -> (SrcSpan -> ForeignHValue -> TcM (Either SDoc hs_syn))        -- How to run x+         -> (SrcSpan -> ForeignHValue -> TcM (Either RunSpliceFailReason hs_syn)) -- How to run x          -> LHsExpr GhcTc        -- Of type x; typically x = Q TH.Exp, or                                  --    something like that          -> TcM hs_syn           -- Of type t@@ -1219,7 +1213,8 @@         -- cases.         ; logger <- getLogger         ; diag_opts <- initDiagOpts <$> getDynFlags-        ; liftIO $ printMessages logger diag_opts ds_msgs+        ; print_config <- initDsMessageOpts <$> getDynFlags+        ; liftIO $ printMessages logger print_config diag_opts ds_msgs          ; ds_expr <- case mb_ds_expr of             Nothing      -> failM   -- Case (a) from Note [Errors in desugaring a splice]@@ -1235,7 +1230,7 @@         ; either_hval <- tryM $ liftIO $                          GHC.Driver.Main.hscCompileCoreExpr hsc_env src_span ds_expr         ; case either_hval of {-            Left exn   -> fail_with_exn "compile and link" exn ;+            Left exn   -> fail_with_exn SplicePhase_CompileAndLink exn ;             Right (hval, needed_mods, needed_pkgs) -> do          {       -- Coerce it to Q t, and run it@@ -1256,7 +1251,7 @@                                                 -- see where this splice is              do { mb_result <- run_and_convert expr_span hval                 ; case mb_result of-                    Left err     -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints err)+                    Left err     -> failWithTc (TcRnRunSpliceFailure Nothing err)                     Right result -> do { traceTc "Got HsSyn result:" (ppr_hs result)                                        ; return $! result } } @@ -1264,17 +1259,15 @@             Right v -> return v             Left se -> case fromException se of                          Just IOEnvFailure -> failM -- Error already in Tc monad-                         _ -> fail_with_exn "run" se -- Exception+                         _ -> fail_with_exn SplicePhase_Run se -- Exception         }}}   where     -- see Note [Concealed TH exceptions]-    fail_with_exn :: Exception e => String -> e -> TcM a+    fail_with_exn :: Exception e => SplicePhase -> e -> TcM a     fail_with_exn phase exn = do         exn_msg <- liftIO $ Panic.safeShowException exn-        let msg = vcat [text "Exception when trying to" <+> text phase <+> text "compile-time code:",-                        nest 2 (text exn_msg),-                        if show_code then text "Code:" <+> ppr expr else empty]-        failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg)+        failWithTc+          $ TcRnSpliceThrewException phase (SomeException exn) exn_msg expr show_code  {- Note [Running typed splices in the zonker]@@ -1390,9 +1383,8 @@    -- 'msg' is forced to ensure exceptions don't escape,   -- see Note [Exceptions in TH]-  qReport True msg  = seqList msg $ addErr $ mkTcRnUnknownMessage $ mkPlainError noHints (text msg)-  qReport False msg = seqList msg $ addDiagnostic $ mkTcRnUnknownMessage $-    mkPlainDiagnostic WarningWithoutFlag noHints (text msg)+  qReport True msg  = seqList msg $ addErr $ TcRnReportCustomQuasiError True msg+  qReport False msg = seqList msg $ addDiagnostic $ TcRnReportCustomQuasiError False msg    qLocation :: TcM TH.Loc   qLocation = do { m <- getModule@@ -1445,9 +1437,8 @@       th_origin <- getThSpliceOrigin       let either_hval = convertToHsDecls th_origin l thds       ds <- case either_hval of-              Left exn -> failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $-                hang (text "Error in a declaration passed to addTopDecls:")-                   2 exn+              Left exn -> failWithTc+                            $ TcRnRunSpliceFailure (Just "addTopDecls") exn               Right ds -> return ds       mapM_ (checkTopDecl . unLoc) ds       th_topdecls_var <- fmap tcg_th_topdecls getGblEnv@@ -1462,9 +1453,8 @@         = return ()       checkTopDecl (ForD _ (ForeignImport { fd_name = L _ name }))         = bindName name-      checkTopDecl _-        = addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $-          text "Only function, value, annotation, and foreign import declarations may be added with addTopDecl"+      checkTopDecl d+        = addErr $ TcRnInvalidTopDecl d        bindName :: RdrName -> TcM ()       bindName (Exact n)@@ -1472,10 +1462,7 @@              ; updTcRef th_topnames_var (\ns -> extendNameSet ns n)              } -      bindName name =-          addErr $ mkTcRnUnknownMessage $ mkPlainError noHints $-          hang (text "The binder" <+> quotes (ppr name) <+> text "is not a NameU.")-             2 (text "Probable cause: you used mkName instead of newName to generate a binding.")+      bindName name = addErr $ TcRnNonExactName name    qAddForeignFilePath lang fp = do     var <- fmap tcg_th_foreign_files getGblEnv@@ -1493,15 +1480,10 @@       let dflags    = hsc_dflags hsc_env       let fopts     = initFinderOpts dflags       r <- liftIO $ findHomeModule fc fopts home_unit (mkModuleName plugin)-      let err = hang-            (text "addCorePlugin: invalid plugin module "-               <+> text (show plugin)-            )-            2-            (text "Plugins in the current package can't be specified.")+      let err = TcRnAddInvalidCorePlugin plugin       case r of-        Found {} -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints err-        FoundMultiple {} -> addErr $ mkTcRnUnknownMessage $ mkPlainError noHints err+        Found {} -> addErr err+        FoundMultiple {} -> addErr err         _ -> return ()       th_coreplugins_var <- tcg_th_coreplugins <$> getGblEnv       updTcRef th_coreplugins_var (plugin:)@@ -1526,9 +1508,7 @@     th_doc_var <- tcg_th_docs <$> getGblEnv     resolved_doc_loc <- resolve_loc doc_loc     is_local <- checkLocalName resolved_doc_loc-    unless is_local $ failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $ text-      "Can't add documentation to" <+> ppr_loc doc_loc <+>-      text "as it isn't inside the current module"+    unless is_local $ failWithTc $ TcRnAddDocToNonLocalDefn doc_loc     let ds = mkGeneratedHsDocString s         hd = lexHsDoc parseIdentifier ds     hd' <- rnHsDoc hd@@ -1539,11 +1519,6 @@       resolve_loc (TH.InstDoc t) = InstDoc <$> fmap getName (lookupThInstName t)       resolve_loc TH.ModuleDoc = pure ModuleDoc -      ppr_loc (TH.DeclDoc n) = ppr_th n-      ppr_loc (TH.ArgDoc n _) = ppr_th n-      ppr_loc (TH.InstDoc t) = ppr_th t-      ppr_loc TH.ModuleDoc = text "the module header"-       -- It doesn't make sense to add documentation to something not inside       -- the current module. So check for it!       checkLocalName (DeclDoc n) = nameIsLocalOrFrom <$> getModule <*> pure n@@ -1616,10 +1591,8 @@     Right (_, (inst:_)) -> return $ getName inst     Right (_, [])       -> noMatches   where-    noMatches = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $-      text "Couldn't find any instances of"-        <+> ppr_th th_type-        <+> text "to add documentation to"+    noMatches = failWithTc $+      TcRnFailedToLookupThInstName th_type NoMatchesFound      -- Get the name of the class for the instance we are documenting     -- > inst_cls_name (Monad Maybe) == Monad@@ -1655,10 +1628,8 @@     inst_cls_name TH.WildCardT               = inst_cls_name_err     inst_cls_name (TH.ImplicitParamT _ _)    = inst_cls_name_err -    inst_cls_name_err = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $-      text "Couldn't work out what instance"-        <+> ppr_th th_type-        <+> text "is supposed to be"+    inst_cls_name_err = failWithTc $+      TcRnFailedToLookupThInstName th_type CouldNotDetermineInstance      -- Basically does the opposite of 'mkThAppTs'     -- > inst_arg_types (Monad Maybe) == [Maybe]@@ -1946,16 +1917,14 @@                      ; let matches = lookupFamInstEnv inst_envs tc tys                      ; traceTc "reifyInstances'2" (ppr matches)                      ; return $ Right (tc, map fim_instance matches) }-            _  -> bale_out $ mkTcRnUnknownMessage $ mkPlainError noHints $-                  (hang (text "reifyInstances:" <+> quotes (ppr ty))-                      2 (text "is not a class constraint or type family application")) }+            _  -> bale_out $ TcRnCannotReifyInstance ty }   where     doc = ClassInstanceCtx     bale_out msg = failWithTc msg      cvt :: Origin -> SrcSpan -> TH.Type -> TcM (LHsType GhcPs)     cvt origin loc th_ty = case convertToHsType origin loc th_ty of-      Left msg -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg)+      Left msg -> failWithTc (TcRnRunSpliceFailure Nothing msg)       Right ty -> return ty  {-@@ -2056,18 +2025,15 @@      do { mb_thing <- tcLookupImported_maybe name         ; case mb_thing of             Succeeded thing -> return (AGlobal thing)-            Failed msg      -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg)+            Failed msg      -> failWithTc (TcRnInterfaceLookupError name msg)     }}}}  notInScope :: TH.Name -> TcRnMessage-notInScope th_name = mkTcRnUnknownMessage $ mkPlainError noHints $-  quotes (text (TH.pprint th_name)) <+>-          text "is not in scope at a reify"-        -- Ugh! Rather an indirect way to display the name+notInScope th_name =+  TcRnCannotReifyOutOfScopeThing th_name  notInEnv :: Name -> TcRnMessage-notInEnv name = mkTcRnUnknownMessage $ mkPlainError noHints $-  quotes (ppr name) <+> text "is not in the type environment at a reify"+notInEnv name = TcRnCannotReifyThingNotInTypeEnv name  ------------------------------ reifyRoles :: TH.Name -> TcM [TH.Role]@@ -2075,7 +2041,7 @@   = do { thing <- getThing th_name        ; case thing of            AGlobal (ATyCon tc) -> return (map reify_role (tyConRoles tc))-           _ -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints $ text "No roles associated with" <+> (ppr thing))+           _ -> failWithTc (TcRnNoRolesAssociatedWithThing thing)        }   where     reify_role Nominal          = TH.NominalR@@ -2608,11 +2574,11 @@   | otherwise      = do { [r1,r2] <- reifyTypes [t1,t2]                         ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) } reifyType ty@(FunTy { ft_af = af, ft_mult = tm, ft_arg = t1, ft_res = t2 })-  | InvisArg <- af = noTH (text "linear invisible argument") (ppr ty)+  | InvisArg <- af = noTH LinearInvisibleArgument ty   | otherwise      = do { [rm,r1,r2] <- reifyTypes [tm,t1,t2]                         ; return (TH.MulArrowT `TH.AppT` rm `TH.AppT` r1 `TH.AppT` r2) } reifyType (CastTy t _)      = reifyType t -- Casts are ignored in TH-reifyType ty@(CoercionTy {})= noTH (text "coercions in types") (ppr ty)+reifyType ty@(CoercionTy {})= noTH CoercionsInTypes ty  reify_for_all :: TyCoRep.ArgFlag -> TyCoRep.Type -> TcM TH.Type -- Arg of reify_for_all is always ForAllTy or a predicate FunTy@@ -2868,11 +2834,8 @@ mkThAppTs :: TH.Type -> [TH.Type] -> TH.Type mkThAppTs fun_ty arg_tys = foldl' TH.AppT fun_ty arg_tys -noTH :: SDoc -> SDoc -> TcM a-noTH s d = failWithTc $ mkTcRnUnknownMessage $ mkPlainError noHints $-  (hsep [text "Can't represent" <+> s <+>-         text "in Template Haskell:",-           nest 2 d])+noTH :: UnrepresentableTypeDescr -> Type -> TcM a+noTH s d = failWithTc $ TcRnCannotRepresentType s d  ppr_th :: TH.Ppr a => a -> SDoc ppr_th x = text (TH.pprint x)

@@ -571,15 +571,15 @@ (WD3) As an alternative to `withDict`, one could define functions like `withT`       above in terms of `unsafeCoerce`. This is more error-prone, however. -(WD4) In order to define things like `reifySymbol` below:+(WD4) In order to define things like `withKnownNat` below: -        reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => r) -> r+        withKnownNat :: SNat n -> (KnownNat n => r) -> r        `withDict` needs to be instantiated with `Any`, like so: -        reifySymbol n k = withDict @(KnownSymbol Any) @String @r n (k @Any)+        withKnownNat = withDict @(KnownNat Any) @(SNat Any) @r -      The use of `Any` is explained in Note [NOINLINE someNatVal] in+      The use of `Any` is explained in Note [NOINLINE withSomeSNat] in       base:GHC.TypeNats.  (WD5) In earlier implementations, `withDict` was implemented as an identifier

@@ -891,9 +891,9 @@       | name `elem` boot_dfun_names = return ()          -- Check that the actual module exports the same thing-      | not (null missing_names)-      = addErrAt (nameSrcSpan (head missing_names))-                 (missingBootThing True (head missing_names) "exported by")+      | missing_name:_ <- missing_names+      = addErrAt (nameSrcSpan missing_name)+                 (missingBootThing True missing_name "exported by")          -- If the boot module does not *define* the thing, we are done         -- (it simply re-exports it, and names match, so nothing further to do)

@@ -2032,6 +2032,14 @@ types in canEqCanLHS *and* having the newtype-unwrapping check above the tyvar check in can_eq_nc. +Note that this only applies to saturated applications of newtype TyCons, as+we can't rewrite an unsaturated application. See for example T22310, where+we ended up with:++  newtype Compose f g a = ...++  [W] t[tau] ~# Compose Foo Bar+ Note [Put touchable variables on the left] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Ticket #10009, a very nasty example:@@ -2401,15 +2409,17 @@      lhs_ty = canEqLHSType lhs -    -- This is about (TyEq:N): check that we don't have a newtype-    -- whose constructor is in scope at the top-level of the RHS.+    -- This is about (TyEq:N): check that we don't have a saturated application+    -- of a newtype TyCon at the top level of the RHS, if the constructor+    -- of the newtype is in scope.     ty_eq_N_OK :: TcS Bool     ty_eq_N_OK       | ReprEq <- eq_rel-      , Just tc <- tyConAppTyCon_maybe rhs+      , Just (tc, tc_args) <- splitTyConApp_maybe rhs       , Just con <- newTyConDataCon_maybe tc-      -- #21010: only a problem if the newtype constructor is in scope-      -- yet we didn't rewrite it away.+      -- #22310: only a problem if the newtype TyCon is saturated.+      , tc_args `lengthAtLeast` tyConArity tc+      -- #21010: only a problem if the newtype constructor is in scope.       = do { rdr_env <- getGlobalRdrEnvTcS            ; let con_in_scope = isJust $ lookupGRE_Name rdr_env (dataConName con)            ; return $ not con_in_scope }

@@ -35,7 +35,7 @@ import GHC.Hs  import GHC.Tc.Errors.Types ( TcRnMessage(..), FixedRuntimeRepProvenance(..)-                           , mkTcRnUnknownMessage )+                           , mkTcRnUnknownMessage, IllegalNewtypeReason (..) ) import GHC.Tc.TyCl.Build import GHC.Tc.Solver( pushLevelAndSolveEqualities, pushLevelAndSolveEqualitiesX                     , reportUnsolvedEqualities )@@ -411,21 +411,27 @@ 2.  When checking a type/class declaration (in module GHC.Tc.TyCl), we come     upon knowledge of the eventual tycon in bits and pieces, and we use     a TcTyCon to record what we know before we are ready to build the-    final TyCon.+    final TyCon.  Here is the plan: -    We first build a MonoTcTyCon, then generalise to a PolyTcTyCon-    See Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType-    Specifically:+    Step 1 (inferInitialKinds, inference only, skipped for checking):+       Make a MonoTcTyCon whose binders are TcTyVars,+       which may contain free unification variables -      S1) In kcTyClGroup, we use checkInitialKinds to get the-          utterly-final Kind of all TyCons in the group that-            (a) have a kind signature or-            (b) have a CUSK.-          This produces a PolyTcTyCon, that is, a TcTyCon in which the binders-          and result kind are full of TyVars (not TcTyVars).  No unification-          variables here; everything is in its final form.+    Step 2 (generaliseTcTyCon)+       Generalise that MonoTcTyCon to make a PolyTcTyCon+       Its binders are skolem TcTyVars, with accurate SkolemInfo -      S2) In kcTyClGroup, we use inferInitialKinds to look over the+    Step 3 (tcTyClDecl)+       Typecheck the type and class decls to produce a final TyCon+       Its binders are final TyVars, not TcTyVars++    Note that a MonoTcTyCon can contain unification variables,+    but a PolyTcTyCon does not: only skolem TcTyVars.  See+    Note [TcTyCon, MonoTcTyCon, and PolyTcTyCon] in GHC.Tc.Utils.TcType++    More details about /kind inference/:++      S1) In kcTyClGroup, we use inferInitialKinds to look over the           declaration of any TyCon that lacks a kind signature or           CUSK, to determine its "shape"; for example, the number of           parameters, and any kind signatures.@@ -434,27 +440,30 @@           "mono" because it has not been been generalised, and its binders           and result kind may have free unification variables. -      S3) Still in kcTyClGroup, we use kcLTyClDecl to kind-check the+      S2) Still in kcTyClGroup, we use kcLTyClDecl to kind-check the           body (class methods, data constructors, etc.) of each of           these MonoTcTyCons, which has the effect of filling in the           metavariables in the tycon's initial kind. -      S4) Still in kcTyClGroup, we use generaliseTyClDecl to generalize-          each MonoTcTyCon to get a PolyTcTyCon, with final TyVars in it,+      S3) Still in kcTyClGroup, we use generaliseTyClDecl to generalize+          each MonoTcTyCon to get a PolyTcTyCon, with skolem TcTyVars in it,           and a final, fixed kind. -      S5) Finally, back in TcTyClDecls, we extend the environment with+      S4) Finally, back in TcTyClDecls, we extend the environment with           the PolyTcTyCons, and typecheck each declaration (regardless           of kind signatures etc) to get final TyCon. -    These TcTyCons are stored in the local environment in GHC.Tc.TyCl,-    until the real full TyCons can be created during desugaring. A-    desugared program should never have a TcTyCon.+    More details about /kind checking/ -3.  A MonoTcTyCon can contain unification variables, but a PolyTcTyCon-    does not: only skolem TcTyVars.+      S5) In kcTyClGroup, we use checkInitialKinds to get the+          utterly-final Kind of all TyCons in the group that+            (a) have a separate kind signature or+            (b) have a CUSK.+          This produces a PolyTcTyCon, that is, a TcTyCon in which the binders+          and result kind are full of TyVars (not TcTyVars).  No unification+          variables here; everything is in its final form. -4.  tyConScopedTyVars.  A challenging piece in all of this is that we+3.  tyConScopedTyVars.  A challenging piece in all of this is that we     end up taking three separate passes over every declaration:       - one in inferInitialKind (this pass look only at the head, not the body)       - one in kcTyClDecls (to kind-check the body)@@ -2425,15 +2434,15 @@              -> TcM Class tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs   = fixM $ \ clas -> -- We need the knot because 'clas' is passed into tcClassATs-    bindTyClTyVars class_name $ \ binders res_kind ->+    bindTyClTyVars class_name $ \ tc_bndrs res_kind ->     do { checkClassKindSig res_kind-       ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr binders)+       ; traceTc "tcClassDecl 1" (ppr class_name $$ ppr tc_bndrs)        ; let tycon_name = class_name        -- We use the same name              roles = roles_info tycon_name  -- for TyCon and Class         ; (ctxt, fds, sig_stuff, at_stuff)-            <- pushLevelAndSolveEqualities skol_info binders $-               -- The (binderVars binders) is needed bring into scope the+            <- pushLevelAndSolveEqualities skol_info tc_bndrs $+               -- The (binderVars tc_bndrs) is needed bring into scope the                -- skolems bound by the class decl header (#17841)                do { ctxt <- tcHsContext hs_ctxt                   ; fds  <- mapM (addLocMA tc_fundep) fundeps@@ -2458,9 +2467,10 @@        -- any unfilled coercion variables unless there is such an error        -- The zonk also squeeze out the TcTyCons, and converts        -- Skolems to tyvars.-       ; ze        <- mkEmptyZonkEnv NoFlexi-       ; ctxt      <- zonkTcTypesToTypesX ze ctxt-       ; sig_stuff <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff+       ; ze          <- mkEmptyZonkEnv NoFlexi+       ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs  -- From TcTyVars to TyVars+       ; ctxt        <- zonkTcTypesToTypesX ze ctxt+       ; sig_stuff   <- mapM (zonkTcMethInfoToMethInfoX ze) sig_stuff          -- ToDo: do we need to zonk at_stuff?         -- TODO: Allow us to distinguish between abstract class,@@ -2482,8 +2492,8 @@                   | otherwise                   = Just (ctxt, at_stuff, sig_stuff, mindef) -       ; clas <- buildClass class_name binders roles fds body-       ; traceTc "tcClassDecl" (ppr fundeps $$ ppr binders $$+       ; clas <- buildClass class_name bndrs roles fds body+       ; traceTc "tcClassDecl" (ppr fundeps $$ ppr bndrs $$                                 ppr fds)        ; return clas }   where@@ -2712,7 +2722,7 @@                               , fdResultSig = L _ sig                               , fdInjectivityAnn = inj })   | DataFamily <- fam_info-  = bindTyClTyVarsAndZonk tc_name $ \ binders res_kind -> do+  = bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> do   { traceTc "tcFamDecl1 data family:" (ppr tc_name)   ; checkFamFlag tc_name @@ -2729,8 +2739,8 @@   -- See also Note [Datatype return kinds]   ; checkDataKindSig DataFamilySort res_kind   ; tc_rep_name <- newTyConRepName tc_name-  ; let inj   = Injective $ replicate (length binders) True-        tycon = mkFamilyTyCon tc_name binders+  ; let inj   = Injective $ replicate (length tc_bndrs) True+        tycon = mkFamilyTyCon tc_name tc_bndrs                               res_kind                               (resultVariableName sig)                               (DataFamilyTyCon tc_rep_name)@@ -2738,12 +2748,12 @@   ; return tycon }    | OpenTypeFamily <- fam_info-  = bindTyClTyVarsAndZonk tc_name $ \ binders res_kind -> do+  = bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> do   { traceTc "tcFamDecl1 open type family:" (ppr tc_name)   ; checkFamFlag tc_name-  ; inj' <- tcInjectivity binders inj+  ; inj' <- tcInjectivity tc_bndrs inj   ; checkResultSigFlag tc_name sig  -- check after injectivity for better errors-  ; let tycon = mkFamilyTyCon tc_name binders res_kind+  ; let tycon = mkFamilyTyCon tc_name tc_bndrs res_kind                                (resultVariableName sig) OpenSynFamilyTyCon                                parent inj'   ; return tycon }@@ -2754,10 +2764,10 @@     do { traceTc "tcFamDecl1 Closed type family:" (ppr tc_name)          -- the variables in the header scope only over the injectivity          -- declaration but this is not involved here-       ; (inj', binders, res_kind)-            <- bindTyClTyVarsAndZonk tc_name $ \ binders res_kind ->-               do { inj' <- tcInjectivity binders inj-                  ; return (inj', binders, res_kind) }+       ; (inj', tc_bndrs, res_kind)+            <- bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind ->+               do { inj' <- tcInjectivity tc_bndrs inj+                  ; return (inj', tc_bndrs, res_kind) }         ; checkFamFlag tc_name -- make sure we have -XTypeFamilies        ; checkResultSigFlag tc_name sig@@ -2766,14 +2776,14 @@          -- but eqns might be empty in the Just case as well        ; case mb_eqns of            Nothing   ->-               return $ mkFamilyTyCon tc_name binders res_kind+               return $ mkFamilyTyCon tc_name tc_bndrs res_kind                                       (resultVariableName sig)                                       AbstractClosedSynFamilyTyCon parent                                       inj'            Just eqns -> do {           -- Process the equations, creating CoAxBranches-       ; let tc_fam_tc = mkTcTyCon tc_name binders res_kind+       ; let tc_fam_tc = mkTcTyCon tc_name tc_bndrs res_kind                                    noTcTyConScopedTyVars                                    False {- this doesn't matter here -}                                    ClosedTypeFamilyFlavour@@ -2792,7 +2802,7 @@               | null eqns = Nothing   -- mkBranchedCoAxiom fails on empty list               | otherwise = Just (mkBranchedCoAxiom co_ax_name fam_tc branches) -             fam_tc = mkFamilyTyCon tc_name binders res_kind (resultVariableName sig)+             fam_tc = mkFamilyTyCon tc_name tc_bndrs res_kind (resultVariableName sig)                       (ClosedSynFamilyTyCon mb_co_ax) parent inj'           -- We check for instance validity later, when doing validity@@ -2853,10 +2863,10 @@ tcTySynRhs :: RolesInfo -> Name            -> LHsType GhcRn -> TcM TyCon tcTySynRhs roles_info tc_name hs_ty-  = bindTyClTyVars tc_name $ \ binders res_kind ->+  = bindTyClTyVars tc_name $ \ tc_bndrs res_kind ->     do { env <- getLclEnv        ; traceTc "tc-syn" (ppr tc_name $$ ppr (tcl_env env))-       ; rhs_ty <- pushLevelAndSolveEqualities skol_info binders $+       ; rhs_ty <- pushLevelAndSolveEqualities skol_info tc_bndrs $                    tcCheckLHsType hs_ty (TheKind res_kind)           -- See Note [Error on unconstrained meta-variables] in GHC.Tc.Utils.TcMType@@ -2870,11 +2880,11 @@                                                  , ppr rhs_ty ] ) }        ; doNotQuantifyTyVars dvs mk_doc -       ; ze            <- mkEmptyZonkEnv NoFlexi-       ; (ze, binders) <- zonkTyVarBindersX ze binders-       ; rhs_ty        <- zonkTcTypeToTypeX ze rhs_ty+       ; ze          <- mkEmptyZonkEnv NoFlexi+       ; (ze, bndrs) <- zonkTyVarBindersX ze tc_bndrs+       ; rhs_ty      <- zonkTcTypeToTypeX ze rhs_ty        ; let roles = roles_info tc_name-       ; return (buildSynTyCon tc_name binders res_kind roles rhs_ty) }+       ; return (buildSynTyCon tc_name bndrs res_kind roles rhs_ty) }   where     skol_info = TyConSkol TypeSynonymFlavour tc_name @@ -4530,40 +4540,30 @@ ------------------------------- checkNewDataCon :: DataCon -> TcM () -- Further checks for the data constructor of a newtype+-- You might wonder if we need to check for an unlifted newtype+-- without -XUnliftedNewTypes, such as+--   newtype C = MkC Int#+-- But they are caught earlier, by GHC.Tc.Gen.HsType.checkDataKindSig checkNewDataCon con-  = do  { checkTc (isSingleton arg_tys) (newtypeFieldErr con (length arg_tys))-              -- One argument--        ; unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes-        ; let allowedArgType =-                unlifted_newtypes || typeLevity_maybe (scaledThing arg_ty1) == Just Lifted-        ; checkTc allowedArgType $ mkTcRnUnknownMessage $ mkPlainError noHints $ vcat-          [ text "A newtype cannot have an unlifted argument type"-          , text "Perhaps you intended to use UnliftedNewtypes"-          ]-        ; show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags+  = do  { show_linear_types <- xopt LangExt.LinearTypes <$> getDynFlags -        ; let check_con what msg =-               checkTc what $ mkTcRnUnknownMessage $ mkPlainError noHints $-                 (msg $$ ppr con <+> dcolon <+> ppr (dataConDisplayType show_linear_types con))+        ; checkTc (isSingleton arg_tys) $+          TcRnIllegalNewtype con show_linear_types (DoesNotHaveSingleField $ length arg_tys)          ; checkTc (ok_mult (scaledMult arg_ty1)) $-          mkTcRnUnknownMessage $ mkPlainError noHints $ text "A newtype constructor must be linear"+          TcRnIllegalNewtype con show_linear_types IsNonLinear -        ; check_con (null eq_spec) $-          text "A newtype constructor must have a return type of form T a1 ... an"-                -- Return type is (T a b c)+        ; checkTc (null eq_spec) $+          TcRnIllegalNewtype con show_linear_types IsGADT -        ; check_con (null theta) $-          text "A newtype constructor cannot have a context in its type"+        ; checkTc (null theta) $+          TcRnIllegalNewtype con show_linear_types HasConstructorContext -        ; check_con (null ex_tvs) $-          text "A newtype constructor cannot have existential type variables"-                -- No existentials+        ; checkTc (null ex_tvs) $+          TcRnIllegalNewtype con show_linear_types HasExistentialTyVar -        ; checkTc (all ok_bang (dataConSrcBangs con))-                  (newtypeStrictError con)-                -- No strictness annotations+        ; checkTc (all ok_bang (dataConSrcBangs con)) $+          TcRnIllegalNewtype con show_linear_types HasStrictnessAnnotation     }   where     (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty)@@ -4679,7 +4679,7 @@         -- Test case: rep-poly/RepPolyClassMethod.          ; unless constrained_class_methods $-          mapM_ check_constraint (tail (cls_pred:op_theta))+          mapM_ check_constraint op_theta          ; check_dm ctxt sel_id cls_pred tau2 dm         }@@ -5333,18 +5333,6 @@   = mkTcRnUnknownMessage $ mkPlainError noHints $     sep [text "A newtype must have exactly one constructor,",          nest 2 $ text "but" <+> quotes (ppr tycon) <+> text "has" <+> speakN n ]--newtypeStrictError :: DataCon -> TcRnMessage-newtypeStrictError con-  = mkTcRnUnknownMessage $ mkPlainError noHints $-  sep [text "A newtype constructor cannot have a strictness annotation,",-         nest 2 $ text "but" <+> quotes (ppr con) <+> text "does"]--newtypeFieldErr :: DataCon -> Int -> TcRnMessage-newtypeFieldErr con_name n_flds-  = mkTcRnUnknownMessage $ mkPlainError noHints $-    sep [text "The constructor of a newtype must have exactly one field",-         nest 2 $ text "but" <+> quotes (ppr con_name) <+> text "has" <+> speakN n_flds]  badSigTyDecl :: Name -> TcRnMessage badSigTyDecl tc_name

@@ -170,7 +170,7 @@         -- tcg_env (TODO: but maybe this isn't relevant anymore).         r <- tcLookupImported_maybe name         case r of-          Failed err -> addErr (mkTcRnUnknownMessage $ mkPlainError noHints err)+          Failed err -> addErr (TcRnInterfaceLookupError name err)           Succeeded real_thing -> checkHsigDeclM sig_iface sig_thing real_thing        -- The hsig did NOT define this function; that means it must

@@ -257,7 +257,7 @@     do  { mb_thing <- tcLookupImported_maybe name         ; case mb_thing of             Succeeded thing -> return thing-            Failed msg      -> failWithTc (mkTcRnUnknownMessage $ mkPlainError noHints msg)+            Failed msg      -> failWithTc (TcRnInterfaceLookupError name msg)         }}}  -- Look up only in this module's global env't. Don't look in imports, etc.

@@ -70,7 +70,7 @@   addErrAt, addErrs,   checkErr,   addMessages,-  discardWarnings,+  discardWarnings, mkDetailedMessage,    -- * Usage environment   tcCollectingUsage, tcScalingUsage, tcEmitBindingUsage,@@ -1068,8 +1068,13 @@ addErrAt loc msg = do { ctxt <- getErrCtxt                       ; tidy_env <- tcInitTidyEnv                       ; err_info <- mkErrInfo tidy_env ctxt-                      ; add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) }+                      ; let detailed_msg = mkDetailedMessage (ErrInfo err_info Outputable.empty) msg+                      ; add_long_err_at loc detailed_msg } +mkDetailedMessage :: ErrInfo -> TcRnMessage -> TcRnMessageDetailed+mkDetailedMessage err_info msg =+  TcRnMessageDetailed err_info msg+ addErrs :: [(SrcSpan,TcRnMessage)] -> TcRn () addErrs msgs = mapM_ add msgs              where@@ -1132,7 +1137,7 @@  reportDiagnostic :: MsgEnvelope TcRnMessage -> TcRn () reportDiagnostic msg-  = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelope msg) ;+  = do { traceTc "Adding diagnostic:" (pprLocMsgEnvelopeDefault msg) ;          errs_var <- getErrsVar ;          msgs     <- readTcRef errs_var ;          writeTcRef errs_var (msg `addMessage` msgs) }@@ -1601,7 +1606,8 @@  = do { ctxt <- getErrCtxt       ; extra <- mkErrInfo env0 ctxt       ; let err_info = ErrInfo extra Outputable.empty-      ; add_diagnostic (TcRnMessageDetailed err_info msg) }+            detailed_msg = mkDetailedMessage err_info msg+      ; add_diagnostic detailed_msg }  -- | A variation of 'addDiagnostic' that takes a function to produce a 'TcRnDsMessage' -- given some additional context about the diagnostic.@@ -1623,14 +1629,14 @@ -- | Display a diagnostic for the current source location, taken from -- the 'TcRn' monad. addDiagnostic :: TcRnMessage -> TcRn ()-addDiagnostic msg = add_diagnostic (TcRnMessageDetailed no_err_info msg)+addDiagnostic msg = add_diagnostic (mkDetailedMessage no_err_info msg)  -- | Display a diagnostic for a given source location. addDiagnosticAt :: SrcSpan -> TcRnMessage -> TcRn () addDiagnosticAt loc msg = do   unit_state <- hsc_units <$> getTopEnv-  let dia = TcRnMessageDetailed no_err_info msg-  mkTcRnMessage loc (TcRnMessageWithInfo unit_state dia) >>= reportDiagnostic+  let detailed_msg = mkDetailedMessage no_err_info msg+  mkTcRnMessage loc (TcRnMessageWithInfo unit_state detailed_msg) >>= reportDiagnostic  -- | Display a diagnostic, with an optional flag, for the current source -- location.@@ -1652,7 +1658,7 @@             -> TcM () add_err_tcm tidy_env msg loc ctxt  = do { err_info <- mkErrInfo tidy_env ctxt ;-        add_long_err_at loc (TcRnMessageDetailed (ErrInfo err_info Outputable.empty) msg) }+        add_long_err_at loc (mkDetailedMessage (ErrInfo err_info Outputable.empty) msg) }  mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts

@@ -1735,12 +1735,6 @@       = return Nothing   -- this can happen for a covar that's associated with                          -- a coercion hole. Test case: typecheck/should_compile/T2494 --- Omit: no TyVars now---      | not (isTcTyVar tkv)---      = return (Just tkv)  -- For associated types in a class with a standalone---                           -- kind signature, we have the class variables in---                           -- scope, and they are TyVars not TcTyVars-       | otherwise       = Just <$> skolemiseQuantifiedTyVar skol_info tkv @@ -1785,12 +1779,18 @@  skolemiseQuantifiedTyVar skol_info tv   = case tcTyVarDetails tv of-      SkolemTv {} -> do { kind <- zonkTcType (tyVarKind tv)-                        ; return (setTyVarKind tv kind) }-        -- It might be a skolem type variable,-        -- for example from a user type signature-       MetaTv {} -> skolemiseUnboundMetaTyVar skol_info tv++      SkolemTv _ lvl _  -- It might be a skolem type variable,+                        -- for example from a user type signature+        -- But it might also be a shared meta-variable across several+        -- type declarations, each with its own skol_info. The first+        -- will skolemise it, but the other uses must update its+        -- skolem info (#22379)+        -> do { kind <- zonkTcType (tyVarKind tv)+              ; let details = SkolemTv skol_info lvl False+                    name = tyVarName tv+              ; return (mkTcTyVar name kind details) }        _other -> pprPanic "skolemiseQuantifiedTyVar" (ppr tv) -- RuntimeUnk