diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs --- a/compiler/GHC/Cmm.hs +++ b/compiler/GHC/Cmm.hs @@ -229,16 +229,15 @@ -- place to convey this information from the code generator to -- where we build the static closures in -- GHC.Cmm.Info.Build.doSRTs. - } deriving Eq + } deriving (Eq, Ord) instance OutputableP Platform CmmInfoTable where pdoc = pprInfoTable - data ProfilingInfo = NoProfilingInfo | ProfilingInfo ByteString ByteString -- closure_type, closure_desc - deriving Eq + deriving (Eq, Ord) ----------------------------------------------------------------------------- -- Static Data ----------------------------------------------------------------------------- diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs --- a/compiler/GHC/Cmm/CLabel.hs +++ b/compiler/GHC/Cmm/CLabel.hs @@ -65,6 +65,7 @@ mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel, mkOutOfBoundsAccessLabel, + mkMemcpyRangeOverlapLabel, mkArrWords_infoLabel, mkSRTInfoLabel, @@ -649,7 +650,8 @@ mkCAFBlackHoleInfoTableLabel, mkSMAP_FROZEN_CLEAN_infoLabel, mkSMAP_FROZEN_DIRTY_infoLabel, mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel, - mkOutOfBoundsAccessLabel, mkMUT_VAR_CLEAN_infoLabel :: CLabel + mkOutOfBoundsAccessLabel, mkMemcpyRangeOverlapLabel, + mkMUT_VAR_CLEAN_infoLabel :: CLabel mkDirty_MUT_VAR_Label = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData @@ -667,7 +669,8 @@ mkSMAP_FROZEN_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo mkSMAP_DIRTY_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo mkBadAlignmentLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment") CmmEntry -mkOutOfBoundsAccessLabel = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") Nothing ForeignLabelInExternalPackage IsFunction +mkOutOfBoundsAccessLabel = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") Nothing ForeignLabelInExternalPackage IsFunction +mkMemcpyRangeOverlapLabel = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") Nothing ForeignLabelInExternalPackage IsFunction mkMUT_VAR_CLEAN_infoLabel = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN") CmmInfo mkSRTInfoLabel :: Int -> CLabel @@ -1384,6 +1387,7 @@ ordinary Haskell function of arity 1 that allocates a (Just x) box: Just = \x -> Just x + Just_entry: The entry code for the worker function Just_closure: The closure for this worker Nothing_closure: a statically allocated closure for Nothing diff --git a/compiler/GHC/Cmm/MachOp.hs b/compiler/GHC/Cmm/MachOp.hs --- a/compiler/GHC/Cmm/MachOp.hs +++ b/compiler/GHC/Cmm/MachOp.hs @@ -51,6 +51,25 @@ assume that the code produced for a MachOp does not introduce new blocks. -} +-- Note [MO_S_MulMayOflo significant width] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- There are two interpretations in the code about what a multiplication +-- overflow exactly means: +-- +-- 1. The result does not fit into the specified width (of type Width.) +-- 2. The result does not fit into a register. +-- +-- (2) has some flaws: A following MO_Mul has a width, too. So MO_S_MulMayOflo +-- may signal no overflow, while MO_Mul truncates the result. There are +-- architectures with several register widths and it might be hard to decide +-- what's an overflow and what not. Both attributes can easily lead to subtle +-- bugs. +-- +-- (1) has the benefit that its interpretation is completely independent of the +-- architecture. So, the mid-term plan is to migrate to this +-- interpretation/sematics. + data MachOp -- Integer operations (insensitive to signed/unsigned) = MO_Add Width @@ -60,7 +79,8 @@ | MO_Mul Width -- low word of multiply -- Signed multiply/divide - | MO_S_MulMayOflo Width -- nonzero if signed multiply overflows + | MO_S_MulMayOflo Width -- nonzero if signed multiply overflows. See + -- Note [MO_S_MulMayOflo significant width] | MO_S_Quot Width -- signed / (same semantics as IntQuotOp) | MO_S_Rem Width -- signed % (same semantics as IntRemOp) | MO_S_Neg Width -- unary - diff --git a/compiler/GHC/Core/Coercion.hs b/compiler/GHC/Core/Coercion.hs --- a/compiler/GHC/Core/Coercion.hs +++ b/compiler/GHC/Core/Coercion.hs @@ -1155,8 +1155,12 @@ Pair ty1 ty2 = coercionKind co go cs co - | Just (ty, r) <- isReflCo_maybe co - = Just (mkReflCo r (getNthFromType cs ty)) + | Just (ty, _co_role) <- isReflCo_maybe co + = let new_role = coercionRole (SelCo cs co) + in Just (mkReflCo new_role (getNthFromType cs ty)) + -- The role of the result (new_role) does not have to + -- be equal to _co_role, the role of co, per Note [SelCo]. + -- This was revealed by #23938. go SelForAll (ForAllCo _ kind_co _) = Just kind_co diff --git a/compiler/GHC/Core/DataCon.hs b/compiler/GHC/Core/DataCon.hs --- a/compiler/GHC/Core/DataCon.hs +++ b/compiler/GHC/Core/DataCon.hs @@ -111,8 +111,8 @@ import Language.Haskell.Syntax.Module.Name {- -Data constructor representation -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Data constructor representation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following Haskell data type declaration data T = T !Int ![Int] @@ -213,7 +213,7 @@ * The wrapper (if it exists) takes dcOrigArgTys as its arguments. The worker takes dataConRepArgTys as its arguments - If the worker is absent, dataConRepArgTys is the same as dcOrigArgTys + If the wrapper is absent, dataConRepArgTys is the same as dcOrigArgTys * The 'NoDataConRep' case of DataConRep is important. Not only is it efficient, but it also ensures that the wrapper is replaced by the @@ -586,12 +586,22 @@ Note [DataCon arities] ~~~~~~~~~~~~~~~~~~~~~~ -dcSourceArity does not take constraints into account, -but dcRepArity does. For example: +A `DataCon`'s source arity and core representation arity may differ: +`dcSourceArity` does not take constraints into account, but `dcRepArity` does. + +The additional arguments taken into account by `dcRepArity` include quantified +dictionaries and coercion arguments, lifted and unlifted (despite the unlifted +coercion arguments having a zero-width runtime representation). +For example: MkT :: Ord a => a -> T a dcSourceArity = 1 dcRepArity = 2 + MkU :: (b ~ '[]) => U b + dcSourceArity = 0 + dcRepArity = 1 + + Note [DataCon user type variable binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A DataCon has two different sets of type variables: @@ -1030,7 +1040,7 @@ Trep :: Int# -> a -> Void# -> T a Actually, the unboxed part isn't implemented yet! -Not that this representation is still *different* from runtime +Note that this representation is still *different* from runtime representation. (Which is what STG uses after unarise). This is how T would end up being used in STG post-unarise: @@ -1446,9 +1456,10 @@ dataConSourceArity :: DataCon -> Arity dataConSourceArity (MkData { dcSourceArity = arity }) = arity --- | Gives the number of actual fields in the /representation/ of the --- data constructor. This may be more than appear in the source code; --- the extra ones are the existentially quantified dictionaries +-- | Gives the number of value arguments (including zero-width coercions) +-- stored by the given `DataCon`'s worker in its Core representation. This may +-- differ from the number of arguments that appear in the source code; see also +-- Note [DataCon arities] dataConRepArity :: DataCon -> Arity dataConRepArity (MkData { dcRepArity = arity }) = arity @@ -1457,8 +1468,14 @@ isNullarySrcDataCon :: DataCon -> Bool isNullarySrcDataCon dc = dataConSourceArity dc == 0 --- | Return whether there are any argument types for this 'DataCon's runtime representation type --- See Note [DataCon arities] +-- | Return whether this `DataCon`'s worker, in its Core representation, takes +-- any value arguments. +-- +-- In particular, remember that we include coercion arguments in the arity of +-- the Core representation of the `DataCon` -- both lifted and unlifted +-- coercions, despite the latter having zero-width runtime representation. +-- +-- See also Note [DataCon arities]. isNullaryRepDataCon :: DataCon -> Bool isNullaryRepDataCon dc = dataConRepArity dc == 0 diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -87,6 +87,8 @@ import GHC.Utils.Panic.Plain import GHC.Utils.Misc +import Data.Maybe( isJust ) + {- ************************************************************************ * * @@ -2303,18 +2305,6 @@ * `/\a. \x. f @(Maybe a) x --> /\a. f @(Maybe a)` See Note [Do not eta reduce PAPs] for why we insist on a trivial head. -2. Type and dictionary abstraction. Regardless of whether 'f' is a value, it - is always sound to reduce /type lambdas/, thus: - (/\a -> f a) --> f - Moreover, we always want to, because it makes RULEs apply more often: - This RULE: `forall g. foldr (build (/\a -> g a))` - should match `foldr (build (/\b -> ...something complex...))` - and the simplest way to do so is eta-reduce `/\a -> g a` in the RULE to `g`. - - The type checker can insert these eta-expanded versions, - with both type and dictionary lambdas; hence the slightly - ad-hoc (all ok_lam bndrs) - Of course, eta reduction is not always sound. See Note [Eta reduction soundness] for when it is. @@ -2353,7 +2343,7 @@ (checked in 'is_eta_reduction_sound' in 'tryEtaReduce', which focuses on the case where `e` is trivial): - A. It is sound to eta-reduce n arguments as long as n does not exceed the +(A) It is sound to eta-reduce n arguments as long as n does not exceed the `exprArity` of `e`. (Needs Arity analysis.) This criterion exploits information about how `e` is *defined*. @@ -2362,7 +2352,7 @@ By contrast, it would be *unsound* to eta-reduce 2 args, `\x y. e x y` to `e`: `e 42` diverges when `(\x y. e x y) 42` does not. - S. It is sound to eta-reduce n arguments in an evaluation context in which all +(S) It is sound to eta-reduce n arguments in an evaluation context in which all calls happen with at least n arguments. (Needs Strictness analysis.) NB: This treats evaluations like a call with 0 args. NB: This criterion exploits information about how `e` is *used*. @@ -2389,23 +2379,42 @@ See Note [Eta reduction based on evaluation context] for the implementation details. This criterion is tested extensively in T21261. - R. Note [Eta reduction in recursive RHSs] tells us that we should not +(R) Note [Eta reduction in recursive RHSs] tells us that we should not eta-reduce `f` in its own RHS and describes our fix. There we have `f = \x. f x` and we should not eta-reduce to `f=f`. Which might change a terminating program (think @f `seq` e@) to a non-terminating one. - E. (See fun_arity in tryEtaReduce.) As a perhaps special case on the +(E) (See fun_arity in tryEtaReduce.) As a perhaps special case on the boundary of (A) and (S), when we know that a fun binder `f` is in WHNF, we simply assume it has arity 1 and apply (A). Example: g f = f `seq` \x. f x Here it's sound eta-reduce `\x. f x` to `f`, because `f` can't be bottom after the `seq`. This turned up in #7542. + T. If the binders are all type arguments, it's always safe to eta-reduce, + regardless of the arity of f. + /\a b. f @a @b --> f + +2. Type and dictionary abstraction. Regardless of whether 'f' is a value, it + is always sound to reduce /type lambdas/, thus: + (/\a -> f a) --> f + Moreover, we always want to, because it makes RULEs apply more often: + This RULE: `forall g. foldr (build (/\a -> g a))` + should match `foldr (build (/\b -> ...something complex...))` + and the simplest way to do so is eta-reduce `/\a -> g a` in the RULE to `g`. + + More debatably, we extend this to dictionary arguments too, because the type + checker can insert these eta-expanded versions, with both type and dictionary + lambdas; hence the slightly ad-hoc (all ok_lam bndrs). That is, we eta-reduce + \(d::Num a). f d --> f + regardless of f's arity. Its not clear whether or not this is important, and + it is not in general sound. But that's the way it is right now. + And here are a few more technical criteria for when it is *not* sound to eta-reduce that are specific to Core and GHC: - L. With linear types, eta-reduction can break type-checking: +(L) With linear types, eta-reduction can break type-checking: f :: A ⊸ B g :: A -> B g = \x. f x @@ -2413,13 +2422,13 @@ complain that g and f don't have the same type. NB: Not unsound in the dynamic semantics, but unsound according to the static semantics of Core. - J. We may not undersaturate join points. +(J) We may not undersaturate join points. See Note [Invariants on join points] in GHC.Core, and #20599. - B. We may not undersaturate functions with no binding. +(B) We may not undersaturate functions with no binding. See Note [Eta expanding primops]. - W. We may not undersaturate StrictWorkerIds. +(W) We may not undersaturate StrictWorkerIds. See Note [CBV Function Ids] in GHC.Types.Id.Info. Here is a list of historic accidents surrounding unsound eta-reduction: @@ -2663,20 +2672,25 @@ ok_fun (App fun (Type {})) = ok_fun fun ok_fun (Cast fun _) = ok_fun fun ok_fun (Tick _ expr) = ok_fun expr - ok_fun (Var fun_id) = is_eta_reduction_sound fun_id || all ok_lam bndrs + ok_fun (Var fun_id) = is_eta_reduction_sound fun_id ok_fun _fun = False --------------- -- See Note [Eta reduction soundness], this is THE place to check soundness! - is_eta_reduction_sound fun = - -- Don't eta-reduce in fun in its own recursive RHSs - not (fun `elemUnVarSet` rec_ids) -- criterion (R) - -- Check that eta-reduction won't make the program stricter... - && (fun_arity fun >= incoming_arity -- criterion (A) and (E) - || all_calls_with_arity incoming_arity) -- criterion (S) - -- ... and that the function can be eta reduced to arity 0 - -- without violating invariants of Core and GHC - && canEtaReduceToArity fun 0 0 -- criteria (L), (J), (W), (B) + is_eta_reduction_sound fun + | fun `elemUnVarSet` rec_ids -- Criterion (R) + = False -- Don't eta-reduce in fun in its own recursive RHSs + + | cantEtaReduceFun fun -- Criteria (L), (J), (W), (B) + = False -- Function can't be eta reduced to arity 0 + -- without violating invariants of Core and GHC + + | otherwise + = -- Check that eta-reduction won't make the program stricter... + fun_arity fun >= incoming_arity -- Criterion (A) and (E) + || all_calls_with_arity incoming_arity -- Criterion (S) + || all ok_lam bndrs -- Criterion (T) + all_calls_with_arity n = isStrict (fst $ peelManyCalls n eval_sd) -- See Note [Eta reduction based on evaluation context] @@ -2726,19 +2740,18 @@ ok_arg _ _ _ _ = Nothing --- | Can we eta-reduce the given function to the specified arity? +-- | Can we eta-reduce the given function -- See Note [Eta reduction soundness], criteria (B), (J), (W) and (L). -canEtaReduceToArity :: Id -> JoinArity -> Arity -> Bool -canEtaReduceToArity fun dest_join_arity dest_arity = - not $ - hasNoBinding fun -- (B) +cantEtaReduceFun :: Id -> Bool +cantEtaReduceFun fun + = hasNoBinding fun -- (B) -- Don't undersaturate functions with no binding. - || ( isJoinId fun && dest_join_arity < idJoinArity fun ) -- (J) + || isJoinId fun -- (J) -- Don't undersaturate join points. -- See Note [Invariants on join points] in GHC.Core, and #20599 - || ( dest_arity < idCbvMarkArity fun ) -- (W) + || (isJust (idCbvMarks_maybe fun)) -- (W) -- Don't undersaturate StrictWorkerIds. -- See Note [CBV Function Ids] in GHC.Types.Id.Info. diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -886,9 +886,6 @@ see `init_menv` in `matchN`. -} -rvInScopeEnv :: RuleMatchEnv -> InScopeEnv -rvInScopeEnv renv = ISE (rnInScopeSet (rv_lcl renv)) (rv_unf renv) - -- * The domain of the TvSubstEnv and IdSubstEnv are the template -- variables passed into the match. -- @@ -1105,7 +1102,16 @@ ------------------------ Lambdas --------------------- match renv subst (Lam x1 e1) e2 mco - | Just (x2, e2', ts) <- exprIsLambda_maybe (rvInScopeEnv renv) (mkCastMCo e2 mco) + | let casted_e2 = mkCastMCo e2 mco + in_scope = extendInScopeSetSet (rnInScopeSet (rv_lcl renv)) + (exprFreeVars casted_e2) + in_scope_env = ISE in_scope (rv_unf renv) + -- extendInScopeSetSet: The InScopeSet of rn_env is not necessarily + -- a superset of the free vars of e2; it is only guaranteed a superset of + -- applyng the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe + -- wants an in-scope set that includes all the free vars of its argument. + -- Hence adding adding (exprFreeVars casted_e2) to the in-scope set (#23630) + , Just (x2, e2', ts) <- exprIsLambda_maybe in_scope_env casted_e2 -- See Note [Lambdas in the template] = let renv' = rnMatchBndr2 renv x1 x2 subst' = subst { rs_binds = rs_binds subst . flip (foldr mkTick) ts } diff --git a/compiler/GHC/Core/Tidy.hs b/compiler/GHC/Core/Tidy.hs --- a/compiler/GHC/Core/Tidy.hs +++ b/compiler/GHC/Core/Tidy.hs @@ -82,7 +82,7 @@ -- This means the code generator can get the full calling convention by only looking at the function -- itself without having to inspect the RHS. -- --- The actual logic is in tidyCbvInfo and takes: +-- The actual logic is in computeCbvInfo and takes: -- * The function id -- * The functions rhs -- And gives us back the function annotated with the marks. @@ -169,7 +169,7 @@ -- seqList: avoid retaining the original rhs | otherwise - = -- pprTraceDebug "tidyCbvInfo: Worker seems to take unboxed tuple/sum types!" + = -- pprTraceDebug "computeCbvInfo: Worker seems to take unboxed tuple/sum types!" -- (ppr fun_id <+> ppr rhs) asNonWorkerLikeId fun_id diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs --- a/compiler/GHC/Driver/Flags.hs +++ b/compiler/GHC/Driver/Flags.hs @@ -5,6 +5,7 @@ , GeneralFlag(..) , Language(..) , optimisationFlags + , codeGenFlags -- * Warnings , WarningFlag(..) @@ -149,6 +150,7 @@ | Opt_D_no_debug_output | Opt_D_dump_faststrings | Opt_D_faststring_stats + | Opt_D_ipe_stats deriving (Eq, Show, Enum) -- | Helper function to query whether a given `DumpFlag` is enabled or not. @@ -211,6 +213,8 @@ | Opt_DistinctConstructorTables | Opt_InfoTableMap + | Opt_InfoTableMapWithFallback + | Opt_InfoTableMapWithStack | Opt_WarnIsError -- -Werror; makes warnings fatal | Opt_ShowWarnGroups -- Show the group a warning belongs to @@ -246,6 +250,7 @@ | Opt_Specialise | Opt_SpecialiseAggressively | Opt_CrossModuleSpecialise + | Opt_PolymorphicSpecialisation | Opt_InlineGenerics | Opt_InlineGenericsAggressively | Opt_StaticArgumentTransformation @@ -467,15 +472,11 @@ | Opt_G_NoOptCoercion deriving (Eq, Show, Enum) --- Check whether a flag should be considered an "optimisation flag" --- for purposes of recompilation avoidance (see --- Note [Ignoring some flag changes] in GHC.Iface.Recomp.Flags). Being listed here is --- not a guarantee that the flag has no other effect. We could, and --- perhaps should, separate out the flags that have some minor impact on --- program semantics and/or error behavior (e.g., assertions), but --- then we'd need to go to extra trouble (and an additional flag) --- to allow users to ignore the optimisation level even though that --- means ignoring some change. +-- | The set of flags which affect optimisation for the purposes of +-- recompilation avoidance. Specifically, these include flags which +-- affect code generation but not the semantics of the program. +-- +-- See Note [Ignoring some flag changes] in GHC.Iface.Recomp.Flags) optimisationFlags :: EnumSet GeneralFlag optimisationFlags = EnumSet.fromList [ Opt_CallArity @@ -507,16 +508,12 @@ , Opt_EnableRewriteRules , Opt_RegsGraph , Opt_RegsIterative - , Opt_PedanticBottoms , Opt_LlvmTBAA - , Opt_LlvmFillUndefWithGarbage , Opt_IrrefutableTuples , Opt_CmmSink , Opt_CmmElimCommonBlocks , Opt_AsmShortcutting - , Opt_OmitYields , Opt_FunToThunk - , Opt_DictsStrict , Opt_DmdTxDictSel , Opt_Loopification , Opt_CfgBlocklayout @@ -525,8 +522,49 @@ , Opt_WorkerWrapper , Opt_WorkerWrapperUnlift , Opt_SolveConstantDicts + ] + +-- | The set of flags which affect code generation and can change a program's +-- runtime behavior (other than performance). These include flags which affect: +-- +-- * user visible debugging information (e.g. info table provenance) +-- * the ability to catch runtime errors (e.g. -fignore-asserts) +-- * the runtime result of the program (e.g. -fomit-yields) +-- * which code or interface file declarations are emitted +-- +-- We also considered placing flags which affect asympototic space behavior +-- (e.g. -ffull-laziness) however this would mean that changing optimisation +-- levels would trigger recompilation even with -fignore-optim-changes, +-- regressing #13604. +-- +-- Also, arguably Opt_IgnoreAsserts should be here as well; however, we place +-- it instead in 'optimisationFlags' since it is implied by @-O[12]@ and +-- therefore would also break #13604. +-- +-- See #23369. +codeGenFlags :: EnumSet GeneralFlag +codeGenFlags = EnumSet.fromList + [ -- Flags that affect runtime result + Opt_EagerBlackHoling + , Opt_ExcessPrecision + , Opt_DictsStrict + , Opt_PedanticBottoms + , Opt_OmitYields + + -- Flags that affect generated code + , Opt_ExposeAllUnfoldings + , Opt_NoTypeableBinds + + -- Flags that affect catching of runtime errors , Opt_CatchNonexhaustiveCases - , Opt_IgnoreAsserts + , Opt_LlvmFillUndefWithGarbage + , Opt_DoTagInferenceChecks + + -- Flags that affect debugging information + , Opt_DistinctConstructorTables + , Opt_InfoTableMap + , Opt_InfoTableMapWithStack + , Opt_InfoTableMapWithFallback ] data WarningFlag = diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs --- a/compiler/GHC/Driver/Session.hs +++ b/compiler/GHC/Driver/Session.hs @@ -61,6 +61,7 @@ makeDynFlagsConsistent, positionIndependent, optimisationFlags, + codeGenFlags, setFlagsFromEnvFile, pprDynFlagsDiff, flagSpecOf, @@ -2606,6 +2607,8 @@ (NoArg (setGeneralFlag Opt_DoTagInferenceChecks)) , make_ord_flag defGhcFlag "dshow-passes" (NoArg $ forceRecompile >> (setVerbosity $ Just 2)) + , make_ord_flag defGhcFlag "dipe-stats" + (setDumpFlag Opt_D_ipe_stats) , make_ord_flag defGhcFlag "dfaststring-stats" (setDumpFlag Opt_D_faststring_stats) , make_ord_flag defGhcFlag "dno-llvm-mangler" @@ -2881,10 +2884,6 @@ -- Caller-CC , make_ord_flag defGhcFlag "fprof-callers" (HasArg setCallerCcFilters) - , make_ord_flag defGhcFlag "fdistinct-constructor-tables" - (NoArg (setGeneralFlag Opt_DistinctConstructorTables)) - , make_ord_flag defGhcFlag "finfo-table-map" - (NoArg (setGeneralFlag Opt_InfoTableMap)) ------ Compiler flags ----------------------------------------------- , make_ord_flag defGhcFlag "fasm" (NoArg (setObjBackend ncgBackend)) @@ -3476,6 +3475,7 @@ flagSpec "specialize-aggressively" Opt_SpecialiseAggressively, flagSpec "cross-module-specialise" Opt_CrossModuleSpecialise, flagSpec "cross-module-specialize" Opt_CrossModuleSpecialise, + flagSpec "polymorphic-specialisation" Opt_PolymorphicSpecialisation, flagSpec "inline-generics" Opt_InlineGenerics, flagSpec "inline-generics-aggressively" Opt_InlineGenericsAggressively, flagSpec "static-argument-transformation" Opt_StaticArgumentTransformation, @@ -3512,7 +3512,11 @@ return dflags)), flagSpec "show-error-context" Opt_ShowErrorContext, flagSpec "cmm-thread-sanitizer" Opt_CmmThreadSanitizer, - flagSpec "split-sections" Opt_SplitSections + flagSpec "split-sections" Opt_SplitSections, + flagSpec "distinct-constructor-tables" Opt_DistinctConstructorTables, + flagSpec "info-table-map" Opt_InfoTableMap, + flagSpec "info-table-map-with-stack" Opt_InfoTableMapWithStack, + flagSpec "info-table-map-with-fallback" Opt_InfoTableMapWithFallback ] ++ fHoleFlags @@ -3882,6 +3886,8 @@ ,(Opt_Strictness, turnOn, Opt_WorkerWrapper) ,(Opt_WriteIfSimplifiedCore, turnOn, Opt_WriteInterface) ,(Opt_ByteCodeAndObjectCode, turnOn, Opt_WriteIfSimplifiedCore) + ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithStack) + ,(Opt_InfoTableMap, turnOn, Opt_InfoTableMapWithFallback) ] ++ validHoleFitsImpliedGFlags -- General flags that are switched on/off when other general flags are switched diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -209,7 +209,7 @@ -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p))) mkMatchGroup origin matches = MG { mg_ext = origin - , mg_alts = matches } + , mg_alts = matches } mkLamCaseMatchGroup :: AnnoBody p body => Origin diff --git a/compiler/GHC/Runtime/Heap/Layout.hs b/compiler/GHC/Runtime/Heap/Layout.hs --- a/compiler/GHC/Runtime/Heap/Layout.hs +++ b/compiler/GHC/Runtime/Heap/Layout.hs @@ -175,7 +175,7 @@ | RTSRep -- The RTS needs to declare info tables with specific Int -- type tags, so this form lets us override the default SMRep -- tag for an SMRep. - deriving Eq + deriving (Eq, Ord) -- | True \<=> This is a static closure. Affects how we garbage-collect it. -- Static closure have an extra static link field at the end. @@ -193,7 +193,7 @@ | ThunkSelector SelectorOffset | BlackHole | IndStatic - deriving Eq + deriving (Eq, Ord) type ConstrDescription = ByteString -- result of dataConIdentity type FunArity = Int @@ -223,7 +223,7 @@ | ArgUnknown -- For imported binds. -- Invariant: Never Unknown for binds of the module -- we are compiling. - deriving (Eq) + deriving (Eq, Ord) instance Outputable ArgDescr where ppr (ArgSpec n) = text "ArgSpec" <+> ppr n diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs --- a/compiler/GHC/Stg/Syntax.hs +++ b/compiler/GHC/Stg/Syntax.hs @@ -236,7 +236,7 @@ -- which can't be let-bound | StgConApp DataCon ConstructorNumber - [StgArg] -- Saturated + [StgArg] -- Saturated. (After Unarisation, [NonVoid StgArg]) [Type] -- See Note [Types in StgConApp] in GHC.Stg.Unarise | StgOpApp StgOp -- Primitive op or foreign call diff --git a/compiler/GHC/StgToCmm/Config.hs b/compiler/GHC/StgToCmm/Config.hs --- a/compiler/GHC/StgToCmm/Config.hs +++ b/compiler/GHC/StgToCmm/Config.hs @@ -49,8 +49,9 @@ , stgToCmmFastPAPCalls :: !Bool -- ^ , stgToCmmSCCProfiling :: !Bool -- ^ Check if cost-centre profiling is enabled , stgToCmmEagerBlackHole :: !Bool -- ^ - , stgToCmmInfoTableMap :: !Bool -- ^ true means generate C Stub for IPE map, See note [Mapping - -- Info Tables to Source Positions] + , stgToCmmInfoTableMap :: !Bool -- ^ true means generate C Stub for IPE map, See Note [Mapping Info Tables to Source Positions] + , stgToCmmInfoTableMapWithFallback :: !Bool -- ^ Include info tables with fallback source locations in the info table map + , stgToCmmInfoTableMapWithStack :: !Bool -- ^ Include info tables for STACK closures in the info table map , stgToCmmOmitYields :: !Bool -- ^ true means omit heap checks when no allocation is performed , stgToCmmOmitIfPragmas :: !Bool -- ^ true means don't generate interface programs (implied by -O0) , stgToCmmPIC :: !Bool -- ^ true if @-fPIC@ diff --git a/compiler/GHC/StgToCmm/Types.hs b/compiler/GHC/StgToCmm/Types.hs --- a/compiler/GHC/StgToCmm/Types.hs +++ b/compiler/GHC/StgToCmm/Types.hs @@ -70,6 +70,52 @@ * We don't absolutely guarantee to serialise the CgInfo: we won't if you have -fomit-interface-pragmas or -fno-code; and we won't read it in if you have -fignore-interface-pragmas. (We could revisit this decision.) + +Note [Imported unlifted nullary datacon wrappers must have correct LFInfo] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As described in `Note [Conveying CAF-info and LFInfo between modules]`, +imported unlifted nullary datacons must have their LambdaFormInfo set to +reflect the fact that they are evaluated . This is necessary as otherwise +references to them may be passed untagged to code that expects tagged +references. + +What may be less obvious is that this must be done for not only datacon +workers but also *wrappers*. The reason is found in this program +from #23146: + + module B where + + type NP :: [UnliftedType] -> UnliftedType + data NP xs where + UNil :: NP '[] + + + module A where + import B + + fieldsSam :: NP xs -> NP xs -> Bool + fieldsSam UNil UNil = True + + x = fieldsSam UNil UNil + +Due to its GADT nature, `B.UNil` produces a trivial wrapper + + $WUNil :: NP '[] + $WUNil = UNil @'[] @~() + +which is referenced in the RHS of `A.x`. If we fail to give `$WUNil` the +correct `LFCon 0` `LambdaFormInfo` then we will end up passing an untagged +pointer to `fieldsSam`. This is problematic as `fieldsSam` may take advantage +of the unlifted nature of its arguments by omitting handling of the zero +tag when scrutinising them. + +The fix is straightforward: extend the logic in `mkLFImported` to cover +(nullary) datacon wrappers as well as workers. This is safe because we +know that the wrapper of a nullary datacon will be in WHNF, even if it +includes equalities evidence (since such equalities are not runtime +relevant). This fixed #23146. + +See also Note [The LFInfo of Imported Ids] -} -- | Codegen-generated Id infos, to be passed to downstream via interfaces. @@ -118,7 +164,7 @@ !StandardFormInfo !Bool -- True <=> *might* be a function type - | LFCon -- A saturated constructor application + | LFCon -- A saturated data constructor application !DataCon -- The constructor | LFUnknown -- Used for function arguments and imported things. diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -1238,6 +1238,11 @@ = vcat [ text "Starting from GHC 9.10, this warning will turn into an error." ] user_manual = vcat [ text "See the user manual, § Undecidable instances and loopy superclasses." ] + TcRnCannotDefaultConcrete frr + -> mkSimpleDecorated $ + ppr (frr_context frr) $$ + text "cannot be assigned a fixed runtime representation," <+> + text "not even by defaulting." diagnosticReason = \case TcRnUnknownMessage m @@ -1646,6 +1651,8 @@ -> ErrorWithoutFlag TcRnLoopySuperclassSolve{} -> WarningWithFlag Opt_WarnLoopySuperclassSolve + TcRnCannotDefaultConcrete{} + -> ErrorWithoutFlag diagnosticHints = \case TcRnUnknownMessage m @@ -2064,6 +2071,8 @@ cls_or_qc = case ctLocOrigin wtd_loc of ScOrigin c_or_q _ -> c_or_q _ -> IsClsInst -- shouldn't happen + TcRnCannotDefaultConcrete{} + -> [SuggestAddTypeSignatures UnnamedBinding] diagnosticCode = constructorCode diff --git a/compiler/GHC/Tc/Errors/Types.hs b/compiler/GHC/Tc/Errors/Types.hs --- a/compiler/GHC/Tc/Errors/Types.hs +++ b/compiler/GHC/Tc/Errors/Types.hs @@ -2793,6 +2793,17 @@ -> PredType -- ^ Wanted 'PredType' -> TcRnMessage + {- TcRnCannotDefaultConcrete is an error occurring when a concrete + type variable cannot be defaulted. + + Test cases: + T23153 + -} + TcRnCannotDefaultConcrete + :: !FixedRuntimeRepOrigin + -> TcRnMessage + + deriving Generic -- | Things forbidden in @type data@ declarations. @@ -3322,7 +3333,9 @@ = EI { ei_pred :: PredType -- report about this -- The ei_pred field will never be an unboxed equality with -- a (casted) tyvar on the right; this is guaranteed by the solver - , ei_evdest :: Maybe TcEvDest -- for Wanteds, where to put evidence + , ei_evdest :: Maybe TcEvDest + -- ^ for Wanteds, where to put the evidence + -- for Givens, Nothing , ei_flavour :: CtFlavour , ei_loc :: CtLoc , ei_m_reason :: Maybe CtIrredReason -- if this ErrorItem was made from a diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -1774,7 +1774,12 @@ <+> ppr (deProposalCts p) type DefaultingPluginResult = [DefaultingProposal] -type FillDefaulting = WantedConstraints -> TcPluginM DefaultingPluginResult +type FillDefaulting + = WantedConstraints + -- Zonked constraints containing the unfilled metavariables that + -- can be defaulted. See wrinkle (DP1) of Note [Defaulting plugins] + -- in GHC.Tc.Solver + -> TcPluginM [DefaultingProposal] -- | A plugin for controlling defaulting. data DefaultingPlugin = forall s. DefaultingPlugin diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs --- a/compiler/GHC/Tc/Types/Constraint.hs +++ b/compiler/GHC/Tc/Types/Constraint.hs @@ -1338,6 +1338,7 @@ -- NB: including stuff used by nested implications that have since -- been discarded -- See Note [Needed evidence variables] + -- and (RC2) in Note [Tracking redundant constraints]a ic_need_inner :: VarSet, -- Includes all used Given evidence ic_need_outer :: VarSet, -- Includes only the free Given evidence -- i.e. ic_need_inner after deleting @@ -2127,10 +2128,10 @@ holes. The idea is that we wish to report the "root cause" -- the error that rewrote all the others. -Worry: It seems possible that *all* unsolved wanteds are rewritten by other -unsolved wanteds, so that e.g. w1 has w2 in its rewriter set, and w2 has -w1 in its rewiter set. We are unable to come up with an example of this in -practice, however, and so we believe this case cannot happen. +Wrinkle: In #22707, we have a case where all of the Wanteds have rewritten +each other. In order to report /some/ error in this case, we simply report +all the Wanteds. The user will get a perhaps-confusing error message, but +they've written a confusing program! Note [Avoiding rewriting cycles] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/GHC/Types/Demand.hs b/compiler/GHC/Types/Demand.hs --- a/compiler/GHC/Types/Demand.hs +++ b/compiler/GHC/Types/Demand.hs @@ -43,23 +43,20 @@ -- ** Manipulating Boxity of a Demand unboxDeeplyDmd, - -- * Demand environments - DmdEnv, emptyDmdEnv, - keepAliveDmdEnv, reuseEnv, - -- * Divergence Divergence(..), topDiv, botDiv, exnDiv, lubDivergence, isDeadEndDiv, + -- * Demand environments + DmdEnv(..), addVarDmdEnv, mkTermDmdEnv, nopDmdEnv, plusDmdEnv, plusDmdEnvs, + reuseEnv, + -- * Demand types DmdType(..), dmdTypeDepth, -- ** Algebra nopDmdType, botDmdType, - lubDmdType, plusDmdType, multDmdType, - -- *** PlusDmdArg - PlusDmdArg, mkPlusDmdArg, toPlusDmdArg, + lubDmdType, plusDmdType, multDmdType, discardArgDmds, -- ** Other operations peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException, - keepAliveDmdType, -- * Demand signatures DmdSig(..), mkDmdSigForArity, mkClosedDmdSig, mkVanillaDmdSig, @@ -85,9 +82,8 @@ import GHC.Prelude -import GHC.Types.Var ( Var, Id ) +import GHC.Types.Var import GHC.Types.Var.Env -import GHC.Types.Var.Set import GHC.Types.Unique.FM import GHC.Types.Basic import GHC.Data.Maybe ( orElse ) @@ -1054,7 +1050,7 @@ argsOneShots :: DmdSig -> Arity -> [[OneShotInfo]] -- ^ See Note [Computing one-shot info] -argsOneShots (DmdSig (DmdType _ arg_ds _)) n_val_args +argsOneShots (DmdSig (DmdType _ arg_ds)) n_val_args | unsaturated_call = [] | otherwise = go arg_ds where @@ -1466,7 +1462,7 @@ -- defaultFvDmd (r1 `lubDivergence` r2) = defaultFvDmd r1 `lubDmd` defaultFvDmd r2 -- (See Note [Default demand on free variables and arguments] for why) --- | See Note [Asymmetry of 'plus*'], which concludes that 'plusDivergence' +-- | See Note [Asymmetry of plusDmdType], which concludes that 'plusDivergence' -- needs to be symmetric. -- Strictly speaking, we should have @plusDivergence Dunno Diverges = ExnOrDiv@. -- But that regresses in too many places (every infinite loop, basically) to be @@ -1737,112 +1733,131 @@ -} -- Subject to Note [Default demand on free variables and arguments] -type DmdEnv = VarEnv Demand +-- | Captures the result of an evaluation of an expression, by +-- +-- * Listing how the free variables of that expression have been evaluted +-- ('de_fvs') +-- * Saying whether or not evaluation would surely diverge ('de_div') +-- +-- See Note [Demand env Equality]. +data DmdEnv = DE { de_fvs :: !(VarEnv Demand), de_div :: !Divergence } -emptyDmdEnv :: DmdEnv -emptyDmdEnv = emptyVarEnv +instance Eq DmdEnv where + DE fv1 div1 == DE fv2 div2 + = div1 == div2 && canonicalise div1 fv1 == canonicalise div2 fv2 + where + canonicalise div fv = filterUFM (/= defaultFvDmd div) fv +mkEmptyDmdEnv :: Divergence -> DmdEnv +mkEmptyDmdEnv div = DE emptyVarEnv div + +-- | Build a potentially terminating 'DmdEnv' from a finite map that says what +-- has been evaluated so far +mkTermDmdEnv :: VarEnv Demand -> DmdEnv +mkTermDmdEnv fvs = DE fvs topDiv + +nopDmdEnv :: DmdEnv +nopDmdEnv = mkEmptyDmdEnv topDiv + +botDmdEnv :: DmdEnv +botDmdEnv = mkEmptyDmdEnv botDiv + +exnDmdEnv :: DmdEnv +exnDmdEnv = mkEmptyDmdEnv exnDiv + +lubDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv +lubDmdEnv (DE fv1 d1) (DE fv2 d2) = DE lub_fv lub_div + where + -- See Note [Demand env Equality] + lub_fv = plusVarEnv_CD lubDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2) + lub_div = lubDivergence d1 d2 + +addVarDmdEnv :: DmdEnv -> Id -> Demand -> DmdEnv +addVarDmdEnv env@(DE fvs div) id dmd + = DE (extendVarEnv fvs id (dmd `plusDmd` lookupDmdEnv env id)) div + +plusDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv +plusDmdEnv (DE fv1 d1) (DE fv2 d2) + -- In contrast to Note [Asymmetry of plusDmdType], this function is symmetric. + | isEmptyVarEnv fv2, defaultFvDmd d2 == absDmd + = DE fv1 (d1 `plusDivergence` d2) -- a very common case that is much more efficient + | isEmptyVarEnv fv1, defaultFvDmd d1 == absDmd + = DE fv2 (d1 `plusDivergence` d2) -- another very common case that is much more efficient + | otherwise + = DE (plusVarEnv_CD plusDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2)) + (d1 `plusDivergence` d2) + +-- | 'DmdEnv' is a monoid via 'plusDmdEnv' and 'nopDmdEnv'; this is its 'msum' +plusDmdEnvs :: [DmdEnv] -> DmdEnv +plusDmdEnvs [] = nopDmdEnv +plusDmdEnvs pdas = foldl1' plusDmdEnv pdas + multDmdEnv :: Card -> DmdEnv -> DmdEnv -multDmdEnv C_11 env = env -multDmdEnv C_00 _ = emptyDmdEnv -multDmdEnv n env = mapVarEnv (multDmd n) env +multDmdEnv C_11 env = env +multDmdEnv C_00 _ = nopDmdEnv +multDmdEnv n (DE fvs div) = DE (mapVarEnv (multDmd n) fvs) (multDivergence n div) reuseEnv :: DmdEnv -> DmdEnv reuseEnv = multDmdEnv C_1N --- | @keepAliveDmdType dt vs@ makes sure that the Ids in @vs@ have --- /some/ usage in the returned demand types -- they are not Absent. --- See Note [Absence analysis for stable unfoldings and RULES] --- in "GHC.Core.Opt.DmdAnal". -keepAliveDmdEnv :: DmdEnv -> IdSet -> DmdEnv -keepAliveDmdEnv env vs - = nonDetStrictFoldVarSet add env vs - where - add :: Id -> DmdEnv -> DmdEnv - add v env = extendVarEnv_C add_dmd env v topDmd +lookupDmdEnv :: DmdEnv -> Id -> Demand +-- See Note [Default demand on free variables and arguments] +lookupDmdEnv (DE fv div) id = lookupVarEnv fv id `orElse` defaultFvDmd div - add_dmd :: Demand -> Demand -> Demand - -- If the existing usage is Absent, make it used - -- Otherwise leave it alone - add_dmd dmd _ | isAbsDmd dmd = topDmd - | otherwise = dmd +delDmdEnv :: DmdEnv -> Id -> DmdEnv +delDmdEnv (DE fv div) id = DE (fv `delVarEnv` id) div -- | Characterises how an expression -- --- * Evaluates its free variables ('dt_env') +-- * Evaluates its free variables ('dt_env') including divergence info -- * Evaluates its arguments ('dt_args') --- * Diverges on every code path or not ('dt_div') -- --- Equality is defined modulo 'defaultFvDmd's in 'dt_env'. --- See Note [Demand type Equality]. data DmdType = DmdType - { dt_env :: !DmdEnv -- ^ Demand on explicitly-mentioned free variables + { dt_env :: !DmdEnv -- ^ Demands on free variables. + -- See Note [Demand type Divergence] , dt_args :: ![Demand] -- ^ Demand on arguments - , dt_div :: !Divergence -- ^ Whether evaluation diverges. - -- See Note [Demand type Divergence] } --- | See Note [Demand type Equality]. +-- | See Note [Demand env Equality]. instance Eq DmdType where - (==) (DmdType fv1 ds1 div1) - (DmdType fv2 ds2 div2) = div1 == div2 && ds1 == ds2 -- cheap checks first - && canonicalise div1 fv1 == canonicalise div2 fv2 - where - canonicalise div fv = filterUFM (/= defaultFvDmd div) fv + DmdType env1 ds1 == DmdType env2 ds2 + = ds1 == ds2 -- cheap checks first + && env1 == env2 -- | Compute the least upper bound of two 'DmdType's elicited /by the same -- incoming demand/! lubDmdType :: DmdType -> DmdType -> DmdType -lubDmdType d1 d2 - = DmdType lub_fv lub_ds lub_div +lubDmdType d1 d2 = DmdType lub_fv lub_ds where n = max (dmdTypeDepth d1) (dmdTypeDepth d2) - (DmdType fv1 ds1 r1) = etaExpandDmdType n d1 - (DmdType fv2 ds2 r2) = etaExpandDmdType n d2 - - -- See Note [Demand type Equality] - lub_fv = plusVarEnv_CD lubDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd r2) + (DmdType fv1 ds1) = etaExpandDmdType n d1 + (DmdType fv2 ds2) = etaExpandDmdType n d2 lub_ds = zipWithEqual "lubDmdType" lubDmd ds1 ds2 - lub_div = lubDivergence r1 r2 - -type PlusDmdArg = (DmdEnv, Divergence) - -mkPlusDmdArg :: DmdEnv -> PlusDmdArg -mkPlusDmdArg env = (env, topDiv) + lub_fv = lubDmdEnv fv1 fv2 -toPlusDmdArg :: DmdType -> PlusDmdArg -toPlusDmdArg (DmdType fv _ r) = (fv, r) +discardArgDmds :: DmdType -> DmdEnv +discardArgDmds (DmdType fv _) = fv -plusDmdType :: DmdType -> PlusDmdArg -> DmdType -plusDmdType (DmdType fv1 ds1 r1) (fv2, t2) - -- See Note [Asymmetry of 'plus*'] - -- 'plus' takes the argument/result info from its *first* arg, - -- using its second arg just for its free-var info. - | isEmptyVarEnv fv2, defaultFvDmd t2 == absDmd - = DmdType fv1 ds1 (r1 `plusDivergence` t2) -- a very common case that is much more efficient - | otherwise - = DmdType (plusVarEnv_CD plusDmd fv1 (defaultFvDmd r1) fv2 (defaultFvDmd t2)) - ds1 - (r1 `plusDivergence` t2) +plusDmdType :: DmdType -> DmdEnv -> DmdType +plusDmdType (DmdType fv ds) fv' + -- See Note [Asymmetry of plusDmdType] + -- 'DmdEnv' forms a (monoidal) action on 'DmdType' via this operation. + = DmdType (plusDmdEnv fv fv') ds botDmdType :: DmdType -botDmdType = DmdType emptyDmdEnv [] botDiv +botDmdType = DmdType botDmdEnv [] -- | The demand type of doing nothing (lazy, absent, no Divergence -- information). Note that it is ''not'' the top of the lattice (which would be -- "may use everything"), so it is (no longer) called topDmdType. nopDmdType :: DmdType -nopDmdType = DmdType emptyDmdEnv [] topDiv - -isNopDmdType :: DmdType -> Bool -isNopDmdType (DmdType env args div) - = div == topDiv && null args && isEmptyVarEnv env +nopDmdType = DmdType nopDmdEnv [] -- | The demand type of an unspecified expression that is guaranteed to -- throw a (precise or imprecise) exception or diverge. exnDmdType :: DmdType -exnDmdType = DmdType emptyDmdEnv [] exnDiv +exnDmdType = DmdType exnDmdEnv [] dmdTypeDepth :: DmdType -> Arity dmdTypeDepth = length . dt_args @@ -1851,7 +1866,7 @@ -- expansion, where n must not be lower than the demand types depth. -- It appends the argument list with the correct 'defaultArgDmd'. etaExpandDmdType :: Arity -> DmdType -> DmdType -etaExpandDmdType n d@DmdType{dt_args = ds, dt_div = div} +etaExpandDmdType n d@DmdType{dt_args = ds, dt_env = env} | n == depth = d | n > depth = d{dt_args = inc_ds} | otherwise = pprPanic "etaExpandDmdType: arity decrease" (ppr n $$ ppr d) @@ -1863,7 +1878,7 @@ -- * Divergence is still valid: -- - A dead end after 2 arguments stays a dead end after 3 arguments -- - The remaining case is Dunno, which is already topDiv - inc_ds = take n (ds ++ repeat (defaultArgDmd div)) + inc_ds = take n (ds ++ repeat (defaultArgDmd (de_div env))) -- | A conservative approximation for a given 'DmdType' in case of an arity -- decrease. Currently, it's just nopDmdType. @@ -1875,30 +1890,27 @@ -- We already have a suitable demand on all -- free vars, so no need to add more! splitDmdTy ty@DmdType{dt_args=dmd:args} = (dmd, ty{dt_args=args}) -splitDmdTy ty@DmdType{dt_div=div} = (defaultArgDmd div, ty) +splitDmdTy ty@DmdType{dt_env=env} = (defaultArgDmd (de_div env), ty) multDmdType :: Card -> DmdType -> DmdType -multDmdType n (DmdType fv args res_ty) +multDmdType n (DmdType fv args) = -- pprTrace "multDmdType" (ppr n $$ ppr fv $$ ppr (multDmdEnv n fv)) $ DmdType (multDmdEnv n fv) (map (multDmd n) args) - (multDivergence n res_ty) peelFV :: DmdType -> Var -> (DmdType, Demand) -peelFV (DmdType fv ds res) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) - (DmdType fv' ds res, dmd) +peelFV (DmdType fv ds) id = -- pprTrace "rfv" (ppr id <+> ppr dmd $$ ppr fv) + (DmdType fv' ds, dmd) where -- Force these arguments so that old `Env` is not retained. - !fv' = fv `delVarEnv` id - -- See Note [Default demand on free variables and arguments] - !dmd = lookupVarEnv fv id `orElse` defaultFvDmd res + !fv' = fv `delDmdEnv` id + !dmd = lookupDmdEnv fv id addDemand :: Demand -> DmdType -> DmdType -addDemand dmd (DmdType fv ds res) = DmdType fv (dmd:ds) res +addDemand dmd (DmdType fv ds) = DmdType fv (dmd:ds) findIdDemand :: DmdType -> Var -> Demand -findIdDemand (DmdType fv _ res) id - = lookupVarEnv fv id `orElse` defaultFvDmd res +findIdDemand (DmdType fv _) id = lookupDmdEnv fv id -- | When e is evaluated after executing an IO action that may throw a precise -- exception, we act as if there is an additional control flow path that is @@ -1914,11 +1926,6 @@ deferAfterPreciseException :: DmdType -> DmdType deferAfterPreciseException = lubDmdType exnDmdType --- | See 'keepAliveDmdEnv'. -keepAliveDmdType :: DmdType -> VarSet -> DmdType -keepAliveDmdType (DmdType fvs ds res) vars = - DmdType (fvs `keepAliveDmdEnv` vars) ds res - {- Note [deferAfterPreciseException] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The big picture is in Note [Precise exceptions and strictness analysis] @@ -1974,32 +1981,25 @@ strong enough to unleash err's signature and hence we see that the whole expression diverges! -Note [Demand type Equality] +Note [Demand env Equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What is the difference between the DmdType {x->A} and ? +What is the difference between the Demand env {x->A} and {}? Answer: There is none! They have the exact same semantics, because any var that -is not mentioned in 'dt_env' implicitly has demand 'defaultFvDmd', based on -the divergence of the demand type 'dt_div'. -Similarly, b{x->B, y->A} is the same as b{y->A}, because the default FV -demand of BotDiv is B. But neither is equal to b, because y has demand B in +is not mentioned in 'de_fvs' implicitly has demand 'defaultFvDmd', based on +the divergence of the demand env 'de_div'. +Similarly, b{x->B, y->A} is the same as b{y->A}, because the default FV +demand of BotDiv is B. But neither is equal to b{}, because y has demand B in the latter, not A as before. -NB: 'dt_env' technically can't stand for its own, because it doesn't tell us the -demand on FVs that don't appear in the DmdEnv. Hence 'PlusDmdArg' carries along -a 'Divergence', for example. - -The Eq instance of DmdType must reflect that, otherwise we can get into monotonicity -issues during fixed-point iteration ({x->A} /= /= {x->A} /= ...). -It does so by filtering out any default FV demands prior to comparing 'dt_env'. -An alternative would be to maintain an invariant that there are no default FV demands -in 'dt_env' to begin with, but that seems more involved to maintain in the current -implementation. +The Eq instance of DmdEnv must reflect that, otherwise we can get into monotonicity +issues during fixed-point iteration ({x->A} /= {} /= {x->A} /= ...). +It does so by filtering out any default FV demands prior to comparing 'de_fvs'. -Note that 'lubDmdType' maintains this kind of equality by using 'plusVarEnv_CD', -involving 'defaultFvDmd' for any entries present in one 'dt_env' but not the +Note that 'lubDmdEnv' maintains this kind of equality by using 'plusVarEnv_CD', +involving 'defaultFvDmd' for any entries present in one 'de_fvs' but not the other. -Note [Asymmetry of 'plus*'] +Note [Asymmetry of plusDmdType] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ 'plus' for DmdTypes is *asymmetrical*, because there can only one be one type contributing argument demands! For example, given (e1 e2), we get @@ -2155,24 +2155,24 @@ -- | Turns a 'DmdType' computed for the particular 'Arity' into a 'DmdSig' -- unleashable at that arity. See Note [Understanding DmdType and DmdSig]. mkDmdSigForArity :: Arity -> DmdType -> DmdSig -mkDmdSigForArity arity dmd_ty@(DmdType fvs args div) - | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args) div +mkDmdSigForArity arity dmd_ty@(DmdType fvs args) + | arity < dmdTypeDepth dmd_ty = DmdSig $ DmdType fvs (take arity args) | otherwise = DmdSig (etaExpandDmdType arity dmd_ty) mkClosedDmdSig :: [Demand] -> Divergence -> DmdSig -mkClosedDmdSig ds res = mkDmdSigForArity (length ds) (DmdType emptyDmdEnv ds res) +mkClosedDmdSig ds div = mkDmdSigForArity (length ds) (DmdType (mkEmptyDmdEnv div) ds) mkVanillaDmdSig :: Arity -> Divergence -> DmdSig mkVanillaDmdSig ar div = mkClosedDmdSig (replicate ar topDmd) div splitDmdSig :: DmdSig -> ([Demand], Divergence) -splitDmdSig (DmdSig (DmdType _ dmds res)) = (dmds, res) +splitDmdSig (DmdSig (DmdType env dmds)) = (dmds, de_div env) dmdSigDmdEnv :: DmdSig -> DmdEnv -dmdSigDmdEnv (DmdSig (DmdType env _ _)) = env +dmdSigDmdEnv (DmdSig (DmdType env _)) = env hasDemandEnvSig :: DmdSig -> Bool -hasDemandEnvSig = not . isEmptyVarEnv . dmdSigDmdEnv +hasDemandEnvSig = not . isEmptyVarEnv . de_fvs . dmdSigDmdEnv botSig :: DmdSig botSig = DmdSig botDmdType @@ -2181,23 +2181,23 @@ nopSig = DmdSig nopDmdType isNopSig :: DmdSig -> Bool -isNopSig (DmdSig ty) = isNopDmdType ty +isNopSig (DmdSig ty) = ty == nopDmdType -- | True if the signature diverges or throws an exception in a saturated call. -- See Note [Dead ends]. isDeadEndSig :: DmdSig -> Bool -isDeadEndSig (DmdSig (DmdType _ _ res)) = isDeadEndDiv res +isDeadEndSig (DmdSig (DmdType env _)) = isDeadEndDiv (de_div env) -- | True if the signature diverges or throws an imprecise exception in a saturated call. -- NB: In constrast to 'isDeadEndSig' this returns False for 'exnDiv'. -- See Note [Dead ends] -- and Note [Precise vs imprecise exceptions]. isBottomingSig :: DmdSig -> Bool -isBottomingSig (DmdSig (DmdType _ _ res)) = res == botDiv +isBottomingSig (DmdSig (DmdType env _)) = de_div env == botDiv -- | True when the signature indicates all arguments are boxed onlyBoxedArguments :: DmdSig -> Bool -onlyBoxedArguments (DmdSig (DmdType _ dmds _)) = all demandIsBoxed dmds +onlyBoxedArguments (DmdSig (DmdType _ dmds)) = all demandIsBoxed dmds where demandIsBoxed BotDmd = True demandIsBoxed AbsDmd = True @@ -2217,12 +2217,15 @@ -- Hence this function conservatively returns False in that case. -- See Note [Dead ends]. isDeadEndAppSig :: DmdSig -> Int -> Bool -isDeadEndAppSig (DmdSig (DmdType _ ds res)) n - = isDeadEndDiv res && not (lengthExceeds ds n) +isDeadEndAppSig (DmdSig (DmdType env ds)) n + = isDeadEndDiv (de_div env) && not (lengthExceeds ds n) +trimBoxityDmdEnv :: DmdEnv -> DmdEnv +trimBoxityDmdEnv (DE fvs div) = DE (mapVarEnv trimBoxity fvs) div + trimBoxityDmdType :: DmdType -> DmdType -trimBoxityDmdType (DmdType fvs ds res) = - DmdType (mapVarEnv trimBoxity fvs) (map trimBoxity ds) res +trimBoxityDmdType (DmdType env ds) = + DmdType (trimBoxityDmdEnv env) (map trimBoxity ds) trimBoxityDmdSig :: DmdSig -> DmdSig trimBoxityDmdSig = coerce trimBoxityDmdType @@ -2247,12 +2250,11 @@ _ -> trimBoxity to_dmd transferArgBoxityDmdType :: DmdType -> DmdType -> DmdType -transferArgBoxityDmdType _from@(DmdType _ from_ds _) to@(DmdType to_fvs to_ds to_res) +transferArgBoxityDmdType _from@(DmdType _ from_ds) to@(DmdType to_env to_ds) | equalLength from_ds to_ds = -- pprTraceWith "transfer" (\r -> ppr _from $$ ppr to $$ ppr r) $ - DmdType to_fvs -- Only arg boxity! See Note [Don't change boxity without worker/wrapper] + DmdType to_env -- Only arg boxity! See Note [Don't change boxity without worker/wrapper] (zipWith transferBoxity from_ds to_ds) - to_res | otherwise = trimBoxityDmdType to @@ -2263,10 +2265,10 @@ -- ^ Add extra ('topDmd') arguments to a strictness signature. -- In contrast to 'etaConvertDmdSig', this /prepends/ additional argument -- demands. This is used by FloatOut. -prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds res)) - | new_args == 0 = sig - | isNopDmdType dmd_ty = sig - | otherwise = DmdSig (DmdType env dmds' res) +prependArgsDmdSig new_args sig@(DmdSig dmd_ty@(DmdType env dmds)) + | new_args == 0 = sig + | dmd_ty == nopDmdType = sig + | otherwise = DmdSig (DmdType env dmds') where dmds' = assertPpr (new_args > 0) (ppr new_args) $ replicate new_args topDmd ++ dmds @@ -2308,7 +2310,7 @@ -- Given a function's 'DmdSig' and a 'SubDemand' for the evaluation context, -- return how the function evaluates its free variables and arguments. dmdTransformSig :: DmdSig -> DmdTransformer -dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds _)) sd +dmdTransformSig (DmdSig dmd_ty@(DmdType _ arg_ds)) sd = multDmdType (fst $ peelManyCalls (length arg_ds) sd) dmd_ty -- see Note [Demands from unsaturated function calls] -- and Note [What are demand signatures?] @@ -2323,7 +2325,7 @@ where arity = length str_marks (n, body_sd) = peelManyCalls arity sd - mk_body_ty n dmds = DmdType emptyDmdEnv (zipWith (bump n) str_marks dmds) topDiv + mk_body_ty n dmds = DmdType nopDmdEnv (zipWith (bump n) str_marks dmds) bump n str dmd | isMarkedStrict str = multDmd n (plusDmd str_field_dmd dmd) | otherwise = multDmd n dmd str_field_dmd = C_01 :* seqSubDmd -- Why not C_11? See Note [Data-con worker strictness] @@ -2334,11 +2336,11 @@ dmdTransformDictSelSig :: DmdSig -> DmdTransformer -- NB: This currently doesn't handle newtype dictionaries. -- It should simply apply call_sd directly to the dictionary, I suppose. -dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod] _)) call_sd +dmdTransformDictSelSig (DmdSig (DmdType _ [_ :* prod])) call_sd | (n, sd') <- peelCallDmd call_sd , Prod _ sig_ds <- prod = multDmdType n $ - DmdType emptyDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)] topDiv + DmdType nopDmdEnv [C_11 :* mkProd Unboxed (map (enhance sd') sig_ds)] | otherwise = nopDmdType -- See Note [Demand transformer for a dictionary selector] where @@ -2460,9 +2462,12 @@ it should not fall over. -} +zapDmdEnv :: DmdEnv -> DmdEnv +zapDmdEnv (DE _ div) = mkEmptyDmdEnv div + -- | Remove the demand environment from the signature. zapDmdEnvSig :: DmdSig -> DmdSig -zapDmdEnvSig (DmdSig (DmdType _ ds r)) = mkClosedDmdSig ds r +zapDmdEnvSig (DmdSig (DmdType env ds)) = DmdSig (DmdType (zapDmdEnv env) ds) zapUsageDemand :: Demand -> Demand -- Remove the usage info, but not the strictness info, from the demand @@ -2483,8 +2488,8 @@ -- | Remove all `C_01 :*` info (but not `CM` sub-demands) from the strictness -- signature zapUsedOnceSig :: DmdSig -> DmdSig -zapUsedOnceSig (DmdSig (DmdType env ds r)) - = DmdSig (DmdType env (map zapUsedOnceDemand ds) r) +zapUsedOnceSig (DmdSig (DmdType env ds)) + = DmdSig (DmdType env (map zapUsedOnceDemand ds)) data KillFlags = KillFlags { kf_abs :: Bool @@ -2569,11 +2574,11 @@ seqDemandList = foldr (seq . seqDemand) () seqDmdType :: DmdType -> () -seqDmdType (DmdType env ds res) = - seqDmdEnv env `seq` seqDemandList ds `seq` res `seq` () +seqDmdType (DmdType env ds) = + seqDmdEnv env `seq` seqDemandList ds `seq` () seqDmdEnv :: DmdEnv -> () -seqDmdEnv env = seqEltsUFM seqDemand env +seqDmdEnv (DE fvs _) = seqEltsUFM seqDemand fvs seqDmdSig :: DmdSig -> () seqDmdSig (DmdSig ty) = seqDmdType ty @@ -2682,17 +2687,20 @@ ppr ExnOrDiv = char 'x' -- for e(x)ception ppr Dunno = empty -instance Outputable DmdType where - ppr (DmdType fv ds res) - = hsep [hcat (map (angleBrackets . ppr) ds) <> ppr res, - if null fv_elts then empty - else braces (fsep (map pp_elt fv_elts))] +instance Outputable DmdEnv where + ppr (DE fvs div) + = ppr div <> if null fv_elts then empty + else braces (fsep (map pp_elt fv_elts)) where pp_elt (uniq, dmd) = ppr uniq <> text "->" <> ppr dmd - fv_elts = nonDetUFMToList fv + fv_elts = nonDetUFMToList fvs -- It's OK to use nonDetUFMToList here because we only do it for -- pretty printing +instance Outputable DmdType where + ppr (DmdType fv ds) + = hcat (map (angleBrackets . ppr) ds) <> ppr fv + instance Outputable DmdSig where ppr (DmdSig ty) = ppr ty @@ -2741,15 +2749,6 @@ 2 -> Prod <$> get bh <*> get bh _ -> pprPanic "Binary:SubDemand" (ppr (fromIntegral h :: Int)) -instance Binary DmdSig where - put_ bh (DmdSig aa) = put_ bh aa - get bh = DmdSig <$> get bh - -instance Binary DmdType where - -- Ignore DmdEnv when spitting out the DmdType - put_ bh (DmdType _ ds dr) = put_ bh ds *> put_ bh dr - get bh = DmdType emptyDmdEnv <$> get bh <*> get bh - instance Binary Divergence where put_ bh Dunno = putByte bh 0 put_ bh ExnOrDiv = putByte bh 1 @@ -2761,3 +2760,16 @@ 1 -> return ExnOrDiv 2 -> return Diverges _ -> pprPanic "Binary:Divergence" (ppr (fromIntegral h :: Int)) + +instance Binary DmdEnv where + -- Ignore VarEnv when spitting out the DmdType + put_ bh (DE _ d) = put_ bh d + get bh = DE emptyVarEnv <$> get bh + +instance Binary DmdType where + put_ bh (DmdType fv ds) = put_ bh fv *> put_ bh ds + get bh = DmdType <$> get bh <*> get bh + +instance Binary DmdSig where + put_ bh (DmdSig aa) = put_ bh aa + get bh = DmdSig <$> get bh diff --git a/compiler/GHC/Types/Error/Codes.hs b/compiler/GHC/Types/Error/Codes.hs --- a/compiler/GHC/Types/Error/Codes.hs +++ b/compiler/GHC/Types/Error/Codes.hs @@ -598,6 +598,8 @@ GhcDiagnosticCode "EmptyStmtsGroupInDoNotation" = 82311 GhcDiagnosticCode "EmptyStmtsGroupInArrowNotation" = 19442 + GhcDiagnosticCode "TcRnCannotDefaultConcrete" = 52083 + -- To generate new random numbers: -- https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain -- diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs --- a/compiler/GHC/Types/Id.hs +++ b/compiler/GHC/Types/Id.hs @@ -697,6 +697,8 @@ setIdCallArity :: Id -> Arity -> Id setIdCallArity id arity = modifyIdInfo (`setCallArityInfo` arity) id +-- | This function counts all arguments post-unarisation, which includes +-- arguments with no runtime representation -- see Note [Unarisation and arity] idFunRepArity :: Id -> RepArity idFunRepArity x = countFunRepArgs (idArity x) (idType x) diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -369,6 +369,7 @@ -- -- See documentation of the getters for what these packed fields mean. lfInfo :: !(Maybe LambdaFormInfo), + -- ^ See Note [The LFInfo of Imported Ids] in GHC.StgToCmm.Closure -- See documentation of the getters for what these packed fields mean. tagSig :: !(Maybe TagSig) @@ -434,7 +435,7 @@ oneShotInfo = bitfieldGetOneShotInfo . bitfield -- | 'Id' arity, as computed by "GHC.Core.Opt.Arity". Specifies how many arguments --- this 'Id' has to be applied to before it doesn any meaningful work. +-- this 'Id' has to be applied to before it does any meaningful work. arityInfo :: IdInfo -> ArityInfo arityInfo = bitfieldGetArityInfo . bitfield diff --git a/compiler/GHC/Types/Literal.hs b/compiler/GHC/Types/Literal.hs --- a/compiler/GHC/Types/Literal.hs +++ b/compiler/GHC/Types/Literal.hs @@ -1000,8 +1000,9 @@ take apart a case scrutinisation on, or arg occurrence of, e.g., `RUBBISH[TupleRep[IntRep,DoubleRep]]` (which may stand in for `(# Int#, Double# #)`) into its sub-parts `RUBBISH[IntRep]` and `RUBBISH[DoubleRep]`, similar to - unboxed tuples. `RUBBISH[VoidRep]` is erased. - See 'unariseRubbish_maybe' and also Note [Post-unarisation invariants]. + unboxed tuples. + + See 'unariseLiteral_maybe' and also Note [Post-unarisation invariants]. 4. Cmm: We translate 'LitRubbish' to their actual rubbish value in 'cgLit'. The particulars are boring, and only matter when debugging illicit use of diff --git a/compiler/GHC/Types/RepType.hs b/compiler/GHC/Types/RepType.hs --- a/compiler/GHC/Types/RepType.hs +++ b/compiler/GHC/Types/RepType.hs @@ -602,8 +602,10 @@ = pprPanic "kindPrimRep" (ppr ki) -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that --- it encodes. See also Note [Getting from RuntimeRep to PrimRep] --- The [PrimRep] is the final runtime representation /after/ unarisation +-- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. +-- The @[PrimRep]@ is the final runtime representation /after/ unarisation. +-- +-- The result does not contain any VoidRep. runtimeRepPrimRep :: HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep] runtimeRepPrimRep doc rr_ty | Just rr_ty' <- coreView rr_ty @@ -615,9 +617,11 @@ = pprPanic "runtimeRepPrimRep" (doc $$ ppr rr_ty) -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that --- it encodes. See also Note [Getting from RuntimeRep to PrimRep] --- The [PrimRep] is the final runtime representation /after/ unarisation --- Returns Nothing if rep can't be determined. Eg. levity polymorphic types. +-- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. +-- The @[PrimRep]@ is the final runtime representation /after/ unarisation +-- and does not contain VoidRep. +-- +-- Returns @Nothing@ if rep can't be determined. Eg. levity polymorphic types. runtimeRepPrimRep_maybe :: Type -> Maybe [PrimRep] runtimeRepPrimRep_maybe rr_ty | Just rr_ty' <- coreView rr_ty diff --git a/compiler/GHC/Utils/Binary.hs b/compiler/GHC/Utils/Binary.hs --- a/compiler/GHC/Utils/Binary.hs +++ b/compiler/GHC/Utils/Binary.hs @@ -1211,13 +1211,13 @@ putBS bh bs = BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do put_ bh l - putPrim bh l (\op -> BS.memcpy op (castPtr ptr) l) + putPrim bh l (\op -> copyBytes op (castPtr ptr) l) getBS :: BinHandle -> IO ByteString getBS bh = do l <- get bh :: IO Int BS.create l $ \dest -> do - getPrim bh l (\src -> BS.memcpy dest src l) + getPrim bh l (\src -> copyBytes dest src l) instance Binary ByteString where put_ bh f = putBS bh f diff --git a/compiler/GHC/Utils/TmpFs.hs b/compiler/GHC/Utils/TmpFs.hs --- a/compiler/GHC/Utils/TmpFs.hs +++ b/compiler/GHC/Utils/TmpFs.hs @@ -6,18 +6,19 @@ , initTmpFs , forkTmpFsFrom , mergeTmpFsInto - , FilesToClean(..) - , emptyFilesToClean + , PathsToClean(..) + , emptyPathsToClean , TempFileLifetime(..) , TempDir (..) , cleanTempDirs , cleanTempFiles , cleanCurrentModuleTempFiles + , keepCurrentModuleTempFiles , addFilesToClean , changeTempFilesLifetime , newTempName , newTempLibName - , newTempDir + , newTempSubDir , withSystemTempDirectory , withTempDirectory ) @@ -63,25 +64,29 @@ -- -- Shared with forked TmpFs. - , tmp_files_to_clean :: IORef FilesToClean + , tmp_files_to_clean :: IORef PathsToClean -- ^ Files to clean (per session or per module) -- -- Not shared with forked TmpFs. + , tmp_subdirs_to_clean :: IORef PathsToClean + -- ^ Subdirs to clean (per session or per module) + -- + -- Not shared with forked TmpFs. } --- | A collection of files that must be deleted before ghc exits. -data FilesToClean = FilesToClean - { ftcGhcSession :: !(Set FilePath) - -- ^ Files that will be deleted at the end of runGhc(T) +-- | A collection of paths that must be deleted before ghc exits. +data PathsToClean = PathsToClean + { ptcGhcSession :: !(Set FilePath) + -- ^ Paths that will be deleted at the end of runGhc(T) - , ftcCurrentModule :: !(Set FilePath) - -- ^ Files that will be deleted the next time + , ptcCurrentModule :: !(Set FilePath) + -- ^ Paths that will be deleted the next time -- 'cleanCurrentModuleTempFiles' is called, or otherwise at the end of -- the session. } -- | Used when a temp file is created. This determines which component Set of --- FilesToClean will get the temp file +-- PathsToClean will get the temp file data TempFileLifetime = TFL_CurrentModule -- ^ A file with lifetime TFL_CurrentModule will be cleaned up at the @@ -93,38 +98,45 @@ newtype TempDir = TempDir FilePath --- | An empty FilesToClean -emptyFilesToClean :: FilesToClean -emptyFilesToClean = FilesToClean Set.empty Set.empty +-- | An empty PathsToClean +emptyPathsToClean :: PathsToClean +emptyPathsToClean = PathsToClean Set.empty Set.empty --- | Merge two FilesToClean -mergeFilesToClean :: FilesToClean -> FilesToClean -> FilesToClean -mergeFilesToClean x y = FilesToClean - { ftcGhcSession = Set.union (ftcGhcSession x) (ftcGhcSession y) - , ftcCurrentModule = Set.union (ftcCurrentModule x) (ftcCurrentModule y) +-- | Merge two PathsToClean +mergePathsToClean :: PathsToClean -> PathsToClean -> PathsToClean +mergePathsToClean x y = PathsToClean + { ptcGhcSession = Set.union (ptcGhcSession x) (ptcGhcSession y) + , ptcCurrentModule = Set.union (ptcCurrentModule x) (ptcCurrentModule y) } -- | Initialise an empty TmpFs initTmpFs :: IO TmpFs initTmpFs = do - files <- newIORef emptyFilesToClean - dirs <- newIORef Map.empty - next <- newIORef 0 + files <- newIORef emptyPathsToClean + subdirs <- newIORef emptyPathsToClean + dirs <- newIORef Map.empty + next <- newIORef 0 return $ TmpFs - { tmp_files_to_clean = files - , tmp_dirs_to_clean = dirs - , tmp_next_suffix = next + { tmp_files_to_clean = files + , tmp_subdirs_to_clean = subdirs + , tmp_dirs_to_clean = dirs + , tmp_next_suffix = next } -- | Initialise an empty TmpFs sharing unique numbers and per-process temporary -- directories with the given TmpFs +-- +-- It's not safe to use the subdirs created by the original TmpFs with the +-- forked one. Use @newTempSubDir@ to create new subdirs instead. forkTmpFsFrom :: TmpFs -> IO TmpFs forkTmpFsFrom old = do - files <- newIORef emptyFilesToClean + files <- newIORef emptyPathsToClean + subdirs <- newIORef emptyPathsToClean return $ TmpFs - { tmp_files_to_clean = files - , tmp_dirs_to_clean = tmp_dirs_to_clean old - , tmp_next_suffix = tmp_next_suffix old + { tmp_files_to_clean = files + , tmp_subdirs_to_clean = subdirs + , tmp_dirs_to_clean = tmp_dirs_to_clean old + , tmp_next_suffix = tmp_next_suffix old } -- | Merge the first TmpFs into the second. @@ -132,9 +144,12 @@ -- The first TmpFs is returned emptied. mergeTmpFsInto :: TmpFs -> TmpFs -> IO () mergeTmpFsInto src dst = do - src_files <- atomicModifyIORef' (tmp_files_to_clean src) (\s -> (emptyFilesToClean, s)) - atomicModifyIORef' (tmp_files_to_clean dst) (\s -> (mergeFilesToClean src_files s, ())) + src_files <- atomicModifyIORef' (tmp_files_to_clean src) (\s -> (emptyPathsToClean, s)) + src_subdirs <- atomicModifyIORef' (tmp_subdirs_to_clean src) (\s -> (emptyPathsToClean, s)) + atomicModifyIORef' (tmp_files_to_clean dst) (\s -> (mergePathsToClean src_files s, ())) + atomicModifyIORef' (tmp_subdirs_to_clean dst) (\s -> (mergePathsToClean src_subdirs s, ())) + cleanTempDirs :: Logger -> TmpFs -> IO () cleanTempDirs logger tmpfs = mask_ @@ -142,64 +157,104 @@ ds <- atomicModifyIORef' ref $ \ds -> (Map.empty, ds) removeTmpDirs logger (Map.elems ds) --- | Delete all files in @tmp_files_to_clean@. +-- | Delete all paths in @tmp_files_to_clean@ and @tmp_subdirs_to_clean@. cleanTempFiles :: Logger -> TmpFs -> IO () cleanTempFiles logger tmpfs = mask_ - $ do let ref = tmp_files_to_clean tmpfs - to_delete <- atomicModifyIORef' ref $ - \FilesToClean - { ftcCurrentModule = cm_files - , ftcGhcSession = gs_files - } -> ( emptyFilesToClean - , Set.toList cm_files ++ Set.toList gs_files) - removeTmpFiles logger to_delete + $ do removeWith (removeTmpFiles logger) (tmp_files_to_clean tmpfs) + removeWith (removeTmpSubdirs logger) (tmp_subdirs_to_clean tmpfs) + where + removeWith remove ref = do + to_delete <- atomicModifyIORef' ref $ + \PathsToClean + { ptcCurrentModule = cm_paths + , ptcGhcSession = gs_paths + } -> ( emptyPathsToClean + , Set.toList cm_paths ++ Set.toList gs_paths) + remove to_delete --- | Delete all files in @tmp_files_to_clean@. That have lifetime --- TFL_CurrentModule. +-- | Keep all the paths in @tmp_files_to_clean@ and @tmp_subdirs_to_clean@ +-- that have lifetime TFL_CurrentModule. This function is used when `-keep-tmp-files` is +-- used in an OPTIONS_GHC pragma. +-- This function removes the temporary file from the TmpFs so we no longer remove +-- it at the env when cleanTempFiles is called. +keepCurrentModuleTempFiles :: HasCallStack => Logger -> TmpFs -> IO () +keepCurrentModuleTempFiles logger tmpfs + = mask_ + $ do to_keep_files <- keep (tmp_files_to_clean tmpfs) + to_keep_subdirs <- keep (tmp_subdirs_to_clean tmpfs) + -- Remove any folders which contain any files we want to keep from the + -- directories we are tracking. A new temporary directory will be created + -- the next time a temporary file is needed (by perhaps another module). + keepDirs (to_keep_files ++ to_keep_subdirs) (tmp_dirs_to_clean tmpfs) + where + keepDirs keeps ref = do + let keep_dirs = Set.fromList (map takeDirectory keeps) + atomicModifyIORef' ref $ \m -> (Map.filter (\fp -> fp `Set.notMember` keep_dirs) m, ()) + + keep ref = do + to_keep <- atomicModifyIORef' ref $ + \ptc@PathsToClean{ptcCurrentModule = cm_paths} -> + (ptc {ptcCurrentModule = Set.empty}, Set.toList cm_paths) + debugTraceMsg logger 2 (text "Keeping:" <+> hsep (map text to_keep)) + return to_keep + +-- | Delete all paths in @tmp_files_to_clean@ and @tmp_subdirs_to_clean@ +-- That have lifetime TFL_CurrentModule. -- If a file must be cleaned eventually, but must survive a -- cleanCurrentModuleTempFiles, ensure it has lifetime TFL_GhcSession. cleanCurrentModuleTempFiles :: Logger -> TmpFs -> IO () cleanCurrentModuleTempFiles logger tmpfs = mask_ - $ do let ref = tmp_files_to_clean tmpfs + $ do removeWith (removeTmpFiles logger) (tmp_files_to_clean tmpfs) + removeWith (removeTmpSubdirs logger) (tmp_subdirs_to_clean tmpfs) + where + removeWith remove ref = do to_delete <- atomicModifyIORef' ref $ - \ftc@FilesToClean{ftcCurrentModule = cm_files} -> - (ftc {ftcCurrentModule = Set.empty}, Set.toList cm_files) - removeTmpFiles logger to_delete + \ptc@PathsToClean{ptcCurrentModule = cm_paths} -> + (ptc {ptcCurrentModule = Set.empty}, Set.toList cm_paths) + remove to_delete -- | Ensure that new_files are cleaned on the next call of -- 'cleanTempFiles' or 'cleanCurrentModuleTempFiles', depending on lifetime. -- If any of new_files are already tracked, they will have their lifetime -- updated. addFilesToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO () -addFilesToClean tmpfs lifetime new_files = modifyIORef' (tmp_files_to_clean tmpfs) $ - \FilesToClean - { ftcCurrentModule = cm_files - , ftcGhcSession = gs_files +addFilesToClean tmpfs lifetime new_files = + addToClean (tmp_files_to_clean tmpfs) lifetime new_files + +addSubdirsToClean :: TmpFs -> TempFileLifetime -> [FilePath] -> IO () +addSubdirsToClean tmpfs lifetime new_subdirs = + addToClean (tmp_subdirs_to_clean tmpfs) lifetime new_subdirs + +addToClean :: IORef PathsToClean -> TempFileLifetime -> [FilePath] -> IO () +addToClean ref lifetime new_filepaths = modifyIORef' ref $ + \PathsToClean + { ptcCurrentModule = cm_paths + , ptcGhcSession = gs_paths } -> case lifetime of - TFL_CurrentModule -> FilesToClean - { ftcCurrentModule = cm_files `Set.union` new_files_set - , ftcGhcSession = gs_files `Set.difference` new_files_set + TFL_CurrentModule -> PathsToClean + { ptcCurrentModule = cm_paths `Set.union` new_filepaths_set + , ptcGhcSession = gs_paths `Set.difference` new_filepaths_set } - TFL_GhcSession -> FilesToClean - { ftcCurrentModule = cm_files `Set.difference` new_files_set - , ftcGhcSession = gs_files `Set.union` new_files_set + TFL_GhcSession -> PathsToClean + { ptcCurrentModule = cm_paths `Set.difference` new_filepaths_set + , ptcGhcSession = gs_paths `Set.union` new_filepaths_set } where - new_files_set = Set.fromList new_files + new_filepaths_set = Set.fromList new_filepaths -- | Update the lifetime of files already being tracked. If any files are -- not being tracked they will be discarded. changeTempFilesLifetime :: TmpFs -> TempFileLifetime -> [FilePath] -> IO () changeTempFilesLifetime tmpfs lifetime files = do - FilesToClean - { ftcCurrentModule = cm_files - , ftcGhcSession = gs_files + PathsToClean + { ptcCurrentModule = cm_paths + , ptcGhcSession = gs_paths } <- readIORef (tmp_files_to_clean tmpfs) let old_set = case lifetime of - TFL_CurrentModule -> gs_files - TFL_GhcSession -> cm_files + TFL_CurrentModule -> gs_paths + TFL_GhcSession -> cm_paths existing_files = [f | f <- files, f `Set.member` old_set] addFilesToClean tmpfs lifetime existing_files @@ -224,20 +279,32 @@ addFilesToClean tmpfs lifetime [filename] return filename -newTempDir :: Logger -> TmpFs -> TempDir -> IO FilePath -newTempDir logger tmpfs tmp_dir +-- | Create a new temporary subdirectory that doesn't already exist +-- The temporary subdirectory is automatically removed at the end of the +-- GHC session, but its contents aren't. Make sure to leave the directory +-- empty before the end of the session, either by removing content +-- directly or by using @addFilesToClean@. +-- +-- If the created subdirectory is not empty, it will not be removed (along +-- with its parent temporary directory) and a warning message will be +-- printed at verbosity 2 and higher. +newTempSubDir :: Logger -> TmpFs -> TempDir -> IO FilePath +newTempSubDir logger tmpfs tmp_dir = do d <- getTempDir logger tmpfs tmp_dir findTempDir (d "ghc_") where findTempDir :: FilePath -> IO FilePath findTempDir prefix = do n <- newTempSuffix tmpfs - let filename = prefix ++ show n - b <- doesDirectoryExist filename + let name = prefix ++ show n + b <- doesDirectoryExist name if b then findTempDir prefix - else do createDirectory filename - -- see mkTempDir below; this is wrong: -> consIORef (tmp_dirs_to_clean tmpfs) filename - return filename + else (do + createDirectory name + addSubdirsToClean tmpfs TFL_GhcSession [name] + return name) + `Exception.catchIO` \e -> if isAlreadyExistsError e + then findTempDir prefix else ioError e newTempLibName :: Logger -> TmpFs -> TempDir -> TempFileLifetime -> Suffix -> IO (FilePath, FilePath, String) @@ -337,6 +404,12 @@ act (non_deletees, deletees) = partition isHaskellUserSrcFilename fs + +removeTmpSubdirs :: Logger -> [FilePath] -> IO () +removeTmpSubdirs logger fs + = traceCmd logger "Deleting temp subdirs" + ("Deleting: " ++ unwords fs) + (mapM_ (removeWith logger removeDirectory) fs) removeWith :: Logger -> (FilePath -> IO ()) -> FilePath -> IO () removeWith logger remover f = remover f `Exception.catchIO` diff --git a/compiler/ghc.cabal b/compiler/ghc.cabal --- a/compiler/ghc.cabal +++ b/compiler/ghc.cabal @@ -3,7 +3,7 @@ -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. Name: ghc -Version: 9.6.2 +Version: 9.6.3 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team @@ -86,9 +86,9 @@ transformers >= 0.5 && < 0.7, exceptions == 0.10.*, stm, - ghc-boot == 9.6.2, - ghc-heap == 9.6.2, - ghci == 9.6.2 + ghc-boot == 9.6.3, + ghc-heap == 9.6.3, + ghci == 9.6.3 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.14 diff --git a/ghc-lib-parser.cabal b/ghc-lib-parser.cabal --- a/ghc-lib-parser.cabal +++ b/ghc-lib-parser.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib-parser -version: 9.6.2.20231121 +version: 9.6.3.20231014 license: BSD-3-Clause license-file: LICENSE category: Development diff --git a/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs b/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs --- a/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs +++ b/ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs @@ -21,7 +21,7 @@ cProjectName = "The Glorious Glasgow Haskell Compilation System" cBooterVersion :: String -cBooterVersion = "9.4.5" +cBooterVersion = "9.4.4" cStage :: String cStage = show (1 :: Int) diff --git a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs --- a/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs +++ b/ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs @@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?] cProjectGitCommitId :: String -cProjectGitCommitId = "7e70df17aee2e39bc599b43e59a52bb30064df4d" +cProjectGitCommitId = "6819b70a7739205a75f0b4fefcfcc9fdab39cab9" cProjectVersion :: String -cProjectVersion = "9.6.2" +cProjectVersion = "9.6.3" cProjectVersionInt :: String cProjectVersionInt = "906" cProjectPatchLevel :: String -cProjectPatchLevel = "2" +cProjectPatchLevel = "3" cProjectPatchLevel1 :: String -cProjectPatchLevel1 = "2" +cProjectPatchLevel1 = "3" cProjectPatchLevel2 :: String cProjectPatchLevel2 = "0" 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 @@ -97,6 +97,9 @@ /* Define to 1 if works. */ #define HAVE_ALLOCA_H 1 +/* Does the toolchain use ARMv8 outline atomics */ +/* #undef HAVE_ARM_OUTLINE_ATOMICS */ + /* Define to 1 if you have the header file. */ /* #undef HAVE_BFD_H */ @@ -198,6 +201,9 @@ /* Define to 1 if you need to link with libm */ #define HAVE_LIBM 1 + +/* Define to 1 if you have the `mingwex' library (-lmingwex). */ +/* #undef HAVE_LIBMINGWEX */ /* Define to 1 if you have libnuma */ #define HAVE_LIBNUMA 0 diff --git a/ghc/ghc-bin.cabal b/ghc/ghc-bin.cabal --- a/ghc/ghc-bin.cabal +++ b/ghc/ghc-bin.cabal @@ -2,7 +2,7 @@ -- ./configure. Make sure you are editing ghc-bin.cabal.in, not ghc-bin.cabal. Name: ghc-bin -Version: 9.6.2 +Version: 9.6.3 Copyright: XXX -- License: XXX -- License-File: XXX @@ -39,8 +39,8 @@ filepath >= 1 && < 1.5, containers >= 0.5 && < 0.7, transformers >= 0.5 && < 0.7, - ghc-boot == 9.6.2, - ghc == 9.6.2 + ghc-boot == 9.6.3, + ghc == 9.6.3 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.14 @@ -58,7 +58,7 @@ Build-depends: deepseq == 1.4.*, ghc-prim >= 0.5.0 && < 0.11, - ghci == 9.6.2, + ghci == 9.6.3, haskeline == 0.8.*, exceptions == 0.10.*, time >= 1.8 && < 1.13 diff --git a/libraries/ghc-boot-th/ghc-boot-th.cabal b/libraries/ghc-boot-th/ghc-boot-th.cabal --- a/libraries/ghc-boot-th/ghc-boot-th.cabal +++ b/libraries/ghc-boot-th/ghc-boot-th.cabal @@ -3,7 +3,7 @@ -- ghc-boot-th.cabal.in, not ghc-boot-th.cabal. name: ghc-boot-th -version: 9.6.2 +version: 9.6.3 license: BSD3 license-file: LICENSE category: GHC diff --git a/libraries/ghc-boot/ghc-boot.cabal b/libraries/ghc-boot/ghc-boot.cabal --- a/libraries/ghc-boot/ghc-boot.cabal +++ b/libraries/ghc-boot/ghc-boot.cabal @@ -5,7 +5,7 @@ -- ghc-boot.cabal. name: ghc-boot -version: 9.6.2 +version: 9.6.3 license: BSD-3-Clause license-file: LICENSE category: GHC @@ -77,7 +77,7 @@ directory >= 1.2 && < 1.4, filepath >= 1.3 && < 1.5, deepseq >= 1.4 && < 1.5, - ghc-boot-th == 9.6.2 + ghc-boot-th == 9.6.3 if !os(windows) build-depends: unix >= 2.7 && < 2.9 diff --git a/libraries/ghc-heap/ghc-heap.cabal b/libraries/ghc-heap/ghc-heap.cabal --- a/libraries/ghc-heap/ghc-heap.cabal +++ b/libraries/ghc-heap/ghc-heap.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: ghc-heap -version: 9.6.2 +version: 9.6.3 license: BSD-3-Clause license-file: LICENSE maintainer: libraries@haskell.org diff --git a/libraries/ghci/GHCi/FFI.hsc b/libraries/ghci/GHCi/FFI.hsc --- a/libraries/ghci/GHCi/FFI.hsc +++ b/libraries/ghci/GHCi/FFI.hsc @@ -22,6 +22,14 @@ -} #if !defined(javascript_HOST_ARCH) +-- See Note [FFI_GO_CLOSURES workaround] in ghc_ffi.h +-- We can't include ghc_ffi.h here as we must build with stage0 +#if defined(darwin_HOST_OS) +#if !defined(FFI_GO_CLOSURES) +#define FFI_GO_CLOSURES 0 +#endif +#endif + #include #endif diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -465,7 +465,7 @@ #define MIN_VERSION_ghc_heap(major1,major2,minor) (\ (major1) < 9 || \ (major1) == 9 && (major2) < 6 || \ - (major1) == 9 && (major2) == 6 && (minor) <= 2) + (major1) == 9 && (major2) == 6 && (minor) <= 3) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo diff --git a/libraries/ghci/ghci.cabal b/libraries/ghci/ghci.cabal --- a/libraries/ghci/ghci.cabal +++ b/libraries/ghci/ghci.cabal @@ -2,7 +2,7 @@ -- ../../configure. Make sure you are editing ghci.cabal.in, not ghci.cabal. name: ghci -version: 9.6.2 +version: 9.6.3 license: BSD3 license-file: LICENSE category: GHC @@ -77,8 +77,8 @@ containers >= 0.5 && < 0.7, deepseq == 1.4.*, filepath == 1.4.*, - ghc-boot == 9.6.2, - ghc-heap == 9.6.2, + ghc-boot == 9.6.3, + ghc-heap == 9.6.3, template-haskell == 2.20.*, transformers >= 0.5 && < 0.7 diff --git a/libraries/template-haskell/template-haskell.cabal b/libraries/template-haskell/template-haskell.cabal --- a/libraries/template-haskell/template-haskell.cabal +++ b/libraries/template-haskell/template-haskell.cabal @@ -56,7 +56,7 @@ build-depends: base >= 4.11 && < 4.19, - ghc-boot-th == 9.6.2, + ghc-boot-th == 9.6.3, ghc-prim, pretty == 1.1.*