diff --git a/compiler/CodeGen.Platform.h b/compiler/CodeGen.Platform.h --- a/compiler/CodeGen.Platform.h +++ b/compiler/CodeGen.Platform.h @@ -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) diff --git a/compiler/GHC.hs b/compiler/GHC.hs --- a/compiler/GHC.hs +++ b/compiler/GHC.hs @@ -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 diff --git a/compiler/GHC/Cmm/CallConv.hs b/compiler/GHC/Cmm/CallConv.hs --- a/compiler/GHC/Cmm/CallConv.hs +++ b/compiler/GHC/Cmm/CallConv.hs @@ -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] diff --git a/compiler/GHC/CmmToAsm/Ppr.hs b/compiler/GHC/CmmToAsm/Ppr.hs --- a/compiler/GHC/CmmToAsm/Ppr.hs +++ b/compiler/GHC/CmmToAsm/Ppr.hs @@ -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 diff --git a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs --- a/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs +++ b/compiler/GHC/CmmToAsm/Wasm/FromCmm.hs @@ -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" diff --git a/compiler/GHC/CmmToAsm/X86/CodeGen.hs b/compiler/GHC/CmmToAsm/X86/CodeGen.hs --- a/compiler/GHC/CmmToAsm/X86/CodeGen.hs +++ b/compiler/GHC/CmmToAsm/X86/CodeGen.hs @@ -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` diff --git a/compiler/GHC/CmmToAsm/X86/Instr.hs b/compiler/GHC/CmmToAsm/X86/Instr.hs --- a/compiler/GHC/CmmToAsm/X86/Instr.hs +++ b/compiler/GHC/CmmToAsm/X86/Instr.hs @@ -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 []) [] diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs --- a/compiler/GHC/CmmToLlvm/CodeGen.hs +++ b/compiler/GHC/CmmToLlvm/CodeGen.hs @@ -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 diff --git a/compiler/GHC/CmmToLlvm/Data.hs b/compiler/GHC/CmmToLlvm/Data.hs --- a/compiler/GHC/CmmToLlvm/Data.hs +++ b/compiler/GHC/CmmToLlvm/Data.hs @@ -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 diff --git a/compiler/GHC/Core/Opt/CSE.hs b/compiler/GHC/Core/Opt/CSE.hs --- a/compiler/GHC/Core/Opt/CSE.hs +++ b/compiler/GHC/Core/Opt/CSE.hs @@ -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') diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -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: diff --git a/compiler/GHC/Core/Opt/FloatIn.hs b/compiler/GHC/Core/Opt/FloatIn.hs --- a/compiler/GHC/Core/Opt/FloatIn.hs +++ b/compiler/GHC/Core/Opt/FloatIn.hs @@ -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: diff --git a/compiler/GHC/Core/Opt/Pipeline.hs b/compiler/GHC/Core/Opt/Pipeline.hs --- a/compiler/GHC/Core/Opt/Pipeline.hs +++ b/compiler/GHC/Core/Opt/Pipeline.hs @@ -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"], diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs --- a/compiler/GHC/Core/Opt/SpecConstr.hs +++ b/compiler/GHC/Core/Opt/SpecConstr.hs @@ -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 diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -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 diff --git a/compiler/GHC/Driver/Config/StgToCmm.hs b/compiler/GHC/Driver/Config/StgToCmm.hs --- a/compiler/GHC/Driver/Config/StgToCmm.hs +++ b/compiler/GHC/Driver/Config/StgToCmm.hs @@ -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 diff --git a/compiler/GHC/Driver/GenerateCgIPEStub.hs b/compiler/GHC/Driver/GenerateCgIPEStub.hs --- a/compiler/GHC/Driver/GenerateCgIPEStub.hs +++ b/compiler/GHC/Driver/GenerateCgIPEStub.hs @@ -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 diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs --- a/compiler/GHC/Driver/Main.hs +++ b/compiler/GHC/Driver/Main.hs @@ -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 diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs --- a/compiler/GHC/Driver/Make.hs +++ b/compiler/GHC/Driver/Make.hs @@ -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 diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs --- a/compiler/GHC/Driver/Pipeline.hs +++ b/compiler/GHC/Driver/Pipeline.hs @@ -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 diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs --- a/compiler/GHC/Driver/Pipeline/Execute.hs +++ b/compiler/GHC/Driver/Pipeline/Execute.hs @@ -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 ] diff --git a/compiler/GHC/HsToCore/Binds.hs b/compiler/GHC/HsToCore/Binds.hs --- a/compiler/GHC/HsToCore/Binds.hs +++ b/compiler/GHC/HsToCore/Binds.hs @@ -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 diff --git a/compiler/GHC/HsToCore/Foreign/C.hs b/compiler/GHC/HsToCore/Foreign/C.hs --- a/compiler/GHC/HsToCore/Foreign/C.hs +++ b/compiler/GHC/HsToCore/Foreign/C.hs @@ -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 ] diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs --- a/compiler/GHC/IfaceToCore.hs +++ b/compiler/GHC/IfaceToCore.hs @@ -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 diff --git a/compiler/GHC/Linker/Dynamic.hs b/compiler/GHC/Linker/Dynamic.hs --- a/compiler/GHC/Linker/Dynamic.hs +++ b/compiler/GHC/Linker/Dynamic.hs @@ -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" ]) diff --git a/compiler/GHC/Llvm/Ppr.hs b/compiler/GHC/Llvm/Ppr.hs --- a/compiler/GHC/Llvm/Ppr.hs +++ b/compiler/GHC/Llvm/Ppr.hs @@ -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 diff --git a/compiler/GHC/Llvm/Syntax.hs b/compiler/GHC/Llvm/Syntax.hs --- a/compiler/GHC/Llvm/Syntax.hs +++ b/compiler/GHC/Llvm/Syntax.hs @@ -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. diff --git a/compiler/GHC/Rename/Doc.hs b/compiler/GHC/Rename/Doc.hs --- a/compiler/GHC/Rename/Doc.hs +++ b/compiler/GHC/Rename/Doc.hs @@ -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) ] diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs --- a/compiler/GHC/Rename/Env.hs +++ b/compiler/GHC/Rename/Env.hs @@ -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' diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -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] diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -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 diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs --- a/compiler/GHC/Rename/Utils.hs +++ b/compiler/GHC/Rename/Utils.hs @@ -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 diff --git a/compiler/GHC/Settings/IO.hs b/compiler/GHC/Settings/IO.hs --- a/compiler/GHC/Settings/IO.hs +++ b/compiler/GHC/Settings/IO.hs @@ -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 diff --git a/compiler/GHC/Stg/CSE.hs b/compiler/GHC/Stg/CSE.hs --- a/compiler/GHC/Stg/CSE.hs +++ b/compiler/GHC/Stg/CSE.hs @@ -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 diff --git a/compiler/GHC/Stg/Debug.hs b/compiler/GHC/Stg/Debug.hs --- a/compiler/GHC/Stg/Debug.hs +++ b/compiler/GHC/Stg/Debug.hs @@ -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. diff --git a/compiler/GHC/StgToCmm/Bind.hs b/compiler/GHC/StgToCmm/Bind.hs --- a/compiler/GHC/StgToCmm/Bind.hs +++ b/compiler/GHC/StgToCmm/Bind.hs @@ -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), diff --git a/compiler/GHC/StgToCmm/CgUtils.hs b/compiler/GHC/StgToCmm/CgUtils.hs --- a/compiler/GHC/StgToCmm/CgUtils.hs +++ b/compiler/GHC/StgToCmm/CgUtils.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs --- a/compiler/GHC/StgToCmm/Closure.hs +++ b/compiler/GHC/StgToCmm/Closure.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs --- a/compiler/GHC/StgToCmm/Expr.hs +++ b/compiler/GHC/StgToCmm/Expr.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Heap.hs b/compiler/GHC/StgToCmm/Heap.hs --- a/compiler/GHC/StgToCmm/Heap.hs +++ b/compiler/GHC/StgToCmm/Heap.hs @@ -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 () diff --git a/compiler/GHC/StgToCmm/Monad.hs b/compiler/GHC/StgToCmm/Monad.hs --- a/compiler/GHC/StgToCmm/Monad.hs +++ b/compiler/GHC/StgToCmm/Monad.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Prim.hs b/compiler/GHC/StgToCmm/Prim.hs --- a/compiler/GHC/StgToCmm/Prim.hs +++ b/compiler/GHC/StgToCmm/Prim.hs @@ -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) diff --git a/compiler/GHC/StgToCmm/Prof.hs b/compiler/GHC/StgToCmm/Prof.hs --- a/compiler/GHC/StgToCmm/Prof.hs +++ b/compiler/GHC/StgToCmm/Prof.hs @@ -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 diff --git a/compiler/GHC/StgToCmm/Sequel.hs b/compiler/GHC/StgToCmm/Sequel.hs --- a/compiler/GHC/StgToCmm/Sequel.hs +++ b/compiler/GHC/StgToCmm/Sequel.hs @@ -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 + } + -------------------------------------------------------------------------------- diff --git a/compiler/GHC/StgToCmm/Utils.hs b/compiler/GHC/StgToCmm/Utils.hs --- a/compiler/GHC/StgToCmm/Utils.hs +++ b/compiler/GHC/StgToCmm/Utils.hs @@ -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) diff --git a/compiler/GHC/StgToJS/Linker/Utils.hs b/compiler/GHC/StgToJS/Linker/Utils.hs --- a/compiler/GHC/StgToJS/Linker/Utils.hs +++ b/compiler/GHC/StgToJS/Linker/Utils.hs @@ -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" diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs --- a/compiler/GHC/Tc/Deriv/Generate.hs +++ b/compiler/GHC/Tc/Deriv/Generate.hs @@ -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 diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs --- a/compiler/GHC/Tc/Gen/HsType.hs +++ b/compiler/GHC/Tc/Gen/HsType.hs @@ -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. +-} {- ********************************************************************* * * diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs --- a/compiler/GHC/Tc/Gen/Splice.hs +++ b/compiler/GHC/Tc/Gen/Splice.hs @@ -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 diff --git a/compiler/GHC/Tc/Solver/Equality.hs b/compiler/GHC/Tc/Solver/Equality.hs --- a/compiler/GHC/Tc/Solver/Equality.hs +++ b/compiler/GHC/Tc/Solver/Equality.hs @@ -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 diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -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 diff --git a/compiler/GHC/Tc/TyCl/Build.hs b/compiler/GHC/Tc/TyCl/Build.hs --- a/compiler/GHC/Tc/TyCl/Build.hs +++ b/compiler/GHC/Tc/TyCl/Build.hs @@ -4,7 +4,6 @@ -} - {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Tc.TyCl.Build ( diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -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 diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} diff --git a/compiler/GHC/Tc/Validity.hs b/compiler/GHC/Tc/Validity.hs --- a/compiler/GHC/Tc/Validity.hs +++ b/compiler/GHC/Tc/Validity.hs @@ -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 diff --git a/compiler/GHC/Tc/Zonk/Type.hs b/compiler/GHC/Tc/Zonk/Type.hs --- a/compiler/GHC/Tc/Zonk/Type.hs +++ b/compiler/GHC/Tc/Zonk/Type.hs @@ -16,7 +16,7 @@ zonkTopDecls, zonkTopExpr, zonkTopLExpr, zonkTopBndrs, zonkTyVarBindersX, zonkTyVarBinderX, - zonkTyBndrsX, + zonkTyBndrX, zonkTyBndrsX, zonkTcTypeToType, zonkTcTypeToTypeX, zonkTcTypesToTypesX, zonkScaledTcTypesToTypesX, zonkTyVarOcc, diff --git a/compiler/GHC/Unit/Finder.hs b/compiler/GHC/Unit/Finder.hs --- a/compiler/GHC/Unit/Finder.hs +++ b/compiler/GHC/Unit/Finder.hs @@ -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 diff --git a/compiler/MachRegs.h b/compiler/MachRegs.h --- a/compiler/MachRegs.h +++ b/compiler/MachRegs.h @@ -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 diff --git a/ghc-lib.cabal b/ghc-lib.cabal --- a/ghc-lib.cabal +++ b/ghc-lib.cabal @@ -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 diff --git a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl --- a/ghc-lib/stage0/compiler/build/primop-docs.hs-incl +++ b/ghc-lib/stage0/compiler/build/primop-docs.hs-incl @@ -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. ") diff --git a/ghc-lib/stage0/lib/settings b/ghc-lib/stage0/lib/settings --- a/ghc-lib/stage0/lib/settings +++ b/ghc-lib/stage0/lib/settings @@ -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") diff --git a/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h b/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h --- a/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +++ b/ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h @@ -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 diff --git a/ghc-lib/stage0/rts/build/include/ghcautoconf.h b/ghc-lib/stage0/rts/build/include/ghcautoconf.h --- a/ghc-lib/stage0/rts/build/include/ghcautoconf.h +++ b/ghc-lib/stage0/rts/build/include/ghcautoconf.h @@ -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 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 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 header file. */ @@ -154,7 +154,7 @@ /* Define to 1 if you have the 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 header file. */ @@ -163,25 +163,25 @@ /* Define to 1 if you have the 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 header file. */ @@ -190,28 +190,28 @@ /* Define to 1 if you have the 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 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 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 header file. */ @@ -266,25 +266,25 @@ /* Define to 1 if you have the 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 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 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 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 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 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 header file. */ @@ -395,10 +395,10 @@ /* Define to 1 if you have the 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 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 does not define. */ +/* Define as 'unsigned int' if 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. */