ghc-lib 9.8.1.20231121 → 9.8.2.20240223
raw patch · 63 files changed
+1228/−588 lines, 63 filesdep ~ghc-lib-parser
Dependency ranges changed: ghc-lib-parser
Files
- compiler/CodeGen.Platform.h +33/−0
- compiler/GHC.hs +1/−3
- compiler/GHC/Cmm/CallConv.hs +4/−2
- compiler/GHC/CmmToAsm/Ppr.hs +3/−2
- compiler/GHC/CmmToAsm/Wasm/FromCmm.hs +1/−1
- compiler/GHC/CmmToAsm/X86/CodeGen.hs +0/−23
- compiler/GHC/CmmToAsm/X86/Instr.hs +4/−2
- compiler/GHC/CmmToLlvm/CodeGen.hs +38/−19
- compiler/GHC/CmmToLlvm/Data.hs +1/−0
- compiler/GHC/Core/Opt/CSE.hs +3/−3
- compiler/GHC/Core/Opt/CprAnal.hs +40/−4
- compiler/GHC/Core/Opt/FloatIn.hs +1/−1
- compiler/GHC/Core/Opt/Pipeline.hs +1/−1
- compiler/GHC/Core/Opt/SpecConstr.hs +7/−14
- compiler/GHC/Core/Opt/Specialise.hs +2/−5
- compiler/GHC/Driver/Config/StgToCmm.hs +2/−0
- compiler/GHC/Driver/GenerateCgIPEStub.hs +203/−95
- compiler/GHC/Driver/Main.hs +31/−10
- compiler/GHC/Driver/Make.hs +28/−24
- compiler/GHC/Driver/Pipeline.hs +12/−1
- compiler/GHC/Driver/Pipeline/Execute.hs +3/−1
- compiler/GHC/HsToCore/Binds.hs +13/−2
- compiler/GHC/HsToCore/Foreign/C.hs +1/−1
- compiler/GHC/IfaceToCore.hs +1/−1
- compiler/GHC/Linker/Dynamic.hs +9/−2
- compiler/GHC/Llvm/Ppr.hs +1/−10
- compiler/GHC/Llvm/Syntax.hs +0/−3
- compiler/GHC/Rename/Doc.hs +1/−1
- compiler/GHC/Rename/Env.hs +19/−16
- compiler/GHC/Rename/Module.hs +5/−4
- compiler/GHC/Rename/Names.hs +49/−10
- compiler/GHC/Rename/Utils.hs +1/−1
- compiler/GHC/Settings/IO.hs +2/−0
- compiler/GHC/Stg/CSE.hs +2/−2
- compiler/GHC/Stg/Debug.hs +2/−2
- compiler/GHC/StgToCmm/Bind.hs +19/−5
- compiler/GHC/StgToCmm/CgUtils.hs +8/−6
- compiler/GHC/StgToCmm/Closure.hs +20/−18
- compiler/GHC/StgToCmm/Expr.hs +13/−35
- compiler/GHC/StgToCmm/Heap.hs +1/−1
- compiler/GHC/StgToCmm/Monad.hs +3/−1
- compiler/GHC/StgToCmm/Prim.hs +23/−10
- compiler/GHC/StgToCmm/Prof.hs +13/−10
- compiler/GHC/StgToCmm/Sequel.hs +12/−2
- compiler/GHC/StgToCmm/Utils.hs +78/−16
- compiler/GHC/StgToJS/Linker/Utils.hs +29/−23
- compiler/GHC/Tc/Deriv/Generate.hs +3/−1
- compiler/GHC/Tc/Gen/HsType.hs +110/−13
- compiler/GHC/Tc/Gen/Splice.hs +8/−2
- compiler/GHC/Tc/Solver/Equality.hs +10/−4
- compiler/GHC/Tc/TyCl.hs +142/−52
- compiler/GHC/Tc/TyCl/Build.hs +0/−1
- compiler/GHC/Tc/TyCl/Instance.hs +22/−17
- compiler/GHC/Tc/TyCl/Utils.hs +0/−1
- compiler/GHC/Tc/Validity.hs +90/−29
- compiler/GHC/Tc/Zonk/Type.hs +1/−1
- compiler/GHC/Unit/Finder.hs +1/−1
- compiler/MachRegs.h +8/−1
- ghc-lib.cabal +4/−4
- ghc-lib/stage0/compiler/build/primop-docs.hs-incl +1/−1
- ghc-lib/stage0/lib/settings +3/−2
- ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +7/−0
- ghc-lib/stage0/rts/build/include/ghcautoconf.h +75/−65
compiler/CodeGen.Platform.h view
@@ -203,6 +203,39 @@ # define d29 61 # define d30 62 # define d31 63++# define q0 32+# define q1 33+# define q2 34+# define q3 35+# define q4 36+# define q5 37+# define q6 38+# define q7 39+# define q8 40+# define q9 41+# define q10 42+# define q11 43+# define q12 44+# define q13 45+# define q14 46+# define q15 47+# define q16 48+# define q17 49+# define q18 50+# define q19 51+# define q20 52+# define q21 53+# define q22 54+# define q23 55+# define q24 56+# define q25 57+# define q26 58+# define q27 59+# define q28 60+# define q29 61+# define q30 62+# define q31 63 #endif # if defined(MACHREGS_darwin)
compiler/GHC.hs view
@@ -1518,9 +1518,7 @@ modInfoModBreaks = minf_modBreaks isDictonaryId :: Id -> Bool-isDictonaryId id- = case tcSplitSigmaTy (idType id) of {- (_tvs, _theta, tau) -> isDictTy tau }+isDictonaryId id = isDictTy (idType id) -- | Looks up a global name: that is, any top-level name in any -- visible module. Unlike 'lookupName', lookupGlobalName does not use
compiler/GHC/Cmm/CallConv.hs view
@@ -193,8 +193,10 @@ realXmmRegNos :: Platform -> [Int] realXmmRegNos platform- | isSse2Enabled platform = regList (pc_MAX_Real_XMM_REG (platformConstants platform))- | otherwise = []+ | isSse2Enabled platform || platformArch platform == ArchAArch64+ = regList (pc_MAX_Real_XMM_REG (platformConstants platform))+ | otherwise+ = [] regList :: Int -> [Int] regList n = [1 .. n]
compiler/GHC/CmmToAsm/Ppr.hs view
@@ -246,9 +246,10 @@ panic "PprBase.pprGNUSectionHeader: unknown section type" flags = case t of Text- | OSMinGW32 <- platformOS platform+ | OSMinGW32 <- platformOS platform, splitSections -> text ",\"xr\""- | otherwise -> text ",\"ax\"," <> sectionType platform "progbits"+ | splitSections+ -> text ",\"ax\"," <> sectionType platform "progbits" CString | OSMinGW32 <- platformOS platform -> empty
compiler/GHC/CmmToAsm/Wasm/FromCmm.hs view
@@ -883,7 +883,7 @@ pure $ SomeWasmExpr ty_word $ WasmExpr $- WasmSymConst "stg_EAGER_BLACKHOLE_info"+ WasmSymConst "__stg_EAGER_BLACKHOLE_info" GCEnter1 -> do onFuncSym "__stg_gc_enter_1" [] [ty_word_cmm] pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_enter_1"
compiler/GHC/CmmToAsm/X86/CodeGen.hs view
@@ -3230,32 +3230,9 @@ (y_reg, y_code) <- getNonClobberedReg y (z_reg, z_code) <- getNonClobberedReg z x_code <- getAnyReg x- y_tmp <- getNewRegNat rep- z_tmp <- getNewRegNat rep let fma213 = FMA3 rep signs FMA213 code dst- | dst == y_reg- , dst == z_reg- = y_code `appOL`- unitOL (MOV rep (OpReg y_reg) (OpReg y_tmp)) `appOL`- z_code `appOL`- unitOL (MOV rep (OpReg z_reg) (OpReg z_tmp)) `appOL`- x_code dst `snocOL`- fma213 (OpReg z_tmp) y_tmp dst- | dst == y_reg- = y_code `appOL`- unitOL (MOV rep (OpReg y_reg) (OpReg z_tmp)) `appOL`- z_code `appOL`- x_code dst `snocOL`- fma213 (OpReg z_reg) y_tmp dst- | dst == z_reg- = y_code `appOL`- z_code `appOL`- unitOL (MOV rep (OpReg z_reg) (OpReg z_tmp)) `appOL`- x_code dst `snocOL`- fma213 (OpReg z_tmp) y_reg dst- | otherwise = y_code `appOL` z_code `appOL` x_code dst `snocOL`
compiler/GHC/CmmToAsm/X86/Instr.hs view
@@ -275,7 +275,8 @@ -- | FMA3 fused multiply-add operations. | FMA3 Format FMASign FMAPermutation Operand Reg Reg- -- src1 (r/m), src2 (r), dst (r)+ -- src3 (r/m), src2 (r), dst/src1 (r)+ -- The is exactly reversed from how intel lists the arguments. -- use ADD, SUB, and SQRT for arithmetic. In both cases, operands -- are Operand Reg.@@ -356,6 +357,7 @@ | OpImm Imm -- immediate value | OpAddr AddrMode -- memory reference +-- NB: As of 2023 we only use the FMA213 permutation. data FMAPermutation = FMA132 | FMA213 | FMA231 -- | Returns which registers are read and written as a (read, written)@@ -443,7 +445,7 @@ PDEP _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst] PEXT _ src mask dst -> mkRU (use_R src $ use_R mask []) [dst] - FMA3 _ _ _ src1 src2 dst -> usageFMA src1 src2 dst+ FMA3 _ _ _ src3 src2 dst -> usageFMA src3 src2 dst -- note: might be a better way to do this PREFETCH _ _ src -> mkRU (use_R src []) []
compiler/GHC/CmmToLlvm/CodeGen.hs view
@@ -12,6 +12,7 @@ import GHC.Platform.Regs ( activeStgRegs ) import GHC.Llvm+import GHC.Llvm.Types import GHC.CmmToLlvm.Base import GHC.CmmToLlvm.Config import GHC.CmmToLlvm.Regs@@ -1787,31 +1788,49 @@ pprPanic "isSMulOK: Not bit type! " $ lparen <> ppr word <> rparen - panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered"+ panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-binary op encountered" ++ "with two arguments! (" ++ show op ++ ")" -genMachOp_slow _opt op [x, y, z] = case op of- MO_FMA var _ -> triLlvmOp getVarType (FMAOp var)- _ -> panicOp- where- triLlvmOp ty op = do- platform <- getPlatform- runExprData $ do- vx <- exprToVarW x- vy <- exprToVarW y- vz <- exprToVarW z-- if | getVarType vx == getVarType vy- , getVarType vx == getVarType vz- -> doExprW (ty vx) $ op vx vy vz- | otherwise- -> pprPanic "triLlvmOp types" (pdoc platform x $$ pdoc platform y $$ pdoc platform z)- panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-ternary op encountered"- ++ "with three arguments! (" ++ show op ++ ")"+genMachOp_slow _opt op [x, y, z] = do+ platform <- getPlatform+ let+ neg x = CmmMachOp (MO_F_Neg (cmmExprWidth platform x)) [x]+ panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: non-ternary op encountered"+ ++ "with three arguments! (" ++ show op ++ ")"+ case op of+ MO_FMA var _ ->+ case var of+ -- LLVM only has the fmadd variant.+ FMAdd -> genFmaOp x y z+ -- Other fused multiply-add operations are implemented in terms of fmadd+ -- This is sound: it does not lose any precision.+ FMSub -> genFmaOp x y (neg z)+ FNMAdd -> genFmaOp (neg x) y z+ FNMSub -> genFmaOp (neg x) y (neg z)+ _ -> panicOp -- More than three expressions, invalid! genMachOp_slow _ _ _ = panic "genMachOp_slow: More than 3 expressions in MachOp!" +-- | Generate code for a fused multiply-add operation.+genFmaOp :: CmmExpr -> CmmExpr -> CmmExpr -> LlvmM ExprData+genFmaOp x y z = runExprData $ do+ vx <- exprToVarW x+ vy <- exprToVarW y+ vz <- exprToVarW z+ let tx = getVarType vx+ ty = getVarType vy+ tz = getVarType vz+ Panic.massertPpr+ (tx == ty && tx == tz)+ (vcat [ text "fma: mismatched arg types"+ , ppLlvmType tx, ppLlvmType ty, ppLlvmType tz ])+ let fname = case tx of+ LMFloat -> fsLit "llvm.fma.f32"+ LMDouble -> fsLit "llvm.fma.f64"+ _ -> pprPanic "fma: type not LMFloat or LMDouble" (ppLlvmType tx)+ fptr <- liftExprData $ getInstrinct fname ty [tx, ty, tz]+ doExprW tx $ Call StdCall fptr [vx, vy, vz] [ReadNone, NoUnwind] -- | Handle CmmLoad expression. genLoad :: Atomic -> CmmExpr -> CmmType -> AlignmentSpec -> LlvmM ExprData
compiler/GHC/CmmToLlvm/Data.hs view
@@ -89,6 +89,7 @@ align = case sec of Section CString _ -> if (platformArch platform == ArchS390X) then Just 2 else Just 1+ Section Data _ -> Just $ platformWordSizeInBytes platform _ -> Nothing const = if sectionProtection sec == ReadOnlySection then Constant else Global
compiler/GHC/Core/Opt/CSE.hs view
@@ -53,8 +53,8 @@ reverse mapping. -Note [Shadowing]-~~~~~~~~~~~~~~~~+Note [Shadowing in CSE]+~~~~~~~~~~~~~~~~~~~~~~~ We have to be careful about shadowing. For example, consider f = \x -> let y = x+x in@@ -900,7 +900,7 @@ extendCSSubst cse x rhs = cse { cs_subst = extendSubst (cs_subst cse) x rhs } -- | Add clones to the substitution to deal with shadowing. See--- Note [Shadowing] for more details. You should call this whenever+-- Note [Shadowing in CSE] for more details. You should call this whenever -- you go under a binder. addBinder :: CSEnv -> Var -> (CSEnv, Var) addBinder cse v = (cse { cs_subst = sub' }, v')
compiler/GHC/Core/Opt/CprAnal.hs view
@@ -35,7 +35,6 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Logger ( Logger, putDumpFileMaybe, DumpFormat (..) ) import Data.List ( mapAccumL )@@ -271,11 +270,11 @@ cprAnalAlt env scrut_ty (Alt con bndrs rhs) = (rhs_ty, Alt con bndrs rhs') where+ ids = filter isId bndrs env_alt | DataAlt dc <- con- , let ids = filter isId bndrs , CprType arity cpr <- scrut_ty- , assert (arity == 0 ) True+ , arity == 0 -- See Note [Dead code may contain type confusions] = case unpackConFieldsCpr dc cpr of AllFieldsSame field_cpr | let sig = mkCprSig 0 field_cpr@@ -284,7 +283,7 @@ | let sigs = zipWith (mkCprSig . idArity) ids field_cprs -> extendSigEnvList env (zipEqual "cprAnalAlt" ids sigs) | otherwise- = env+ = extendSigEnvAllSame env ids topCprSig (rhs_ty, rhs') = cprAnal env_alt rhs --@@ -431,6 +430,43 @@ (id', rhs', env') = cprAnalBind env id rhs {-+Note [Dead code may contain type confusions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In T23862, we have a nested case match that looks like this++ data CheckSingleton (check :: Bool) where+ Checked :: CheckSingleton True+ Unchecked :: CheckSingleton False+ data family Result (check :: Bool) a+ data instance Result True a = CheckedResult a+ newtype instance Result True a = UncheckedResult a++ case m () of Checked co1 ->+ case m () of Unchecked co2 ->+ case ((\_ -> True)+ |> .. UncheckedResult ..+ |> sym co2+ |> co1) :: Result True (Bool -> Bool) of+ CheckedResult f -> CheckedResult (f True)++Clearly, the innermost case is dead code, because the `Checked` and `Unchecked`+cases are apart.+However, both constructors introduce mutually contradictory coercions `co1` and+`co2` along which GHC generates a type confusion:++ 1. (\_ -> True) :: Bool -> Bool+ 2. newtype coercion UncheckedResult (\_ -> True) :: Result False (Bool -> Bool)+ 3. |> ... sym co1 ... :: Result check (Bool -> Bool)+ 4. |> ... co2 ... :: Result True (Bool -> Bool)++Note that we started with a function, injected into `Result` via a newtype+instance and then match on it with a datatype instance.++We have to handle this case gracefully in `cprAnalAlt`, where for the innermost+case we see a `DataAlt` for `CheckedResult`, yet have a scrutinee type that+abstracts the function `(\_ -> True)` with arity 1.+In this case, don't pretend we know anything about the fields of `CheckedResult`!+ Note [The OPAQUE pragma and avoiding the reboxing of results] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider:
compiler/GHC/Core/Opt/FloatIn.hs view
@@ -306,7 +306,7 @@ (y:ys) -> ...(let x = y+1 in x)... [] -> blah because the y is captured. This doesn't happen much, because shadowing is-rare, but it did happen in #22662.+rare (see Note [Shadowing in Core]), but it did happen in #22662. One solution would be to clone as we go. But a simpler one is this:
compiler/GHC/Core/Opt/Pipeline.hs view
@@ -309,7 +309,7 @@ [ CoreLiberateCase, simplify "post-liberate-case" ], -- Run the simplifier after LiberateCase to vastly -- reduce the possibility of shadowing- -- Reason: see Note [Shadowing] in GHC.Core.Opt.SpecConstr+ -- Reason: see Note [Shadowing in SpecConstr] in GHC.Core.Opt.SpecConstr runWhen spec_constr $ CoreDoPasses [ CoreDoSpecConstr, simplify "post-spec-constr"],
compiler/GHC/Core/Opt/SpecConstr.hs view
@@ -256,7 +256,7 @@ * Find the free variables of the abstracted pattern * Pass these variables, less any that are in scope at- the fn defn. But see Note [Shadowing] below.+ the fn defn. But see Note [Shadowing in SpecConstr] below. NOTICE that we only abstract over variables that are not in scope,@@ -264,8 +264,8 @@ in f_spec's RHS. -Note [Shadowing]-~~~~~~~~~~~~~~~~+Note [Shadowing in SpecConstr]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In this pass we gather up usage information that may mention variables that are bound between the usage site and the definition site; or (more seriously) may be bound to something different at the definition site.@@ -1478,8 +1478,7 @@ scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c)) scExpr' _ e@(Lit {}) = return (nullUsage, e) scExpr' env (Tick t e) = do (usg, e') <- scExpr env e- (usg_t, t') <- scTickish env t- return (combineUsage usg usg_t, Tick t' e')+ return (usg, Tick (scTickish env t) e') scExpr' env (Cast e co) = do (usg, e') <- scExpr env e return (usg, mkCast e' (scSubstCo env co)) -- Important to use mkCast here@@ -1541,14 +1540,8 @@ -- | Substitute the free variables captured by a breakpoint. -- Variables are dropped if they have a non-variable substitution, like in -- 'GHC.Opt.Specialise.specTickish'.-scTickish :: ScEnv -> CoreTickish -> UniqSM (ScUsage, CoreTickish)-scTickish env = \case- Breakpoint ext i fv -> do- (usg, fv') <- unzip <$> mapM (\ v -> scExpr env (Var v)) fv- pure (combineUsages usg, Breakpoint ext i [v | Var v <- fv'])- t@ProfNote {} -> pure (nullUsage, t)- t@HpcTick {} -> pure (nullUsage, t)- t@SourceNote {} -> pure (nullUsage, t)+scTickish :: ScEnv -> CoreTickish -> CoreTickish+scTickish SCE {sc_subst = subst} = substTickish subst {- Note [Do not specialise evals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -2512,7 +2505,7 @@ -- Quantify over variables that are not in scope -- at the call site -- See Note [Free type variables of the qvar types]- -- See Note [Shadowing] at the top+ -- See Note [Shadowing in SpecConstr] at the top (ktvs, ids) = partition isTyVar qvars qvars' = scopedSort ktvs ++ map sanitise ids
compiler/GHC/Core/Opt/Specialise.hs view
@@ -68,6 +68,7 @@ import Data.List( partition ) import Data.List.NonEmpty ( NonEmpty (..) )+import GHC.Core.Subst (substTickish) {- ************************************************************************@@ -1268,11 +1269,7 @@ -------------- specTickish :: SpecEnv -> CoreTickish -> CoreTickish-specTickish (SE { se_subst = subst }) (Breakpoint ext ix ids)- = Breakpoint ext ix [ id' | id <- ids, Var id' <- [Core.lookupIdSubst subst id]]- -- drop vars from the list if they have a non-variable substitution.- -- should never happen, but it's harmless to drop them anyway.-specTickish _ other_tickish = other_tickish+specTickish (SE { se_subst = subst }) bp = substTickish subst bp -------------- specCase :: SpecEnv
compiler/GHC/Driver/Config/StgToCmm.hs view
@@ -42,6 +42,8 @@ , stgToCmmSCCProfiling = sccProfilingEnabled dflags , stgToCmmEagerBlackHole = gopt Opt_EagerBlackHoling dflags , stgToCmmInfoTableMap = gopt Opt_InfoTableMap dflags+ , stgToCmmInfoTableMapWithFallback = gopt Opt_InfoTableMapWithFallback dflags+ , stgToCmmInfoTableMapWithStack = gopt Opt_InfoTableMapWithStack dflags , stgToCmmOmitYields = gopt Opt_OmitYields dflags , stgToCmmOmitIfPragmas = gopt Opt_OmitInterfacePragmas dflags , stgToCmmPIC = gopt Opt_PIC dflags
compiler/GHC/Driver/GenerateCgIPEStub.hs view
@@ -1,37 +1,41 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TupleSections #-} -module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) where+module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks) where +import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map-import Data.Maybe (mapMaybe, listToMaybe)+import Data.Semigroup ((<>)) import GHC.Cmm-import GHC.Cmm.CLabel (CLabel)-import GHC.Cmm.Dataflow (Block, C, O)+import GHC.Cmm.CLabel (CLabel, mkAsmTempLabel)+import GHC.Cmm.Dataflow (O) import GHC.Cmm.Dataflow.Block (blockSplit, blockToList)-import GHC.Cmm.Dataflow.Collections (mapToList)+import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label (Label) import GHC.Cmm.Info.Build (emptySRT) import GHC.Cmm.Pipeline (cmmPipeline)-import GHC.Data.Maybe (firstJusts) import GHC.Data.Stream (Stream, liftIO) import qualified GHC.Data.Stream as Stream import GHC.Driver.Env (hsc_dflags, hsc_logger) import GHC.Driver.Env.Types (HscEnv)-import GHC.Driver.Flags (GeneralFlag (Opt_InfoTableMap))+import GHC.Driver.Flags (GeneralFlag (..), DumpFlag(Opt_D_ipe_stats)) import GHC.Driver.DynFlags (gopt, targetPlatform) import GHC.Driver.Config.StgToCmm import GHC.Driver.Config.Cmm import GHC.Prelude import GHC.Runtime.Heap.Layout (isStackRep)-import GHC.Settings (Platform, platformTablesNextToCode)+import GHC.Settings (platformTablesNextToCode) import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState) import GHC.StgToCmm.Prof (initInfoTableProv) import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos)+import GHC.StgToCmm.Utils import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation) import GHC.Types.Name.Set (NonCaffySet) import GHC.Types.Tickish (GenTickish (SourceNote))-import GHC.Unit.Types (Module)-import GHC.Utils.Misc+import GHC.Unit.Types (Module, moduleName)+import GHC.Unit.Module (moduleNameString)+import qualified GHC.Utils.Logger as Logger+import GHC.Utils.Outputable (ppr) {- Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]@@ -52,11 +56,17 @@ This leads to the question: How to figure out the source location of a return frame? -While the lookup algorithms when tables-next-to-code is on/off differ in details, they have in-common that we want to lookup the `CmmNode.CmmTick` (containing a `SourceNote`) that is nearest-(before) the usage of the return frame's label. (Which label and label type is used differs between-these two use cases.)+The algorithm for determining source locations for stack info tables is implemented in+`lookupEstimatedTicks` as two passes over every 'CmmGroupSRTs'. The first pass generates estimated+source locations for any labels potentially corresponding to stack info tables in the Cmm code. The+second pass walks over the Cmm decls and creates an entry in the IPE map for every info table,+looking up source locations for stack info tables in the map generated during the first pass. +The rest of this note will document exactly how the first pass generates the map from labels to+estimated source positions. The algorithms are different depending on whether tables-next-to-code+is on or off. Both algorithms have in common that we are looking for a `CmmNode.CmmTick`+(containing a `SourceNote`) that is near what we estimate to be the label of a return stack frame.+ With tables-next-to-code ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -107,16 +117,16 @@ Here we use the fact, that calls (represented by `CmmNode.CmmCall`) are always closed on exit (`CmmNode O C`, `O` means open, `C` closed). In other words, they are always at the end of a block. -So, given a stack represented info table (likely representing a return frame, but this isn't completely-sure as there are e.g. update frames, too) with it's label (`c18g` in the example above) and a `CmmGraph`:- - Look at the end of every block, if it's a `CmmNode.CmmCall` returning to the continuation with the- label of the return frame.- - If there's such a call, lookup the nearest `CmmNode.CmmTick` by traversing the middle part of the block- backwards (from end to beginning).- - Take the first `CmmNode.CmmTick` that contains a `Tickish.SourceNote` and return it's payload as- `IpeSourceLocation`. (There are other `Tickish` constructors like `ProfNote` or `HpcTick`, these are- ignored.)+So, given a `CmmGraph`:+ - Look at the end of every block: If it is a `CmmNode.CmmCall` returning to some label, lookup+ the nearest `CmmNode.CmmTick` by traversing the middle part of the block backwards (from end to+ beginning).+ - Take the first `CmmNode.CmmTick` that contains a `Tickish.SourceNote` and map the label we+ found to it's payload as an `IpeSourceLocation`. (There are other `Tickish` constructors like+ `ProfNote` or `HpcTick`, these are ignored.) +See `labelsToSourcesWithTNTC` for the implementation of this algorithm.+ Without tables-next-to-code ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -170,16 +180,27 @@ Notice, that this cannot be done with the `Label` `c18M`, but with the `CLabel` `block_c18M_info` (`label: block_c18M_info` is actually a `CLabel`). -The find the tick:- - Every `Block` is checked from top (first) to bottom (last) node for an assignment like- `I64[Sp - 24] = block_c18M_info;`. The lefthand side is actually ignored.- - If such an assignment is found the search is over, because the payload (content of- `Tickish.SourceNote`, represented as `IpeSourceLocation`) of last visited tick is always- remembered in a `Maybe`.+Given a `CmmGraph`:+ - Check every `CmmBlock` from top (first) to bottom (last).+ - If a `CmmTick` holding a `SourceNote` is found, remember the source location in the tick.+ - If an assignment of the form `... = block_c18M_info;` (a `CmmStore` whose RHS is a+ `CmmLit (CmmLabel l)`) is found, map that label to the most recently visited source note's+ location.++See `labelsToSourcesSansTNTC` for the implementation of this algorithm. -} -generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CmmCgInfos-generateCgIPEStub hsc_env this_mod denv s = do+generateCgIPEStub+ :: HscEnv+ -> Module+ -> InfoTableProvMap+ -> ( NonCaffySet+ , ModuleLFInfos+ , Map CmmInfoTable (Maybe IpeSourceLocation)+ , IPEStats+ )+ -> Stream IO CmmGroupSRTs CmmCgInfos+generateCgIPEStub hsc_env this_mod denv (nonCaffySet, moduleLFInfos, infoTablesWithTickishes, initStats) = do let dflags = hsc_dflags hsc_env platform = targetPlatform dflags logger = hsc_logger hsc_env@@ -187,82 +208,169 @@ cmm_cfg = initCmmConfig dflags cgState <- liftIO initC - -- Collect info tables, but only if -finfo-table-map is enabled, otherwise labeledInfoTablesWithTickishes is empty.- let collectFun = if gopt Opt_InfoTableMap dflags then collect platform else collectNothing- (labeledInfoTablesWithTickishes, (nonCaffySet, moduleLFInfos)) <- Stream.mapAccumL_ collectFun [] s- -- Yield Cmm for Info Table Provenance Entries (IPEs)- let denv' = denv {provInfoTables = Map.fromList (map (\(_, i, t) -> (cit_lbl i, t)) labeledInfoTablesWithTickishes)}- ((ipeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv (map sndOf3 labeledInfoTablesWithTickishes) denv')+ let denv' = denv {provInfoTables = Map.mapKeys cit_lbl infoTablesWithTickishes}+ ((mIpeStub, ipeCmmGroup), _) = runC (initStgToCmmConfig dflags this_mod) fstate cgState $ getCmm (initInfoTableProv initStats (Map.keys infoTablesWithTickishes) denv') (_, ipeCmmGroupSRTs) <- liftIO $ cmmPipeline logger cmm_cfg (emptySRT this_mod) ipeCmmGroup Stream.yield ipeCmmGroupSRTs - 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- let labelsToInfoTables = collectInfoTables cmmGroupSRTs- labelsToInfoTablesToTickishes = map (\(l, i) -> (l, i, lookupEstimatedTick platform cmmGroupSRTs l i)) labelsToInfoTables- return (acc ++ labelsToInfoTablesToTickishes, cmmGroupSRTs)+ ipeStub <-+ case mIpeStub of+ Just (stats, stub) -> do+ -- Print ipe stats if requested+ liftIO $+ Logger.putDumpFileMaybe logger+ Opt_D_ipe_stats+ ("IPE Stats for module " ++ (moduleNameString $ moduleName this_mod))+ Logger.FormatText+ (ppr stats)+ return stub+ Nothing -> return mempty - collectNothing :: [a] -> CmmGroupSRTs -> IO ([a], CmmGroupSRTs)- collectNothing _ cmmGroupSRTs = pure ([], cmmGroupSRTs)+ return CmmCgInfos {cgNonCafs = nonCaffySet, cgLFInfos = moduleLFInfos, cgIPEStub = ipeStub} - collectInfoTables :: CmmGroupSRTs -> [(Label, CmmInfoTable)]- collectInfoTables cmmGroup = concat $ mapMaybe extractInfoTables cmmGroup+-- | Given:+-- * an initial mapping from info tables to possible source locations,+-- * initial 'IPEStats',+-- * a 'CmmGroupSRTs',+--+-- map every info table listed in the 'CmmProc's of the group to their possible+-- source locations and update 'IPEStats' for skipped stack info tables (in case+-- both -finfo-table-map and -fno-info-table-map-with-stack were given). See:+-- Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]+--+-- Note: While it would be cleaner if we could keep the recursion and+-- accumulation internal to this function, this cannot be done without+-- separately traversing stream of 'CmmGroupSRTs' in 'GHC.Driver.Main'. The+-- initial implementation of this logic did such a thing, and code generation+-- performance suffered considerably as a result (see #23103).+lookupEstimatedTicks+ :: HscEnv+ -> Map CmmInfoTable (Maybe IpeSourceLocation)+ -> IPEStats+ -> CmmGroupSRTs+ -> IO (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+lookupEstimatedTicks hsc_env ipes stats cmm_group_srts =+ -- Pass 2: Create an entry in the IPE map for every info table listed in+ -- this CmmGroupSRTs. If the info table is a stack info table and+ -- -finfo-table-map-with-stack is enabled, look up its estimated source+ -- location in the map generate during Pass 1. If the info table is a stack+ -- info table and -finfo-table-map-with-stack is not enabled, skip the table+ -- and note it as skipped in the IPE stats. If the info table is not a stack+ -- info table, insert into the IPE map with no source location information+ -- (for now; see `convertInfoProvMap` in GHC.StgToCmm.Utils to see how source+ -- locations for these tables get filled in)+ pure $ foldl' collectInfoTables (ipes, stats) cmm_group_srts+ where+ dflags = hsc_dflags hsc_env+ platform = targetPlatform dflags - extractInfoTables :: GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph -> Maybe [(Label, CmmInfoTable)]- extractInfoTables (CmmProc h _ _ _) = Just $ mapToList (info_tbls h)- extractInfoTables _ = Nothing+ -- Pass 1: Map every label meeting the conditions described in Note+ -- [Stacktraces from Info Table Provenance Entries (IPE based stack+ -- unwinding)] to the estimated source location (also as described in the+ -- aformentioned note)+ --+ -- Note: It's important that this remains a thunk so we do not compute this+ -- map if -fno-info-table-with-stack is given+ labelsToSources :: Map CLabel IpeSourceLocation+ labelsToSources =+ if platformTablesNextToCode platform then+ foldl' labelsToSourcesWithTNTC Map.empty cmm_group_srts+ else+ foldl' labelsToSourcesSansTNTC Map.empty cmm_group_srts - lookupEstimatedTick :: Platform -> CmmGroupSRTs -> Label -> CmmInfoTable -> Maybe IpeSourceLocation- lookupEstimatedTick platform cmmGroup infoTableLabel infoTable = do- -- All return frame info tables are stack represented, though not all stack represented info- -- tables have to be return frames.- if (isStackRep . cit_rep) infoTable- then do- let findFun =- if platformTablesNextToCode platform- then findCmmTickishWithTNTC infoTableLabel- else findCmmTickishSansTNTC (cit_lbl infoTable)- blocks = concatMap toBlockList (graphs cmmGroup)- firstJusts $ map findFun blocks- else Nothing- graphs :: CmmGroupSRTs -> [CmmGraph]- graphs = foldl' go []+ collectInfoTables+ :: (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+ -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph+ -> (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+ collectInfoTables (!acc, !stats) (CmmProc h _ _ _) =+ mapFoldlWithKey go (acc, stats) (info_tbls h) where- go :: [CmmGraph] -> GenCmmDecl d h CmmGraph -> [CmmGraph]- go acc (CmmProc _ _ _ g) = g : acc- go acc _ = acc-- findCmmTickishWithTNTC :: Label -> Block CmmNode C C -> Maybe IpeSourceLocation- findCmmTickishWithTNTC label block = do- let (_, middleBlock, endBlock) = blockSplit block+ go :: (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+ -> Label+ -> CmmInfoTable+ -> (Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+ go (!acc, !stats) lbl' tbl =+ let+ lbl =+ if platformTablesNextToCode platform then+ -- TNTC case, the mapped CLabel will be the result of+ -- mkAsmTempLabel on the info table label+ mkAsmTempLabel lbl'+ else+ -- Non-TNTC case, the mapped CLabel will be the CLabel of the+ -- info table itself+ cit_lbl tbl+ in+ if (isStackRep . cit_rep) tbl then+ if gopt Opt_InfoTableMapWithStack dflags then+ -- This is a stack info table and we DO want to put it in the+ -- info table map+ (Map.insert tbl (Map.lookup lbl labelsToSources) acc, stats)+ else+ -- This is a stack info table but we DO NOT want to put it in+ -- the info table map (-fno-info-table-map-with-stack was+ -- given), track it as skipped+ (acc, stats <> skippedIpeStats)+ else+ -- This is not a stack info table, so put it in the map with no+ -- source location (for now)+ (Map.insert tbl Nothing acc, stats)+ collectInfoTables (!acc, !stats) _ = (acc, stats) - isCallWithReturnFrameLabel endBlock label- lastTickInBlock middleBlock+-- | See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]+labelsToSourcesWithTNTC+ :: Map CLabel IpeSourceLocation+ -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph+ -> Map CLabel IpeSourceLocation+labelsToSourcesWithTNTC acc (CmmProc _ _ _ cmm_graph) =+ foldl' go acc (toBlockList cmm_graph)+ where+ go :: Map CLabel IpeSourceLocation -> CmmBlock -> Map CLabel IpeSourceLocation+ go acc block =+ case (,) <$> returnFrameLabel <*> lastTickInBlock of+ Just (clabel, src_loc) -> Map.insert clabel src_loc acc+ Nothing -> acc where- isCallWithReturnFrameLabel :: CmmNode O C -> Label -> Maybe ()- isCallWithReturnFrameLabel (CmmCall _ (Just l) _ _ _ _) clabel | l == clabel = Just ()- isCallWithReturnFrameLabel _ _ = Nothing+ (_, middleBlock, endBlock) = blockSplit block - lastTickInBlock block =- listToMaybe $- mapMaybe maybeTick $ (reverse . blockToList) block+ returnFrameLabel :: Maybe CLabel+ returnFrameLabel =+ case endBlock of+ (CmmCall _ (Just l) _ _ _ _) -> Just $ mkAsmTempLabel l+ _ -> Nothing - maybeTick :: CmmNode O O -> Maybe IpeSourceLocation- maybeTick (CmmTick (SourceNote span name)) = Just (span, name)- maybeTick _ = Nothing+ lastTickInBlock = foldr maybeTick Nothing (blockToList middleBlock) - findCmmTickishSansTNTC :: CLabel -> Block CmmNode C C -> Maybe IpeSourceLocation- findCmmTickishSansTNTC cLabel block = do- let (_, middleBlock, _) = blockSplit block- find cLabel (blockToList middleBlock) Nothing+ maybeTick :: CmmNode O O -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation+ maybeTick _ s@(Just _) = s+ maybeTick (CmmTick (SourceNote span name)) Nothing = Just (span, name)+ maybeTick _ _ = Nothing+labelsToSourcesWithTNTC acc _ = acc++-- | See Note [Stacktraces from Info Table Provenance Entries (IPE based stack unwinding)]+labelsToSourcesSansTNTC+ :: Map CLabel IpeSourceLocation+ -> GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph+ -> Map CLabel IpeSourceLocation+labelsToSourcesSansTNTC acc (CmmProc _ _ _ cmm_graph) =+ foldl' go acc (toBlockList cmm_graph)+ where+ go :: Map CLabel IpeSourceLocation -> CmmBlock -> Map CLabel IpeSourceLocation+ go acc block = fst $ foldl' collectLabels (acc, Nothing) (blockToList middleBlock) where- find :: CLabel -> [CmmNode O O] -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation- find label (b : blocks) lastTick = case b of- (CmmStore _ (CmmLit (CmmLabel l)) _) -> if label == l then lastTick else find label blocks lastTick- (CmmTick (SourceNote span name)) -> find label blocks $ Just (span, name)- _ -> find label blocks lastTick- find _ [] _ = Nothing+ (_, middleBlock, _) = blockSplit block++ collectLabels+ :: (Map CLabel IpeSourceLocation, Maybe IpeSourceLocation)+ -> CmmNode O O+ -> (Map CLabel IpeSourceLocation, Maybe IpeSourceLocation)+ collectLabels (!acc, lastTick) b =+ case (b, lastTick) of+ (CmmStore _ (CmmLit (CmmLabel l)) _, Just src_loc) ->+ (Map.insert l src_loc acc, Nothing)+ (CmmTick (SourceNote span name), _) ->+ (acc, Just (span, name))+ _ -> (acc, lastTick)+labelsToSourcesSansTNTC acc _ = acc
compiler/GHC/Driver/Main.hs view
@@ -137,7 +137,7 @@ import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Tidy import GHC.Driver.Hooks-import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub)+import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks) import GHC.Runtime.Context import GHC.Runtime.Interpreter@@ -246,7 +246,6 @@ import GHC.Types.Name.Cache ( initNameCache ) import GHC.Types.Name.Reader import GHC.Types.Name.Ppr-import GHC.Types.Name.Set (NonCaffySet) import GHC.Types.TyThing import GHC.Types.HpcInfo import GHC.Types.Unique.Supply (uniqFromMask)@@ -281,11 +280,11 @@ import Data.IORef import System.FilePath as FilePath import System.Directory+import qualified Data.Map as M+import Data.Map (Map) 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@@ -296,8 +295,10 @@ import System.IO.Unsafe ( unsafeInterleaveIO ) import GHC.Iface.Env ( trace_if ) import GHC.Stg.InferTags.TagSig (seqTagSig)+import GHC.StgToCmm.Utils (IPEStats) import GHC.Types.Unique.FM import GHC.Types.Unique.DFM+import GHC.Cmm.Config (CmmConfig) {- **********************************************************************@@ -2157,21 +2158,41 @@ cmm_config = initCmmConfig dflags - pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos)+ pipeline_stream :: Stream IO CmmGroupSRTs CmmCgInfos pipeline_stream = do- (non_cafs, lf_infos) <-+ ((mod_srt_info, ipes, ipe_stats), lf_infos) <- {-# SCC "cmmPipeline" #-}- Stream.mapAccumL_ (cmmPipeline logger cmm_config) (emptySRT this_mod) ppr_stream1- <&> first (srtMapNonCAFs . moduleSRTMap)+ Stream.mapAccumL_ (pipeline_action logger cmm_config) (emptySRT this_mod, M.empty, mempty) ppr_stream1+ let nonCaffySet = srtMapNonCAFs (moduleSRTMap mod_srt_info)+ cmmCgInfos <- generateCgIPEStub hsc_env this_mod denv (nonCaffySet, lf_infos, ipes, ipe_stats)+ return cmmCgInfos - return (non_cafs, lf_infos)+ pipeline_action+ :: Logger+ -> CmmConfig+ -> (ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)+ -> CmmGroup+ -> IO ((ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats), CmmGroupSRTs)+ pipeline_action logger cmm_config (mod_srt_info, ipes, stats) cmm_group = do+ (mod_srt_info', cmm_srts) <- cmmPipeline logger cmm_config mod_srt_info cmm_group + -- If -finfo-table-map is enabled, we precompute a map from info+ -- tables to source locations. See Note [Mapping Info Tables to Source+ -- Positions] in GHC.Stg.Debug.+ (ipes', stats') <-+ if (gopt Opt_InfoTableMap dflags) then+ lookupEstimatedTicks hsc_env ipes stats cmm_srts+ else+ return (ipes, stats)++ return ((mod_srt_info', ipes', stats'), cmm_srts)+ dump2 a = do unless (null a) $ putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a) return a - return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv pipeline_stream+ return $ Stream.mapM dump2 pipeline_stream myCoreToStg :: Logger -> DynFlags -> [Var] -> Bool
compiler/GHC/Driver/Make.hs view
@@ -609,7 +609,7 @@ -- Now perform another toposort but just with these nodes and relevant hs-boot files. -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph. mresolved_cycle = collapseSCC (topSortWithBoot nodes)- in acyclic ++ [maybe (UnresolvedCycle nodes) ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []+ in acyclic ++ [either UnresolvedCycle ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs [] (mg, lookup_node) = moduleGraphNodes False (mgModSummaries' mod_graph) trans_deps_map = allReachable mg (mkNodeKey . node_payload)@@ -640,12 +640,12 @@ get_boot_module m = case m of ModuleNode _ ms | HsSrcFile <- ms_hsc_src ms -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing -- Any cycles should be resolved now- collapseSCC :: [SCC ModuleGraphNode] -> Maybe [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)]+ collapseSCC :: [SCC ModuleGraphNode] -> Either [ModuleGraphNode] [(Either ModuleGraphNode ModuleGraphNodeWithBootFile)] -- Must be at least two nodes, as we were in a cycle- collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Just [toNodeWithBoot node1, toNodeWithBoot node2]- collapseSCC (AcyclicSCC node : nodes) = (toNodeWithBoot node :) <$> collapseSCC nodes+ collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Right [toNodeWithBoot node1, toNodeWithBoot node2]+ collapseSCC (AcyclicSCC node : nodes) = either (Left . (node :)) (Right . (toNodeWithBoot node :)) (collapseSCC nodes) -- Cyclic- collapseSCC _ = Nothing+ collapseSCC nodes = Left (flattenSCCs nodes) toNodeWithBoot :: ModuleGraphNode -> Either ModuleGraphNode ModuleGraphNodeWithBootFile toNodeWithBoot mn =@@ -772,6 +772,7 @@ let pruneHomeUnitEnv hme = hme { homeUnitEnv_hpt = emptyHomePackageTable } setSession $ discardIC $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env+ hsc_env <- getSession -- Unload everything liftIO $ unload interp hsc_env@@ -781,7 +782,6 @@ worker_limit <- liftIO $ mkWorkerLimit dflags - setSession $ hscUpdateHUG (unitEnv_map pruneHomeUnitEnv) hsc_env (upsweep_ok, new_deps) <- withDeferredDiagnostics $ do hsc_env <- getSession liftIO $ upsweep worker_limit hsc_env mhmi_cache diag_wrapper mHscMessage (toCache pruned_cache) build_plan@@ -1146,33 +1146,37 @@ -- which would retain all the result variables, preventing us from collecting them -- after they are no longer used. !build_deps = getDependencies direct_deps build_map- let build_action =- withCurrentUnit (moduleGraphNodeUnitId mod) $ do- (hug, deps) <- wait_deps_hug hug_var build_deps+ let !build_action = case mod of InstantiationNode uid iu -> do- executeInstantiationNode mod_idx n_mods hug uid iu- return (Nothing, deps)- ModuleNode _build_deps ms -> do+ withCurrentUnit (moduleGraphNodeUnitId mod) $ do+ (hug, deps) <- wait_deps_hug hug_var build_deps+ executeInstantiationNode mod_idx n_mods hug uid iu+ return (Nothing, deps)+ ModuleNode _build_deps ms -> let !old_hmi = M.lookup (msKey ms) old_hpt rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes- hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms- -- Write the HMI to an external cache (if one exists)- -- See Note [Caching HomeModInfo]- liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi- -- This global MVar is incrementally modified in order to avoid having to- -- recreate the HPT before compiling each module which leads to a quadratic amount of work.- liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi)- return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps )+ in withCurrentUnit (moduleGraphNodeUnitId mod) $ do+ (hug, deps) <- wait_deps_hug hug_var build_deps+ hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms+ -- Write the HMI to an external cache (if one exists)+ -- See Note [Caching HomeModInfo]+ liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi+ -- This global MVar is incrementally modified in order to avoid having to+ -- recreate the HPT before compiling each module which leads to a quadratic amount of work.+ liftIO $ modifyMVar_ hug_var (return . addHomeModInfoToHug hmi)+ return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps ) LinkNode _nks uid -> do- executeLinkNode hug (mod_idx, n_mods) uid direct_deps- return (Nothing, deps)+ withCurrentUnit (moduleGraphNodeUnitId mod) $ do+ (hug, deps) <- wait_deps_hug hug_var build_deps+ executeLinkNode hug (mod_idx, n_mods) uid direct_deps+ return (Nothing, deps) res_var <- liftIO newEmptyMVar let result_var = mkResultVar res_var setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var)- return $ (MakeAction build_action res_var)+ return $! (MakeAction build_action res_var) buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction]@@ -2988,7 +2992,7 @@ run_pipeline :: RunMakeM a -> IO (Maybe a) run_pipeline p = runMaybeT (runReaderT p env) -data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a))+data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a)) waitMakeAction :: MakeAction -> IO () waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar
compiler/GHC/Driver/Pipeline.hs view
@@ -129,6 +129,7 @@ import Data.Time ( getCurrentTime ) import GHC.Iface.Recomp+import GHC.Types.Unique.DSet -- Simpler type synonym for actions in the pipeline monad type P m = TPipelineClass TPhase m@@ -497,8 +498,18 @@ -- next, check libraries. XXX this only checks Haskell libraries, -- not extra_libraries or -l things from the command line.+ -- pkg_deps is just the direct dependencies so take the transitive closure here+ -- to decide if we need to relink or not.+ let pkg_hslibs acc uid+ | uid `elementOfUniqDSet` acc = acc+ | Just c <- lookupUnitId unit_state uid =+ foldl' @[] pkg_hslibs (addOneToUniqDSet acc uid) (unitDepends c)+ | otherwise = acc++ all_pkg_deps = foldl' @[] pkg_hslibs emptyUniqDSet pkg_deps+ let pkg_hslibs = [ (collectLibraryDirs (ways dflags) [c], lib)- | Just c <- map (lookupUnitId unit_state) pkg_deps,+ | Just c <- map (lookupUnitId unit_state) (uniqDSetToList all_pkg_deps), lib <- unitHsLibs (ghcNameVersion dflags) (ways dflags) c ] pkg_libfiles <- mapM (uncurry (findHSLib platform (ways dflags))) pkg_hslibs
compiler/GHC/Driver/Pipeline/Execute.hs view
@@ -990,6 +990,7 @@ | otherwise = "static" platform = targetPlatform dflags+ arch = platformArch platform align :: Int align = case platformArch platform of@@ -1007,7 +1008,8 @@ ++ ["+avx512cd"| isAvx512cdEnabled dflags ] ++ ["+avx512er"| isAvx512erEnabled dflags ] ++ ["+avx512pf"| isAvx512pfEnabled dflags ]- ++ ["+fma" | isFmaEnabled dflags ]+ -- For Arch64 +fma is not a option (it's unconditionally available).+ ++ ["+fma" | isFmaEnabled dflags && (arch /= ArchAArch64) ] ++ ["+bmi" | isBmiEnabled dflags ] ++ ["+bmi2" | isBmi2Enabled dflags ]
compiler/GHC/HsToCore/Binds.hs view
@@ -849,7 +849,16 @@ = Left (DsRuleIgnoredDueToConstructor con) -- See Note [No RULES on datacons] | otherwise = case decompose fun2 args2 of- Nothing -> Left (DsRuleLhsTooComplicated orig_lhs lhs2)+ Nothing -> -- pprTrace "decomposeRuleLhs 3" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs+ -- , text "orig_lhs:" <+> ppr orig_lhs+ -- , text "rhs_fvs:" <+> ppr rhs_fvs+ -- , text "orig_lhs:" <+> ppr orig_lhs+ -- , text "lhs1:" <+> ppr lhs1+ -- , text "lhs2:" <+> ppr lhs2+ -- , text "fun2:" <+> ppr fun2+ -- , text "args2:" <+> ppr args2+ -- ]) $+ Left (DsRuleLhsTooComplicated orig_lhs lhs2) Just (fn_id, args) | not (null unbound) -> -- Check for things unbound on LHS@@ -921,7 +930,9 @@ split_lets :: CoreExpr -> ([(DictId,CoreExpr)], CoreExpr) split_lets (Let (NonRec d r) body)- | isDictId d+ | isDictId d -- Catches dictionaries, yes, but also catches dictionary+ -- /functions/ arising from solving a+ -- quantified contraint (#24370) = ((d,r):bs, body') where (bs, body') = split_lets body
compiler/GHC/HsToCore/Foreign/C.hs view
@@ -554,7 +554,7 @@ , ppUnless res_hty_is_unit $ if libffi then char '*' <> parens (ffi_cResType <> char '*') <>- text "resp = cret;"+ text "resp = " <> parens ffi_cResType <> text "cret;" else text "return cret;" , rbrace ]
compiler/GHC/IfaceToCore.hs view
@@ -825,7 +825,7 @@ Just def -> forkM (mk_at_doc tc) $ extendIfaceTyVarEnv (tyConTyVars tc) $ do { tc_def <- tcIfaceType def- ; return (Just (tc_def, NoATVI)) }+ ; return (Just (tc_def, NoVI)) } -- Must be done lazily in case the RHS of the defaults mention -- the type constructor being defined here -- e.g. type AT a; type AT b = AT [b] #8002
compiler/GHC/Linker/Dynamic.hs view
@@ -11,6 +11,7 @@ import GHC.Prelude import GHC.Platform import GHC.Platform.Ways+import GHC.Settings (ToolSettings(toolSettings_ldSupportsSingleModule)) import GHC.Driver.Config.Linker import GHC.Driver.Session@@ -150,6 +151,9 @@ -- dynamic binding nonsense when referring to symbols from -- within the library. The NCG assumes that this option is -- specified (on i386, at least).+ -- In XCode 15, -single_module is the default and passing the+ -- flag is now obsolete and raises a warning (#24168). We encode+ -- this information into the toolchain field ...SupportsSingleModule. -- -install_name -- Mac OS/X stores the path where a dynamic library is (to -- be) installed in the library itself. It's called the@@ -175,8 +179,11 @@ ] ++ map Option o_files ++ [ Option "-undefined",- Option "dynamic_lookup",- Option "-single_module" ]+ Option "dynamic_lookup"+ ]+ ++ (if toolSettings_ldSupportsSingleModule (toolSettings dflags)+ then [ Option "-single_module" ]+ else [ ]) ++ (if platformArch platform `elem` [ ArchX86_64, ArchAArch64 ] then [ ] else [ Option "-Wl,-read_only_relocs,suppress" ])
compiler/GHC/Llvm/Ppr.hs view
@@ -27,7 +27,7 @@ ppLit, ppTypeLit, ppName,- ppPlainName+ ppPlainName, ) where @@ -40,7 +40,6 @@ import Data.List ( intersperse ) import GHC.Utils.Outputable -import GHC.Cmm.MachOp ( FMASign(..), pprFMASign ) import GHC.CmmToLlvm.Config import GHC.Utils.Panic import GHC.Types.Unique@@ -289,7 +288,6 @@ AtomicRMW aop tgt src ordering -> ppAtomicRMW opts aop tgt src ordering CmpXChg addr old new s_ord f_ord -> ppCmpXChg opts addr old new s_ord f_ord Phi tp predecessors -> ppPhi opts tp predecessors- FMAOp op x y z -> pprFMAOp opts op x y z Asm asm c ty v se sk -> ppAsm opts asm c ty v se sk MExpr meta expr -> ppMetaAnnotExpr opts meta expr {-# SPECIALIZE ppLlvmExpression :: LlvmCgConfig -> LlvmExpression -> SDoc #-}@@ -375,13 +373,6 @@ <+> ppName opts left <> comma <+> ppName opts right {-# SPECIALIZE ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> SDoc #-} {-# SPECIALIZE ppCmpOp :: LlvmCgConfig -> LlvmCmpOp -> LlvmVar -> LlvmVar -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable--pprFMAOp :: IsLine doc => LlvmCgConfig -> FMASign -> LlvmVar -> LlvmVar -> LlvmVar -> doc-pprFMAOp opts signs x y z =- pprFMASign signs <+> ppLlvmType (getVarType x)- <+> ppName opts x <> comma- <+> ppName opts y <> comma- <+> ppName opts z ppAssignment :: IsLine doc => LlvmCgConfig -> LlvmVar -> doc -> doc ppAssignment opts var expr = ppName opts var <+> equals <+> expr
compiler/GHC/Llvm/Syntax.hs view
@@ -10,7 +10,6 @@ import GHC.Llvm.Types import GHC.Types.Unique-import GHC.Cmm.MachOp ( FMASign(..) ) -- | Block labels type LlvmBlockId = Unique@@ -338,8 +337,6 @@ expression is executed. -} | Asm LMString LMString LlvmType [LlvmVar] Bool Bool-- | FMAOp FMASign LlvmVar LlvmVar LlvmVar {- | A LLVM expression with metadata attached to it.
compiler/GHC/Rename/Doc.hs view
@@ -40,5 +40,5 @@ rnHsDocIdentifiers gre_env ns = [ L l $ greName gre | L l rdr_name <- ns- , gre <- lookupGRE gre_env (LookupOccName (rdrNameOcc rdr_name) AllRelevantGREs)+ , gre <- lookupGRE gre_env (LookupRdrName rdr_name AllRelevantGREs) ]
compiler/GHC/Rename/Env.hs view
@@ -695,13 +695,14 @@ | otherwise = do gre_env <- getGlobalRdrEnv let original_gres = lookupGRE gre_env (LookupChildren (rdrNameOcc rdr_name) how_lkup)- -- The remaining GREs are things that we *could* export here, note that- -- this includes things which have `NoParent`. Those are sorted in- -- `checkPatSynParent`.+ picked_gres = pick_gres original_gres+ -- The remaining GREs are things that we *could* export here.+ -- Note that this includes things which have `NoParent`;+ -- those are sorted in `checkPatSynParent`. traceRn "parent" (ppr parent) traceRn "lookupExportChild original_gres:" (ppr original_gres)- traceRn "lookupExportChild picked_gres:" (ppr (picked_gres original_gres) $$ ppr must_have_parent)- case picked_gres original_gres of+ traceRn "lookupExportChild picked_gres:" (ppr picked_gres $$ ppr must_have_parent)+ case picked_gres of NoOccurrence -> noMatchingParentErr original_gres UniqueOccurrence g ->@@ -748,34 +749,36 @@ addNameClashErrRn rdr_name gres return (FoundChild (NE.head gres)) - picked_gres :: [GlobalRdrElt] -> DisambigInfo+ pick_gres :: [GlobalRdrElt] -> DisambigInfo -- For Unqual, find GREs that are in scope qualified or unqualified -- For Qual, find GREs that are in scope with that qualification- picked_gres gres+ pick_gres gres | isUnqual rdr_name = mconcat (map right_parent gres) | otherwise = mconcat (map right_parent (pickGREs rdr_name gres)) right_parent :: GlobalRdrElt -> DisambigInfo- right_parent p- = case greParent p of+ right_parent gre+ = case greParent gre of ParentIs cur_parent- | parent == cur_parent -> DisambiguatedOccurrence p+ | parent == cur_parent -> DisambiguatedOccurrence gre | otherwise -> NoOccurrence- NoParent -> UniqueOccurrence p+ NoParent -> UniqueOccurrence gre {-# INLINEABLE lookupSubBndrOcc_helper #-} --- This domain specific datatype is used to record why we decided it was+-- | This domain specific datatype is used to record why we decided it was -- possible that a GRE could be exported with a parent. data DisambigInfo = NoOccurrence- -- The GRE could never be exported. It has the wrong parent.+ -- ^ The GRE could not be found, or it has the wrong parent. | UniqueOccurrence GlobalRdrElt- -- The GRE has no parent. It could be a pattern synonym.+ -- ^ The GRE has no parent. It could be a pattern synonym. | DisambiguatedOccurrence GlobalRdrElt- -- The parent of the GRE is the correct parent+ -- ^ The parent of the GRE is the correct parent. | AmbiguousOccurrence (NE.NonEmpty GlobalRdrElt)+ -- ^ The GRE is ambiguous.+ -- -- For example, two normal identifiers with the same name are in -- scope. They will both be resolved to "UniqueOccurrence" and the -- monoid will combine them to this failing case.@@ -787,7 +790,7 @@ ppr (AmbiguousOccurrence gres) = text "Ambiguous:" <+> ppr gres instance Semi.Semigroup DisambigInfo where- -- This is the key line: We prefer disambiguated occurrences to other+ -- These are the key lines: we prefer disambiguated occurrences to other -- names. _ <> DisambiguatedOccurrence g' = DisambiguatedOccurrence g' DisambiguatedOccurrence g' <> _ = DisambiguatedOccurrence g'
compiler/GHC/Rename/Module.hs view
@@ -71,9 +71,9 @@ import Control.Monad import Control.Arrow ( first )-import Data.Foldable ( toList )+import Data.Foldable ( toList, for_ ) import Data.List ( mapAccumL )-import Data.List.NonEmpty ( NonEmpty(..), head )+import Data.List.NonEmpty ( NonEmpty(..), head, nonEmpty ) import Data.Maybe ( isNothing, fromMaybe, mapMaybe ) import qualified Data.Set as Set ( difference, fromList, toList, null ) import GHC.Types.GREInfo (ConInfo, mkConInfo, conInfoFields)@@ -725,9 +725,10 @@ && not (cls_tkv `elemNameSet` pat_fvs) -- ...but not bound on the LHS. bad_tvs = filter improperly_scoped inst_head_tvs- ; unless (null bad_tvs) $ addErr $+ ; for_ (nonEmpty bad_tvs) $ \ ne_bad_tvs ->+ addErr $ TcRnIllegalInstance $ IllegalFamilyInstance $- FamInstRHSOutOfScopeTyVars Nothing bad_tvs+ FamInstRHSOutOfScopeTyVars Nothing ne_bad_tvs ; let eqn_fvs = rhs_fvs `plusFV` pat_fvs -- See Note [Type family equations and occurrences]
compiler/GHC/Rename/Names.hs view
@@ -1068,14 +1068,18 @@ these two exports, respectively, during construction of the imp_occ_env, we begin by associating the following two elements with the key T: - T -> ImpOccItem { imp_item = T, imp_bundled = [C,T] , imp_is_parent = False }- T -> ImpOccItem { imp_item = T, imp_bundled = [T1,T2,T3], imp_is_parent = True }+ T -> ImpOccItem { imp_item = gre1, imp_bundled = [C,T] , imp_is_parent = False }+ T -> ImpOccItem { imp_item = gre2, imp_bundled = [T1,T2,T3], imp_is_parent = True } -We combine these (in function 'combine' in 'mkImportOccEnv') by simply discarding-the first item, to get:+where `gre1`, `gre2` are two GlobalRdrElts with greName T.+We combine these (in function 'combine' in 'mkImportOccEnv') by discarding the+non-parent item, thusly: - T -> IE_ITem { imp_item = T, imp_bundled = [T1,T2,T3], imp_is_parent = True }+ T -> IE_ITem { imp_item = gre1 `plusGRE` gre2, imp_bundled = [T1,T2,T3], imp_is_parent = True } +Note the `plusGRE`: this ensures we don't drop parent information;+see Note [Preserve parent information when combining import OccEnvs].+ So the overall imp_occ_env is: C -> ImpOccItem { imp_item = C, imp_bundled = [T ], imp_is_parent = True }@@ -1133,6 +1137,31 @@ which looks up 'S' and then finds the unique 'foo' amongst its children. See T16745 for a test of this.++Note [Preserve parent information when combining import OccEnvs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When discarding one ImpOccItem in favour of another, as described in+Note [Dealing with imports], we must make sure to combine the GREs so that+we don't lose information.++Consider for example #24084:++ module M1 where { class C a where { type T a } }+ module M2 ( module M1 ) where { import M1 }+ module M3 where { import M2 ( C, T ); instance C () where T () = () }++When processing the import list of `M3`, we will have two `Avail`s attached+to `T`, namely `C(C, T)` and `T(T)`. We combine them in the `combine` function+of `mkImportOccEnv`; as described in Note [Dealing with imports] we discard+`C(C, T)` in favour of `T(T)`. However, in doing so, we **must not**+discard the information want that `C` is the parent of `T`. Indeed,+losing track of this information can cause errors when importing,+as we could get an error of the form++ ‘T’ is not a (visible) associated type of class ‘C’++This explains why we use `plusGRE` when combining the two ImpOccItems, even+though we are discarding one in favour of the other. -} -- | All the 'GlobalRdrElt's associated with an 'AvailInfo'.@@ -1439,6 +1468,14 @@ -- ^ Is the import item a parent? See Note [Dealing with imports]. } +instance Outputable ImpOccItem where+ ppr (ImpOccItem { imp_item = item, imp_bundled = bundled, imp_is_parent = is_par })+ = braces $ hsep+ [ text "ImpOccItem"+ , if is_par then text "[is_par]" else empty+ , ppr (greName item) <+> ppr (greParent item)+ , braces $ text "bundled:" <+> ppr (map greName bundled) ]+ -- | Make an 'OccEnv' of all the imports. -- -- Complicated by the fact that associated data types and pattern synonyms@@ -1465,9 +1502,9 @@ -- See Note [Dealing with imports] -- 'combine' may be called for associated data types which appear- -- twice in the all_avails. In the example, we combine- -- T(T,T1,T2,T3) and C(C,T) to give (T, T(T,T1,T2,T3), Just C)- -- NB: the AvailTC can have fields as well as data constructors (#12127)+ -- twice in the all_avails. In the example, we have two Avails for T,+ -- namely T(T,T1,T2,T3) and C(C,T), and we combine them by dropping the+ -- latter, in which T is not the parent. combine :: ImpOccItem -> ImpOccItem -> ImpOccItem combine item1@(ImpOccItem { imp_item = gre1, imp_is_parent = is_parent1 }) item2@(ImpOccItem { imp_item = gre2, imp_is_parent = is_parent2 })@@ -1475,11 +1512,13 @@ , not (isRecFldGRE gre1 || isRecFldGRE gre2) -- NB: does not force GREInfo. , let name1 = greName gre1 name2 = greName gre2+ gre = gre1 `plusGRE` gre2+ -- See Note [Preserve parent information when combining import OccEnvs] = assertPpr (name1 == name2) (ppr name1 <+> ppr name2) $ if is_parent1- then item1- else item2+ then item1 { imp_item = gre }+ else item2 { imp_item = gre } -- Discard C(C,T) in favour of T(T, T1, T2, T3). -- 'combine' may also be called for pattern synonyms which appear both
compiler/GHC/Rename/Utils.hs view
@@ -172,7 +172,7 @@ where (loc,occ) = get_loc_occ n mb_local = lookupLocalRdrOcc local_env occ- gres = lookupGRE global_env (LookupRdrName (mkRdrUnqual occ) (RelevantGREsFOS WantBoth))+ gres = lookupGRE global_env (LookupRdrName (mkRdrUnqual occ) (RelevantGREsFOS WantNormal)) -- Make an Unqualified RdrName and look that up, so that -- we don't find any GREs that are in scope qualified-only
compiler/GHC/Settings/IO.hs view
@@ -105,6 +105,7 @@ ldSupportsCompactUnwind <- getBooleanSetting "ld supports compact unwind" ldSupportsFilelist <- getBooleanSetting "ld supports filelist" ldSupportsResponseFiles <- getBooleanSetting "ld supports response files"+ ldSupportsSingleModule <- getBooleanSetting "ld supports single module" ldIsGnuLd <- getBooleanSetting "ld is GNU ld" arSupportsDashL <- getBooleanSetting "ar supports -L" @@ -174,6 +175,7 @@ { toolSettings_ldSupportsCompactUnwind = ldSupportsCompactUnwind , toolSettings_ldSupportsFilelist = ldSupportsFilelist , toolSettings_ldSupportsResponseFiles = ldSupportsResponseFiles+ , toolSettings_ldSupportsSingleModule = ldSupportsSingleModule , toolSettings_ldIsGnuLd = ldIsGnuLd , toolSettings_ccSupportsNoPie = gccSupportsNoPie , toolSettings_useInplaceMinGW = useInplaceMinGW
compiler/GHC/Stg/CSE.hs view
@@ -165,8 +165,8 @@ -- ^ This substitution is applied to the code as we traverse it. -- Entries have one of two reasons: --- -- * The input might have shadowing (see Note [Shadowing]), so we have- -- to rename some binders as we traverse the tree.+ -- * The input might have shadowing (see Note [Shadowing in Core]),+ -- so we have to rename some binders as we traverse the tree. -- * If we remove `let x = Con z` because `let y = Con z` is in scope, -- we note this here as x ↦ y. , ce_bndrMap :: IdEnv OutId
compiler/GHC/Stg/Debug.hs view
@@ -210,7 +210,7 @@ 1. Data constructors to a list of where they are used. 2. `Name`s and where they originate from. 3. Stack represented info tables (return frames) to an approximated source location- of the call that pushed a contiunation on the stacks.+ of the call that pushed a continuation on the stacks. During the CoreToStg phase, this map is populated whenever something is turned into a StgRhsClosure or an StgConApp. The current source position is recorded@@ -253,7 +253,7 @@ In the old times, each usage of a data constructor used the same info table. This made it impossible to distinguish which actual usage of a data constructor was-contributing primarily to the allocation in a program. Using the `-fdistinct-info-tables` flag you+contributing primarily to the allocation in a program. Using the `-fdistinct-constructor-tables` flag you can cause code generation to generate a distinct info table for each usage of a constructor. Then, when inspecting the heap you can see precisely which usage of a constructor was responsible for each allocation.
compiler/GHC/StgToCmm/Bind.hs view
@@ -553,7 +553,13 @@ -- Extend reader monad with information that -- self-recursive tail calls can be optimized into local -- jumps. See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr.- ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do+ ; let !self_loop_info = MkSelfLoopInfo+ { sli_id = bndr+ , sli_arity = arity+ , sli_header_block = loop_header_id+ , sli_registers = arg_regs+ }+ ; withSelfLoop self_loop_info $ do { -- Main payload ; entryHeapCheck cl_info node' arity arg_regs $ do@@ -702,11 +708,19 @@ when eager_blackholing $ do whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node- emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) (currentTSOExpr platform)+ emitAtomicStore platform MemOrderRelease+ (cmmOffsetW platform node (fixedHdrSizeW profile))+ (currentTSOExpr platform) -- See Note [Heap memory barriers] in SMP.h.- let w = wordWidth platform- emitPrimCall [] (MO_AtomicWrite w MemOrderRelease)- [node, CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform)]+ emitAtomicStore platform MemOrderRelease+ node+ (CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform))++emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode ()+emitAtomicStore platform mord addr val =+ emitPrimCall [] (MO_AtomicWrite w mord) [addr, val]+ where+ w = typeWidth $ cmmExprType platform val setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF),
compiler/GHC/StgToCmm/CgUtils.hs view
@@ -177,16 +177,18 @@ (globalRegSpillType platform reg) NaturallyAligned - CmmRegOff (CmmGlobal reg_use) offset ->+ CmmRegOff greg@(CmmGlobal reg) offset -> -- RegOf leaves are just a shorthand form. If the reg maps -- to a real reg, we keep the shorthand, otherwise, we just -- expand it and defer to the above code.- let reg = globalRegUseGlobalReg reg_use in- case reg `elem` activeStgRegs platform of+ -- NB: to ensure type correctness we need to ensure the Add+ -- as well as the Int need to be of the same size as the+ -- register.+ case globalRegUseGlobalReg reg `elem` activeStgRegs platform of True -> expr- False -> CmmMachOp (MO_Add (wordWidth platform)) [- fixExpr (CmmReg (CmmGlobal reg_use)),+ False -> CmmMachOp (MO_Add (cmmRegWidth greg)) [+ fixExpr (CmmReg greg), CmmLit (CmmInt (fromIntegral offset)- (wordWidth platform))]+ (cmmRegWidth greg))] other_expr -> other_expr
compiler/GHC/StgToCmm/Closure.hs view
@@ -95,7 +95,6 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain-import GHC.Utils.Misc import GHC.Data.Maybe (isNothing) import Data.Coerce (coerce)@@ -539,12 +538,12 @@ getCallMethod :: StgToCmmConfig -> Name -- Function being applied- -> Id -- Function Id used to chech if it can refer to+ -> Id -- Function Id used to check if it can refer to -- CAF's and whether the function is tail-calling -- itself -> LambdaFormInfo -- Its info -> RepArity -- Number of available arguments- -> RepArity -- Number of them being void arguments+ -- (including void args) -> CgLoc -- Passed in from cgIdApp so that we can -- handle let-no-escape bindings and self-recursive -- tail calls using the same data constructor,@@ -553,19 +552,22 @@ -> Maybe SelfLoopInfo -- can we perform a self-recursive tail-call -> CallMethod -getCallMethod cfg _ id _ n_args v_args _cg_loc (Just (self_loop_id, block_id, args))+getCallMethod cfg _ id _ n_args _cg_loc (Just self_loop) | stgToCmmLoopification cfg- , id == self_loop_id- , args `lengthIs` (n_args - v_args)+ , MkSelfLoopInfo+ { sli_id = loop_id, sli_arity = arity+ , sli_header_block = blk_id, sli_registers = arg_regs+ } <- self_loop+ , id == loop_id+ , n_args == arity -- If these patterns match then we know that: -- * loopification optimisation is turned on -- * function is performing a self-recursive call in a tail position- -- * number of non-void parameters of the function matches functions arity.- -- See Note [Self-recursive tail calls] and Note [Void arguments in- -- self-recursive tail calls] in GHC.StgToCmm.Expr for more details- = JumpToIt block_id args+ -- * number of parameters matches the function's arity.+ -- See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr for more details+ = JumpToIt blk_id arg_regs -getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _v_args _cg_loc _self_loop_info+getCallMethod cfg name id (LFReEntrant _ arity _ _) n_args _cg_loc _self_loop_info | n_args == 0 -- No args at all && not (profileIsProfiling (stgToCmmProfile cfg)) -- See Note [Evaluating functions with profiling] in rts/Apply.cmm@@ -573,16 +575,16 @@ | n_args < arity = SlowCall -- Not enough args | otherwise = DirectEntry (enterIdLabel (stgToCmmPlatform cfg) name (idCafInfo id)) arity -getCallMethod _ _name _ LFUnlifted n_args _v_args _cg_loc _self_loop_info+getCallMethod _ _name _ LFUnlifted n_args _cg_loc _self_loop_info = assert (n_args == 0) ReturnIt -getCallMethod _ _name _ (LFCon _) n_args _v_args _cg_loc _self_loop_info+getCallMethod _ _name _ (LFCon _) n_args _cg_loc _self_loop_info = assert (n_args == 0) ReturnIt -- n_args=0 because it'd be ill-typed to apply a saturated -- constructor application to anything getCallMethod cfg name id (LFThunk _ _ updatable std_form_info is_fun)- n_args _v_args _cg_loc _self_loop_info+ n_args _cg_loc _self_loop_info | Just sig <- idTagSig_maybe id , isTaggedSig sig -- Infered to be already evaluated by Tag Inference@@ -620,7 +622,7 @@ updatable) 0 -- Imported(Unknown) Ids-getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _v_args _cg_locs _self_loop_info+getCallMethod cfg name id (LFUnknown might_be_a_function) n_args _cg_locs _self_loop_info | n_args == 0 , Just sig <- idTagSig_maybe id , isTaggedSig sig -- Infered to be already evaluated by Tag Inference@@ -637,14 +639,14 @@ EnterIt -- Not a function -- TODO: Redundant with above match?--- getCallMethod _ name _ (LFUnknown False) n_args _v_args _cg_loc _self_loop_info+-- getCallMethod _ name _ (LFUnknown False) n_args _cg_loc _self_loop_info -- = assertPpr (n_args == 0) (ppr name <+> ppr n_args) -- EnterIt -- Not a function -getCallMethod _ _name _ LFLetNoEscape _n_args _v_args (LneLoc blk_id lne_regs) _self_loop_info+getCallMethod _ _name _ LFLetNoEscape _n_args (LneLoc blk_id lne_regs) _self_loop_info = JumpToIt blk_id lne_regs -getCallMethod _ _ _ _ _ _ _ _ = panic "Unknown call method"+getCallMethod _ _ _ _ _ _ _ = panic "Unknown call method" ----------------------------------------------------------------------------- -- Data types for closure information
compiler/GHC/StgToCmm/Expr.hs view
@@ -1002,8 +1002,7 @@ fun = idInfoToAmode fun_info lf_info = cg_lf fun_info n_args = length args- v_args = length $ filter (isZeroBitTy . stgArgType) args- case getCallMethod cfg fun_name fun_id lf_info n_args v_args (cg_loc fun_info) self_loop of+ case getCallMethod cfg fun_name fun_id lf_info n_args (cg_loc fun_info) self_loop of -- A value in WHNF, so we can just return it. ReturnIt | isZeroBitTy (idType fun_id) -> emitReturn []@@ -1098,12 +1097,14 @@ -- -- Implementation is spread across a couple of places in the code: ----- * FCode monad stores additional information in its reader environment--- (stgToCmmSelfLoop field). This information tells us which function can--- tail call itself in an optimized way (it is the function currently--- being compiled), what is the label of a loop header (L1 in example above)--- and information about local registers in which we should arguments--- before making a call (this would be a and b in example above).+-- * FCode monad stores additional information in its reader+-- environment (stgToCmmSelfLoop field). This `SelfLoopInfo`+-- record tells us which function can tail call itself in an+-- optimized way (it is the function currently being compiled),+-- its RepArity, what is the label of its loop header (L1 in+-- example above) and information about which local registers+-- should receive arguments when making a call (this would be a+-- and b in the example above). -- -- * Whenever we are compiling a function, we set that information to reflect -- the fact that function currently being compiled can be jumped to, instead@@ -1127,36 +1128,13 @@ -- of call will be generated. getCallMethod decides to generate a self -- recursive tail call when (a) environment stores information about -- possible self tail-call; (b) that tail call is to a function currently--- being compiled; (c) number of passed non-void arguments is equal to--- function's arity. (d) loopification is turned on via -floopification--- command-line option.+-- being compiled; (c) number of passed arguments is equal to+-- function's unarised arity. (d) loopification is turned on via+-- -floopification command-line option. -- -- * Command line option to turn loopification on and off is implemented in -- DynFlags, then passed to StgToCmmConfig for this phase.--------- Note [Void arguments in self-recursive tail calls]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~------ State# tokens can get in the way of the loopification optimization as seen in--- #11372. Consider this:------ foo :: [a]--- -> (a -> State# s -> (# State s, Bool #))--- -> State# s--- -> (# State# s, Maybe a #)--- foo [] f s = (# s, Nothing #)--- foo (x:xs) f s = case f x s of--- (# s', b #) -> case b of--- True -> (# s', Just x #)--- False -> foo xs f s'------ We would like to compile the call to foo as a local jump instead of a call--- (see Note [Self-recursive tail calls]). However, the generated function has--- an arity of 2 while we apply it to 3 arguments, one of them being of void--- type. Thus, we mustn't count arguments of void type when checking whether--- we can turn a call into a self-recursive jump.---+ emitEnter :: CmmExpr -> FCode ReturnKind emitEnter fun = do
compiler/GHC/StgToCmm/Heap.hs view
@@ -635,7 +635,7 @@ -- See Note [Self-recursive loop header]. self_loop_info <- getSelfLoop case self_loop_info of- Just (_, loop_header_id, _)+ Just MkSelfLoopInfo { sli_header_block = loop_header_id } | checkYield && isJust mb_stk_hwm -> emitLabel loop_header_id _otherwise -> return ()
compiler/GHC/StgToCmm/Monad.hs view
@@ -42,6 +42,8 @@ Sequel(..), ReturnKind(..), withSequel, getSequel, + SelfLoopInfo(..),+ setTickyCtrLabel, getTickyCtrLabel, tickScope, getTickScope, @@ -298,7 +300,7 @@ -- else the RTS will deadlock _and_ also experience a severe -- performance degradation , fcs_sequel :: !Sequel -- ^ What to do at end of basic block- , fcs_selfloop :: Maybe SelfLoopInfo -- ^ Which tail calls can be compiled as local jumps?+ , fcs_selfloop :: !(Maybe SelfLoopInfo) -- ^ Which tail calls can be compiled as local jumps? -- See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr , fcs_ticky :: !CLabel -- ^ Destination for ticky counts , fcs_tickscope :: !CmmTickScope -- ^ Tick scope for new blocks & ticks
compiler/GHC/StgToCmm/Prim.hs view
@@ -2299,7 +2299,7 @@ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Check to make sure that we can generate code for the specified vector type -- given the current set of dynamic flags.--- Currently these checks are specific to x86 and x86_64 architecture.+-- Currently these checks are specific to x86, x86_64 and AArch64 architectures. -- This should be fixed! -- In particular, -- 1) Add better support for other architectures! (this may require a redesign)@@ -2330,27 +2330,40 @@ checkVecCompatibility :: StgToCmmConfig -> PrimOpVecCat -> Length -> Width -> FCode () checkVecCompatibility cfg vcat l w = case stgToCmmVecInstrsErr cfg of- Nothing -> check vecWidth vcat l w -- We are in a compatible backend- Just err -> sorry err -- incompatible backend, do panic+ Nothing | isX86 -> checkX86 vecWidth vcat l w+ | platformArch platform == ArchAArch64 -> checkAArch64 vecWidth+ | otherwise -> sorry "SIMD vector instructions are not supported on this architecture."+ Just err -> sorry err -- incompatible backend, do panic where platform = stgToCmmPlatform cfg- check :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()- check W128 FloatVec 4 W32 | not (isSseEnabled platform) =+ isX86 = case platformArch platform of+ ArchX86_64 -> True+ ArchX86 -> True+ _ -> False+ checkX86 :: Width -> PrimOpVecCat -> Length -> Width -> FCode ()+ checkX86 W128 FloatVec 4 W32 | isSseEnabled platform = return ()+ | otherwise = sorry $ "128-bit wide single-precision floating point " ++ "SIMD vector instructions require at least -msse."- check W128 _ _ _ | not (isSse2Enabled platform) =+ checkX86 W128 _ _ _ | not (isSse2Enabled platform) = sorry $ "128-bit wide integer and double precision " ++ "SIMD vector instructions require at least -msse2."- check W256 FloatVec _ _ | not (stgToCmmAvx cfg) =+ checkX86 W256 FloatVec _ _ | stgToCmmAvx cfg = return ()+ | otherwise = sorry $ "256-bit wide floating point " ++ "SIMD vector instructions require at least -mavx."- check W256 _ _ _ | not (stgToCmmAvx2 cfg) =+ checkX86 W256 _ _ _ | not (stgToCmmAvx2 cfg) = sorry $ "256-bit wide integer " ++ "SIMD vector instructions require at least -mavx2."- check W512 _ _ _ | not (stgToCmmAvx512f cfg) =+ checkX86 W512 _ _ _ | not (stgToCmmAvx512f cfg) = sorry $ "512-bit wide " ++ "SIMD vector instructions require -mavx512f."- check _ _ _ _ = return ()+ checkX86 _ _ _ _ = return ()++ checkAArch64 :: Width -> FCode ()+ checkAArch64 W256 = sorry $ "256-bit wide SIMD vector instructions are not supported."+ checkAArch64 W512 = sorry $ "512-bit wide SIMD vector instructions are not supported."+ checkAArch64 _ = return () vecWidth = typeWidth (vecVmmType vcat l w)
compiler/GHC/StgToCmm/Prof.hs view
@@ -274,24 +274,27 @@ where (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform --- | Emit info-table provenance declarations-initInfoTableProv :: [CmmInfoTable] -> InfoTableProvMap -> FCode CStub-initInfoTableProv infos itmap+-- | Emit info-table provenance declarations and track IPE stats.+--+-- Note that the stats passed to this function will (rather, should) only ever+-- contain stats for skipped STACK info tables accumulated in+-- 'generateCgIPEStub'.+initInfoTableProv :: IPEStats -> [CmmInfoTable] -> InfoTableProvMap -> FCode (Maybe (IPEStats, CStub))+initInfoTableProv stats infos itmap = do cfg <- getStgToCmmConfig- let ents = convertInfoProvMap infos this_mod itmap- info_table = stgToCmmInfoTableMap cfg- platform = stgToCmmPlatform cfg- this_mod = stgToCmmThisModule cfg-+ let (stats', ents) = convertInfoProvMap cfg this_mod itmap stats infos+ info_table = stgToCmmInfoTableMap cfg+ platform = stgToCmmPlatform cfg+ this_mod = stgToCmmThisModule cfg case ents of- [] -> return mempty+ [] -> return Nothing _ -> do -- Emit IPE buffer emitIpeBufferListNode this_mod ents -- Create the C stub which initialises the IPE map- return (ipInitCode info_table platform this_mod)+ return (Just (stats', ipInitCode info_table platform this_mod)) -- --------------------------------------------------------------------------- -- Set the current cost centre stack
compiler/GHC/StgToCmm/Sequel.hs view
@@ -12,13 +12,14 @@ module GHC.StgToCmm.Sequel ( Sequel(..)- , SelfLoopInfo+ , SelfLoopInfo(..) ) where import GHC.Cmm.BlockId import GHC.Cmm import GHC.Types.Id+import GHC.Types.Basic (RepArity) import GHC.Utils.Outputable import GHC.Prelude@@ -41,5 +42,14 @@ ppr Return = text "Return" ppr (AssignTo regs b) = text "AssignTo" <+> ppr regs <+> ppr b -type SelfLoopInfo = (Id, BlockId, [LocalReg])+data SelfLoopInfo = MkSelfLoopInfo+ { sli_id :: !Id+ , sli_arity :: !RepArity+ -- ^ always equal to 'idFunRepArity' of sli_id,+ -- i.e. unarised arity, including void arguments+ , sli_registers :: ![LocalReg]+ -- ^ Excludes void arguments (LocalReg is never void)+ , sli_header_block :: !BlockId+ }+ --------------------------------------------------------------------------------
compiler/GHC/StgToCmm/Utils.hs view
@@ -7,6 +7,8 @@ -- (c) The University of Glasgow 2004-2006 -- -----------------------------------------------------------------------------+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} module GHC.StgToCmm.Utils ( emitDataLits, emitRODataLits,@@ -43,7 +45,8 @@ emitUpdRemSetPush, emitUpdRemSetPushThunk, - convertInfoProvMap, cmmInfoTableToInfoProvEnt+ convertInfoProvMap, cmmInfoTableToInfoProvEnt, IPEStats(..),+ closureIpeStats, fallbackIpeStats, skippedIpeStats, ) where import GHC.Prelude hiding ( head, init, last, tail )@@ -90,6 +93,8 @@ import GHC.Data.Maybe import Control.Monad import qualified Data.Map.Strict as Map+import qualified Data.IntMap.Strict as I+import qualified Data.Semigroup (Semigroup(..)) -------------------------------------------------------------------------- --@@ -607,39 +612,96 @@ cn = rtsClosureType (cit_rep cmit) in InfoProvEnt cl cn "" this_mod Nothing +data IPEStats = IPEStats { ipe_total :: !Int+ , ipe_closure_types :: !(I.IntMap Int)+ , ipe_fallback :: !Int+ , ipe_skipped :: !Int }++instance Semigroup IPEStats where+ (IPEStats a1 a2 a3 a4) <> (IPEStats b1 b2 b3 b4) = IPEStats (a1 + b1) (I.unionWith (+) a2 b2) (a3 + b3) (a4 + b4)++instance Monoid IPEStats where+ mempty = IPEStats 0 I.empty 0 0++fallbackIpeStats :: IPEStats+fallbackIpeStats = mempty { ipe_total = 1, ipe_fallback = 1 }++closureIpeStats :: Int -> IPEStats+closureIpeStats t = mempty { ipe_total = 1, ipe_closure_types = I.singleton t 1 }++skippedIpeStats :: IPEStats+skippedIpeStats = mempty { ipe_skipped = 1 }++instance Outputable IPEStats where+ ppr = pprIPEStats++pprIPEStats :: IPEStats -> SDoc+pprIPEStats (IPEStats{..}) =+ vcat $ [ text "Tables with info:" <+> ppr ipe_total+ , text "Tables with fallback:" <+> ppr ipe_fallback+ , text "Tables skipped:" <+> ppr ipe_skipped+ ] ++ [ text "Info(" <> ppr k <> text "):" <+> ppr n | (k, n) <- I.assocs ipe_closure_types ]+ -- | Convert source information collected about identifiers in 'GHC.STG.Debug' -- to entries suitable for placing into the info table provenance table.-convertInfoProvMap :: [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt]-convertInfoProvMap defns this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) =- map (\cmit ->- let cl = cit_lbl cmit+--+-- The initial stats given to this function will (or should) only contain stats+-- for stack info tables skipped during 'generateCgIPEStub'. As the fold+-- progresses, counts of tables per closure type will be accumulated.+convertInfoProvMap :: StgToCmmConfig -> Module -> InfoTableProvMap -> IPEStats -> [CmmInfoTable] -> (IPEStats, [InfoProvEnt])+convertInfoProvMap cfg this_mod (InfoTableProvMap (UniqMap dcenv) denv infoTableToSourceLocationMap) initStats cmits =+ foldl' convertInfoProvMap' (initStats, []) cmits+ where+ convertInfoProvMap' :: (IPEStats, [InfoProvEnt]) -> CmmInfoTable -> (IPEStats, [InfoProvEnt])+ convertInfoProvMap' (!stats, acc) cmit = do+ let+ cl = cit_lbl cmit cn = rtsClosureType (cit_rep cmit) tyString :: Outputable a => a -> String tyString = renderWithContext defaultSDocContext . ppr - lookupClosureMap :: Maybe InfoProvEnt+ lookupClosureMap :: Maybe (IPEStats, InfoProvEnt) lookupClosureMap = case hasHaskellName cl >>= lookupUniqMap denv of- Just (ty, mbspan) -> Just (InfoProvEnt cl cn (tyString ty) this_mod mbspan)+ Just (ty, mbspan) -> Just (closureIpeStats cn, (InfoProvEnt cl cn (tyString ty) this_mod mbspan)) Nothing -> Nothing - lookupDataConMap = do+ lookupDataConMap :: Maybe (IPEStats, InfoProvEnt)+ lookupDataConMap = (closureIpeStats cn,) <$> do UsageSite _ n <- hasIdLabelInfo cl >>= getConInfoTableLocation -- This is a bit grimy, relies on the DataCon and Name having the same Unique, which they do (dc, ns) <- hasHaskellName cl >>= lookupUFM_Directly dcenv . getUnique -- Lookup is linear but lists will be small (< 100)- return $ InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns))+ return $ (InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns))) + lookupInfoTableToSourceLocation :: Maybe (IPEStats, InfoProvEnt) lookupInfoTableToSourceLocation = do sourceNote <- Map.lookup (cit_lbl cmit) infoTableToSourceLocationMap- return $ InfoProvEnt cl cn "" this_mod sourceNote+ return $ (closureIpeStats cn, (InfoProvEnt cl cn "" this_mod sourceNote)) -- This catches things like prim closure types and anything else which doesn't have a -- source location- simpleFallback = cmmInfoTableToInfoProvEnt this_mod cmit+ simpleFallback =+ if stgToCmmInfoTableMapWithFallback cfg then+ -- Create a default entry with fallback IPE data+ Just (fallbackIpeStats, cmmInfoTableToInfoProvEnt this_mod cmit)+ else+ -- If we are omitting tables with fallback info+ -- (-fno-info-table-map-with-fallback was given), do not create an+ -- entry+ Nothing - in- if (isStackRep . cit_rep) cmit then- fromMaybe simpleFallback lookupInfoTableToSourceLocation- else- fromMaybe simpleFallback (lookupDataConMap `firstJust` lookupClosureMap)) defns+ trackSkipped :: Maybe (IPEStats, InfoProvEnt) -> (IPEStats, [InfoProvEnt])+ trackSkipped Nothing =+ (stats Data.Semigroup.<> skippedIpeStats, acc)+ trackSkipped (Just (s, !c)) =+ (stats Data.Semigroup.<> s, c:acc)++ trackSkipped $+ if (isStackRep . cit_rep) cmit then+ -- Note that we should have already skipped STACK info tables if+ -- necessary in 'generateCgIPEStub', so we should not need to worry+ -- about doing that here.+ fromMaybe simpleFallback (Just <$> lookupInfoTableToSourceLocation)+ else+ fromMaybe simpleFallback (Just <$> firstJust lookupDataConMap lookupClosureMap)
compiler/GHC/StgToJS/Linker/Utils.hs view
@@ -47,6 +47,14 @@ import Data.Char (isSpace) import qualified Control.Exception as Exception +import GHC.Builtin.Types+import Language.Haskell.Syntax.Basic+import GHC.Types.Name+import GHC.StgToJS.Ids+import GHC.Core.DataCon+import GHC.JS.Unsat.Syntax+import GHC.Data.FastString+ -- | Retrieve library directories provided by the @UnitId@ in @UnitState@ getInstalledPackageLibDirs :: UnitState -> UnitId -> [ShortText] getInstalledPackageLibDirs us = maybe mempty unitLibraryDirs . lookupUnitId us@@ -71,6 +79,26 @@ commonCppDefs_vanilla = genCommonCppDefs False commonCppDefs_profiled = genCommonCppDefs True +-- | Generate macros MK_TUP* for tuples sized 2+.+genMkTup :: Bool -> Int -> ByteString+genMkTup profiling n = mconcat+ [ "#define MK_TUP", sn -- #define MK_TUPn+ , "(", B.intercalate "," xs, ")" -- (x1,x2,...)+ , "(h$c", sn, "(" -- (h$cn(+ , bytesFS symbol, "," -- h$ghczmprimZCGHCziTupleziPrimziZnT_con_e, -- ,+ , B.intercalate "," $ map (\x -> "(" <> x <> ")") xs -- (x1),(x2),(...)+ , if profiling then ",h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM" else "" -- ,h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM+ , "))\n" -- ))\n+ ]+ where+ xs = take n $ map (("x" <>) . Char8.pack . show) ([1..] :: [Int])+ sn = Char8.pack $ show n+ TxtI symbol = makeIdentForId (dataConWorkId $ tupleDataCon Boxed n) Nothing IdConEntry mod+ name = tupleDataConName Boxed n+ mod = case nameModule_maybe name of+ Just m -> m+ Nothing -> error "Tuple constructor is missing a module"+ -- | Generate CPP Definitions depending on a profiled or normal build. This -- occurs at link time. genCommonCppDefs :: Bool -> ByteString@@ -87,29 +115,7 @@ in mconcat (closure_defs ++ thread_defs) -- low-level heap object manipulation macros- , if profiling- then mconcat- [ "#define MK_TUP2(x1,x2) (h$c2(h$ghczmprimZCGHCziTupleziPrimziZLz2cUZR_con_e,(x1),(x2),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"- , "#define MK_TUP3(x1,x2,x3) (h$c3(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUZR_con_e,(x1),(x2),(x3),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"- , "#define MK_TUP4(x1,x2,x3,x4) (h$c4(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"- , "#define MK_TUP5(x1,x2,x3,x4,x5) (h$c5(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"- , "#define MK_TUP6(x1,x2,x3,x4,x5,x6) (h$c6(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"- , "#define MK_TUP7(x1,x2,x3,x4,x5,x6,x7) (h$c7(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"- , "#define MK_TUP8(x1,x2,x3,x4,x5,x6,x7,x8) (h$c8(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"- , "#define MK_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9) (h$c9(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"- , "#define MK_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) (h$c10(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),(x10),h$currentThread?h$currentThread.ccs:h$CCS_SYSTEM))\n"- ]- else mconcat- [ "#define MK_TUP2(x1,x2) (h$c2(h$ghczmprimZCGHCziTupleziPrimziZLz2cUZR_con_e,(x1),(x2)))\n"- , "#define MK_TUP3(x1,x2,x3) (h$c3(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUZR_con_e,(x1),(x2),(x3)))\n"- , "#define MK_TUP4(x1,x2,x3,x4) (h$c4(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4)))\n"- , "#define MK_TUP5(x1,x2,x3,x4,x5) (h$c5(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5)))\n"- , "#define MK_TUP6(x1,x2,x3,x4,x5,x6) (h$c6(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6)))\n"- , "#define MK_TUP7(x1,x2,x3,x4,x5,x6,x7) (h$c7(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7)))\n"- , "#define MK_TUP8(x1,x2,x3,x4,x5,x6,x7,x8) (h$c8(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8)))\n"- , "#define MK_TUP9(x1,x2,x3,x4,x5,x6,x7,x8,x9) (h$c9(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9)))\n"- , "#define MK_TUP10(x1,x2,x3,x4,x5,x6,x7,x8,x9,x10) (h$c10(h$ghczmprimZCGHCziTupleziPrimziZLz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUz2cUZR_con_e,(x1),(x2),(x3),(x4),(x5),(x6),(x7),(x8),(x9),(x10)))\n"- ]+ , mconcat (map (genMkTup profiling) [2..10]) , "#define TUP2_1(x) ((x).d1)\n" , "#define TUP2_2(x) ((x).d2)\n"
compiler/GHC/Tc/Deriv/Generate.hs view
@@ -52,7 +52,7 @@ import GHC.Tc.Utils.Env import GHC.Tc.Utils.TcType import GHC.Tc.Zonk.Type-import GHC.Tc.Validity ( checkValidCoAxBranch )+import GHC.Tc.Validity import GHC.Core.DataCon import GHC.Core.FamInstEnv@@ -71,6 +71,7 @@ import GHC.Types.Unique.FM ( lookupUFM, listToUFM ) import GHC.Types.Var.Env import GHC.Types.Var+import GHC.Types.Var.Set import GHC.Builtin.Names import GHC.Builtin.Names.TH@@ -2085,6 +2086,7 @@ rep_lhs_tys let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs' fam_tc rep_lhs_tys rep_rhs_ty+ checkFamPatBinders fam_tc (rep_tvs' ++ rep_cvs') emptyVarSet rep_lhs_tys rep_rhs_ty -- Check (c) from Note [GND and associated type families] in GHC.Tc.Deriv checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom) newFamInst SynFamilyInst axiom
compiler/GHC/Tc/Gen/HsType.hs view
@@ -2562,13 +2562,14 @@ -- ^^^^^^^^^ -- We do it here because at this point the environment has been -- extended with both 'implicit_tcv_prs' and 'explicit_tv_prs'.- ; ctx_k <- kc_res_ki+ ; res_kind :: ContextKind <- kc_res_ki + -- Work out extra_arity, the number of extra invisible binders from -- the kind signature that should be part of the TyCon's arity. -- See Note [Arity inference in kcCheckDeclHeader_sig] ; let n_invis_tcbs = countWhile isInvisibleTyConBinder excess_sig_tcbs- invis_arity = case ctx_k of+ invis_arity = case res_kind of AnyKind -> n_invis_tcbs -- No kind signature, so make all the invisible binders -- the signature into part of the arity of the TyCon OpenKind -> n_invis_tcbs -- Result kind is (TYPE rr), so again make all the@@ -2582,12 +2583,9 @@ , ppr invis_arity, ppr invis_tcbs , ppr n_invis_tcbs ] - -- Unify res_ki (from the type declaration) with the residual kind from- -- the kind signature. Don't forget to apply the skolemising 'subst' first.- ; case ctx_k of- AnyKind -> return () -- No signature- _ -> do { res_ki <- newExpectedKind ctx_k- ; discardResult (unifyKind Nothing sig_res_kind' res_ki) }+ -- Unify res_ki (from the type declaration) with+ -- sig_res_kind', the residual kind from the kind signature.+ ; checkExpectedResKind sig_res_kind' res_kind -- Add more binders for data/newtype, so the result kind has no arrows -- See Note [Datatype return kinds]@@ -2610,6 +2608,7 @@ ; implicit_tvs <- liftZonkM $ zonkTcTyVarsToTcTyVars implicit_tvs ; let implicit_prs = implicit_nms `zip` implicit_tvs ; checkForDuplicateScopedTyVars implicit_prs+ ; checkForDisconnectedScopedTyVars flav all_tcbs implicit_prs -- Swizzle the Names so that the TyCon uses the user-declared implicit names -- E.g type T :: k -> Type@@ -2623,11 +2622,11 @@ all_tv_prs = mkTyVarNamePairs (binderVars swizzled_tcbs) ; traceTc "kcCheckDeclHeader swizzle" $ vcat- [ text "implicit_prs = " <+> ppr implicit_prs- , text "implicit_nms = " <+> ppr implicit_nms- , text "hs_tv_bndrs = " <+> ppr hs_tv_bndrs- , text "all_tcbs = " <+> pprTyVars (binderVars all_tcbs)- , text "swizzled_tcbs = " <+> pprTyVars (binderVars swizzled_tcbs)+ [ text "sig_tcbs =" <+> ppr sig_tcbs+ , text "implicit_prs =" <+> ppr implicit_prs+ , text "hs_tv_bndrs =" <+> ppr hs_tv_bndrs+ , text "all_tcbs =" <+> pprTyVars (binderVars all_tcbs)+ , text "swizzled_tcbs =" <+> pprTyVars (binderVars swizzled_tcbs) , text "tycon_res_kind =" <+> ppr tycon_res_kind , text "swizzled_kind =" <+> ppr swizzled_kind ] @@ -2648,6 +2647,27 @@ ] ; return tc } +-- | Check the result kind annotation on a type constructor against+-- the corresponding section of the standalone kind signature.+-- Drops invisible binders that interfere with unification.+checkExpectedResKind :: TcKind -- ^ the result kind from the separate kind signature+ -> ContextKind -- ^ the result kind from the declaration header+ -> TcM ()+checkExpectedResKind _ AnyKind+ = return () -- No signature in the declaration header+checkExpectedResKind sig_kind res_ki+ = do { actual_res_ki <- newExpectedKind res_ki++ ; let -- Drop invisible binders from sig_kind until they match up+ -- with res_ki. By analogy with checkExpectedKind.+ n_res_invis_bndrs = invisibleTyBndrCount actual_res_ki+ n_sig_invis_bndrs = invisibleTyBndrCount sig_kind+ n_to_inst = n_sig_invis_bndrs - n_res_invis_bndrs++ (_, sig_kind') = splitInvisPiTysN n_to_inst sig_kind++ ; discardResult $ unifyKind Nothing sig_kind' actual_res_ki }+ matchUpSigWithDecl :: Name -- Name of the type constructor for error messages -> [TcTyConBinder] -- TcTyConBinders (with skolem TcTyVars) from the separate kind signature@@ -2985,6 +3005,25 @@ * * ********************************************************************* -} +checkForDisconnectedScopedTyVars :: TyConFlavour TyCon -> [TcTyConBinder]+ -> [(Name,TcTyVar)] -> TcM ()+-- See Note [Disconnected type variables]+-- `scoped_prs` is the mapping gotten by unifying+-- - the standalone kind signature for T, with+-- - the header of the type/class declaration for T+checkForDisconnectedScopedTyVars flav sig_tcbs scoped_prs+ = when (needsEtaExpansion flav) $+ -- needsEtaExpansion: see wrinkle (DTV1) in Note [Disconnected type variables]+ mapM_ report_disconnected (filterOut ok scoped_prs)+ where+ sig_tvs = mkVarSet (binderVars sig_tcbs)+ ok (_, tc_tv) = tc_tv `elemVarSet` sig_tvs++ report_disconnected :: (Name,TcTyVar) -> TcM ()+ report_disconnected (nm, _)+ = setSrcSpan (getSrcSpan nm) $+ addErrTc $ TcRnDisconnectedTyVar nm+ checkForDuplicateScopedTyVars :: [(Name,TcTyVar)] -> TcM () -- Check for duplicates -- E.g. data SameKind (a::k) (b::k)@@ -3014,6 +3053,64 @@ = setSrcSpan (getSrcSpan n2) $ addErrTc $ TcRnDifferentNamesForTyVar n1 n2 ++{- Note [Disconnected type variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This note applies when kind-checking the header of a type/class decl that has+a separate, standalone kind signature. See #24083.++Consider:+ type S a = Type++ type C :: forall k. S k -> Constraint+ class C (a :: S kk) where+ op :: ...kk...++Note that the class has a separate kind signature, so the elaborated decl should+look like+ class C @kk (a :: S kk) where ...++But how can we "connect up" the scoped variable `kk` with the skolem kind from the+standalone kind signature for `C`? In general we do this by unifying the two.+For example+ type T k = (k,Type)+ type W :: forall k. T k -> Type+ data W (a :: (x,Type)) = ..blah blah..++When we encounter (a :: (x,Type)) we unify the kind (x,Type) with the kind (T k)+from the standalone kind signature. Of course, unification looks through synonyms+so we end up with the mapping [x :-> k] that connects the scoped type variable `x`+with the kind from the signature.++But in our earlier example this unification is ineffective -- because `S` is a+phantom synonym that just discards its argument. So our plan is this:++ if matchUpSigWithDecl fails to connect `kk with `k`, by unification,+ we give up and complain about a "disconnected" type variable.++See #24083 for dicussion of alternatives, none satisfactory. Also the fix is+easy: just add an explicit `@kk` parameter to the declaration, to bind `kk`+explicitly, rather than binding it implicitly via unification.++(DTV1) We only want to make this check when there /are/ scoped type variables; and+ that is determined by needsEtaExpansion. Examples:++ type C :: x -> y -> Constraint+ class C a :: b -> Constraint where { ... }+ -- The a,b scope over the "..."++ type D :: forall k. k -> Type+ data family D :: kk -> Type+ -- Nothing for `kk` to scope over!++ In the latter data-family case, the match-up stuff in kcCheckDeclHeader_sig will+ return [] for `extra_tcbs`, and in fact `all_tcbs` will be empty. So if we do+ the check-for-disconnected-tyvars check we'll complain that `kk` is not bound+ to one of `all_tcbs` (see #24083, comments about the `singletons` package).++ The scoped-tyvar stuff is needed precisely for data/class/newtype declarations,+ where needsEtaExpansion is True.+-} {- ********************************************************************* * *
compiler/GHC/Tc/Gen/Splice.hs view
@@ -1945,8 +1945,8 @@ -- False <=> value namespace -> String -> TcM (Maybe TH.Name) lookupName is_type_name s- = do { mb_nm <- lookupSameOccRn_maybe rdr_name- ; return (fmap reifyName mb_nm) }+ = do { mb_nm <- lookupOccRn_maybe rdr_name+ ; return (fmap (reifyName . greName) mb_nm) } where th_name = TH.mkName s -- Parses M.x into a base of 'x' and a module of 'M' @@ -1961,6 +1961,12 @@ | otherwise = if isLexCon occ_fs then mkDataOccFS occ_fs else mkVarOccFS occ_fs+ -- NB: when we pick the variable namespace, we+ -- might well obtain an identifier in a record+ -- field namespace, as lookupOccRn_maybe looks in+ -- record field namespaces when looking up variables.+ -- This ensures we can look up record fields using+ -- this function (#24293). rdr_name = case TH.nameModule th_name of Nothing -> mkRdrUnqual occ
compiler/GHC/Tc/Solver/Equality.hs view
@@ -1660,12 +1660,16 @@ swap_for_size = typesSize fun_args2 > typesSize fun_args1 -- See Note [Orienting TyFamLHS/TyFamLHS]- swap_for_rewriting = anyVarSet (isTouchableMetaTyVar tclvl) tvs2 &&+ meta_tv_lhs = anyVarSet (isTouchableMetaTyVar tclvl) tvs1+ meta_tv_rhs = anyVarSet (isTouchableMetaTyVar tclvl) tvs2+ swap_for_rewriting = meta_tv_rhs && not meta_tv_lhs -- See Note [Put touchable variables on the left]- not (anyVarSet (isTouchableMetaTyVar tclvl) tvs1) -- This second check is just to avoid unfruitful swapping - ; if swap_for_rewriting || swap_for_size+ -- It's important that we don't flip-flop (#T24134)+ -- So swap_for_rewriting "wins", and we only try swap_for_size+ -- if swap_for_rewriting doesn't care either way+ ; if swap_for_rewriting || (meta_tv_lhs == meta_tv_rhs && swap_for_size) then finish_with_swapping else finish_without_swapping } } where@@ -1884,7 +1888,9 @@ -- If we had F a ~ G (F a), which gives an occurs check, -- then swap it to G (F a) ~ F a, which does not -- However `swap_for_size` above will orient it with (G (F a)) on- -- the left anwyway, so the next four lines of code are redundant+ -- the left anwyway. `swap_for_rewriting` "wins", but that doesn't+ -- matter: in the occurs check case swap_for_rewriting will be moot.+ -- TL;DR: the next four lines of code are redundant -- I'm leaving them here in case they become relevant again -- | TyFamLHS {} <- lhs -- , Just can_rhs <- canTyFamEqLHS_maybe rhs
compiler/GHC/Tc/TyCl.hs view
@@ -48,6 +48,7 @@ import GHC.Tc.TyCl.Utils import GHC.Tc.TyCl.Class import {-# SOURCE #-} GHC.Tc.TyCl.Instance( tcInstDecls1 )+import {-# SOURCE #-} GHC.Tc.Module( checkBootDeclM ) import GHC.Tc.Deriv (DerivInfo(..)) import GHC.Tc.Gen.HsType import GHC.Tc.Instance.Class( AssocInstInfo(..) )@@ -84,6 +85,7 @@ import GHC.Types.Name.Env import GHC.Types.SrcLoc import GHC.Types.SourceFile+import GHC.Types.TypeEnv import GHC.Types.Unique import GHC.Types.Basic import qualified GHC.LanguageExtensions as LangExt@@ -93,6 +95,7 @@ import GHC.Data.List.SetOps( minusList, equivClasses ) import GHC.Unit+import GHC.Unit.Module.ModDetails import GHC.Utils.Outputable import GHC.Utils.Panic@@ -108,6 +111,7 @@ import Data.List ( partition) import Data.List.NonEmpty ( NonEmpty(..) ) import qualified Data.List.NonEmpty as NE+import Data.Traversable ( for ) import Data.Tuple( swap ) {-@@ -193,12 +197,13 @@ -- Step 1: Typecheck the standalone kind signatures and type/class declarations ; traceTc "---- tcTyClGroup ---- {" empty ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))- ; (tyclss, data_deriv_info, kindless) <-+ ; (tyclss_with_validity_infos, data_deriv_info, kindless) <- tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution] do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs ; tcTyClDecls tyclds kisig_env role_annots }-+ ; let tyclss = map fst tyclss_with_validity_infos -- Step 1.5: Make sure we don't have any type synonym cycles+ ; traceTc "Starting synonym cycle check" (ppr tyclss) ; home_unit <- hsc_home_unit <$> getTopEnv ; checkSynCycles (homeUnitAsUnit home_unit) tyclss tyclds@@ -209,7 +214,16 @@ -- Do it before Step 3 (adding implicit things) because the latter -- expects well-formed TyCons ; traceTc "Starting validity check" (ppr tyclss)- ; tyclss <- concatMapM checkValidTyCl tyclss+ ; tyclss <- tcExtendTyConEnv tyclss $+ -- NB: put the TyCons in the environment for validity checking,+ -- as we might look them up in checkTyConConsistentWithBoot.+ -- See Note [TyCon boot consistency checking].+ fmap concat . for tyclss_with_validity_infos $ \ (tycls, ax_validity_infos) ->+ do { tcAddFamInstCtxt (text "type family") (tyConName tycls) $+ tcAddClosedTypeFamilyDeclCtxt tycls $+ mapM_ (checkTyFamEqnValidityInfo tycls) ax_validity_infos+ ; checkValidTyCl tycls }+ ; traceTc "Done validity check" (ppr tyclss) ; mapM_ (recoverM (return ()) . checkValidRoleAnnots role_annots) tyclss -- See Note [Check role annotations in a second pass]@@ -239,7 +253,7 @@ :: [LTyClDecl GhcRn] -> KindSigEnv -> RoleAnnotEnv- -> TcM ([TyCon], [DerivInfo], NameSet)+ -> TcM ([(TyCon, [TyFamEqnValidityInfo])], [DerivInfo], NameSet) tcTyClDecls tyclds kisig_env role_annots = do { -- Step 1: kind-check this group and returns the final -- (possibly-polymorphic) kind of each TyCon and Class@@ -259,10 +273,11 @@ -- NB: We have to be careful here to NOT eagerly unfold -- type synonyms, as we have not tested for type synonym -- loops yet and could fall into a black hole.- ; fixM $ \ ~(rec_tyclss, _, _) -> do+ ; fixM $ \ ~(rec_tyclss_with_validity_infos, _, _) -> do { tcg_env <- getGblEnv -- Forced so we don't retain a reference to the TcGblEnv ; let !src = tcg_src tcg_env+ rec_tyclss = map fst rec_tyclss_with_validity_infos roles = inferRoles src role_annots rec_tyclss -- Populate environment with knot-tied ATyCon for TyCons@@ -2515,23 +2530,26 @@ datatypes are just a new sub-class thereof. -} -tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM (TyCon, [DerivInfo])+tcTyClDecl :: RolesInfo -> LTyClDecl GhcRn -> TcM ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]) tcTyClDecl roles_info (L loc decl) | Just thing <- wiredInNameTyThing_maybe (tcdName decl) = case thing of -- See Note [Declarations for wired-in things]- ATyCon tc -> return (tc, wiredInDerivInfo tc decl)+ ATyCon tc -> return ((tc, []), wiredInDerivInfo tc decl) _ -> pprPanic "tcTyClDecl" (ppr thing) | otherwise = setSrcSpanA loc $ tcAddDeclCtxt decl $ do { traceTc "---- tcTyClDecl ---- {" (ppr decl)- ; (tc, deriv_infos) <- tcTyClDecl1 Nothing roles_info decl+ ; (tc_vi@(tc, _), deriv_infos) <- tcTyClDecl1 Nothing roles_info decl ; traceTc "---- tcTyClDecl end ---- }" (ppr tc)- ; return (tc, deriv_infos) }+ ; return (tc_vi, deriv_infos) } noDerivInfos :: a -> (a, [DerivInfo]) noDerivInfos a = (a, []) +noEqnValidityInfos :: a -> (a, [TyFamEqnValidityInfo])+noEqnValidityInfos a = (a, [])+ wiredInDerivInfo :: TyCon -> TyClDecl GhcRn -> [DerivInfo] wiredInDerivInfo tycon decl | DataDecl { tcdDataDefn = dataDefn } <- decl@@ -2546,7 +2564,7 @@ wiredInDerivInfo _ _ = [] -- "type family" declarations-tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM (TyCon, [DerivInfo])+tcTyClDecl1 :: Maybe Class -> RolesInfo -> TyClDecl GhcRn -> TcM ((TyCon, [TyFamEqnValidityInfo]), [DerivInfo]) tcTyClDecl1 parent _roles_info (FamDecl { tcdFam = fd }) = fmap noDerivInfos $ tcFamDecl1 parent fd@@ -2556,7 +2574,7 @@ (SynDecl { tcdLName = L _ tc_name , tcdRhs = rhs }) = assert (isNothing _parent )- fmap noDerivInfos $+ fmap ( noDerivInfos . noEqnValidityInfos ) $ tcTySynRhs roles_info tc_name rhs -- "data/newtype" declaration@@ -2564,6 +2582,7 @@ decl@(DataDecl { tcdLName = L _ tc_name , tcdDataDefn = defn }) = assert (isNothing _parent) $+ fmap (\(tc, deriv_info) -> ((tc, []), deriv_info)) $ tcDataDefn (tcMkDeclCtxt decl) roles_info tc_name defn tcTyClDecl1 _parent roles_info@@ -2577,7 +2596,7 @@ = assert (isNothing _parent) $ do { clas <- tcClassDecl1 roles_info class_name hs_ctxt meths fundeps sigs ats at_defs- ; return (noDerivInfos (classTyCon clas)) }+ ; return (noDerivInfos $ noEqnValidityInfos (classTyCon clas)) } {- *********************************************************************@@ -2665,14 +2684,14 @@ {- Note [Associated type defaults] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~- The following is an example of associated type defaults:- class C a where- data D a - type F a b :: *- type F a b = [a] -- Default+ class C a where+ data D a + type F a b :: *+ type F a b = [a] -- Default+ Note that we can get default definitions only for type families, not data families. -}@@ -2706,7 +2725,8 @@ (at_def_tycon at_def) [at_def]) emptyNameEnv at_defs - tc_at at = do { fam_tc <- addLocMA (tcFamDecl1 (Just cls)) at+ tc_at at = do { (fam_tc, val_infos) <- addLocMA (tcFamDecl1 (Just cls)) at+ ; mapM_ (checkTyFamEqnValidityInfo fam_tc) val_infos ; let at_defs = lookupNameEnv at_defs_map (at_fam_name at) `orElse` [] ; atd <- tcDefaultAssocDecl fam_tc at_defs@@ -2714,9 +2734,9 @@ ------------------------- tcDefaultAssocDecl ::- TyCon -- ^ Family TyCon (not knot-tied)- -> [LTyFamDefltDecl GhcRn] -- ^ Defaults- -> TcM (Maybe (KnotTied Type, ATValidityInfo)) -- ^ Type checked RHS+ TyCon -- ^ Family TyCon (not knot-tied)+ -> [LTyFamDefltDecl GhcRn] -- ^ Defaults+ -> TcM (Maybe (KnotTied Type, TyFamEqnValidityInfo)) -- ^ Type checked RHS tcDefaultAssocDecl _ [] = return Nothing -- No default declaration @@ -2756,8 +2776,9 @@ -- at an associated type. But this would be wrong, because an associated -- type default LHS can mention *different* type variables than the -- enclosing class. So it's treated more as a freestanding beast.- ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc NotAssociated- outer_bndrs hs_pats hs_rhs_ty+ ; (qtvs, non_user_tvs, pats, rhs_ty)+ <- tcTyFamInstEqnGuts fam_tc NotAssociated+ outer_bndrs hs_pats hs_rhs_ty ; let fam_tvs = tyConTyVars fam_tc ; traceTc "tcDefaultAssocDecl 2" (vcat@@ -2776,7 +2797,13 @@ -- simply create an empty substitution and let GHC fall -- over later, in GHC.Tc.Validity.checkValidAssocTyFamDeflt. -- See Note [Type-checking default assoc decls].- ; pure $ Just (substTyUnchecked subst rhs_ty, ATVI (locA loc) pats)++ ; pure $ Just ( substTyUnchecked subst rhs_ty+ , VI { vi_loc = locA loc+ , vi_qtvs = qtvs+ , vi_non_user_tvs = non_user_tvs+ , vi_pats = pats+ , vi_rhs = rhs_ty } ) -- We perform checks for well-formedness and validity later, in -- GHC.Tc.Validity.checkValidAssocTyFamDeflt. }@@ -2879,7 +2906,7 @@ * * ********************************************************************* -} -tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM TyCon+tcFamDecl1 :: Maybe Class -> FamilyDecl GhcRn -> TcM (TyCon, [TyFamEqnValidityInfo]) tcFamDecl1 parent (FamilyDecl { fdInfo = fam_info , fdLName = tc_lname@(L _ tc_name) , fdResultSig = L _ sig@@ -2908,7 +2935,7 @@ (resultVariableName sig) (DataFamilyTyCon tc_rep_name) parent inj- ; return tycon }+ ; return (tycon, []) } | OpenTypeFamily <- fam_info = bindTyClTyVarsAndZonk tc_name $ \ tc_bndrs res_kind -> do@@ -2919,7 +2946,7 @@ ; let tycon = mkFamilyTyCon tc_name tc_bndrs res_kind (resultVariableName sig) OpenSynFamilyTyCon parent inj'- ; return tycon }+ ; return (tycon, []) } | ClosedTypeFamily mb_eqns <- fam_info = -- Closed type families are a little tricky, because they contain the definition@@ -2939,10 +2966,11 @@ -- but eqns might be empty in the Just case as well ; case mb_eqns of Nothing ->- return $ mkFamilyTyCon tc_name tc_bndrs res_kind- (resultVariableName sig)- AbstractClosedSynFamilyTyCon parent- inj'+ let tc = mkFamilyTyCon tc_name tc_bndrs res_kind+ (resultVariableName sig)+ AbstractClosedSynFamilyTyCon parent+ inj'+ in return (tc, []) Just eqns -> do { -- Process the equations, creating CoAxBranches@@ -2951,7 +2979,8 @@ False {- this doesn't matter here -} ClosedTypeFamilyFlavour - ; branches <- mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns+ ; (branches, axiom_validity_infos) <-+ unzip <$> mapAndReportM (tcTyFamInstEqn tc_fam_tc NotAssociated) eqns -- Do not attempt to drop equations dominated by earlier -- ones here; in the case of mutual recursion with a data -- type, we get a knot-tying failure. Instead we check@@ -2971,7 +3000,7 @@ -- We check for instance validity later, when doing validity -- checking for the tycon. Exception: checking equations -- overlap done by dropDominatedAxioms- ; return fam_tc } }+ ; return (fam_tc, axiom_validity_infos) } } #if __GLASGOW_HASKELL__ <= 810 | otherwise = panic "tcFamInst1" -- Silence pattern-exhaustiveness checker@@ -3183,7 +3212,7 @@ -------------------------- tcTyFamInstEqn :: TcTyCon -> AssocInstInfo -> LTyFamInstEqn GhcRn- -> TcM (KnotTied CoAxBranch)+ -> TcM (KnotTied CoAxBranch, TyFamEqnValidityInfo) -- Needs to be here, not in GHC.Tc.TyCl.Instance, because closed families -- (typechecked here) have TyFamInstEqns @@ -3202,14 +3231,23 @@ ; checkTyFamInstEqn fam_tc eqn_tc_name hs_pats - ; (qtvs, pats, rhs_ty) <- tcTyFamInstEqnGuts fam_tc mb_clsinfo- outer_bndrs hs_pats hs_rhs_ty+ ; (qtvs, non_user_tvs, pats, rhs_ty)+ <- tcTyFamInstEqnGuts fam_tc mb_clsinfo+ outer_bndrs hs_pats hs_rhs_ty -- Don't print results they may be knot-tied -- (tcFamInstEqnGuts zonks to Type)- ; return (mkCoAxBranch qtvs [] [] pats rhs_ty- (map (const Nominal) qtvs)- (locA loc)) } + ; let ax = mkCoAxBranch qtvs [] [] pats rhs_ty+ (map (const Nominal) qtvs)+ (locA loc)+ vi = VI { vi_loc = locA loc+ , vi_qtvs = qtvs+ , vi_non_user_tvs = non_user_tvs+ , vi_pats = pats+ , vi_rhs = rhs_ty }++ ; return (ax, vi) }+ checkTyFamInstEqn :: TcTyCon -> Name -> [HsArg p tm ty] -> TcM () checkTyFamInstEqn tc_fam_tc eqn_tc_name hs_pats = do { -- Ensure that each equation's type constructor is for the right@@ -3292,11 +3330,13 @@ -} --------------------------+ tcTyFamInstEqnGuts :: TyCon -> AssocInstInfo -> HsOuterFamEqnTyVarBndrs GhcRn -- Implicit and explicit binders -> HsTyPats GhcRn -- Patterns -> LHsType GhcRn -- RHS- -> TcM ([TyVar], [TcType], TcType) -- (tyvars, pats, rhs)+ -> TcM ([TyVar], TyVarSet, [TcType], TcType)+ -- (tyvars, non_user_tvs, pats, rhs) -- Used only for type families, not data families tcTyFamInstEqnGuts fam_tc mb_clsinfo outer_hs_bndrs hs_pats hs_rhs_ty = do { traceTc "tcTyFamInstEqnGuts {" (ppr fam_tc $$ ppr outer_hs_bndrs $$ ppr hs_pats)@@ -3350,11 +3390,12 @@ ; return (tidy_env2, UninfTyCtx_TyFamRhs rhs_ty) } ; doNotQuantifyTyVars dvs_rhs err_ctx - ; (final_tvs, lhs_ty, rhs_ty) <- initZonkEnv NoFlexi $+ ; (final_tvs, non_user_tvs, lhs_ty, rhs_ty) <- initZonkEnv NoFlexi $ runZonkBndrT (zonkTyBndrsX final_tvs) $ \ final_tvs ->- do { lhs_ty <- zonkTcTypeToTypeX lhs_ty- ; rhs_ty <- zonkTcTypeToTypeX rhs_ty- ; return (final_tvs, lhs_ty, rhs_ty) }+ do { lhs_ty <- zonkTcTypeToTypeX lhs_ty+ ; rhs_ty <- zonkTcTypeToTypeX rhs_ty+ ; non_user_tvs <- traverse lookupTyVarX qtvs+ ; return (final_tvs, non_user_tvs, lhs_ty, rhs_ty) } ; let pats = unravelFamInstPats lhs_ty -- Note that we do this after solveEqualities@@ -3365,7 +3406,7 @@ -- Don't try to print 'pats' here, because lhs_ty involves -- a knot-tied type constructor, so we get a black hole - ; return (final_tvs, pats, rhs_ty) }+ ; return (final_tvs, mkVarSet non_user_tvs, pats, rhs_ty) } checkFamTelescope :: TcLevel -> HsOuterFamEqnTyVarBndrs GhcRn@@ -4179,7 +4220,7 @@ certainly degrade error messages a bit, though. -} --- ^ From information about a source datacon definition, extract out+-- | From information about a source datacon definition, extract out -- what the universal variables and the GADT equalities should be. -- See Note [mkGADTVars]. mkGADTVars :: [TyVar] -- ^ The tycon vars@@ -4241,7 +4282,7 @@ eqs' = (t_tv', r_ty) : eqs | otherwise- = pprPanic "mkGADTVars" (ppr tmpl_tvs $$ ppr subst)+ = choose (t_tv:univs) eqs t_sub r_sub t_tvs -- choose an appropriate name for a univ tyvar. -- This *must* preserve the Unique of the result tv, so that we@@ -4327,6 +4368,7 @@ recoverM recovery_code $ do { traceTc "Starting validity for tycon" (ppr tc) ; checkValidTyCon tc+ ; checkTyConConsistentWithBoot tc -- See Note [TyCon boot consistency checking] ; traceTc "Done validity for tycon" (ppr tc) ; return [tc] } where@@ -4403,6 +4445,49 @@ -- T2 { f1 :: c, f2 :: c, f3 ::Int } :: T -- Here we do not complain about f1,f2 because they are existential +-- | Check that a 'TyCon' is consistent with the one in the hs-boot file,+-- if any.+--+-- See Note [TyCon boot consistency checking].+checkTyConConsistentWithBoot :: TyCon -> TcM ()+checkTyConConsistentWithBoot tc =+ do { gbl_env <- getGblEnv+ ; let name = tyConName tc+ real_thing = ATyCon tc+ boot_info = tcg_self_boot gbl_env+ boot_type_env = case boot_info of+ NoSelfBoot -> emptyTypeEnv+ SelfBoot boot_details -> md_types boot_details+ m_boot_info = lookupTypeEnv boot_type_env name+ ; case m_boot_info of+ Nothing -> return ()+ Just boot_thing -> checkBootDeclM HsBoot boot_thing real_thing+ }++{- Note [TyCon boot consistency checking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We want to throw an error when A.hs and A.hs-boot define a TyCon inconsistently,+e.g.++ -- A.hs-boot+ type D :: Type+ data D++ -- A.hs+ data D (k :: Type) = MkD++Here A.D and A[boot].D have different kinds, so we must error. In addition, we+must error eagerly, lest other parts of the compiler witness this inconsistency+(which was the subject of #16127). To achieve this, we call+checkTyConIsConsistentWithBoot in checkValidTyCl, which is called in+GHC.Tc.TyCl.tcTyClGroup.++Note that, when calling checkValidTyCl, we must extend the TyCon environment.+For example, we could end up comparing the RHS of two type synonym declarations+to check they are consistent, and these RHS might mention some of the TyCons we+are validity checking, so they need to be in the environment.+-}+ checkValidTyCon :: TyCon -> TcM () checkValidTyCon tc | isPrimTyCon tc -- Happens when Haddock'ing GHC.Prim@@ -4665,7 +4750,7 @@ -- See Note [DataCon user type variable binders] in GHC.Core.DataCon -- checked here because we sometimes build invalid DataCons before -- erroring above here- ; when debugIsOn $+ ; when debugIsOn $ whenNoErrs $ massertPpr (checkDataConTyVars con) $ ppr con $$ ppr (dataConFullSig con) $$ ppr (dataConUserTyVars con) @@ -4837,14 +4922,19 @@ -- since there is no possible ambiguity (#10020) -- Check that any default declarations for associated types are valid- ; whenIsJust m_dflt_rhs $ \ (rhs, at_validity_info) ->+ ; whenIsJust m_dflt_rhs $ \ (_, at_validity_info) -> case at_validity_info of- NoATVI -> pure ()- ATVI loc pats ->+ NoVI -> pure ()+ VI { vi_loc = loc+ , vi_qtvs = qtvs+ , vi_non_user_tvs = non_user_tvs+ , vi_pats = pats+ , vi_rhs = orig_rhs } -> setSrcSpan loc $ tcAddFamInstCtxt (text "default type instance") (getName fam_tc) $ do { checkValidAssocTyFamDeflt fam_tc pats- ; checkValidTyFamEqn fam_tc fam_tvs (mkTyVarTys fam_tvs) rhs }}+ ; checkFamPatBinders fam_tc qtvs non_user_tvs pats orig_rhs+ ; checkValidTyFamEqn fam_tc pats orig_rhs }} where fam_tvs = tyConTyVars fam_tc
compiler/GHC/Tc/TyCl/Build.hs view
@@ -4,7 +4,6 @@ -} - {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Tc.TyCl.Build (
compiler/GHC/Tc/TyCl/Instance.hs view
@@ -606,11 +606,13 @@ -- (1) do the work of verifying the synonym group -- For some reason we don't have a location for the equation -- itself, so we make do with the location of family name- ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo- (L (na2la $ getLoc fam_lname) eqn)+ ; (co_ax_branch, co_ax_validity_info)+ <- tcTyFamInstEqn fam_tc mb_clsinfo+ (L (na2la $ getLoc fam_lname) eqn) -- (2) check for validity ; checkConsistentFamInst mb_clsinfo fam_tc co_ax_branch+ ; checkTyFamEqnValidityInfo fam_tc co_ax_validity_info ; checkValidCoAxBranch fam_tc co_ax_branch -- (3) construct coercion axiom@@ -711,7 +713,7 @@ -- See [Arity of data families] in GHC.Core.FamInstEnv ; skol_info <- mkSkolemInfo FamInstSkol ; let new_or_data = dataDefnConsNewOrData hs_cons- ; (qtvs, pats, tc_res_kind, stupid_theta)+ ; (qtvs, non_user_tvs, pats, tc_res_kind, stupid_theta) <- tcDataFamInstHeader mb_clsinfo skol_info fam_tc outer_bndrs fixity hs_ctxt hs_pats m_ksig new_or_data @@ -786,7 +788,7 @@ , text "res_kind:" <+> ppr res_kind , text "eta_pats" <+> ppr eta_pats , text "eta_tcbs" <+> ppr eta_tcbs ]- ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->+ ; (rep_tc, (axiom, ax_rhs)) <- fixM $ \ ~(rec_rep_tc, _) -> do { data_cons <- tcExtendTyVarEnv (binderVars tc_ty_binders) $ -- For H98 decls, the tyvars scope -- over the data constructors@@ -822,13 +824,15 @@ -- further instance might not introduce a new recursive -- dependency. (2) They are always valid loop breakers as -- they involve a coercion.- ; return (rep_tc, axiom) } + ; return (rep_tc, (axiom, ax_rhs)) }+ -- Remember to check validity; no recursion to worry about here -- Check that left-hand sides are ok (mono-types, no type families, -- consistent instantiations, etc) ; let ax_branch = coAxiomSingleBranch axiom ; checkConsistentFamInst mb_clsinfo fam_tc ax_branch+ ; checkFamPatBinders fam_tc zonked_post_eta_qtvs non_user_tvs eta_pats ax_rhs ; checkValidCoAxBranch fam_tc ax_branch ; checkValidTyCon rep_tc @@ -836,10 +840,10 @@ m_deriv_info = case derivs of [] -> Nothing preds ->- Just $ DerivInfo { di_rep_tc = rep_tc+ Just $ DerivInfo { di_rep_tc = rep_tc , di_scoped_tvs = scoped_tvs- , di_clauses = preds- , di_ctxt = tcMkDataFamInstCtxt decl }+ , di_clauses = preds+ , di_ctxt = tcMkDataFamInstCtxt decl } ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom ; return (fam_inst, m_deriv_info) }@@ -913,7 +917,7 @@ -> LexicalFixity -> Maybe (LHsContext GhcRn) -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> NewOrData- -> TcM ([TcTyVar], [TcType], TcKind, TcThetaType)+ -> TcM ([TcTyVar], TyVarSet, [TcType], TcKind, TcThetaType) -- All skolem TcTyVars, all zonked so it's clear what the free vars are -- The "header" of a data family instance is the part other than -- the data constructors themselves@@ -973,14 +977,15 @@ -- the outer_tvs. See Note [Generalising in tcTyFamInstEqnGuts] ; reportUnsolvedEqualities skol_info final_tvs tclvl wanted - ; (final_tvs,lhs_ty,master_res_kind,instance_res_kind,stupid_theta) <-+ ; (final_tvs, non_user_tvs, lhs_ty, master_res_kind, instance_res_kind, stupid_theta) <- liftZonkM $ do- { final_tvs <- zonkTcTyVarsToTcTyVars final_tvs- ; lhs_ty <- zonkTcType lhs_ty- ; master_res_kind <- zonkTcType master_res_kind- ; instance_res_kind <- zonkTcType instance_res_kind- ; stupid_theta <- zonkTcTypes stupid_theta- ; return (final_tvs,lhs_ty,master_res_kind,instance_res_kind,stupid_theta) }+ { final_tvs <- mapM zonkTcTyVarToTcTyVar final_tvs+ ; non_user_tvs <- mapM zonkTcTyVarToTcTyVar qtvs+ ; lhs_ty <- zonkTcType lhs_ty+ ; master_res_kind <- zonkTcType master_res_kind+ ; instance_res_kind <- zonkTcType instance_res_kind+ ; stupid_theta <- zonkTcTypes stupid_theta+ ; return (final_tvs, non_user_tvs, lhs_ty, master_res_kind, instance_res_kind, stupid_theta) } -- Check that res_kind is OK with checkDataKindSig. We need to -- check that it's ok because res_kind can come from a user-written@@ -992,7 +997,7 @@ -- For the scopedSort see Note [Generalising in tcTyFamInstEqnGuts] ; let pats = unravelFamInstPats lhs_ty - ; return (final_tvs, pats, master_res_kind, stupid_theta) }+ ; return (final_tvs, mkVarSet non_user_tvs, pats, master_res_kind, stupid_theta) } where fam_name = tyConName fam_tc data_ctxt = DataKindCtxt fam_name
compiler/GHC/Tc/TyCl/Utils.hs view
@@ -1,4 +1,3 @@- {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-}
compiler/GHC/Tc/Validity.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -14,6 +15,7 @@ checkValidInstance, checkValidInstHead, validDerivPred, checkTySynRhs, checkEscapingKind, checkValidCoAxiom, checkValidCoAxBranch,+ checkFamPatBinders, checkTyFamEqnValidityInfo, checkValidTyFamEqn, checkValidAssocTyFamDeflt, checkConsistentFamInst, checkTyConTelescope, ) where@@ -82,6 +84,8 @@ import Data.Foldable import Data.Function import Data.List ( (\\) )+import qualified Data.List.NonEmpty as NE+import Data.List.NonEmpty ( NonEmpty(..) ) {- ************************************************************************@@ -2160,28 +2164,32 @@ -- Check that a "type instance" is well-formed (which includes decidability -- unless -XUndecidableInstances is given). --+-- See also the separate 'checkFamPatBinders' which performs scoping checks+-- on a type family equation.+-- (It's separate because it expects 'TyFamEqnValidityInfo', which comes from a+-- separate place e.g. for associated type defaults.) checkValidCoAxBranch :: TyCon -> CoAxBranch -> TcM () checkValidCoAxBranch fam_tc- (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs- , cab_lhs = typats+ (CoAxBranch { cab_lhs = typats , cab_rhs = rhs, cab_loc = loc }) = setSrcSpan loc $- checkValidTyFamEqn fam_tc (tvs++cvs) typats rhs+ checkValidTyFamEqn fam_tc typats rhs -- | Do validity checks on a type family equation, including consistency -- with any enclosing class instance head, termination, and lack of -- polytypes.-checkValidTyFamEqn :: TyCon -- ^ of the type family- -> [Var] -- ^ Bound variables in the equation- -> [Type] -- ^ Type patterns- -> Type -- ^ Rhs+--+-- See also the separate 'checkFamPatBinders' which performs scoping checks+-- on a type family equation.+-- (It's separate because it expects 'TyFamEqnValidityInfo', which comes from a+-- separate place e.g. for associated type defaults.)+checkValidTyFamEqn :: TyCon -- ^ of the type family+ -> [Type] -- ^ Type patterns+ -> Type -- ^ Rhs -> TcM ()-checkValidTyFamEqn fam_tc qvs typats rhs+checkValidTyFamEqn fam_tc typats rhs = do { checkValidTypePats fam_tc typats - -- Check for things used on the right but not bound on the left- ; checkFamPatBinders fam_tc qvs typats rhs- -- Check for oversaturated visible kind arguments in a type family -- equation. -- See Note [Oversaturated type family equations]@@ -2283,19 +2291,47 @@ = Nothing -----------------++-- | Perform scoping check on a type family equation.+--+-- See 'TyFamEqnValidityInfo'.+checkTyFamEqnValidityInfo :: TyCon -> TyFamEqnValidityInfo -> TcM ()+checkTyFamEqnValidityInfo fam_tc = \ case+ NoVI -> return ()+ VI { vi_loc = loc+ , vi_qtvs = qtvs+ , vi_non_user_tvs = non_user_tvs+ , vi_pats = pats+ , vi_rhs = rhs } ->+ setSrcSpan loc $+ checkFamPatBinders fam_tc qtvs non_user_tvs pats rhs++-- | Check binders for a type or data family declaration.+--+-- Specifically, this function checks for:+--+-- - type variables used on the RHS but not bound (explicitly or implicitly)+-- in the LHS,+-- - variables bound by a forall in the LHS but not used in the RHS.+--+-- See Note [Check type family instance binders]. checkFamPatBinders :: TyCon- -> [TcTyVar] -- Bound on LHS of family instance- -> [TcType] -- LHS patterns- -> Type -- RHS+ -> [TcTyVar] -- ^ Bound on LHS of family instance+ -> TyVarSet -- ^ non-user-written tyvars+ -> [TcType] -- ^ LHS patterns+ -> TcType -- ^ RHS -> TcM ()-checkFamPatBinders fam_tc qtvs pats rhs+checkFamPatBinders fam_tc qtvs non_user_tvs pats rhs = do { traceTc "checkFamPatBinders" $ vcat [ debugPprType (mkTyConApp fam_tc pats) , ppr (mkTyConApp fam_tc pats)+ , text "rhs:" <+> ppr rhs , text "qtvs:" <+> ppr qtvs- , text "rhs_tvs:" <+> ppr (fvVarSet rhs_fvs)+ , text "rhs_fvs:" <+> ppr (fvVarSet rhs_fvs) , text "cpt_tvs:" <+> ppr cpt_tvs- , text "inj_cpt_tvs:" <+> ppr inj_cpt_tvs ]+ , text "inj_cpt_tvs:" <+> ppr inj_cpt_tvs+ , text "bad_rhs_tvs:" <+> ppr bad_rhs_tvs+ , text "bad_qtvs:" <+> ppr (map ifiqtv bad_qtvs) ] -- Check for implicitly-bound tyvars, mentioned on the -- RHS but not bound on the LHS@@ -2303,17 +2339,19 @@ -- data family D Int = MkD (forall (a::k). blah) -- In both cases, 'k' is not bound on the LHS, but is used on the RHS -- We catch the former in kcDeclHeader, and the latter right here- -- See Note [Check type-family instance binders]+ -- See Note [Check type family instance binders] ; check_tvs (FamInstRHSOutOfScopeTyVars (Just (fam_tc, pats, dodgy_tvs)))- bad_rhs_tvs+ (map tyVarName bad_rhs_tvs) -- Check for explicitly forall'd variable that is not bound on LHS -- data instance forall a. T Int = MkT Int -- See Note [Unused explicitly bound variables in a family pattern]- -- See Note [Check type-family instance binders]+ -- See Note [Check type family instance binders] ; check_tvs FamInstLHSUnusedBoundTyVars bad_qtvs } where+ rhs_fvs = tyCoFVsOfType rhs+ cpt_tvs = tyCoVarsOfTypes pats inj_cpt_tvs = fvVarSet $ injectiveVarsOfTypes False pats -- The type variables that are in injective positions.@@ -2324,18 +2362,41 @@ -- NB: It's OK to use the nondeterministic `fvVarSet` function here, -- since the order of `inj_cpt_tvs` is never revealed in an error -- message.- rhs_fvs = tyCoFVsOfType rhs- used_tvs = cpt_tvs `unionVarSet` fvVarSet rhs_fvs- bad_qtvs = filterOut (`elemVarSet` used_tvs) qtvs- -- Bound but not used at all- bad_rhs_tvs = filterOut (`elemVarSet` inj_cpt_tvs) (fvVarList rhs_fvs)- -- Used on RHS but not bound on LHS++ -- Bound but not used at all+ bad_qtvs = mapMaybe bad_qtv_maybe qtvs++ bad_qtv_maybe qtv+ | not_bound_in_pats+ = let reason+ | dodgy+ = InvalidFamInstQTvDodgy+ | used_in_rhs+ = InvalidFamInstQTvNotBoundInPats+ | otherwise+ = InvalidFamInstQTvNotUsedInRHS+ in Just $ InvalidFamInstQTv+ { ifiqtv = qtv+ , ifiqtv_user_written = not $ qtv `elemVarSet` non_user_tvs+ , ifiqtv_reason = reason+ }+ | otherwise+ = Nothing+ where+ not_bound_in_pats = not $ qtv `elemVarSet` inj_cpt_tvs+ dodgy = not_bound_in_pats && qtv `elemVarSet` cpt_tvs+ used_in_rhs = qtv `elemVarSet` fvVarSet rhs_fvs++ -- Used on RHS but not bound on LHS+ bad_rhs_tvs = filterOut ((`elemVarSet` inj_cpt_tvs) <||> (`elem` qtvs)) (fvVarList rhs_fvs)+ dodgy_tvs = cpt_tvs `minusVarSet` inj_cpt_tvs check_tvs mk_err tvs- = unless (null tvs) $ addErrAt (getSrcSpan (head tvs)) $+ = for_ (NE.nonEmpty tvs) $ \ ne_tvs@(tv0 :| _) ->+ addErrAt (getSrcSpan tv0) $ TcRnIllegalInstance $ IllegalFamilyInstance $- mk_err (map tyVarName tvs)+ mk_err ne_tvs -- | Checks that a list of type patterns is valid in a matching (LHS) -- position of a class instances or type/data family instance.@@ -2441,7 +2502,7 @@ | otherwise = BindMe -{- Note [Check type-family instance binders]+{- Note [Check type family instance binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In a type family instance, we require (of course), type variables used on the RHS are matched on the LHS. This is checked by
compiler/GHC/Tc/Zonk/Type.hs view
@@ -16,7 +16,7 @@ zonkTopDecls, zonkTopExpr, zonkTopLExpr, zonkTopBndrs, zonkTyVarBindersX, zonkTyVarBinderX,- zonkTyBndrsX,+ zonkTyBndrX, zonkTyBndrsX, zonkTcTypeToType, zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX, zonkTyVarOcc,
compiler/GHC/Unit/Finder.hs view
@@ -301,7 +301,7 @@ , fr_suggestions = [] }) LookupUnusable unusable -> let unusables' = map get_unusable unusable- get_unusable (m, ModUnusable r) = (moduleUnit m, r)+ get_unusable (_, ModUnusable r) = r get_unusable (_, r) = pprPanic "findLookupResult: unexpected origin" (ppr r) in return (NotFound{ fr_paths = [], fr_pkg = Nothing
compiler/MachRegs.h view
@@ -457,6 +457,12 @@ #define REG_D3 d14 #define REG_D4 d15 +#define REG_XMM1 q4+#define REG_XMM2 q5++#define CALLER_SAVES_XMM1+#define CALLER_SAVES_XMM2+ /* ----------------------------------------------------------------------------- The s390x register mapping @@ -593,6 +599,8 @@ #elif defined(MACHREGS_wasm32) +#define REG_Base 0+ #define REG_R1 1 #define REG_R2 2 #define REG_R3 3@@ -624,7 +632,6 @@ #define REG_SpLim 25 #define REG_Hp 26 #define REG_HpLim 27-#define REG_CCCS 28 /* ----------------------------------------------------------------------------- The loongarch64 register mapping
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib-version: 9.8.1.20231121+version: 9.8.2.20240223 license: BSD-3-Clause license-file: LICENSE category: Development@@ -38,6 +38,7 @@ ghc-lib/stage0/compiler/build/primop-docs.hs-incl ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs libraries/containers/containers/include/containers.h+ compiler/ghc-llvm-version.h rts/include/ghcconfig.h compiler/MachRegs.h compiler/CodeGen.Platform.h@@ -45,7 +46,6 @@ compiler/ClosureTypes.h compiler/FunTypes.h compiler/Unique.h- compiler/ghc-llvm-version.h source-repository head type: git location: git@github.com:digital-asset/ghc-lib.git@@ -92,8 +92,8 @@ stm, semaphore-compat, rts,- hpc == 0.6.*,- ghc-lib-parser == 9.8.1.20231121+ hpc >= 0.6 && < 0.8,+ ghc-lib-parser == 9.8.2.20240223 build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4 other-extensions: BangPatterns
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -386,7 +386,7 @@ , ("traceMarker#"," Emits a marker event via the RTS tracing framework. The contents\n of the event is the zero-terminated byte string passed as the first\n argument. The event will be emitted either to the @.eventlog@ file,\n or to stderr, depending on the runtime RTS flags. ") , ("setThreadAllocationCounter#"," Sets the allocation counter for the current thread to the given value. ") , ("StackSnapshot#"," Haskell representation of a @StgStack*@ that was created (cloned)\n with a function in \"GHC.Stack.CloneStack\". Please check the\n documentation in that module for more detailed explanations. ")- , ("coerce"," The function 'coerce' allows you to safely convert between values of\n types that have the same representation with no run-time overhead. In the\n simplest case you can use it instead of a newtype constructor, to go from\n the newtype's concrete type to the abstract type. But it also works in\n more complicated settings, e.g. converting a list of newtypes to a list of\n concrete types.\n\n This function is representation-polymorphic, but the\n 'RuntimeRep' type argument is marked as 'Inferred', meaning\n that it is not available for visible type application. This means\n the typechecker will accept @'coerce' \\@'Int' \\@Age 42@.\n ")+ , ("coerce"," The function 'coerce' allows you to safely convert between values of\n types that have the same representation with no run-time overhead. In the\n simplest case you can use it instead of a newtype constructor, to go from\n the newtype's concrete type to the abstract type. But it also works in\n more complicated settings, e.g. converting a list of newtypes to a list of\n concrete types.\n\n When used in conversions involving a newtype wrapper,\n make sure the newtype constructor is in scope.\n\n This function is representation-polymorphic, but the\n 'RuntimeRep' type argument is marked as 'Inferred', meaning\n that it is not available for visible type application. This means\n the typechecker will accept @'coerce' \\@'Int' \\@Age 42@.\n\n === __Examples__\n\n >>> newtype TTL = TTL Int deriving (Eq, Ord, Show)\n >>> newtype Age = Age Int deriving (Eq, Ord, Show)\n >>> coerce (Age 42) :: TTL\n TTL 42\n >>> coerce (+ (1 :: Int)) (Age 42) :: TTL\n TTL 43\n >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL]\n [TTL 43,TTL 25]\n\n ") , ("broadcastInt8X16#"," Broadcast a scalar to all elements of a vector. ") , ("broadcastInt16X8#"," Broadcast a scalar to all elements of a vector. ") , ("broadcastInt32X4#"," Broadcast a scalar to all elements of a vector. ")
ghc-lib/stage0/lib/settings view
@@ -2,7 +2,7 @@ ,("C compiler flags", "--target=x86_64-apple-darwin -Qunused-arguments") ,("C++ compiler command", "/usr/bin/g++") ,("C++ compiler flags", "--target=x86_64-apple-darwin ")-,("C compiler link flags", "--target=x86_64-apple-darwin -Wl,-no_fixup_chains")+,("C compiler link flags", "--target=x86_64-apple-darwin -Wl,-no_fixup_chains -Wl,-no_warn_duplicate_libraries") ,("C compiler supports -no-pie", "NO") ,("Haskell CPP command", "/usr/bin/gcc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")@@ -10,8 +10,9 @@ ,("ld flags", "") ,("ld supports compact unwind", "YES") ,("ld supports filelist", "YES")-,("ld supports response files", "NO")+,("ld supports response files", "YES") ,("ld is GNU ld", "NO")+,("ld supports single module", "NO") ,("Merge objects command", "ld") ,("Merge objects flags", "-r") ,("ar command", "/usr/bin/ar")
ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h view
@@ -1,5 +1,12 @@ /* This file is created automatically. Do not edit by hand.*/ +// MAX_Real_Vanilla_REG 6+// MAX_Real_Float_REG 6+// MAX_Real_Double_REG 6+// MAX_Real_Long_REG 0+// WORD_SIZE 8+// BITMAP_BITS_SHIFT 6+// TAG_BITS 3 #define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,64,8,16,8,0,72,56,8,16,0,8,8,0,8,0,104,120,16,8,16,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976,1" #define CONTROL_GROUP_CONST_291 291 #define STD_HDR_SIZE 1
ghc-lib/stage0/rts/build/include/ghcautoconf.h view
@@ -106,36 +106,36 @@ /* Does C compiler support __atomic primitives? */ #define HAVE_C11_ATOMICS 1 -/* Define to 1 if you have the `clock_gettime' function. */+/* Define to 1 if you have the 'clock_gettime' function. */ #define HAVE_CLOCK_GETTIME 1 -/* Define to 1 if you have the `ctime_r' function. */+/* Define to 1 if you have the 'ctime_r' function. */ #define HAVE_CTIME_R 1 /* Define to 1 if you have the <ctype.h> header file. */ #define HAVE_CTYPE_H 1 -/* Define to 1 if you have the declaration of `ctime_r', and to 0 if you+/* Define to 1 if you have the declaration of 'ctime_r', and to 0 if you don't. */ #define HAVE_DECL_CTIME_R 1 -/* Define to 1 if you have the declaration of `environ', and to 0 if you+/* Define to 1 if you have the declaration of 'environ', and to 0 if you don't. */ #define HAVE_DECL_ENVIRON 0 -/* Define to 1 if you have the declaration of `MADV_DONTNEED', and to 0 if you+/* Define to 1 if you have the declaration of 'MADV_DONTNEED', and to 0 if you don't. */ /* #undef HAVE_DECL_MADV_DONTNEED */ -/* Define to 1 if you have the declaration of `MADV_FREE', and to 0 if you+/* Define to 1 if you have the declaration of 'MADV_FREE', and to 0 if you don't. */ /* #undef HAVE_DECL_MADV_FREE */ -/* Define to 1 if you have the declaration of `MAP_NORESERVE', and to 0 if you+/* Define to 1 if you have the declaration of 'MAP_NORESERVE', and to 0 if you don't. */ /* #undef HAVE_DECL_MAP_NORESERVE */ -/* Define to 1 if you have the declaration of `program_invocation_short_name',+/* Define to 1 if you have the declaration of 'program_invocation_short_name', and to 0 if you don't. */ #define HAVE_DECL_PROGRAM_INVOCATION_SHORT_NAME 0 @@ -145,7 +145,7 @@ /* Define to 1 if you have the <dlfcn.h> header file. */ #define HAVE_DLFCN_H 1 -/* Define to 1 if you have the `dlinfo' function. */+/* Define to 1 if you have the 'dlinfo' function. */ /* #undef HAVE_DLINFO */ /* Define to 1 if you have the <elfutils/libdw.h> header file. */@@ -154,7 +154,7 @@ /* Define to 1 if you have the <errno.h> header file. */ #define HAVE_ERRNO_H 1 -/* Define to 1 if you have the `eventfd' function. */+/* Define to 1 if you have the 'eventfd' function. */ /* #undef HAVE_EVENTFD */ /* Define to 1 if you have the <fcntl.h> header file. */@@ -163,25 +163,25 @@ /* Define to 1 if you have the <ffi.h> header file. */ /* #undef HAVE_FFI_H */ -/* Define to 1 if you have the `fork' function. */+/* Define to 1 if you have the 'fork' function. */ #define HAVE_FORK 1 -/* Define to 1 if you have the `getclock' function. */+/* Define to 1 if you have the 'getclock' function. */ /* #undef HAVE_GETCLOCK */ /* Define to 1 if you have the `GetModuleFileName' function. */ /* #undef HAVE_GETMODULEFILENAME */ -/* Define to 1 if you have the `getpid' function. */+/* Define to 1 if you have the 'getpid' function. */ #define HAVE_GETPID 1 -/* Define to 1 if you have the `getrusage' function. */+/* Define to 1 if you have the 'getrusage' function. */ #define HAVE_GETRUSAGE 1 -/* Define to 1 if you have the `gettimeofday' function. */+/* Define to 1 if you have the 'gettimeofday' function. */ #define HAVE_GETTIMEOFDAY 1 -/* Define to 1 if you have the `getuid' function. */+/* Define to 1 if you have the 'getuid' function. */ #define HAVE_GETUID 1 /* Define to 1 if you have the <grp.h> header file. */@@ -190,28 +190,28 @@ /* Define to 1 if you have the <inttypes.h> header file. */ #define HAVE_INTTYPES_H 1 -/* Define to 1 if you have the `bfd' library (-lbfd). */+/* Define to 1 if you have the 'bfd' library (-lbfd). */ /* #undef HAVE_LIBBFD */ -/* Define to 1 if you have the `dl' library (-ldl). */+/* Define to 1 if you have the 'dl' library (-ldl). */ #define HAVE_LIBDL 1 -/* Define to 1 if you have the `iberty' library (-liberty). */+/* Define to 1 if you have the 'iberty' library (-liberty). */ /* #undef HAVE_LIBIBERTY */ /* Define to 1 if you need to link with libm */ #define HAVE_LIBM 1 -/* Define to 1 if you have the `mingwex' library (-lmingwex). */+/* Define to 1 if you have the 'mingwex' library (-lmingwex). */ /* #undef HAVE_LIBMINGWEX */ /* Define to 1 if you have libnuma */ #define HAVE_LIBNUMA 0 -/* Define to 1 if you have the `pthread' library (-lpthread). */+/* Define to 1 if you have the 'pthread' library (-lpthread). */ #define HAVE_LIBPTHREAD 1 -/* Define to 1 if you have the `rt' library (-lrt). */+/* Define to 1 if you have the 'rt' library (-lrt). */ /* #undef HAVE_LIBRT */ /* Define to 1 if you wish to compress IPE data in compiler results (requires@@ -224,7 +224,7 @@ /* Define to 1 if you have the <locale.h> header file. */ #define HAVE_LOCALE_H 1 -/* Define to 1 if the system has the type `long long'. */+/* Define to 1 if the system has the type 'long long'. */ #define HAVE_LONG_LONG 1 /* Define to 1 if you have the <minix/config.h> header file. */@@ -242,7 +242,7 @@ /* Define to 1 if we have printf$LDBLStub (Apple Mac OS >= 10.4, PPC). */ #define HAVE_PRINTF_LDBLSTUB 0 -/* Define to 1 if you have the `pthread_condattr_setclock' function. */+/* Define to 1 if you have the 'pthread_condattr_setclock' function. */ /* #undef HAVE_PTHREAD_CONDATTR_SETCLOCK */ /* Define to 1 if you have the <pthread.h> header file. */@@ -266,25 +266,25 @@ /* Define to 1 if you have the <pwd.h> header file. */ #define HAVE_PWD_H 1 -/* Define to 1 if you have the `raise' function. */+/* Define to 1 if you have the 'raise' function. */ #define HAVE_RAISE 1 -/* Define to 1 if you have the `sched_getaffinity' function. */+/* Define to 1 if you have the 'sched_getaffinity' function. */ /* #undef HAVE_SCHED_GETAFFINITY */ /* Define to 1 if you have the <sched.h> header file. */ #define HAVE_SCHED_H 1 -/* Define to 1 if you have the `sched_setaffinity' function. */+/* Define to 1 if you have the 'sched_setaffinity' function. */ /* #undef HAVE_SCHED_SETAFFINITY */ -/* Define to 1 if you have the `setitimer' function. */+/* Define to 1 if you have the 'setitimer' function. */ #define HAVE_SETITIMER 1 -/* Define to 1 if you have the `setlocale' function. */+/* Define to 1 if you have the 'setlocale' function. */ #define HAVE_SETLOCALE 1 -/* Define to 1 if you have the `siginterrupt' function. */+/* Define to 1 if you have the 'siginterrupt' function. */ #define HAVE_SIGINTERRUPT 1 /* Define to 1 if you have the <signal.h> header file. */@@ -308,7 +308,7 @@ /* Define to 1 if Apple-style dead-stripping is supported. */ #define HAVE_SUBSECTIONS_VIA_SYMBOLS 1 -/* Define to 1 if you have the `sysconf' function. */+/* Define to 1 if you have the 'sysconf' function. */ #define HAVE_SYSCONF 1 /* Define to 1 if you have libffi. */@@ -362,22 +362,22 @@ /* Define to 1 if you have the <termios.h> header file. */ #define HAVE_TERMIOS_H 1 -/* Define to 1 if you have the `timer_settime' function. */+/* Define to 1 if you have the 'timer_settime' function. */ /* #undef HAVE_TIMER_SETTIME */ -/* Define to 1 if you have the `times' function. */+/* Define to 1 if you have the 'times' function. */ #define HAVE_TIMES 1 /* Define to 1 if you have the <unistd.h> header file. */ #define HAVE_UNISTD_H 1 -/* Define to 1 if you have the `uselocale' function. */+/* Define to 1 if you have the 'uselocale' function. */ #define HAVE_USELOCALE 1 /* Define to 1 if you have the <utime.h> header file. */ #define HAVE_UTIME_H 1 -/* Define to 1 if you have the `vfork' function. */+/* Define to 1 if you have the 'vfork' function. */ #define HAVE_VFORK 1 /* Define to 1 if you have the <vfork.h> header file. */@@ -395,10 +395,10 @@ /* Define to 1 if you have the <winsock.h> header file. */ /* #undef HAVE_WINSOCK_H */ -/* Define to 1 if `fork' works. */+/* Define to 1 if 'fork' works. */ #define HAVE_WORKING_FORK 1 -/* Define to 1 if `vfork' works. */+/* Define to 1 if 'vfork' works. */ #define HAVE_WORKING_VFORK 1 /* Define to 1 if you have the <zstd.h> header file. */@@ -435,67 +435,67 @@ /* Use mmap in the runtime linker */ #define RTS_LINKER_USE_MMAP 1 -/* The size of `char', as computed by sizeof. */+/* The size of 'char', as computed by sizeof. */ #define SIZEOF_CHAR 1 -/* The size of `double', as computed by sizeof. */+/* The size of 'double', as computed by sizeof. */ #define SIZEOF_DOUBLE 8 -/* The size of `float', as computed by sizeof. */+/* The size of 'float', as computed by sizeof. */ #define SIZEOF_FLOAT 4 -/* The size of `int', as computed by sizeof. */+/* The size of 'int', as computed by sizeof. */ #define SIZEOF_INT 4 -/* The size of `int16_t', as computed by sizeof. */+/* The size of 'int16_t', as computed by sizeof. */ #define SIZEOF_INT16_T 2 -/* The size of `int32_t', as computed by sizeof. */+/* The size of 'int32_t', as computed by sizeof. */ #define SIZEOF_INT32_T 4 -/* The size of `int64_t', as computed by sizeof. */+/* The size of 'int64_t', as computed by sizeof. */ #define SIZEOF_INT64_T 8 -/* The size of `int8_t', as computed by sizeof. */+/* The size of 'int8_t', as computed by sizeof. */ #define SIZEOF_INT8_T 1 -/* The size of `long', as computed by sizeof. */+/* The size of 'long', as computed by sizeof. */ #define SIZEOF_LONG 8 -/* The size of `long long', as computed by sizeof. */+/* The size of 'long long', as computed by sizeof. */ #define SIZEOF_LONG_LONG 8 -/* The size of `short', as computed by sizeof. */+/* The size of 'short', as computed by sizeof. */ #define SIZEOF_SHORT 2 -/* The size of `uint16_t', as computed by sizeof. */+/* The size of 'uint16_t', as computed by sizeof. */ #define SIZEOF_UINT16_T 2 -/* The size of `uint32_t', as computed by sizeof. */+/* The size of 'uint32_t', as computed by sizeof. */ #define SIZEOF_UINT32_T 4 -/* The size of `uint64_t', as computed by sizeof. */+/* The size of 'uint64_t', as computed by sizeof. */ #define SIZEOF_UINT64_T 8 -/* The size of `uint8_t', as computed by sizeof. */+/* The size of 'uint8_t', as computed by sizeof. */ #define SIZEOF_UINT8_T 1 -/* The size of `unsigned char', as computed by sizeof. */+/* The size of 'unsigned char', as computed by sizeof. */ #define SIZEOF_UNSIGNED_CHAR 1 -/* The size of `unsigned int', as computed by sizeof. */+/* The size of 'unsigned int', as computed by sizeof. */ #define SIZEOF_UNSIGNED_INT 4 -/* The size of `unsigned long', as computed by sizeof. */+/* The size of 'unsigned long', as computed by sizeof. */ #define SIZEOF_UNSIGNED_LONG 8 -/* The size of `unsigned long long', as computed by sizeof. */+/* The size of 'unsigned long long', as computed by sizeof. */ #define SIZEOF_UNSIGNED_LONG_LONG 8 -/* The size of `unsigned short', as computed by sizeof. */+/* The size of 'unsigned short', as computed by sizeof. */ #define SIZEOF_UNSIGNED_SHORT 2 -/* The size of `void *', as computed by sizeof. */+/* The size of 'void *', as computed by sizeof. */ #define SIZEOF_VOID_P 8 /* If using the C implementation of alloca, define if you know the@@ -510,7 +510,7 @@ in the compiler (requires libzstd) */ #define STATIC_LIBZSTD 0 -/* Define to 1 if all of the C90 standard headers exist (not just the ones+/* Define to 1 if all of the C89 standard headers exist (not just the ones required in a freestanding environment). This macro is provided for backward compatibility; new code need not use it. */ #define STDC_HEADERS 1@@ -527,7 +527,7 @@ /* Set to 1 to use libdw */ #define USE_LIBDW 0 -/* Enable extensions on AIX 3, Interix. */+/* Enable extensions on AIX, Interix, z/OS. */ #ifndef _ALL_SOURCE # define _ALL_SOURCE 1 #endif@@ -588,11 +588,15 @@ #ifndef __STDC_WANT_IEC_60559_DFP_EXT__ # define __STDC_WANT_IEC_60559_DFP_EXT__ 1 #endif+/* Enable extensions specified by C23 Annex F. */+#ifndef __STDC_WANT_IEC_60559_EXT__+# define __STDC_WANT_IEC_60559_EXT__ 1+#endif /* Enable extensions specified by ISO/IEC TS 18661-4:2015. */ #ifndef __STDC_WANT_IEC_60559_FUNCS_EXT__ # define __STDC_WANT_IEC_60559_FUNCS_EXT__ 1 #endif-/* Enable extensions specified by ISO/IEC TS 18661-3:2015. */+/* Enable extensions specified by C23 Annex H and ISO/IEC TS 18661-3:2015. */ #ifndef __STDC_WANT_IEC_60559_TYPES_EXT__ # define __STDC_WANT_IEC_60559_TYPES_EXT__ 1 #endif@@ -633,16 +637,22 @@ /* Number of bits in a file offset, on hosts where this is settable. */ /* #undef _FILE_OFFSET_BITS */ -/* Define for large files, on AIX-style hosts. */+/* Define to 1 on platforms where this makes off_t a 64-bit type. */ /* #undef _LARGE_FILES */ +/* Number of bits in time_t, on hosts where this is settable. */+/* #undef _TIME_BITS */++/* Define to 1 on platforms where this makes time_t a 64-bit type. */+/* #undef __MINGW_USE_VC2005_COMPAT */+ /* ARM pre v6 */ /* #undef arm_HOST_ARCH_PRE_ARMv6 */ /* ARM pre v7 */ /* #undef arm_HOST_ARCH_PRE_ARMv7 */ -/* Define to empty if `const' does not conform to ANSI C. */+/* Define to empty if 'const' does not conform to ANSI C. */ /* #undef const */ /* Define as a signed integer type capable of holding a process identifier. */@@ -654,10 +664,10 @@ /* The minimum supported LLVM version number */ #define sUPPORTED_LLVM_VERSION_MIN (11) -/* Define to `unsigned int' if <sys/types.h> does not define. */+/* Define as 'unsigned int' if <stddef.h> doesn't define. */ /* #undef size_t */ -/* Define as `fork' if `vfork' does not work. */+/* Define as 'fork' if 'vfork' does not work. */ /* #undef vfork */ /* ghcautoconf.h.autoconf. Generated from ghcautoconf.h.autoconf.in by configure. */ /* ghcautoconf.h.autoconf.in. Generated from configure.ac by autoheader. */