diff --git a/CodeGen.Platform.h b/CodeGen.Platform.h --- a/CodeGen.Platform.h +++ b/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/GHC.hs b/GHC.hs --- a/GHC.hs +++ b/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/GHC/Builtin/primops.txt.pp b/GHC/Builtin/primops.txt.pp --- a/GHC/Builtin/primops.txt.pp +++ b/GHC/Builtin/primops.txt.pp @@ -3826,10 +3826,25 @@ more complicated settings, e.g. converting a list of newtypes to a list of concrete types. + When used in conversions involving a newtype wrapper, + make sure the newtype constructor is in scope. + This function is representation-polymorphic, but the 'RuntimeRep' type argument is marked as 'Inferred', meaning that it is not available for visible type application. This means the typechecker will accept @'coerce' \@'Int' \@Age 42@. + + === __Examples__ + + >>> newtype TTL = TTL Int deriving (Eq, Ord, Show) + >>> newtype Age = Age Int deriving (Eq, Ord, Show) + >>> coerce (Age 42) :: TTL + TTL 42 + >>> coerce (+ (1 :: Int)) (Age 42) :: TTL + TTL 43 + >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL] + [TTL 43,TTL 25] + } ------------------------------------------------------------------------ diff --git a/GHC/Cmm.hs b/GHC/Cmm.hs --- a/GHC/Cmm.hs +++ b/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/GHC/Cmm/CallConv.hs b/GHC/Cmm/CallConv.hs --- a/GHC/Cmm/CallConv.hs +++ b/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/GHC/Cmm/Lexer.hs b/GHC/Cmm/Lexer.hs --- a/GHC/Cmm/Lexer.hs +++ b/GHC/Cmm/Lexer.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 13 "_build/source-dist/ghc-9.8.1-src/ghc-9.8.1/compiler/GHC/Cmm/Lexer.x" #-} +{-# LINE 13 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Cmm/Lexer.x" #-} module GHC.Cmm.Lexer ( CmmToken(..), cmmlex, ) where @@ -386,7 +386,7 @@ , (0,alex_action_20) ] -{-# LINE 134 "_build/source-dist/ghc-9.8.1-src/ghc-9.8.1/compiler/GHC/Cmm/Lexer.x" #-} +{-# LINE 134 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Cmm/Lexer.x" #-} data CmmToken = CmmT_SpecChar Char | CmmT_DotDot diff --git a/GHC/CmmToAsm/Ppr.hs b/GHC/CmmToAsm/Ppr.hs --- a/GHC/CmmToAsm/Ppr.hs +++ b/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/GHC/CmmToAsm/Wasm/FromCmm.hs b/GHC/CmmToAsm/Wasm/FromCmm.hs --- a/GHC/CmmToAsm/Wasm/FromCmm.hs +++ b/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/GHC/CmmToAsm/X86/CodeGen.hs b/GHC/CmmToAsm/X86/CodeGen.hs --- a/GHC/CmmToAsm/X86/CodeGen.hs +++ b/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/GHC/CmmToAsm/X86/Instr.hs b/GHC/CmmToAsm/X86/Instr.hs --- a/GHC/CmmToAsm/X86/Instr.hs +++ b/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/GHC/CmmToLlvm/CodeGen.hs b/GHC/CmmToLlvm/CodeGen.hs --- a/GHC/CmmToLlvm/CodeGen.hs +++ b/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/GHC/CmmToLlvm/Data.hs b/GHC/CmmToLlvm/Data.hs --- a/GHC/CmmToLlvm/Data.hs +++ b/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/GHC/Core.hs b/GHC/Core.hs --- a/GHC/Core.hs +++ b/GHC/Core.hs @@ -155,7 +155,7 @@ -- f_1 x_2 = let f_3 x_4 = x_4 + 1 -- in f_3 (x_2 - 2) -- @ --- But see Note [Shadowing] below. +-- But see Note [Shadowing in Core] below. -- -- 3. The resulting syntax tree undergoes type checking (which also deals with instantiating -- type class arguments) to yield a 'GHC.Hs.Expr.HsExpr' type that has 'GHC.Types.Id.Id' as it's names. @@ -313,26 +313,6 @@ deriving Data {- -Note [Shadowing] -~~~~~~~~~~~~~~~~ -While various passes attempt to rename on-the-fly in a manner that -avoids "shadowing" (thereby simplifying downstream optimizations), -neither the simplifier nor any other pass GUARANTEES that shadowing is -avoided. Thus, all passes SHOULD work fine even in the presence of -arbitrary shadowing in their inputs. - -In particular, scrutinee variables `x` in expressions of the form -`Case e x t` are often renamed to variables with a prefix -"wild_". These "wild" variables may appear in the body of the -case-expression, and further, may be shadowed within the body. - -So the Unique in a Var is not really unique at all. Still, it's very -useful to give a constant-time equality/ordering for Vars, and to give -a key that can be used to make sets of Vars (VarSet), or mappings from -Vars to other things (VarEnv). Moreover, if you do want to eliminate -shadowing, you can give a new Unique to an Id without changing its -printable name, which makes debugging easier. - Note [Literal alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ Literal alternatives (LitAlt lit) are always for *un-lifted* literals. @@ -363,6 +343,39 @@ \(c :: Age~#Int) (d::Int). d |> (sym c) Here 'c' is a CoVar, which is lambda-bound, but it /occurs/ in a Coercion, (sym c). + +Note [Shadowing in Core] +~~~~~~~~~~~~~~~~~~~~~~~~ +You might wonder if there is an invariant that a Core expression has no +"shadowing". For example, is this illegal? + \x. \x. blah -- x is shadowed +Answer; no! Core does /not/ have a no-shadowing invariant. + +Neither the simplifier nor any other pass GUARANTEES that shadowing is +avoided. Thus, all passes SHOULD work fine even in the presence of +arbitrary shadowing in their inputs. + +So the Unique in a Var is not really unique at all. Still, it's very +useful to give a constant-time equality/ordering for Vars, and to give +a key that can be used to make sets of Vars (VarSet), or mappings from +Vars to other things (VarEnv). Moreover, if you do want to eliminate +shadowing, you can give a new Unique to an Id without changing its +printable name, which makes debugging easier. + +It would in many ways be easier to have a no-shadowing invariant. And the +Simplifier does its best to clone variables that are shadowed. But it is +extremely difficult to GUARANTEE it: + +* We use `GHC.Types.Id.mkTemplateLocal` to make up local binders, with uniques + that are locally-unique (enough for the purpose) but not globally unique. + It is convenient not to have to plumb a unique supply to these functions. + +* It is very difficult for the Simplifier to gurantee a no-shadowing result. + See Note [Shadowing in the Simplifier] in GHC.Core.Opt.Simplify.Iteration. + +* See Note [Shadowing in CSE] in GHC.Core.Opt.CSE + +* See Note [Shadowing in SpecConstr] in GHC.Core.Opt.SpecContr Note [Core letrec invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Core/Class.hs b/GHC/Core/Class.hs --- a/GHC/Core/Class.hs +++ b/GHC/Core/Class.hs @@ -8,7 +8,7 @@ module GHC.Core.Class ( Class, ClassOpItem, - ClassATItem(..), ATValidityInfo(..), + ClassATItem(..), TyFamEqnValidityInfo(..), ClassMinimalDef, DefMethInfo, pprDefMethInfo, @@ -34,6 +34,7 @@ import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc +import GHC.Types.Var.Set import GHC.Utils.Outputable import GHC.Data.BooleanFormula (BooleanFormula, mkTrue) @@ -96,20 +97,44 @@ data ClassATItem = ATI TyCon -- See Note [Associated type tyvar names] - (Maybe (Type, ATValidityInfo)) - -- Default associated type (if any) from this template - -- Note [Associated type defaults] + (Maybe (Type, TyFamEqnValidityInfo)) + -- ^ Default associated type (if any) from this template. + -- + -- As per Note [Associated type defaults], the Type has been renamed + -- to use the class tyvars, while the 'TyFamEqnValidityInfo' uses + -- the original user-written type variables. --- | Information about an associated type family default implementation. This --- is used solely for validity checking. +-- | Information about a type family equation, used for validity checking +-- of closed type family equations and associated type family default equations. +-- +-- This type exists to delay validity-checking after typechecking type declaration +-- groups, to avoid cyclic evaluation inside the typechecking knot. +-- -- See @Note [Type-checking default assoc decls]@ in "GHC.Tc.TyCl". -data ATValidityInfo - = NoATVI -- Used for associated type families that are imported - -- from another module, for which we don't need to - -- perform any validity checking. +data TyFamEqnValidityInfo + -- | Used for equations which don't need any validity checking, + -- for example equations imported from another module. + = NoVI - | ATVI SrcSpan [Type] -- Used for locally defined associated type families. - -- The [Type] are the LHS patterns. + -- | Information necessary for validity checking of a type family equation. + | VI + { vi_loc :: SrcSpan + , vi_qtvs :: [TcTyVar] + -- ^ LHS quantified type variables + , vi_non_user_tvs :: TyVarSet + -- ^ non-user-written type variables (for error message reporting) + -- + -- Example: with -XPolyKinds, typechecking @type instance forall a. F = ()@ + -- introduces the kind variable @k@ for the kind of @a@. See #23734. + , vi_pats :: [Type] + -- ^ LHS patterns + , vi_rhs :: Type + -- ^ RHS of the equation + -- + -- NB: for associated type family default declarations, this is the RHS + -- *before* applying the substitution from + -- Note [Type-checking default assoc decls] in GHC.Tc.TyCl. + } type ClassMinimalDef = BooleanFormula Name -- Required methods @@ -166,9 +191,14 @@ * HOWEVER, in the internal ClassATItem we rename the RHS to match the tyConTyVars of the family TyCon. So in the example above we'd get a ClassATItem of - ATI F ((x,a) -> b) - So the tyConTyVars of the family TyCon bind the free vars of - the default Type rhs + + ATI F (Just ((x,a) -> b, validity_info) + + That is, the type stored in the first component of the pair has been + renamed to use the class type variables. On the other hand, the + TyFamEqnValidityInfo, used for validity checking of the type family equation + (considered as a free-standing equation) uses the original types, e.g. + involving the type variables 'p', 'q', 'r'. The @mkClass@ function fills in the indirect superclasses. diff --git a/GHC/Core/Coercion/Axiom.hs b/GHC/Core/Coercion/Axiom.hs --- a/GHC/Core/Coercion/Axiom.hs +++ b/GHC/Core/Coercion/Axiom.hs @@ -236,25 +236,35 @@ -- INVARIANT: co_ax_implicit == True implies length co_ax_branches == 1. } +-- | A branch of a coercion axiom, which provides the evidence for +-- unwrapping a newtype or a type-family reduction step using a single equation. data CoAxBranch = CoAxBranch - { cab_loc :: SrcSpan -- Location of the defining equation - -- See Note [CoAxiom locations] - , cab_tvs :: [TyVar] -- Bound type variables; not necessarily fresh - -- See Note [CoAxBranch type variables] - , cab_eta_tvs :: [TyVar] -- Eta-reduced tyvars - -- cab_tvs and cab_lhs may be eta-reduced; see - -- Note [Eta reduction for data families] - , cab_cvs :: [CoVar] -- Bound coercion variables - -- Always empty, for now. - -- See Note [Constraints in patterns] - -- in GHC.Tc.TyCl - , cab_roles :: [Role] -- See Note [CoAxBranch roles] - , cab_lhs :: [Type] -- Type patterns to match against - , cab_rhs :: Type -- Right-hand side of the equality - -- See Note [CoAxioms are homogeneous] - , cab_incomps :: [CoAxBranch] -- The previous incompatible branches - -- See Note [Storing compatibility] + { cab_loc :: SrcSpan + -- ^ Location of the defining equation + -- See Note [CoAxiom locations] + , cab_tvs :: [TyVar] + -- ^ Bound type variables; not necessarily fresh + -- See Note [CoAxBranch type variables] + , cab_eta_tvs :: [TyVar] + -- ^ Eta-reduced tyvars + -- cab_tvs and cab_lhs may be eta-reduced; see + -- Note [Eta reduction for data families] + , cab_cvs :: [CoVar] + -- ^ Bound coercion variables + -- Always empty, for now. + -- See Note [Constraints in patterns] + -- in GHC.Tc.TyCl + , cab_roles :: [Role] + -- ^ See Note [CoAxBranch roles] + , cab_lhs :: [Type] + -- ^ Type patterns to match against + , cab_rhs :: Type + -- ^ Right-hand side of the equality + -- See Note [CoAxioms are homogeneous] + , cab_incomps :: [CoAxBranch] + -- ^ The previous incompatible branches + -- See Note [Storing compatibility] } deriving Data.Data diff --git a/GHC/Core/Opt/CSE.hs b/GHC/Core/Opt/CSE.hs --- a/GHC/Core/Opt/CSE.hs +++ b/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/GHC/Core/Opt/CprAnal.hs b/GHC/Core/Opt/CprAnal.hs --- a/GHC/Core/Opt/CprAnal.hs +++ b/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/GHC/Core/Opt/FloatIn.hs b/GHC/Core/Opt/FloatIn.hs --- a/GHC/Core/Opt/FloatIn.hs +++ b/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/GHC/Core/Opt/Pipeline.hs b/GHC/Core/Opt/Pipeline.hs --- a/GHC/Core/Opt/Pipeline.hs +++ b/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/GHC/Core/Opt/Simplify/Iteration.hs b/GHC/Core/Opt/Simplify/Iteration.hs --- a/GHC/Core/Opt/Simplify/Iteration.hs +++ b/GHC/Core/Opt/Simplify/Iteration.hs @@ -119,14 +119,6 @@ The returned floats and env both have an in-scope set, and they are guaranteed to be the same. - -Note [Shadowing] -~~~~~~~~~~~~~~~~ -The simplifier used to guarantee that the output had no shadowing, but -it does not do so any more. (Actually, it never did!) The reason is -documented with simplifyArgs. - - Eta expansion ~~~~~~~~~~~~~~ For eta expansion, we want to catch things like @@ -262,7 +254,7 @@ = do { (env1, triples) <- mapAccumLM add_rules env0 pairs0 ; let new_bndrs = map sndOf3 triples ; (rec_floats, env2) <- enterRecGroupRHSs env1 new_bndrs $ \env -> - go env triples + go env triples ; return (mkRecFloats rec_floats, env2) } where add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr)) @@ -303,10 +295,12 @@ | otherwise = case bind_cxt of BC_Join is_rec cont -> simplTrace "SimplBind:join" (ppr old_bndr) $ - simplJoinBind env is_rec cont old_bndr new_bndr rhs env + simplJoinBind is_rec cont + (old_bndr,env) (new_bndr,env) (rhs,env) BC_Let top_lvl is_rec -> simplTrace "SimplBind:normal" (ppr old_bndr) $ - simplLazyBind env top_lvl is_rec old_bndr new_bndr rhs env + simplLazyBind top_lvl is_rec + (old_bndr,env) (new_bndr,env) (rhs,env) simplTrace :: String -> SDoc -> SimplM a -> SimplM a simplTrace herald doc thing_inside = do @@ -316,19 +310,16 @@ else thing_inside -------------------------- -simplLazyBind :: SimplEnv - -> TopLevelFlag -> RecFlag - -> InId -> OutId -- Binder, both pre-and post simpl - -- Not a JoinId +simplLazyBind :: TopLevelFlag -> RecFlag + -> (InId, SimplEnv) -- InBinder, and static env for its unfolding (if any) + -> (OutId, SimplEnv) -- OutBinder, and SimplEnv after simplifying that binder -- The OutId has IdInfo (notably RULES), -- except arity, unfolding - -- Ids only, no TyVars - -> InExpr -> SimplEnv -- The RHS and its environment + -> (InExpr, SimplEnv) -- The RHS and its static environment -> SimplM (SimplFloats, SimplEnv) --- Precondition: the OutId is already in the InScopeSet of the incoming 'env' --- Precondition: not a JoinId +-- Precondition: Ids only, no TyVars; not a JoinId -- Precondition: rhs obeys the let-can-float invariant -simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se +simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se) = assert (isId bndr ) assertPpr (not (isJoinId bndr)) (ppr bndr) $ -- pprTrace "simplLazyBind" ((ppr bndr <+> ppr bndr1) $$ ppr rhs $$ ppr (seIdSubst rhs_se)) $ @@ -379,24 +370,23 @@ ; let poly_floats = foldl' extendFloats (emptyFloats env) poly_binds ; return (poly_floats, body3) } - ; let env' = env `setInScopeFromF` rhs_floats - ; rhs' <- rebuildLam env' tvs' body3 rhs_cont - ; (bind_float, env2) <- completeBind env' (BC_Let top_lvl is_rec) bndr bndr1 rhs' + ; let env1 = env `setInScopeFromF` rhs_floats + ; rhs' <- rebuildLam env1 tvs' body3 rhs_cont + ; (bind_float, env2) <- completeBind (BC_Let top_lvl is_rec) (bndr,unf_se) (bndr1,rhs',env1) ; return (rhs_floats `addFloats` bind_float, env2) } -------------------------- -simplJoinBind :: SimplEnv - -> RecFlag +simplJoinBind :: RecFlag -> SimplCont - -> InId -> OutId -- Binder, both pre-and post simpl - -- The OutId has IdInfo, except arity, - -- unfolding - -> InExpr -> SimplEnv -- The right hand side and its env + -> (InId, SimplEnv) -- InBinder, with static env for its unfolding + -> (OutId, SimplEnv) -- OutBinder; SimplEnv has the binder in scope + -- The OutId has IdInfo, except arity, unfolding + -> (InExpr, SimplEnv) -- The right hand side and its env -> SimplM (SimplFloats, SimplEnv) -simplJoinBind env is_rec cont old_bndr new_bndr rhs rhs_se +simplJoinBind is_rec cont (old_bndr, unf_se) (new_bndr, env) (rhs, rhs_se) = do { let rhs_env = rhs_se `setInScopeFromE` env ; rhs' <- simplJoinRhs rhs_env old_bndr rhs cont - ; completeBind env (BC_Join is_rec cont) old_bndr new_bndr rhs' } + ; completeBind (BC_Join is_rec cont) (old_bndr, unf_se) (new_bndr, rhs', env) } -------------------------- simplAuxBind :: SimplEnv @@ -407,7 +397,7 @@ -- auxiliary bindings, notably in knownCon. -- -- The binder comes from a case expression (case binder or alternative) --- and so does not have rules, inline pragmas etc. +-- and so does not have rules, unfolding, inline pragmas etc. -- -- Precondition: rhs satisfies the let-can-float invariant @@ -436,8 +426,8 @@ -- Simplify the binder and complete the binding ; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr - ; (bind_float, env2) <- completeBind env1 (BC_Let NotTopLevel NonRecursive) - bndr new_bndr rhs1 + ; (bind_float, env2) <- completeBind (BC_Let NotTopLevel NonRecursive) + (bndr,env) (new_bndr, rhs1, env1) ; return (rhs_floats `addFloats` bind_float, env2) } @@ -843,7 +833,7 @@ ; (arity_type, expr2) <- tryEtaExpandRhs env (BC_Let top_lvl NonRecursive) var expr1 -- Technically we should extend the in-scope set in 'env' with -- the 'floats' from prepareRHS; but they are all fresh, so there is - -- no danger of introducing name shadowig in eta expansion + -- no danger of introducing name shadowing in eta expansion ; unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc var expr2 @@ -917,11 +907,11 @@ Nor does it do the atomic-argument thing -} -completeBind :: SimplEnv - -> BindContext - -> InId -- Old binder - -> OutId -- New binder; can be a JoinId - -> OutExpr -- New RHS +completeBind :: BindContext + -> (InId, SimplEnv) -- Old binder, and the static envt in which to simplify + -- its stable unfolding (if any) + -> (OutId, OutExpr, SimplEnv) -- New binder and rhs; can be a JoinId. + -- And the SimplEnv with that OutId in scope. -> SimplM (SimplFloats, SimplEnv) -- completeBind may choose to do its work -- * by extending the substitution (e.g. let x = y in ...) @@ -929,7 +919,7 @@ -- -- Binder /can/ be a JoinId -- Precondition: rhs obeys the let-can-float invariant -completeBind env bind_cxt old_bndr new_bndr new_rhs +completeBind bind_cxt (old_bndr, unf_se) (new_bndr, new_rhs, env) | isCoVar old_bndr = case new_rhs of Coercion co -> return (emptyFloats env, extendCvSubst env old_bndr co) @@ -945,9 +935,10 @@ -- See Note [Eta-expanding at let bindings] in GHC.Core.Opt.Simplify.Utils ; (new_arity, eta_rhs) <- tryEtaExpandRhs env bind_cxt new_bndr new_rhs - -- Simplify the unfolding - ; new_unfolding <- simplLetUnfolding env bind_cxt old_bndr - eta_rhs (idType new_bndr) new_arity old_unf + -- Simplify the unfolding; see Note [Environment for simplLetUnfolding] + ; new_unfolding <- simplLetUnfolding (unf_se `setInScopeFromE` env) + bind_cxt old_bndr + eta_rhs (idType new_bndr) new_arity old_unf ; let new_bndr_w_info = addLetBndrInfo new_bndr new_arity new_unfolding -- See Note [In-scope set as a substitution] @@ -1064,7 +1055,37 @@ unfolding because it's too big. Hence the belt-and-braces `orElse` in the defn of unf_rhs. The Nothing case probably never happens. +Note [Environment for simplLetUnfolding] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to be rather careful about the static environment in which +we simplify a stable unfolding. Consider (#24242): + f x = let y_Xb = ... in + let step1_Xb {Stable unfolding = ....y_Xb...} = rhs in + ... + +Note that `y_Xb` and `step1_Xb` have the same unique (`Xb`). This can happen; +see Note [Shadowing in Core] in GHC.Core, and Note [Shadowing in the Simplifier]. +This is perfectly fine. The `y_Xb` in the stable unfolding of the non- +recursive binding for `step1` refers, of course, to `let y_Xb = ....`. +When simplifying the binder `step1_Xb` we'll give it a new unique, and +extend the static environment with [Xb :-> step1_Xc], say. + +But when simplifying step1's stable unfolding, we must use static environment +/before/ simplifying the binder `step1_Xb`; that is, a static envt that maps +[Xb :-> y_Xb], /not/ [Xb :-> step1_Xc]. + +That is why we pass around a pair `(InId, SimplEnv)` for the binder, keeping +track of the right environment for the unfolding of that InId. See the type +of `simplLazyBind`, `simplJoinBind`, `completeBind`. + +This only matters when we have + - A non-recursive binding for f + - has a stable unfolding + - and that unfolding mentions a variable y + - that has the same unique as f. +So triggering a bug here is really hard! + ************************************************************************ * * \subsection[Simplify-simplExpr]{The main function: simplExpr} @@ -1524,7 +1545,7 @@ completeBindX :: SimplEnv -> FromWhat - -> InId -> OutExpr -- Bind this Id to this (simplified) expression + -> InId -> OutExpr -- Non-recursively bind this Id to this (simplified) expression -- (the let-can-float invariant may not be satisfied) -> InExpr -- In this body -> SimplCont -- Consumed by this continuation @@ -1554,14 +1575,14 @@ -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env', -- because this is simplNonRecX, so bndr is not in scope in the RHS. - ; (bind_float, env2) <- completeBind (env2 `setInScopeFromF` rhs_floats) - (BC_Let NotTopLevel NonRecursive) - bndr bndr2 rhs1 + ; let env3 = env2 `setInScopeFromF` rhs_floats + ; (bind_float, env4) <- completeBind (BC_Let NotTopLevel NonRecursive) + (bndr,env) (bndr2, rhs1, env3) -- Must pass env1 to completeBind in case simplBinder had to clone, -- and extended the substitution with [bndr :-> new_bndr] -- Simplify the body - ; (body_floats, body') <- simplNonRecBody env2 from_what body cont + ; (body_floats, body') <- simplNonRecBody env4 from_what body cont ; let all_floats = rhs_floats `addFloats` bind_float `addFloats` body_floats ; return ( all_floats, body' ) } @@ -1776,10 +1797,11 @@ ------------------ simplNonRecE :: SimplEnv -> FromWhat - -> InId -- The binder, always an Id - -- Never a join point - -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) - -> InExpr -- Body of the let/lambda + -> InId -- The binder, always an Id + -- Never a join point + -- The static env for its unfolding (if any) is the first parameter + -> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda) + -> InExpr -- Body of the let/lambda -> SimplCont -> SimplM (SimplFloats, OutExpr) @@ -1808,8 +1830,8 @@ | otherwise -- Evaluate RHS lazily = do { (env1, bndr1) <- simplNonRecBndr env bndr ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive) - ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive - bndr bndr2 rhs rhs_se + ; (floats1, env3) <- simplLazyBind NotTopLevel NonRecursive + (bndr,env) (bndr2,env2) (rhs,rhs_se) ; (floats2, expr') <- simplNonRecBody env3 from_what body cont ; return (floats1 `addFloats` floats2, expr') } @@ -1935,7 +1957,7 @@ res_ty = contResultType cont ; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont) - ; (floats1, env3) <- simplJoinBind env2 NonRecursive cont bndr bndr2 rhs env + ; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env) ; (floats2, body') <- simplExprF env3 body cont ; return (floats1 `addFloats` floats2, body') } @@ -2275,7 +2297,7 @@ (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty , sc_dup = Simplified , sc_cont = cont }) - -- Note [Shadowing] + -- Note [Shadowing in the Simplifier] -- Lazy arguments | otherwise @@ -2408,10 +2430,10 @@ participate in the rule firing. So we mark them as Simplified to avoid re-simplifying them. -Note [Shadowing] -~~~~~~~~~~~~~~~~ -This part of the simplifier may break the no-shadowing invariant -Consider +Note [Shadowing in the Simplifier] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +This part of the simplifier may return an expression that has shadowing. +(See Note [Shadowing in Core] in GHC.Core.hs.) Consider f (...(\a -> e)...) (case y of (a,b) -> e') where f is strict in its second arg If we simplify the innermost one first we get (...(\a -> e)...) @@ -2431,6 +2453,8 @@ to get the effect that finding (error "foo") in a strict arg position will discard the entire application and replace it with (error "foo"). Getting all this at once is TOO HARD! + +See also Note [Shadowing in prepareAlts] in GHC.Core.Opt.Simplify.Utils. Note [No eta-expansion in runRW#] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Core/Opt/Simplify/Utils.hs b/GHC/Core/Opt/Simplify/Utils.hs --- a/GHC/Core/Opt/Simplify/Utils.hs +++ b/GHC/Core/Opt/Simplify/Utils.hs @@ -191,10 +191,11 @@ | StrictBind -- (StrictBind x b K)[e] = let x = e in K[b] -- or, equivalently, = K[ (\x.b) e ] { sc_dup :: DupFlag -- See Note [DupFlag invariants] - , sc_bndr :: InId , sc_from :: FromWhat + , sc_bndr :: InId , sc_body :: InExpr - , sc_env :: StaticEnv -- See Note [StaticEnv invariant] + , sc_env :: StaticEnv -- Static env for both sc_bndr (stable unfolding thereof) + -- and sc_body. Also see Note [StaticEnv invariant] , sc_cont :: SimplCont } | StrictArg -- (StrictArg (f e1 ..en) K)[e] = K[ f e1 .. en e ] @@ -2279,7 +2280,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Note that we pass case_bndr::InId to prepareAlts; an /InId/, not an /OutId/. This is vital, because `refineDefaultAlt` uses `tys` to build -a new /InAlt/. If you pass an OutId, we'll end up appling the +a new /InAlt/. If you pass an OutId, we'll end up applying the substitution twice: disaster (#23012). However this does mean that filling in the default alt might be diff --git a/GHC/Core/Opt/SpecConstr.hs b/GHC/Core/Opt/SpecConstr.hs --- a/GHC/Core/Opt/SpecConstr.hs +++ b/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/GHC/Core/Opt/Specialise.hs b/GHC/Core/Opt/Specialise.hs --- a/GHC/Core/Opt/Specialise.hs +++ b/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/GHC/Core/Predicate.hs b/GHC/Core/Predicate.hs --- a/GHC/Core/Predicate.hs +++ b/GHC/Core/Predicate.hs @@ -99,7 +99,14 @@ mkClassPred clas tys = mkTyConApp (classTyCon clas) tys isDictTy :: Type -> Bool -isDictTy = isClassPred +-- True of dictionaries (Eq a) and +-- dictionary functions (forall a. Eq a => Eq [a]) +-- See Note [Type determines value] +-- See #24370 (and the isDictId call in GHC.HsToCore.Binds.decomposeRuleLhs) +-- for why it's important to catch dictionary bindings +isDictTy ty = isClassPred pred + where + (_, pred) = splitInvisPiTys ty typeDeterminesValue :: Type -> Bool -- See Note [Type determines value] diff --git a/GHC/Core/Subst.hs b/GHC/Core/Subst.hs --- a/GHC/Core/Subst.hs +++ b/GHC/Core/Subst.hs @@ -590,11 +590,13 @@ = exprFVs fv_expr (const True) emptyVarSet $! acc ------------------ +-- | Drop free vars from the breakpoint if they have a non-variable substitution. substTickish :: Subst -> CoreTickish -> CoreTickish substTickish subst (Breakpoint ext n ids) = Breakpoint ext n (mapMaybe do_one ids) where do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst + substTickish _subst other = other {- Note [Substitute lazily] diff --git a/GHC/Core/Unify.hs b/GHC/Core/Unify.hs --- a/GHC/Core/Unify.hs +++ b/GHC/Core/Unify.hs @@ -31,6 +31,7 @@ import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Name( Name, mkSysTvName, mkSystemVarName ) +import GHC.Builtin.Names( tYPETyConKey, cONSTRAINTTyConKey ) import GHC.Core.Type hiding ( getTvSubstEnv ) import GHC.Core.Coercion hiding ( getCvSubstEnv ) import GHC.Core.TyCon @@ -1150,8 +1151,10 @@ -- TYPE and CONSTRAINT are not Apart -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim -- NB: at this point we know that the two TyCons do not match - | Just {} <- sORTKind_maybe ty1 - , Just {} <- sORTKind_maybe ty2 + | Just (tc1,_) <- mb_tc_app1, let u1 = tyConUnique tc1 + , Just (tc2,_) <- mb_tc_app2, let u2 = tyConUnique tc2 + , (u1 == tYPETyConKey && u2 == cONSTRAINTTyConKey) || + (u2 == tYPETyConKey && u1 == cONSTRAINTTyConKey) = maybeApart MARTypeVsConstraint -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim -- Note [Type and Constraint are not apart] diff --git a/GHC/Data/Bag.hs b/GHC/Data/Bag.hs --- a/GHC/Data/Bag.hs +++ b/GHC/Data/Bag.hs @@ -39,6 +39,7 @@ import qualified Data.List.NonEmpty as NE import qualified Data.Semigroup ( (<>) ) import Control.Applicative( Alternative( (<|>) ) ) +import Control.DeepSeq infixr 3 `consBag` infixl 3 `snocBag` @@ -49,6 +50,12 @@ | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty | ListBag (NonEmpty a) deriving (Foldable, Functor, Traversable) + +instance NFData a => NFData (Bag a) where + rnf EmptyBag = () + rnf (UnitBag a) = rnf a + rnf (TwoBags a b) = rnf a `seq` rnf b + rnf (ListBag a) = rnf a emptyBag :: Bag a emptyBag = EmptyBag diff --git a/GHC/Data/Graph/Directed.hs b/GHC/Data/Graph/Directed.hs --- a/GHC/Data/Graph/Directed.hs +++ b/GHC/Data/Graph/Directed.hs @@ -46,7 +46,7 @@ import GHC.Prelude -import GHC.Utils.Misc ( minWith, count ) +import GHC.Utils.Misc ( sortWith, count ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Data.Maybe ( expectJust ) @@ -219,47 +219,52 @@ [payload]) -- Rest of the path; -- [a,b,c] means c depends on b, b depends on a --- | Find a reasonably short cycle a->b->c->a, in a strongly --- connected component. The input nodes are presumed to be --- a SCC, so you can start anywhere. +-- | Find a reasonably short cycle a->b->c->a, in a graph +-- The graph might not necessarily be strongly connected. findCycle :: forall payload key. Ord key => [Node key payload] -- The nodes. The dependencies can -- contain extra keys, which are ignored -> Maybe [payload] -- A cycle, starting with node -- so each depends on the next findCycle graph - = go Set.empty (new_work root_deps []) [] + = goRoots plausible_roots where env :: Map.Map key (Node key payload) env = Map.fromList [ (node_key node, node) | node <- graph ] - -- Find the node with fewest dependencies among the SCC modules - -- This is just a heuristic to find some plausible root module - root :: Node key payload - root = fst (minWith snd [ (node, count (`Map.member` env) - (node_dependencies node)) - | node <- graph ]) - DigraphNode root_payload root_key root_deps = root + goRoots [] = Nothing + goRoots (root:xs) = + case go Set.empty (new_work root_deps []) [] of + Nothing -> goRoots xs + Just res -> Just res + where + DigraphNode root_payload root_key root_deps = root + -- 'go' implements Dijkstra's algorithm, more or less + go :: Set.Set key -- Visited + -> [WorkItem key payload] -- Work list, items length n + -> [WorkItem key payload] -- Work list, items length n+1 + -> Maybe [payload] -- Returned cycle + -- Invariant: in a call (go visited ps qs), + -- visited = union (map tail (ps ++ qs)) + go _ [] [] = Nothing -- No cycles + go visited [] qs = go visited qs [] + go visited (((DigraphNode payload key deps), path) : ps) qs + | key == root_key = Just (root_payload : reverse path) + | key `Set.member` visited = go visited ps qs + | key `Map.notMember` env = go visited ps qs + | otherwise = go (Set.insert key visited) + ps (new_qs ++ qs) + where + new_qs = new_work deps (payload : path) - -- 'go' implements Dijkstra's algorithm, more or less - go :: Set.Set key -- Visited - -> [WorkItem key payload] -- Work list, items length n - -> [WorkItem key payload] -- Work list, items length n+1 - -> Maybe [payload] -- Returned cycle - -- Invariant: in a call (go visited ps qs), - -- visited = union (map tail (ps ++ qs)) - go _ [] [] = Nothing -- No cycles - go visited [] qs = go visited qs [] - go visited (((DigraphNode payload key deps), path) : ps) qs - | key == root_key = Just (root_payload : reverse path) - | key `Set.member` visited = go visited ps qs - | key `Map.notMember` env = go visited ps qs - | otherwise = go (Set.insert key visited) - ps (new_qs ++ qs) - where - new_qs = new_work deps (payload : path) + -- Find the nodes with fewest dependencies among the SCC modules + -- This is just a heuristic to find some plausible root module + plausible_roots :: [Node key payload] + plausible_roots = map fst (sortWith snd [ (node, count (`Map.member` env) (node_dependencies node)) + | node <- graph ]) + new_work :: [key] -> [payload] -> [WorkItem key payload] new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] diff --git a/GHC/Driver/Config/StgToCmm.hs b/GHC/Driver/Config/StgToCmm.hs --- a/GHC/Driver/Config/StgToCmm.hs +++ b/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/GHC/Driver/DynFlags.hs b/GHC/Driver/DynFlags.hs --- a/GHC/Driver/DynFlags.hs +++ b/GHC/Driver/DynFlags.hs @@ -694,7 +694,8 @@ avx512er = False, avx512f = False, avx512pf = False, - fma = False, + -- Use FMA by default on AArch64 + fma = (platformArch . sTargetPlatform $ mySettings) == ArchAArch64, rtldInfo = panic "defaultDynFlags: no rtldInfo", rtccInfo = panic "defaultDynFlags: no rtccInfo", rtasmInfo = panic "defaultDynFlags: no rtasmInfo", diff --git a/GHC/Driver/Flags.hs b/GHC/Driver/Flags.hs --- a/GHC/Driver/Flags.hs +++ b/GHC/Driver/Flags.hs @@ -161,6 +161,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. @@ -223,6 +224,8 @@ | Opt_DistinctConstructorTables | Opt_InfoTableMap + | Opt_InfoTableMapWithFallback + | Opt_InfoTableMapWithStack | Opt_WarnIsError -- -Werror; makes warnings fatal | Opt_ShowWarnGroups -- Show the group a warning belongs to @@ -577,6 +580,8 @@ -- Flags that affect debugging information , Opt_DistinctConstructorTables , Opt_InfoTableMap + , Opt_InfoTableMapWithStack + , Opt_InfoTableMapWithFallback ] data WarningFlag = @@ -684,7 +689,7 @@ | Opt_WarnImplicitRhsQuantification -- Since 9.8 | Opt_WarnIncompleteExportWarnings -- Since 9.8 | Opt_WarnInconsistentFlags -- Since 9.8 - deriving (Eq, Ord, Show, Enum) + deriving (Eq, Ord, Show, Enum, Bounded) -- | Return the names of a WarningFlag -- diff --git a/GHC/Driver/GenerateCgIPEStub.hs b/GHC/Driver/GenerateCgIPEStub.hs --- a/GHC/Driver/GenerateCgIPEStub.hs +++ b/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/GHC/Driver/Main.hs b/GHC/Driver/Main.hs --- a/GHC/Driver/Main.hs +++ b/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/GHC/Driver/Make.hs b/GHC/Driver/Make.hs --- a/GHC/Driver/Make.hs +++ b/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/GHC/Driver/Pipeline.hs b/GHC/Driver/Pipeline.hs --- a/GHC/Driver/Pipeline.hs +++ b/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/GHC/Driver/Pipeline/Execute.hs b/GHC/Driver/Pipeline/Execute.hs --- a/GHC/Driver/Pipeline/Execute.hs +++ b/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/GHC/Driver/Session.hs b/GHC/Driver/Session.hs --- a/GHC/Driver/Session.hs +++ b/GHC/Driver/Session.hs @@ -1566,6 +1566,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" @@ -1804,10 +1806,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)) @@ -2170,126 +2168,125 @@ wWarningFlags = map snd (sortBy (comparing fst) wWarningFlagsDeps) wWarningFlagsDeps :: [(Deprecation, FlagSpec WarningFlag)] -wWarningFlagsDeps = mconcat [ +wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of -- See Note [Updating flag description in the User's Guide] -- See Note [Supporting CLI completion] -- Please keep the list of flags below sorted alphabetically - warnSpec Opt_WarnAlternativeLayoutRuleTransitional, - warnSpec Opt_WarnAmbiguousFields, - depWarnSpec Opt_WarnAutoOrphans - "it has no effect", - warnSpec Opt_WarnCPPUndef, - warnSpec Opt_WarnUnbangedStrictPatterns, - warnSpec Opt_WarnDeferredTypeErrors, - warnSpec Opt_WarnDeferredOutOfScopeVariables, - warnSpec Opt_WarnDeprecatedFlags, - warnSpec Opt_WarnDerivingDefaults, - warnSpec Opt_WarnDerivingTypeable, - warnSpec Opt_WarnDodgyExports, - warnSpec Opt_WarnDodgyForeignImports, - warnSpec Opt_WarnDodgyImports, - warnSpec Opt_WarnEmptyEnumerations, - subWarnSpec "duplicate-constraints" - Opt_WarnDuplicateConstraints - "it is subsumed by -Wredundant-constraints", - warnSpec Opt_WarnRedundantConstraints, - warnSpec Opt_WarnDuplicateExports, - depWarnSpec Opt_WarnHiShadows - "it is not used, and was never implemented", - warnSpec Opt_WarnInaccessibleCode, - warnSpec Opt_WarnImplicitPrelude, - depWarnSpec Opt_WarnImplicitKindVars - "it is now an error", - warnSpec Opt_WarnIncompletePatterns, - warnSpec Opt_WarnIncompletePatternsRecUpd, - warnSpec Opt_WarnIncompleteUniPatterns, - warnSpec Opt_WarnInlineRuleShadowing, - warnSpec Opt_WarnIdentities, - warnSpec Opt_WarnMissingFields, - warnSpec Opt_WarnMissingImportList, - warnSpec Opt_WarnMissingExportList, - subWarnSpec "missing-local-sigs" - Opt_WarnMissingLocalSignatures - "it is replaced by -Wmissing-local-signatures", - warnSpec Opt_WarnMissingLocalSignatures, - warnSpec Opt_WarnMissingMethods, - depWarnSpec Opt_WarnMissingMonadFailInstances - "fail is no longer a method of Monad", - warnSpec Opt_WarnSemigroup, - warnSpec Opt_WarnMissingSignatures, - warnSpec Opt_WarnMissingKindSignatures, - warnSpec Opt_WarnMissingPolyKindSignatures, - subWarnSpec "missing-exported-sigs" - Opt_WarnMissingExportedSignatures - "it is replaced by -Wmissing-exported-signatures", - warnSpec Opt_WarnMissingExportedSignatures, - warnSpec Opt_WarnMonomorphism, - warnSpec Opt_WarnNameShadowing, - warnSpec Opt_WarnNonCanonicalMonadInstances, - depWarnSpec Opt_WarnNonCanonicalMonadFailInstances - "fail is no longer a method of Monad", - warnSpec Opt_WarnNonCanonicalMonoidInstances, - warnSpec Opt_WarnOrphans, - warnSpec Opt_WarnOverflowedLiterals, - warnSpec Opt_WarnOverlappingPatterns, - warnSpec Opt_WarnMissedSpecs, - warnSpec Opt_WarnAllMissedSpecs, - warnSpec' Opt_WarnSafe setWarnSafe, - warnSpec Opt_WarnTrustworthySafe, - warnSpec Opt_WarnInferredSafeImports, - warnSpec Opt_WarnMissingSafeHaskellMode, - warnSpec Opt_WarnTabs, - warnSpec Opt_WarnTypeDefaults, - warnSpec Opt_WarnTypedHoles, - warnSpec Opt_WarnPartialTypeSignatures, - warnSpec Opt_WarnUnrecognisedPragmas, - warnSpec Opt_WarnMisplacedPragmas, - warnSpec' Opt_WarnUnsafe setWarnUnsafe, - warnSpec Opt_WarnUnsupportedCallingConventions, - warnSpec Opt_WarnUnsupportedLlvmVersion, - warnSpec Opt_WarnMissedExtraSharedLib, - warnSpec Opt_WarnUntickedPromotedConstructors, - warnSpec Opt_WarnUnusedDoBind, - warnSpec Opt_WarnUnusedForalls, - warnSpec Opt_WarnUnusedImports, - warnSpec Opt_WarnUnusedLocalBinds, - warnSpec Opt_WarnUnusedMatches, - warnSpec Opt_WarnUnusedPatternBinds, - warnSpec Opt_WarnUnusedTopBinds, - warnSpec Opt_WarnUnusedTypePatterns, - warnSpec Opt_WarnUnusedRecordWildcards, - warnSpec Opt_WarnRedundantBangPatterns, - warnSpec Opt_WarnRedundantRecordWildcards, - warnSpec Opt_WarnRedundantStrictnessFlags, - warnSpec Opt_WarnWrongDoBind, - warnSpec Opt_WarnMissingPatternSynonymSignatures, - warnSpec Opt_WarnMissingDerivingStrategies, - warnSpec Opt_WarnSimplifiableClassConstraints, - warnSpec Opt_WarnMissingHomeModules, - warnSpec Opt_WarnUnrecognisedWarningFlags, - warnSpec Opt_WarnStarBinder, - warnSpec Opt_WarnStarIsType, - depWarnSpec Opt_WarnSpaceAfterBang - "bang patterns can no longer be written with a space", - warnSpec Opt_WarnPartialFields, - warnSpec Opt_WarnPrepositiveQualifiedModule, - warnSpec Opt_WarnUnusedPackages, - warnSpec Opt_WarnCompatUnqualifiedImports, - warnSpec Opt_WarnInvalidHaddock, - warnSpec Opt_WarnOperatorWhitespaceExtConflict, - warnSpec Opt_WarnOperatorWhitespace, - warnSpec Opt_WarnImplicitLift, - warnSpec Opt_WarnMissingExportedPatternSynonymSignatures, - warnSpec Opt_WarnForallIdentifier, - warnSpec Opt_WarnUnicodeBidirectionalFormatCharacters, - warnSpec Opt_WarnGADTMonoLocalBinds, - warnSpec Opt_WarnTypeEqualityOutOfScope, - warnSpec Opt_WarnTypeEqualityRequiresOperators, - warnSpec Opt_WarnTermVariableCapture, - warnSpec Opt_WarnMissingRoleAnnotations, - warnSpec Opt_WarnImplicitRhsQuantification, - warnSpec Opt_WarnIncompleteExportWarnings - ] + Opt_WarnAlternativeLayoutRuleTransitional -> warnSpec x + Opt_WarnAmbiguousFields -> warnSpec x + Opt_WarnAutoOrphans + -> depWarnSpec x "it has no effect" + Opt_WarnCPPUndef -> warnSpec x + Opt_WarnUnbangedStrictPatterns -> warnSpec x + Opt_WarnDeferredTypeErrors -> warnSpec x + Opt_WarnDeferredOutOfScopeVariables -> warnSpec x + Opt_WarnDeprecatedFlags -> warnSpec x + Opt_WarnDerivingDefaults -> warnSpec x + Opt_WarnDerivingTypeable -> warnSpec x + Opt_WarnDodgyExports -> warnSpec x + Opt_WarnDodgyForeignImports -> warnSpec x + Opt_WarnDodgyImports -> warnSpec x + Opt_WarnEmptyEnumerations -> warnSpec x + Opt_WarnDuplicateConstraints + -> subWarnSpec "duplicate-constraints" x "it is subsumed by -Wredundant-constraints" + Opt_WarnRedundantConstraints -> warnSpec x + Opt_WarnDuplicateExports -> warnSpec x + Opt_WarnHiShadows + -> depWarnSpec x "it is not used, and was never implemented" + Opt_WarnInaccessibleCode -> warnSpec x + Opt_WarnImplicitPrelude -> warnSpec x + Opt_WarnImplicitKindVars + -> depWarnSpec x "it is now an error" + Opt_WarnIncompletePatterns -> warnSpec x + Opt_WarnIncompletePatternsRecUpd -> warnSpec x + Opt_WarnIncompleteUniPatterns -> warnSpec x + Opt_WarnInconsistentFlags -> warnSpec x + Opt_WarnInlineRuleShadowing -> warnSpec x + Opt_WarnIdentities -> warnSpec x + Opt_WarnLoopySuperclassSolve -> warnSpec x + Opt_WarnMissingFields -> warnSpec x + Opt_WarnMissingImportList -> warnSpec x + Opt_WarnMissingExportList -> warnSpec x + Opt_WarnMissingLocalSignatures + -> subWarnSpec "missing-local-sigs" x + "it is replaced by -Wmissing-local-signatures" + ++ warnSpec x + Opt_WarnMissingMethods -> warnSpec x + Opt_WarnMissingMonadFailInstances + -> depWarnSpec x "fail is no longer a method of Monad" + Opt_WarnSemigroup -> warnSpec x + Opt_WarnMissingSignatures -> warnSpec x + Opt_WarnMissingKindSignatures -> warnSpec x + Opt_WarnMissingPolyKindSignatures -> warnSpec x + Opt_WarnMissingExportedSignatures + -> subWarnSpec "missing-exported-sigs" x + "it is replaced by -Wmissing-exported-signatures" + ++ warnSpec x + Opt_WarnMonomorphism -> warnSpec x + Opt_WarnNameShadowing -> warnSpec x + Opt_WarnNonCanonicalMonadInstances -> warnSpec x + Opt_WarnNonCanonicalMonadFailInstances -> depWarnSpec x "fail is no longer a method of Monad" + Opt_WarnNonCanonicalMonoidInstances -> warnSpec x + Opt_WarnOrphans -> warnSpec x + Opt_WarnOverflowedLiterals -> warnSpec x + Opt_WarnOverlappingPatterns -> warnSpec x + Opt_WarnMissedSpecs -> warnSpec x + Opt_WarnAllMissedSpecs -> warnSpec x + Opt_WarnSafe -> warnSpec' x setWarnSafe + Opt_WarnTrustworthySafe -> warnSpec x + Opt_WarnInferredSafeImports -> warnSpec x + Opt_WarnMissingSafeHaskellMode -> warnSpec x + Opt_WarnTabs -> warnSpec x + Opt_WarnTypeDefaults -> warnSpec x + Opt_WarnTypedHoles -> warnSpec x + Opt_WarnPartialTypeSignatures -> warnSpec x + Opt_WarnUnrecognisedPragmas -> warnSpec x + Opt_WarnMisplacedPragmas -> warnSpec x + Opt_WarnUnsafe -> warnSpec' x setWarnUnsafe + Opt_WarnUnsupportedCallingConventions -> warnSpec x + Opt_WarnUnsupportedLlvmVersion -> warnSpec x + Opt_WarnMissedExtraSharedLib -> warnSpec x + Opt_WarnUntickedPromotedConstructors -> warnSpec x + Opt_WarnUnusedDoBind -> warnSpec x + Opt_WarnUnusedForalls -> warnSpec x + Opt_WarnUnusedImports -> warnSpec x + Opt_WarnUnusedLocalBinds -> warnSpec x + Opt_WarnUnusedMatches -> warnSpec x + Opt_WarnUnusedPatternBinds -> warnSpec x + Opt_WarnUnusedTopBinds -> warnSpec x + Opt_WarnUnusedTypePatterns -> warnSpec x + Opt_WarnUnusedRecordWildcards -> warnSpec x + Opt_WarnRedundantBangPatterns -> warnSpec x + Opt_WarnRedundantRecordWildcards -> warnSpec x + Opt_WarnRedundantStrictnessFlags -> warnSpec x + Opt_WarnWrongDoBind -> warnSpec x + Opt_WarnMissingPatternSynonymSignatures -> warnSpec x + Opt_WarnMissingDerivingStrategies -> warnSpec x + Opt_WarnSimplifiableClassConstraints -> warnSpec x + Opt_WarnMissingHomeModules -> warnSpec x + Opt_WarnUnrecognisedWarningFlags -> warnSpec x + Opt_WarnStarBinder -> warnSpec x + Opt_WarnStarIsType -> warnSpec x + Opt_WarnSpaceAfterBang + -> depWarnSpec x "bang patterns can no longer be written with a space" + Opt_WarnPartialFields -> warnSpec x + Opt_WarnPrepositiveQualifiedModule -> warnSpec x + Opt_WarnUnusedPackages -> warnSpec x + Opt_WarnCompatUnqualifiedImports -> warnSpec x + Opt_WarnInvalidHaddock -> warnSpec x + Opt_WarnOperatorWhitespaceExtConflict -> warnSpec x + Opt_WarnOperatorWhitespace -> warnSpec x + Opt_WarnImplicitLift -> warnSpec x + Opt_WarnMissingExportedPatternSynonymSignatures -> warnSpec x + Opt_WarnForallIdentifier -> warnSpec x + Opt_WarnUnicodeBidirectionalFormatCharacters -> warnSpec x + Opt_WarnGADTMonoLocalBinds -> warnSpec x + Opt_WarnTypeEqualityOutOfScope -> warnSpec x + Opt_WarnTypeEqualityRequiresOperators -> warnSpec x + Opt_WarnTermVariableCapture -> warnSpec x + Opt_WarnMissingRoleAnnotations -> warnSpec x + Opt_WarnImplicitRhsQuantification -> warnSpec x + Opt_WarnIncompleteExportWarnings -> warnSpec x warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)] warningGroupsDeps = map mk warningGroups @@ -2485,7 +2482,11 @@ flagSpec "show-error-context" Opt_ShowErrorContext, flagSpec "cmm-thread-sanitizer" Opt_CmmThreadSanitizer, flagSpec "split-sections" Opt_SplitSections, - flagSpec "break-points" Opt_InsertBreakpoints + flagSpec "break-points" Opt_InsertBreakpoints, + 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 @@ -2779,6 +2780,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/GHC/HsToCore/Binds.hs b/GHC/HsToCore/Binds.hs --- a/GHC/HsToCore/Binds.hs +++ b/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/GHC/HsToCore/Foreign/C.hs b/GHC/HsToCore/Foreign/C.hs --- a/GHC/HsToCore/Foreign/C.hs +++ b/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/GHC/Iface/Errors/Ppr.hs b/GHC/Iface/Errors/Ppr.hs --- a/GHC/Iface/Errors/Ppr.hs +++ b/GHC/Iface/Errors/Ppr.hs @@ -279,9 +279,10 @@ mod_hidden pkg = text "it is a hidden module in the package" <+> quotes (ppr pkg) - unusable (pkg, reason) - = text "It is a member of the package" - <+> quotes (ppr pkg) + unusable (UnusableUnit unit reason reexport) + = text "It is " <> (if reexport then text "reexported from the package" + else text "a member of the package") + <+> quotes (ppr unit) $$ pprReason (text "which is") reason diff --git a/GHC/Iface/Errors/Types.hs b/GHC/Iface/Errors/Types.hs --- a/GHC/Iface/Errors/Types.hs +++ b/GHC/Iface/Errors/Types.hs @@ -25,7 +25,7 @@ import GHC.Types.Name (Name) import GHC.Types.TyThing (TyThing) import GHC.Unit.Types (Module, InstalledModule, UnitId, Unit) -import GHC.Unit.State (UnitState, ModuleSuggestion, ModuleOrigin, UnusableUnitReason, UnitInfo) +import GHC.Unit.State (UnitState, ModuleSuggestion, ModuleOrigin, UnusableUnit, UnitInfo) import GHC.Exception.Type (SomeException) import GHC.Unit.Types ( IsBootInterface ) import Language.Haskell.Syntax.Module.Name ( ModuleName ) @@ -80,7 +80,7 @@ | CouldntFindInFiles [FilePath] | GenericMissing [(Unit, Maybe UnitInfo)] [Unit] - [(Unit, UnusableUnitReason)] [FilePath] + [UnusableUnit] [FilePath] | MultiplePackages [(Module, ModuleOrigin)] deriving Generic diff --git a/GHC/IfaceToCore.hs b/GHC/IfaceToCore.hs --- a/GHC/IfaceToCore.hs +++ b/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/GHC/Linker/Dynamic.hs b/GHC/Linker/Dynamic.hs --- a/GHC/Linker/Dynamic.hs +++ b/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/GHC/Llvm/Ppr.hs b/GHC/Llvm/Ppr.hs --- a/GHC/Llvm/Ppr.hs +++ b/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/GHC/Llvm/Syntax.hs b/GHC/Llvm/Syntax.hs --- a/GHC/Llvm/Syntax.hs +++ b/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/GHC/Parser/HaddockLex.hs b/GHC/Parser/HaddockLex.hs --- a/GHC/Parser/HaddockLex.hs +++ b/GHC/Parser/HaddockLex.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 1 "_build/source-dist/ghc-9.8.1-src/ghc-9.8.1/compiler/GHC/Parser/HaddockLex.x" #-} +{-# LINE 1 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Parser/HaddockLex.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -funbox-strict-fields #-} @@ -109,7 +109,7 @@ , (0,alex_action_1) ] -{-# LINE 86 "_build/source-dist/ghc-9.8.1-src/ghc-9.8.1/compiler/GHC/Parser/HaddockLex.x" #-} +{-# LINE 86 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Parser/HaddockLex.x" #-} data AlexInput = AlexInput { alexInput_position :: !RealSrcLoc , alexInput_string :: !ByteString diff --git a/GHC/Parser/Lexer.hs b/GHC/Parser/Lexer.hs --- a/GHC/Parser/Lexer.hs +++ b/GHC/Parser/Lexer.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-binds -fno-warn-missing-signatures #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} -{-# LINE 43 "_build/source-dist/ghc-9.8.1-src/ghc-9.8.1/compiler/GHC/Parser/Lexer.x" #-} +{-# LINE 43 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Parser/Lexer.x" #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} @@ -789,7 +789,7 @@ , (0,alex_action_101) ] -{-# LINE 794 "_build/source-dist/ghc-9.8.1-src/ghc-9.8.1/compiler/GHC/Parser/Lexer.x" #-} +{-# LINE 794 "_build/source-dist/ghc-9.8.2-src/ghc-9.8.2/compiler/GHC/Parser/Lexer.x" #-} -- Operator whitespace occurrence. See Note [Whitespace-sensitive operator parsing]. data OpWs = OpWsPrefix -- a !b @@ -1483,7 +1483,7 @@ nested_doc_comment :: Action nested_doc_comment span buf _len _buf2 = {-# SCC "nested_doc_comment" #-} withLexedDocType worker where - worker input docType _checkNextLine = nested_comment_logic endComment "" input span + worker input@(AI start_loc _) docType _checkNextLine = nested_comment_logic endComment "" input (mkPsSpan start_loc (psSpanEnd span)) where endComment input lcomment = docCommentEnd input (docType (\d -> NestedDocString d (mkHsDocStringChunk . dropTrailingDec <$> lcomment))) buf span diff --git a/GHC/Platform/Wasm32.hs b/GHC/Platform/Wasm32.hs --- a/GHC/Platform/Wasm32.hs +++ b/GHC/Platform/Wasm32.hs @@ -4,7 +4,6 @@ import GHC.Prelude --- TODO -#define MACHREGS_NO_REGS 1 --- #define MACHREGS_wasm32 1 +#define MACHREGS_NO_REGS 0 +#define MACHREGS_wasm32 1 #include "CodeGen.Platform.h" diff --git a/GHC/Rename/Doc.hs b/GHC/Rename/Doc.hs --- a/GHC/Rename/Doc.hs +++ b/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/GHC/Rename/Env.hs b/GHC/Rename/Env.hs --- a/GHC/Rename/Env.hs +++ b/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/GHC/Rename/Module.hs b/GHC/Rename/Module.hs --- a/GHC/Rename/Module.hs +++ b/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/GHC/Rename/Names.hs b/GHC/Rename/Names.hs --- a/GHC/Rename/Names.hs +++ b/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/GHC/Rename/Utils.hs b/GHC/Rename/Utils.hs --- a/GHC/Rename/Utils.hs +++ b/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/GHC/Runtime/Heap/Layout.hs b/GHC/Runtime/Heap/Layout.hs --- a/GHC/Runtime/Heap/Layout.hs +++ b/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/GHC/Settings.hs b/GHC/Settings.hs --- a/GHC/Settings.hs +++ b/GHC/Settings.hs @@ -89,6 +89,7 @@ { toolSettings_ldSupportsCompactUnwind :: Bool , toolSettings_ldSupportsFilelist :: Bool , toolSettings_ldSupportsResponseFiles :: Bool + , toolSettings_ldSupportsSingleModule :: Bool , toolSettings_ldIsGnuLd :: Bool , toolSettings_ccSupportsNoPie :: Bool , toolSettings_useInplaceMinGW :: Bool diff --git a/GHC/Settings/IO.hs b/GHC/Settings/IO.hs --- a/GHC/Settings/IO.hs +++ b/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/GHC/Stg/CSE.hs b/GHC/Stg/CSE.hs --- a/GHC/Stg/CSE.hs +++ b/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/GHC/Stg/Debug.hs b/GHC/Stg/Debug.hs --- a/GHC/Stg/Debug.hs +++ b/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/GHC/StgToCmm/Bind.hs b/GHC/StgToCmm/Bind.hs --- a/GHC/StgToCmm/Bind.hs +++ b/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/GHC/StgToCmm/CgUtils.hs b/GHC/StgToCmm/CgUtils.hs --- a/GHC/StgToCmm/CgUtils.hs +++ b/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/GHC/StgToCmm/Closure.hs b/GHC/StgToCmm/Closure.hs --- a/GHC/StgToCmm/Closure.hs +++ b/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/GHC/StgToCmm/Config.hs b/GHC/StgToCmm/Config.hs --- a/GHC/StgToCmm/Config.hs +++ b/GHC/StgToCmm/Config.hs @@ -50,8 +50,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/GHC/StgToCmm/Expr.hs b/GHC/StgToCmm/Expr.hs --- a/GHC/StgToCmm/Expr.hs +++ b/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/GHC/StgToCmm/Heap.hs b/GHC/StgToCmm/Heap.hs --- a/GHC/StgToCmm/Heap.hs +++ b/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/GHC/StgToCmm/Monad.hs b/GHC/StgToCmm/Monad.hs --- a/GHC/StgToCmm/Monad.hs +++ b/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/GHC/StgToCmm/Prim.hs b/GHC/StgToCmm/Prim.hs --- a/GHC/StgToCmm/Prim.hs +++ b/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/GHC/StgToCmm/Prof.hs b/GHC/StgToCmm/Prof.hs --- a/GHC/StgToCmm/Prof.hs +++ b/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/GHC/StgToCmm/Sequel.hs b/GHC/StgToCmm/Sequel.hs --- a/GHC/StgToCmm/Sequel.hs +++ b/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/GHC/StgToCmm/Utils.hs b/GHC/StgToCmm/Utils.hs --- a/GHC/StgToCmm/Utils.hs +++ b/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/GHC/StgToJS/Linker/Utils.hs b/GHC/StgToJS/Linker/Utils.hs --- a/GHC/StgToJS/Linker/Utils.hs +++ b/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/GHC/Tc/Deriv/Generate.hs b/GHC/Tc/Deriv/Generate.hs --- a/GHC/Tc/Deriv/Generate.hs +++ b/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/GHC/Tc/Errors/Ppr.hs b/GHC/Tc/Errors/Ppr.hs --- a/GHC/Tc/Errors/Ppr.hs +++ b/GHC/Tc/Errors/Ppr.hs @@ -987,6 +987,12 @@ -- Note [Swizzling the tyvars before generaliseTcTyCon] = vcat [ quotes (ppr n1) <+> text "bound at" <+> ppr (getSrcLoc n1) , quotes (ppr n2) <+> text "bound at" <+> ppr (getSrcLoc n2) ] + + TcRnDisconnectedTyVar n + -> mkSimpleDecorated $ + hang (text "Scoped type variable only appears non-injectively in declaration header:") + 2 (quotes (ppr n) <+> text "bound at" <+> ppr (getSrcLoc n)) + TcRnInvalidReturnKind data_sort allowed_kind kind _suggested_ext -> mkSimpleDecorated $ sep [ ppDataSort data_sort <+> @@ -2135,6 +2141,8 @@ -> ErrorWithoutFlag TcRnDifferentNamesForTyVar{} -> ErrorWithoutFlag + TcRnDisconnectedTyVar{} + -> ErrorWithoutFlag TcRnInvalidReturnKind{} -> ErrorWithoutFlag TcRnClassKindNotConstraint{} @@ -2752,6 +2760,8 @@ -> noHints TcRnDifferentNamesForTyVar{} -> noHints + TcRnDisconnectedTyVar n + -> [SuggestBindTyVarExplicitly n] TcRnInvalidReturnKind _ _ _ mb_suggest_unlifted_ext -> case mb_suggest_unlifted_ext of Nothing -> noHints @@ -5994,7 +6004,7 @@ hang (text "Mismatched type name in type family instance.") 2 (vcat [ text "Expected:" <+> ppr fam_tc_name , text " Actual:" <+> ppr eqn_tc_name ]) - FamInstRHSOutOfScopeTyVars mb_dodgy tvs -> + FamInstRHSOutOfScopeTyVars mb_dodgy (NE.toList -> tvs) -> hang (text "Out of scope type variable" <> plural tvs <+> pprWithCommas (quotes . ppr) tvs <+> text "in the RHS of a family instance.") @@ -6007,13 +6017,60 @@ mk_extra = case mb_dodgy of Nothing -> empty Just (fam_tc, pats, dodgy_tvs) -> - ppWhen (any (`elemVarSetByKey` dodgy_tvs) (map nameUnique tvs)) $ + ppWhen (any (`elemVarSetByKey` dodgy_tvs) (fmap nameUnique tvs)) $ hang (text "The real LHS (expanding synonyms) is:") 2 (pprTypeApp fam_tc (map expandTypeSynonyms pats)) - FamInstLHSUnusedBoundTyVars tvs -> - hang (text "Type variable" <> plural tvs <+> pprQuotedList tvs - <+> isOrAre tvs <+> text "bound by a forall,") - 2 (text "but not used in the family instance.") + FamInstLHSUnusedBoundTyVars (NE.toList -> bad_qtvs) -> + vcat [ not_bound_msg, not_used_msg, dodgy_msg ] + where + + -- Filter to only keep user-written variables, + -- unless none were user-written in which case we report all of them + -- (as we need to report an error). + filter_user tvs + = map ifiqtv + $ case filter ifiqtv_user_written tvs of { [] -> tvs ; qvs -> qvs } + + (not_bound, not_used, dodgy) + = case foldr acc_tv ([], [], []) bad_qtvs of + (nb, nu, d) -> (filter_user nb, filter_user nu, filter_user d) + + acc_tv tv (nb, nu, d) = case ifiqtv_reason tv of + InvalidFamInstQTvNotUsedInRHS -> (nb, tv : nu, d) + InvalidFamInstQTvNotBoundInPats -> (tv : nb, nu, d) + InvalidFamInstQTvDodgy -> (nb, nu, tv : d) + + -- Error message for type variables not bound in LHS patterns. + not_bound_msg + | null not_bound + = empty + | otherwise + = vcat [ text "The type variable" <> plural not_bound <+> pprQuotedList not_bound + <+> isOrAre not_bound <+> text "bound by a forall," + , text "but" <+> doOrDoes not_bound <+> text "not appear in any of the LHS patterns of the family instance." ] + + -- Error message for type variables bound by a forall but not used + -- in the RHS. + not_used_msg = + if null not_used + then empty + else text "The type variable" <> plural not_used <+> pprQuotedList not_used + <+> isOrAre not_used <+> text "bound by a forall," $$ + text "but" <+> itOrThey not_used <+> + isOrAre not_used <> text "n't used in the family instance." + + -- Error message for dodgy type variables. + -- See Note [Dodgy binding sites in type family instances] in GHC.Tc.Validity. + dodgy_msg + | null dodgy + = empty + | otherwise + = hang (text "Dodgy type variable" <> plural dodgy <+> pprQuotedList dodgy + <+> text "in the LHS of a family instance:") + 2 (text "the type variable" <> plural dodgy <+> pprQuotedList dodgy + <+> text "syntactically appear" <> singular dodgy <+> text "in LHS patterns," + $$ text "but" <+> itOrThey dodgy <+> doOrDoes dodgy <> text "n't appear in an injective position.") + illegalFamilyInstanceHints :: IllegalFamilyInstanceReason -> [GhcHint] illegalFamilyInstanceHints = \case diff --git a/GHC/Tc/Errors/Types.hs b/GHC/Tc/Errors/Types.hs --- a/GHC/Tc/Errors/Types.hs +++ b/GHC/Tc/Errors/Types.hs @@ -137,6 +137,7 @@ , IllegalHasFieldInstance(..) , CoverageProblem(..), FailedCoverageCondition(..) , IllegalFamilyInstanceReason(..) + , InvalidFamInstQTv(..), InvalidFamInstQTvReason(..) , InvalidAssoc(..), InvalidAssocInstance(..) , InvalidAssocDefault(..), AssocDefaultBadArgs(..) @@ -180,7 +181,7 @@ import GHC.Types.Hint (UntickedPromotedThing(..)) import GHC.Types.ForeignCall (CLabelString) import GHC.Types.Id.Info ( RecSelParent(..) ) -import GHC.Types.Name (Name, OccName, getSrcLoc, getSrcSpan) +import GHC.Types.Name (NamedThing(..), Name, OccName, getSrcLoc, getSrcSpan) import qualified GHC.Types.Name.Occurrence as OccName import GHC.Types.Name.Reader import GHC.Types.SourceFile (HsBootOrSig(..)) @@ -2262,6 +2263,13 @@ -} TcRnDifferentNamesForTyVar :: !Name -> !Name -> TcRnMessage + {-| TcRnDisconnectedTyVar is an error for a data declaration that has a kind signature, + where the implicitly-bound type type variables can't be matched up unambiguously + with the ones from the signature. See Note [Disconnected type variables] in + GHC.Tc.Gen.HsType. + -} + TcRnDisconnectedTyVar :: !Name -> TcRnMessage + {-| TcRnInvalidReturnKind is an error for a data declaration that has a kind signature with an invalid result kind. @@ -4547,13 +4555,46 @@ -- ^ family 'TyCon', arguments, and set of "dodgy" type variables -- See Note [Dodgy binding sites in type family instances] -- in GHC.Tc.Validity - ![Name] -- ^ the out-of-scope type variables + !(NE.NonEmpty Name) -- ^ the out-of-scope type variables | FamInstLHSUnusedBoundTyVars - ![Name] -- ^ the unused bound type variables + !(NE.NonEmpty InvalidFamInstQTv) -- ^ the unused bound type variables | InvalidAssoc !InvalidAssoc deriving Generic + +-- | A quantified type variable in a type or data family equation that +-- is either not bound in any LHS patterns or not used in the RHS (or both). +data InvalidFamInstQTv + = InvalidFamInstQTv + { ifiqtv :: TcTyVar + , ifiqtv_user_written :: Bool + -- ^ Did the user write this type variable, or was introduced by GHC? + -- For example: with @-XPolyKinds@, in @type instance forall a. F = ()@, + -- we have a user-written @a@ but GHC introduces a kind variable @k@ + -- as well. See #23734. + , ifiqtv_reason :: InvalidFamInstQTvReason + -- ^ For what reason was the quantified type variable invalid? + } + +data InvalidFamInstQTvReason + -- | A dodgy binder, i.e. a variable that syntactically appears in + -- LHS patterns but only in non-injective positions. + -- + -- See Note [Dodgy binding sites in type family instances] + -- in GHC.Tc.Validity. + = InvalidFamInstQTvDodgy + -- | A quantified type variable in a type or data family equation + -- that is not bound in any LHS patterns. + | InvalidFamInstQTvNotBoundInPats + -- | A quantified type variable in a type or data family equation + -- that is not used on the RHS. + | InvalidFamInstQTvNotUsedInRHS + +-- The 'check_tvs' function in 'GHC.Tc.Validity.checkFamPatBinders' +-- uses 'getSrcSpan', so this 'NamedThing' instance is convenient. +instance NamedThing InvalidFamInstQTv where + getName = getName . ifiqtv data InvalidAssoc -- | An invalid associated family instance. diff --git a/GHC/Tc/Gen/HsType.hs b/GHC/Tc/Gen/HsType.hs --- a/GHC/Tc/Gen/HsType.hs +++ b/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/GHC/Tc/Gen/Splice.hs b/GHC/Tc/Gen/Splice.hs --- a/GHC/Tc/Gen/Splice.hs +++ b/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/GHC/Tc/Solver/Equality.hs b/GHC/Tc/Solver/Equality.hs --- a/GHC/Tc/Solver/Equality.hs +++ b/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/GHC/Tc/TyCl.hs b/GHC/Tc/TyCl.hs --- a/GHC/Tc/TyCl.hs +++ b/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/GHC/Tc/TyCl/Build.hs b/GHC/Tc/TyCl/Build.hs --- a/GHC/Tc/TyCl/Build.hs +++ b/GHC/Tc/TyCl/Build.hs @@ -4,7 +4,6 @@ -} - {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module GHC.Tc.TyCl.Build ( diff --git a/GHC/Tc/TyCl/Instance.hs b/GHC/Tc/TyCl/Instance.hs --- a/GHC/Tc/TyCl/Instance.hs +++ b/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/GHC/Tc/TyCl/Utils.hs b/GHC/Tc/TyCl/Utils.hs --- a/GHC/Tc/TyCl/Utils.hs +++ b/GHC/Tc/TyCl/Utils.hs @@ -1,4 +1,3 @@ - {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE TypeFamilies #-} diff --git a/GHC/Tc/Validity.hs b/GHC/Tc/Validity.hs --- a/GHC/Tc/Validity.hs +++ b/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/GHC/Tc/Zonk/Type.hs b/GHC/Tc/Zonk/Type.hs --- a/GHC/Tc/Zonk/Type.hs +++ b/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/GHC/Types/Avail.hs b/GHC/Types/Avail.hs --- a/GHC/Types/Avail.hs +++ b/GHC/Types/Avail.hs @@ -175,7 +175,7 @@ -- 'avails' may have several items with the same availName -- E.g import Ix( Ix(..), index ) -- will give Ix(Ix,index,range) and Ix(index) --- We want to combine these; addAvail does that +-- We want to combine these; plusAvail does that nubAvails :: [AvailInfo] -> [AvailInfo] nubAvails avails = eltsDNameEnv (foldl' add emptyDNameEnv avails) where diff --git a/GHC/Types/Error/Codes.hs b/GHC/Types/Error/Codes.hs --- a/GHC/Types/Error/Codes.hs +++ b/GHC/Types/Error/Codes.hs @@ -458,6 +458,7 @@ GhcDiagnosticCode "TcRnInvalidVisibleKindArgument" = 20967 GhcDiagnosticCode "TcRnTooManyBinders" = 05989 GhcDiagnosticCode "TcRnDifferentNamesForTyVar" = 17370 + GhcDiagnosticCode "TcRnDisconnectedTyVar" = 59738 GhcDiagnosticCode "TcRnInvalidReturnKind" = 55233 GhcDiagnosticCode "TcRnClassKindNotConstraint" = 80768 GhcDiagnosticCode "TcRnMatchesHaveDiffNumArgs" = 91938 diff --git a/GHC/Types/Hint.hs b/GHC/Types/Hint.hs --- a/GHC/Types/Hint.hs +++ b/GHC/Types/Hint.hs @@ -474,6 +474,9 @@ -} | SuggestBindTyVarOnLhs RdrName + {-| Suggest binding explicitly; e.g data T @k (a :: F k) = .... -} + | SuggestBindTyVarExplicitly Name + -- | An 'InstantiationSuggestion' for a '.hsig' file. This is generated -- by GHC in case of a 'DriverUnexpectedSignature' and suggests a way -- to instantiate a particular signature, where the first argument is diff --git a/GHC/Types/Hint/Ppr.hs b/GHC/Types/Hint/Ppr.hs --- a/GHC/Types/Hint/Ppr.hs +++ b/GHC/Types/Hint/Ppr.hs @@ -266,6 +266,9 @@ ppr_r = quotes $ ppr r SuggestBindTyVarOnLhs tv -> text "Bind" <+> quotes (ppr tv) <+> text "on the LHS of the type declaration" + SuggestBindTyVarExplicitly tv + -> text "bind" <+> quotes (ppr tv) + <+> text "explicitly with" <+> quotes (char '@' <> ppr tv) perhapsAsPat :: SDoc perhapsAsPat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace" diff --git a/GHC/Types/Name/Reader.hs b/GHC/Types/Name/Reader.hs --- a/GHC/Types/Name/Reader.hs +++ b/GHC/Types/Name/Reader.hs @@ -76,6 +76,7 @@ -- ** Global 'RdrName' mapping elements: 'GlobalRdrElt', 'Provenance', 'ImportSpec' GlobalRdrEltX(..), GlobalRdrElt, IfGlobalRdrElt, FieldGlobalRdrElt, greName, greNameSpace, greParent, greInfo, + plusGRE, insertGRE, forceGlobalRdrEnv, hydrateGlobalRdrEnv, isLocalGRE, isImportedGRE, isRecFldGRE, fieldGREInfo, @@ -573,7 +574,10 @@ -- Note [Retrieving the GREInfo from interfaces] in GHC.Types.GREInfo. } deriving (Data) +instance NFData a => NFData (GlobalRdrEltX a) where + rnf (GRE name par _ imp info) = rnf name `seq` rnf par `seq` rnf imp `seq` rnf info + {- Note [IfGlobalRdrEnv] ~~~~~~~~~~~~~~~~~~~~~~~~ Information pertinent to the renamer about a 'Name' is stored in the fields of @@ -619,18 +623,19 @@ greInfo :: GlobalRdrElt -> GREInfo greInfo = gre_info -instance NFData IfGlobalRdrElt where - rnf !_ = () - -- | See Note [Parents] data Parent = NoParent - | ParentIs { par_is :: Name } + | ParentIs { par_is :: !Name } deriving (Eq, Data) instance Outputable Parent where ppr NoParent = empty ppr (ParentIs n) = text "parent:" <> ppr n +instance NFData Parent where + rnf NoParent = () + rnf (ParentIs n) = rnf n + plusParent :: Parent -> Parent -> Parent -- See Note [Combining parents] plusParent p1@(ParentIs _) p2 = hasParent p1 p2 @@ -933,11 +938,10 @@ -- | Drop all 'GREInfo' fields in a 'GlobalRdrEnv' in order to -- avoid space leaks. --- -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. forceGlobalRdrEnv :: GlobalRdrEnvX info -> IfGlobalRdrEnv forceGlobalRdrEnv rdrs = - strictMapOccEnv (strictMap (\ gre -> gre { gre_info = () })) rdrs + strictMapOccEnv (strictMap (\ gre -> gre { gre_info = ()})) rdrs -- | Hydrate a previously dehydrated 'GlobalRdrEnv', -- by (lazily!) looking up the 'GREInfo' using the provided function. @@ -1165,6 +1169,17 @@ } -> WhichGREs GREInfo +instance Outputable (WhichGREs info) where + ppr SameNameSpace = text "SameNameSpace" + ppr (RelevantGREs { includeFieldSelectors = sel + , lookupVariablesForFields = vars + , lookupTyConsAsWell = tcs_too }) + = braces $ hsep + [ text "RelevantGREs" + , text (show sel) + , if vars then text "[vars]" else empty + , if tcs_too then text "[tcs]" else empty ] + -- | Look up as many possibly relevant 'GlobalRdrElt's as possible. pattern AllRelevantGREs :: WhichGREs GREInfo pattern AllRelevantGREs = @@ -1199,6 +1214,17 @@ -- See Note [childGREPriority]. } +instance Outputable LookupChild where + ppr (LookupChild { wantedParent = par + , lookupDataConFirst = dc + , prioritiseParent = prio_parent }) + = braces $ hsep + [ text "LookupChild" + , braces (text "parent:" <+> ppr par) + , if dc then text "[dc_first]" else empty + , if prio_parent then text "[prio_parent]" else empty + ] + -- | After looking up something with the given 'NameSpace', is the resulting -- 'GlobalRdrElt' we have obtained relevant, according to the 'RelevantGREs' -- specification of which 'NameSpace's are relevant? @@ -1893,25 +1919,28 @@ -- -- The 'ImportSpec' of something says how it came to be imported -- It's quite elaborate so that we can give accurate unused-name warnings. -data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, - is_item :: ImpItemSpec } +data ImportSpec = ImpSpec { is_decl :: !ImpDeclSpec, + is_item :: !ImpItemSpec } deriving( Eq, Data ) +instance NFData ImportSpec where + rnf = rwhnf -- All fields are strict, so we don't need to do anything + -- | Import Declaration Specification -- -- Describes a particular import declaration and is -- shared among all the 'Provenance's for that decl data ImpDeclSpec = ImpDeclSpec { - is_mod :: Module, -- ^ Module imported, e.g. @import Muggle@ + is_mod :: !Module, -- ^ Module imported, e.g. @import Muggle@ -- Note the @Muggle@ may well not be -- the defining module for this thing! -- TODO: either should be Module, or there -- should be a Maybe UnitId here too. - is_as :: ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) - is_qual :: Bool, -- ^ Was this import qualified? - is_dloc :: SrcSpan -- ^ The location of the entire import declaration + is_as :: !ModuleName, -- ^ Import alias, e.g. from @as M@ (or @Muggle@ if there is no @as@ clause) + is_qual :: !Bool, -- ^ Was this import qualified? + is_dloc :: !SrcSpan -- ^ The location of the entire import declaration } deriving (Eq, Data) -- | Import Item Specification @@ -1922,8 +1951,8 @@ -- or had a hiding list | ImpSome { - is_explicit :: Bool, - is_iloc :: SrcSpan -- Location of the import item + is_explicit :: !Bool, + is_iloc :: !SrcSpan -- Location of the import item } -- ^ The import had an import list. -- The 'is_explicit' field is @True@ iff the thing was named -- /explicitly/ in the import specs rather diff --git a/GHC/Unit/Finder.hs b/GHC/Unit/Finder.hs --- a/GHC/Unit/Finder.hs +++ b/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/GHC/Unit/Finder/Types.hs b/GHC/Unit/Finder/Types.hs --- a/GHC/Unit/Finder/Types.hs +++ b/GHC/Unit/Finder/Types.hs @@ -61,7 +61,7 @@ -- but the *unit* is hidden -- | Module is in these units, but it is unusable - , fr_unusables :: [(Unit, UnusableUnitReason)] + , fr_unusables :: [UnusableUnit] , fr_suggestions :: [ModuleSuggestion] -- ^ Possible mis-spelled modules } diff --git a/GHC/Unit/Module/ModIface.hs b/GHC/Unit/Module/ModIface.hs --- a/GHC/Unit/Module/ModIface.hs +++ b/GHC/Unit/Module/ModIface.hs @@ -575,11 +575,7 @@ `seq` rnf mi_anns `seq` rnf mi_decls `seq` rnf mi_extra_decls - `seq` mi_globals - -- NB: we already removed any potential space leaks in 'mi_globals' by - -- dehydrating, that is, by turning the 'GlobalRdrEnv' into a 'IfGlobalRdrEnv'. - -- This means we don't need to use 'rnf' here. - -- See Note [Forcing GREInfo] in GHC.Types.GREInfo. + `seq` rnf mi_globals `seq` rnf mi_insts `seq` rnf mi_fam_insts `seq` rnf mi_rules diff --git a/GHC/Unit/State.hs b/GHC/Unit/State.hs --- a/GHC/Unit/State.hs +++ b/GHC/Unit/State.hs @@ -43,6 +43,7 @@ LookupResult(..), ModuleSuggestion(..), ModuleOrigin(..), + UnusableUnit(..), UnusableUnitReason(..), pprReason, @@ -173,8 +174,10 @@ -- (But maybe the user didn't realize), so we'll still keep track -- of these modules.) ModHidden - -- | Module is unavailable because the package is unusable. - | ModUnusable UnusableUnitReason + + -- | Module is unavailable because the unit is unusable. + | ModUnusable !UnusableUnit + -- | Module is public, and could have come from some places. | ModOrigin { -- | @Just False@ means that this module is in @@ -192,6 +195,13 @@ , fromPackageFlag :: Bool } +-- | A unusable unit module origin +data UnusableUnit = UnusableUnit + { uuUnit :: !Unit -- ^ Unusable unit + , uuReason :: !UnusableUnitReason -- ^ Reason + , uuIsReexport :: !Bool -- ^ Is the "module" a reexport? + } + instance Outputable ModuleOrigin where ppr ModHidden = text "hidden module" ppr (ModUnusable _) = text "unusable module" @@ -236,7 +246,8 @@ text "x: " <> ppr x $$ text "y: " <> ppr y g Nothing x = x g x Nothing = x - x <> y = pprPanic "ModOrigin: hidden module redefined" $ + + x <> y = pprPanic "ModOrigin: module origin mismatch" $ text "x: " <> ppr x $$ text "y: " <> ppr y instance Monoid ModuleOrigin where @@ -1818,21 +1829,36 @@ mkUnusableModuleNameProvidersMap unusables = nonDetFoldUniqMap extend_modmap emptyUniqMap unusables where - extend_modmap (_uid, (pkg, reason)) modmap = addListTo modmap bindings + extend_modmap (_uid, (unit_info, reason)) modmap = addListTo modmap bindings where bindings :: [(ModuleName, UniqMap Module ModuleOrigin)] bindings = exposed ++ hidden - origin = ModUnusable reason - pkg_id = mkUnit pkg + origin_reexport = ModUnusable (UnusableUnit unit reason True) + origin_normal = ModUnusable (UnusableUnit unit reason False) + unit = mkUnit unit_info exposed = map get_exposed exposed_mods - hidden = [(m, mkModMap pkg_id m origin) | m <- hidden_mods] + hidden = [(m, mkModMap unit m origin_normal) | m <- hidden_mods] - get_exposed (mod, Just mod') = (mod, unitUniqMap mod' origin) - get_exposed (mod, _) = (mod, mkModMap pkg_id mod origin) + -- with re-exports, c:Foo can be reexported from two (or more) + -- unusable packages: + -- Foo -> a:Foo (unusable reason A) -> c:Foo + -- -> b:Foo (unusable reason B) -> c:Foo + -- + -- We must be careful to not record the following (#21097): + -- Foo -> c:Foo (unusable reason A) + -- -> c:Foo (unusable reason B) + -- But: + -- Foo -> a:Foo (unusable reason A) + -- -> b:Foo (unusable reason B) + -- + get_exposed (mod, Just _) = (mod, mkModMap unit mod origin_reexport) + get_exposed (mod, _) = (mod, mkModMap unit mod origin_normal) + -- in the reexport case, we create a virtual module that doesn't + -- exist but we don't care as it's only used as a key in the map. - exposed_mods = unitExposedModules pkg - hidden_mods = unitHiddenModules pkg + exposed_mods = unitExposedModules unit_info + hidden_mods = unitHiddenModules unit_info -- | Add a list of key/value pairs to a nested map. -- diff --git a/GHC/Utils/Outputable.hs b/GHC/Utils/Outputable.hs --- a/GHC/Utils/Outputable.hs +++ b/GHC/Utils/Outputable.hs @@ -51,6 +51,7 @@ ppWhen, ppUnless, ppWhenOption, ppUnlessOption, speakNth, speakN, speakNOf, plural, singular, isOrAre, doOrDoes, itsOrTheir, thisOrThese, hasOrHave, + itOrThey, unicodeSyntax, coloured, keyword, @@ -1523,6 +1524,15 @@ itsOrTheir :: [a] -> SDoc itsOrTheir [_] = text "its" itsOrTheir _ = text "their" + +-- | 'it' or 'they', depeneding on the length of the list. +-- +-- > itOrThey [x] = text "it" +-- > itOrThey [x,y] = text "they" +-- > itOrThey [] = text "they" -- probably avoid this +itOrThey :: [a] -> SDoc +itOrThey [_] = text "it" +itOrThey _ = text "they" -- | Determines the form of subject appropriate for the length of a list: diff --git a/MachRegs.h b/MachRegs.h --- a/MachRegs.h +++ b/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.cabal b/ghc.cabal --- a/ghc.cabal +++ b/ghc.cabal @@ -3,7 +3,7 @@ -- ./configure. Make sure you are editing ghc.cabal.in, not ghc.cabal. Name: ghc -Version: 9.8.1 +Version: 9.8.2 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team @@ -110,9 +110,9 @@ exceptions == 0.10.*, semaphore-compat, stm, - ghc-boot == 9.8.1, - ghc-heap == 9.8.1, - ghci == 9.8.1 + ghc-boot == 9.8.2, + ghc-heap == 9.8.2, + ghci == 9.8.2 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.14