ghc-lib 9.2.5.20221107 → 9.2.6.20230211
raw patch · 14 files changed
+593/−227 lines, 14 filesdep ~ghc-lib-parserPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: ghc-lib-parser
API changes (from Hackage documentation)
- GHC.CmmToAsm.AArch64.Instr: instance GHC.Show.Show GHC.CmmToAsm.AArch64.Instr.Instr
+ GHC.CmmToAsm.AArch64.Instr: instrCon :: Instr -> String
+ GHC.Core.Opt.FloatIn: instance GHC.Utils.Outputable.Outputable GHC.Core.Opt.FloatIn.FloatInBind
Files
- compiler/GHC.hs +8/−2
- compiler/GHC/CmmToAsm/AArch64/Instr.hs +78/−11
- compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +2/−4
- compiler/GHC/Core/Opt/DmdAnal.hs +144/−15
- compiler/GHC/Core/Opt/FloatIn.hs +158/−100
- compiler/GHC/CoreToStg.hs +13/−12
- compiler/GHC/Driver/Main.hs +22/−12
- compiler/GHC/HsToCore/Expr.hs +2/−1
- compiler/GHC/Rename/Bind.hs +47/−10
- compiler/GHC/Tc/Errors.hs +80/−42
- compiler/GHC/Tc/Instance/Typeable.hs +18/−4
- ghc-lib.cabal +13/−6
- ghc-lib/stage0/lib/GhclibDerivedConstants.h +7/−7
- ghc-lib/stage0/lib/settings +1/−1
compiler/GHC.hs view
@@ -554,7 +554,12 @@ initGhcMonad :: GhcMonad m => Maybe FilePath -> m () initGhcMonad mb_top_dir- = do { env <- liftIO $+ = do { -- The call to c_keepCAFsForGHCi must not be optimized away. Even in non-debug builds.+ -- So we can't use assertM here.+ -- See Note [keepCAFsForGHCi] in keepCAFsForGHCi.c for details about why.+ !keep_cafs <- liftIO $ c_keepCAFsForGHCi+ ; MASSERT( keep_cafs )+ ; env <- liftIO $ do { top_dir <- findTopDir mb_top_dir ; mySettings <- initSysTools top_dir ; myLlvmConfig <- lazyInitLlvmConfig top_dir@@ -600,7 +605,6 @@ arch = platformArch platform tablesNextToCode = platformTablesNextToCode platform - -- %************************************************************************ -- %* * -- Flags & settings@@ -1931,3 +1935,5 @@ mkApiErr :: DynFlags -> SDoc -> GhcApiError mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) +foreign import ccall unsafe "keepCAFsForGHCi"+ c_keepCAFsForGHCi :: IO Bool
compiler/GHC/CmmToAsm/AArch64/Instr.hs view
@@ -73,6 +73,11 @@ regUsageOfInstr :: Platform -> Instr -> RegUsage regUsageOfInstr platform instr = case instr of ANN _ i -> regUsageOfInstr platform i+ COMMENT{} -> usage ([], [])+ PUSH_STACK_FRAME -> usage ([], [])+ POP_STACK_FRAME -> usage ([], [])+ DELTA{} -> usage ([], [])+ -- 1. Arithmetic Instructions ------------------------------------------------ ADD dst src1 src2 -> usage (regOp src1 ++ regOp src2, regOp dst) CMN l r -> usage (regOp l ++ regOp r, [])@@ -137,7 +142,7 @@ FCVTZS dst src -> usage (regOp src, regOp dst) FABS dst src -> usage (regOp src, regOp dst) - _ -> panic "regUsageOfInstr"+ _ -> panic $ "regUsageOfInstr: " ++ instrCon instr where -- filtering the usage is necessary, otherwise the register@@ -203,7 +208,11 @@ patchRegsOfInstr :: Instr -> (Reg -> Reg) -> Instr patchRegsOfInstr instr env = case instr of -- 0. Meta Instructions- ANN d i -> ANN d (patchRegsOfInstr i env)+ ANN d i -> ANN d (patchRegsOfInstr i env)+ COMMENT{} -> instr+ PUSH_STACK_FRAME -> instr+ POP_STACK_FRAME -> instr+ DELTA{} -> instr -- 1. Arithmetic Instructions ---------------------------------------------- ADD o1 o2 o3 -> ADD (patchOp o1) (patchOp o2) (patchOp o3) CMN o1 o2 -> CMN (patchOp o1) (patchOp o2)@@ -269,8 +278,7 @@ SCVTF o1 o2 -> SCVTF (patchOp o1) (patchOp o2) FCVTZS o1 o2 -> FCVTZS (patchOp o1) (patchOp o2) FABS o1 o2 -> FABS (patchOp o1) (patchOp o2)-- _ -> pprPanic "patchRegsOfInstr" (text $ show instr)+ _ -> panic $ "patchRegsOfInstr: " ++ instrCon instr where patchOp :: Operand -> Operand patchOp (OpReg w r) = OpReg w (env r)@@ -326,7 +334,7 @@ B (TBlock bid) -> B (TBlock (patchF bid)) BL (TBlock bid) ps rs -> BL (TBlock (patchF bid)) ps rs BCOND c (TBlock bid) -> BCOND c (TBlock (patchF bid))- _ -> pprPanic "patchJumpInstr" (text $ show instr)+ _ -> panic $ "patchJumpInstr: " ++ instrCon instr -- ----------------------------------------------------------------------------- -- Note [Spills and Reloads]@@ -638,10 +646,69 @@ -- Float ABSolute value | FABS Operand Operand -instance Show Instr where- show (LDR _f o1 o2) = "LDR " ++ show o1 ++ ", " ++ show o2- show (MOV o1 o2) = "MOV " ++ show o1 ++ ", " ++ show o2- show _ = "missing"+instrCon :: Instr -> String+instrCon i =+ case i of+ COMMENT{} -> "COMMENT"+ MULTILINE_COMMENT{} -> "COMMENT"+ ANN{} -> "ANN"+ LOCATION{} -> "LOCATION"+ LDATA{} -> "LDATA"+ NEWBLOCK{} -> "NEWBLOCK"+ DELTA{} -> "DELTA"+ SXTB{} -> "SXTB"+ UXTB{} -> "UXTB"+ SXTH{} -> "SXTH"+ UXTH{} -> "UXTH"+ PUSH_STACK_FRAME{} -> "PUSH_STACK_FRAME"+ POP_STACK_FRAME{} -> "POP_STACK_FRAME"+ ADD{} -> "ADD"+ CMN{} -> "CMN"+ CMP{} -> "CMP"+ MSUB{} -> "MSUB"+ MUL{} -> "MUL"+ NEG{} -> "NEG"+ SDIV{} -> "SDIV"+ SMULH{} -> "SMULH"+ SMULL{} -> "SMULL"+ SUB{} -> "SUB"+ UDIV{} -> "UDIV"+ SBFM{} -> "SBFM"+ UBFM{} -> "UBFM"+ SBFX{} -> "SBFX"+ UBFX{} -> "UBFX"+ AND{} -> "AND"+ ANDS{} -> "ANDS"+ ASR{} -> "ASR"+ BIC{} -> "BIC"+ BICS{} -> "BICS"+ EON{} -> "EON"+ EOR{} -> "EOR"+ LSL{} -> "LSL"+ LSR{} -> "LSR"+ MOV{} -> "MOV"+ MOVK{} -> "MOVK"+ MVN{} -> "MVN"+ ORN{} -> "ORN"+ ORR{} -> "ORR"+ ROR{} -> "ROR"+ TST{} -> "TST"+ STR{} -> "STR"+ LDR{} -> "LDR"+ STP{} -> "STP"+ LDP{} -> "LDP"+ CSET{} -> "CSET"+ CBZ{} -> "CBZ"+ CBNZ{} -> "CBNZ"+ J{} -> "J"+ B{} -> "B"+ BL{} -> "BL"+ BCOND{} -> "BCOND"+ DMBSY{} -> "DMBSY"+ FCVT{} -> "FCVT"+ SCVTF{} -> "SCVTF"+ FCVTZS{} -> "FCVTZS"+ FABS{} -> "FABS" data Target = TBlock BlockId@@ -769,11 +836,11 @@ opRegUExt W32 r = OpRegExt W32 r EUXTW 0 opRegUExt W16 r = OpRegExt W16 r EUXTH 0 opRegUExt W8 r = OpRegExt W8 r EUXTB 0-opRegUExt w _r = pprPanic "opRegUExt" (text $ show w)+opRegUExt w _r = pprPanic "opRegUExt" (ppr w) opRegSExt :: Width -> Reg -> Operand opRegSExt W64 r = OpRegExt W64 r ESXTX 0 opRegSExt W32 r = OpRegExt W32 r ESXTW 0 opRegSExt W16 r = OpRegExt W16 r ESXTH 0 opRegSExt W8 r = OpRegExt W8 r ESXTB 0-opRegSExt w _r = pprPanic "opRegSExt" (text $ show w)+opRegSExt w _r = pprPanic "opRegSExt" (ppr w)
compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs view
@@ -115,10 +115,8 @@ ArchSPARC64 -> panic "trivColorable ArchSPARC64" ArchPPC_64 _ -> 15 ArchARM _ _ _ -> panic "trivColorable ArchARM"- -- We should be able to allocate *a lot* more in princple.- -- essentially all 32 - SP, so 31, we'd trash the link reg- -- as well as the platform and all others though.- ArchAArch64 -> 18+ -- N.B. x18 is reserved by the platform on AArch64/Darwin+ ArchAArch64 -> 17 ArchAlpha -> panic "trivColorable ArchAlpha" ArchMipseb -> panic "trivColorable ArchMipseb" ArchMipsel -> panic "trivColorable ArchMipsel"
compiler/GHC/Core/Opt/DmdAnal.hs view
@@ -275,7 +275,7 @@ -> WithDmdType (DmdResult CoreBind a) dmdAnalBindLetUp top_lvl env id rhs anal_body = WithDmdType final_ty (R (NonRec id' rhs') (body')) where- WithDmdType body_ty body' = anal_body env+ WithDmdType body_ty body' = anal_body (addInScopeAnalEnv env id) WithDmdType body_ty' id_dmd = findBndrDmd env notArgOfDfun body_ty id !id' = setBindIdDemandInfo top_lvl id id_dmd (rhs_ty, rhs') = dmdAnalStar env (dmdTransformThunkDmd rhs id_dmd) rhs@@ -405,7 +405,8 @@ dmdAnal' env dmd (Lam var body) | isTyVar var = let- WithDmdType body_ty body' = dmdAnal env dmd body+ WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) dmd body+ -- See Note [Bringing a new variable into scope] in WithDmdType body_ty (Lam var body') @@ -413,7 +414,8 @@ = let (n, body_dmd) = peelCallDmd dmd -- body_dmd: a demand to analyze the body - WithDmdType body_ty body' = dmdAnal env body_dmd body+ WithDmdType body_ty body' = dmdAnal (addInScopeAnalEnv env var) body_dmd body+ -- See Note [Bringing a new variable into scope] WithDmdType lam_ty var' = annotateLamIdBndr env notArgOfDfun body_ty var new_dmd_type = multDmdType n lam_ty in@@ -424,7 +426,9 @@ -- If it's a DataAlt, it should be the only constructor of the type. | is_single_data_alt alt = let- WithDmdType rhs_ty rhs' = dmdAnal env dmd rhs+ rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)+ -- See Note [Bringing a new variable into scope]+ WithDmdType rhs_ty rhs' = dmdAnal rhs_env dmd rhs WithDmdType alt_ty1 dmds = findBndrsDmds env rhs_ty bndrs WithDmdType alt_ty2 case_bndr_dmd = findBndrDmd env False alt_ty1 case_bndr -- Evaluation cardinality on the case binder is irrelevant and a no-op.@@ -435,10 +439,11 @@ -- whole DmdEnv !(!bndrs', !scrut_sd) | DataAlt _ <- alt- , id_dmds <- addCaseBndrDmd case_bndr_sd dmds- -- See Note [Demand on scrutinee of a product case]- = let !new_info = setBndrsDemandInfo bndrs id_dmds- !new_prod = mkProd id_dmds+ -- See Note [Demand on the scrutinee of a product case]+ , let !scrut_sd = scrutSubDmd case_bndr_sd dmds+ , let !fld_dmds' = fieldBndrDmds scrut_sd (length dmds)+ = let !new_info = setBndrsDemandInfo bndrs fld_dmds'+ !new_prod = mkProd fld_dmds' in (new_info, new_prod) | otherwise -- __DEFAULT and literal alts. Simply add demands and discard the@@ -547,15 +552,38 @@ dmdAnalSumAlt :: AnalEnv -> SubDemand -> Id -> Alt Var -> WithDmdType (Alt Var) dmdAnalSumAlt env dmd case_bndr (Alt con bndrs rhs)- | WithDmdType rhs_ty rhs' <- dmdAnal env dmd rhs+ | let rhs_env = addInScopeAnalEnvs env (case_bndr:bndrs)+ -- See Note [Bringing a new variable into scope]+ , WithDmdType rhs_ty rhs' <- dmdAnal rhs_env dmd rhs , WithDmdType alt_ty dmds <- findBndrsDmds env rhs_ty bndrs , let (_ :* case_bndr_sd) = findIdDemand alt_ty case_bndr- -- See Note [Demand on scrutinee of a product case]- id_dmds = addCaseBndrDmd case_bndr_sd dmds+ -- See Note [Demand on case-alternative binders]+ -- we can't use the scrut_sd, because it says 'Prod' and we'll use+ -- topSubDmd anyway for scrutinees of sum types.+ scrut_sd = scrutSubDmd case_bndr_sd dmds+ id_dmds = fieldBndrDmds scrut_sd (length dmds) -- Do not put a thunk into the Alt- !new_ids = setBndrsDemandInfo bndrs id_dmds- = WithDmdType alt_ty (Alt con new_ids rhs')+ !new_ids = setBndrsDemandInfo bndrs id_dmds+ = -- pprTrace "dmdAnalSumAlt" (ppr con $$ ppr case_bndr $$ ppr dmd $$ ppr alt_ty) $+ WithDmdType alt_ty (Alt con new_ids rhs') +-- See Note [Demand on the scrutinee of a product case]+scrutSubDmd :: SubDemand -> [Demand] -> SubDemand+scrutSubDmd case_sd fld_dmds =+ -- pprTraceWith "scrutSubDmd" (\scrut_sd -> ppr case_sd $$ ppr fld_dmds $$ ppr scrut_sd) $+ case_sd `plusSubDmd` mkProd fld_dmds++-- See Note [Demand on case-alternative binders]+fieldBndrDmds :: SubDemand -- on the scrutinee+ -> Arity+ -> [Demand] -- Final demands for the components of the DataCon+fieldBndrDmds scrut_sd n_flds =+ case viewProd n_flds scrut_sd of+ Just ds -> ds+ Nothing -> replicate n_flds topDmd+ -- Either an arity mismatch or scrut_sd was a call demand.+ -- See Note [Untyped demand on case-alternative binders]+ {- Note [Analysing with absent demand] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -666,6 +694,89 @@ x = (a, absent-error) and that'll crash. +Note [Demand on case-alternative binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The demand on a binder in a case alternative comes+ (a) From the demand on the binder itself+ (b) From the demand on the case binder+Forgetting (b) led directly to #10148.++Example. Source code:+ f x@(p,_) = if p then foo x else True++ foo (p,True) = True+ foo (p,q) = foo (q,p)++After strictness analysis, forgetting (b):+ f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) ->+ case x_an1+ of wild_X7 [Dmd=MP(ML,ML)]+ { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) ->+ case p_an2 of _ {+ False -> GHC.Types.True;+ True -> foo wild_X7 }++Note that ds_dnz is syntactically dead, but the expression bound to it is+reachable through the case binder wild_X7. Now watch what happens if we inline+foo's wrapper:+ f = \ (x_an1 [Dmd=1P(1L,ML)] :: (Bool, Bool)) ->+ case x_an1+ of _ [Dmd=MP(ML,ML)]+ { (p_an2 [Dmd=1L], ds_dnz [Dmd=A]) ->+ case p_an2 of _ {+ False -> GHC.Types.True;+ True -> $wfoo_soq GHC.Types.True ds_dnz }++Look at that! ds_dnz has come back to life in the call to $wfoo_soq! A second+run of demand analysis would no longer infer ds_dnz to be absent.+But unlike occurrence analysis, which infers properties of the *syntactic*+shape of the program, the results of demand analysis describe expressions+*semantically* and are supposed to be mostly stable across Simplification.+That's why we should better account for (b).+In #10148, we ended up emitting a single-entry thunk instead of an updateable+thunk for a let binder that was an an absent case-alt binder during DmdAnal.++This is needed even for non-product types, in case the case-binder+is used but the components of the case alternative are not.++Note [Untyped demand on case-alternative binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+With unsafeCoerce, #8037 and #22039 taught us that the demand on the case binder+may be a call demand or have a different number of fields than the constructor+of the case alternative it is used in. From T22039:++ blarg :: (Int, Int) -> Int+ blarg (x,y) = x+y+ -- blarg :: <1!P(1L,1L)>++ f :: Either Int Int -> Int+ f Left{} = 0+ f e = blarg (unsafeCoerce e)+ ==> { desugars to }+ f = \ (ds_d1nV :: Either Int Int) ->+ case ds_d1nV of wild_X1 {+ Left ds_d1oV -> lvl_s1Q6;+ Right ipv_s1Pl ->+ blarg+ (case unsafeEqualityProof @(*) @(Either Int Int) @(Int, Int) of+ { UnsafeRefl co_a1oT ->+ wild_X1 `cast` (Sub (Sym co_a1oT) :: Either Int Int ~R# (Int, Int))+ })+ }++The case binder `e`/`wild_X1` has demand 1!P(1L,1L), with two fields, from the call+to `blarg`, but `Right` only has one field. Although the code will crash when+executed, we must be able to analyse it in 'fieldBndrDmds' and conservatively+approximate with Top instead of panicking because of the mismatch.+In #22039, this kind of code was guarded behind a safe `cast` and thus dead+code, but nevertheless led to a panic of the compiler.++You might wonder why the same problem doesn't come up when scrutinising a+product type instead of a sum type. It appears that for products, `wild_X1`+will be inlined before DmdAnal.++See also Note [mkWWstr and unsafeCoerce] for a related issue.+ Note [Aggregated demand for cardinality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ FIXME: This Note should be named [LetUp vs. LetDown] and probably predates@@ -1437,7 +1548,7 @@ emptySigEnv :: SigEnv emptySigEnv = emptyVarEnv --- | Extend an environment with the strictness IDs attached to the id+-- | Extend an environment with the strictness sigs attached to the Ids extendAnalEnvs :: TopLevelFlag -> AnalEnv -> [Id] -> AnalEnv extendAnalEnvs top_lvl env vars = env { ae_sigs = extendSigEnvs top_lvl (ae_sigs env) vars }@@ -1456,6 +1567,12 @@ lookupSigEnv :: AnalEnv -> Id -> Maybe (StrictSig, TopLevelFlag) lookupSigEnv env id = lookupVarEnv (ae_sigs env) id +addInScopeAnalEnv :: AnalEnv -> Var -> AnalEnv+addInScopeAnalEnv env id = env { ae_sigs = delVarEnv (ae_sigs env) id }++addInScopeAnalEnvs :: AnalEnv -> [Var] -> AnalEnv+addInScopeAnalEnvs env ids = env { ae_sigs = delVarEnvList (ae_sigs env) ids }+ nonVirgin :: AnalEnv -> AnalEnv nonVirgin env = env { ae_virgin = False } @@ -1496,8 +1613,20 @@ fam_envs = ae_fam_envs env -{- Note [Initialising strictness]+{- Note [Bringing a new variable into scope]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+ f x = blah+ g = ...(\f. ...f...)...++In the body of the '\f', any occurrence of `f` refers to the lambda-bound `f`,+not the top-level `f` (which will be in `ae_sigs`). So it's very important+to delete `f` from `ae_sigs` when we pass a lambda/case/let-up binding of `f`.+Otherwise chaos results (#22718).++Note [Initialising strictness] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+ See section 9.2 (Finding fixpoints) of the paper. Our basic plan is to initialise the strictness of each Id in a
compiler/GHC/Core/Opt/FloatIn.hs view
@@ -43,6 +43,10 @@ import GHC.Utils.Misc import GHC.Utils.Panic +import GHC.Utils.Outputable++import Data.List ( mapAccumL )+ {- Top-level interface function, @floatInwards@. Note that we do not actually float any bindings downwards from the top-level.@@ -132,7 +136,7 @@ ************************************************************************ -} -type FreeVarSet = DIdSet+type FreeVarSet = DVarSet type BoundVarSet = DIdSet data FloatInBind = FB BoundVarSet FreeVarSet FloatBind@@ -140,11 +144,17 @@ -- of recursive bindings, the set doesn't include the bound -- variables. -type FloatInBinds = [FloatInBind]- -- In reverse dependency order (innermost binder first)+type FloatInBinds = [FloatInBind] -- In normal dependency order+ -- (outermost binder first)+type RevFloatInBinds = [FloatInBind] -- In reverse dependency order+ -- (innermost binder first) +instance Outputable FloatInBind where+ ppr (FB bvs fvs _) = text "FB" <> braces (sep [ text "bndrs =" <+> ppr bvs+ , text "fvs =" <+> ppr fvs ])+ fiExpr :: Platform- -> FloatInBinds -- Binds we're trying to drop+ -> RevFloatInBinds -- Binds we're trying to drop -- as far "inwards" as possible -> CoreExprWithFVs -- Input expr -> CoreExpr -- Result@@ -155,13 +165,12 @@ fiExpr _ to_drop (_, AnnVar v) = wrapFloats to_drop (Var v) fiExpr _ to_drop (_, AnnCoercion co) = wrapFloats to_drop (Coercion co) fiExpr platform to_drop (_, AnnCast expr (co_ann, co))- = wrapFloats (drop_here ++ co_drop) $+ = wrapFloats drop_here $ Cast (fiExpr platform e_drop expr) co where- [drop_here, e_drop, co_drop]- = sepBindsByDropPoint platform False- [freeVarsOf expr, freeVarsOfAnn co_ann]- to_drop+ (drop_here, [e_drop])+ = sepBindsByDropPoint platform False to_drop+ (freeVarsOfAnn co_ann) [freeVarsOf expr] {- Applications: we do float inside applications, mainly because we@@ -170,7 +179,7 @@ -} fiExpr platform to_drop ann_expr@(_,AnnApp {})- = wrapFloats drop_here $ wrapFloats extra_drop $+ = wrapFloats drop_here $ mkTicks ticks $ mkApps (fiExpr platform fun_drop ann_fun) (zipWithEqual "fiExpr" (fiExpr platform) arg_drops ann_args)@@ -180,19 +189,18 @@ (ann_fun, ann_args, ticks) = collectAnnArgsTicks tickishFloatable ann_expr fun_ty = exprType (deAnnotate ann_fun) fun_fvs = freeVarsOf ann_fun- arg_fvs = map freeVarsOf ann_args - (drop_here : extra_drop : fun_drop : arg_drops)- = sepBindsByDropPoint platform False- (extra_fvs : fun_fvs : arg_fvs)- to_drop+ (drop_here, fun_drop : arg_drops)+ = sepBindsByDropPoint platform False to_drop+ here_fvs (fun_fvs : arg_fvs)+ -- Shortcut behaviour: if to_drop is empty, -- sepBindsByDropPoint returns a suitable bunch of empty -- lists without evaluating extra_fvs, and hence without -- peering into each argument - (_, extra_fvs) = foldl' add_arg (fun_ty, extra_fvs0) ann_args- extra_fvs0 = case ann_fun of+ ((_,here_fvs), arg_fvs) = mapAccumL add_arg (fun_ty,here_fvs0) ann_args+ here_fvs0 = case ann_fun of (_, AnnVar _) -> fun_fvs _ -> emptyDVarSet -- Don't float the binding for f into f x y z; see Note [Join points]@@ -200,15 +208,13 @@ -- join point, floating it in isn't especially harmful but it's -- useless since the simplifier will immediately float it back out.) - add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> (Type,FreeVarSet)- add_arg (fun_ty, extra_fvs) (_, AnnType ty)- = (piResultTy fun_ty ty, extra_fvs)-- add_arg (fun_ty, extra_fvs) (arg_fvs, arg)- | noFloatIntoArg arg arg_ty- = (res_ty, extra_fvs `unionDVarSet` arg_fvs)- | otherwise- = (res_ty, extra_fvs)+ add_arg :: (Type,FreeVarSet) -> CoreExprWithFVs -> ((Type,FreeVarSet),FreeVarSet)+ add_arg (fun_ty, here_fvs) (arg_fvs, AnnType ty)+ = ((piResultTy fun_ty ty, here_fvs), arg_fvs)+ -- We can't float into some arguments, so put them into the here_fvs+ add_arg (fun_ty, here_fvs) (arg_fvs, arg)+ | noFloatIntoArg arg arg_ty = ((res_ty,here_fvs `unionDVarSet` arg_fvs), emptyDVarSet)+ | otherwise = ((res_ty,here_fvs), arg_fvs) where (_, arg_ty, res_ty) = splitFunTy fun_ty @@ -292,7 +298,6 @@ Urk! if all are tyvars, and we don't float in, we may miss an opportunity to float inside a nested case branch - Note [Floating coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~ We could, in principle, have a coercion binding like@@ -312,6 +317,36 @@ bind a coercion variable mentioned in any of the types, that binder must be dropped right away. +Note [Shadowing and name capture]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Suppose we have+ let x = y+1 in+ case p of+ (y:ys) -> ...x...+ [] -> blah+It is obviously bogus for FloatIn to transform to+ case p of+ (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.++One solution would be to clone as we go. But a simpler one is this:++ at a binding site (like that for (y:ys) above), abandon float-in for+ any floating bindings that mention the binders (y, ys in this case)++We achieve that by calling sepBindsByDropPoint with the binders in+the "used-here" set:++* In fiExpr (AnnLam ...). For the body there is no need to delete+ the lambda-binders from the body_fvs, because any bindings that+ mention these binders will be dropped here anyway.++* In fiExpr (AnnCase ...). Remember to include the case_bndr in the+ binders. Again, no need to delete the alt binders from the rhs+ free vars, beause any bindings mentioning them will be dropped+ here unconditionally. -} fiExpr platform to_drop lam@(_, AnnLam _ _)@@ -320,11 +355,18 @@ = wrapFloats to_drop (mkLams bndrs (fiExpr platform [] body)) | otherwise -- Float inside- = mkLams bndrs (fiExpr platform to_drop body)+ = wrapFloats drop_here $+ mkLams bndrs (fiExpr platform body_drop body) where (bndrs, body) = collectAnnBndrs lam+ body_fvs = freeVarsOf body + -- Why sepBindsByDropPoint? Because of potential capture+ -- See Note [Shadowing and name capture]+ (drop_here, [body_drop]) = sepBindsByDropPoint platform False to_drop+ (mkDVarSet bndrs) [body_fvs]+ {- We don't float lets inwards past an SCC. ToDo: keep info on current cc, and when passing@@ -462,16 +504,16 @@ = wrapFloats shared_binds $ fiExpr platform (case_float : rhs_binds) rhs where- case_float = FB (mkDVarSet (case_bndr : alt_bndrs)) scrut_fvs+ case_float = FB all_bndrs scrut_fvs (FloatCase scrut' case_bndr con alt_bndrs) scrut' = fiExpr platform scrut_binds scrut- rhs_fvs = freeVarsOf rhs `delDVarSetList` (case_bndr : alt_bndrs)- scrut_fvs = freeVarsOf scrut+ rhs_fvs = freeVarsOf rhs -- No need to delete alt_bndrs+ scrut_fvs = freeVarsOf scrut -- See Note [Shadowing and name capture]+ all_bndrs = mkDVarSet alt_bndrs `extendDVarSet` case_bndr - [shared_binds, scrut_binds, rhs_binds]- = sepBindsByDropPoint platform False- [scrut_fvs, rhs_fvs]- to_drop+ (shared_binds, [scrut_binds, rhs_binds])+ = sepBindsByDropPoint platform False to_drop+ all_bndrs [scrut_fvs, rhs_fvs] fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts) = wrapFloats drop_here1 $@@ -481,38 +523,42 @@ -- use zipWithEqual, we should have length alts_drops_s = length alts where -- Float into the scrut and alts-considered-together just like App- [drop_here1, scrut_drops, alts_drops]- = sepBindsByDropPoint platform False- [scrut_fvs, all_alts_fvs]- to_drop+ (drop_here1, [scrut_drops, alts_drops])+ = sepBindsByDropPoint platform False to_drop+ all_alt_bndrs [scrut_fvs, all_alt_fvs]+ -- all_alt_bndrs: see Note [Shadowing and name capture] -- Float into the alts with the is_case flag set- (drop_here2 : alts_drops_s)- | [ _ ] <- alts = [] : [alts_drops]- | otherwise = sepBindsByDropPoint platform True alts_fvs alts_drops+ (drop_here2, alts_drops_s)+ = sepBindsByDropPoint platform True alts_drops emptyDVarSet alts_fvs - scrut_fvs = freeVarsOf scrut- alts_fvs = map alt_fvs alts- all_alts_fvs = unionDVarSets alts_fvs- alt_fvs (AnnAlt _con args rhs)- = foldl' delDVarSet (freeVarsOf rhs) (case_bndr:args)- -- Delete case_bndr and args from free vars of rhs- -- to get free vars of alt+ scrut_fvs = freeVarsOf scrut + all_alt_bndrs = foldr (unionDVarSet . ann_alt_bndrs) (unitDVarSet case_bndr) alts+ ann_alt_bndrs (AnnAlt _ bndrs _) = mkDVarSet bndrs++ alts_fvs :: [DVarSet]+ alts_fvs = [freeVarsOf rhs | AnnAlt _ _ rhs <- alts]+ -- No need to delete binders+ -- See Note [Shadowing and name capture]++ all_alt_fvs :: DVarSet+ all_alt_fvs = foldr unionDVarSet (unitDVarSet case_bndr) alts_fvs+ fi_alt to_drop (AnnAlt con args rhs) = Alt con args (fiExpr platform to_drop rhs) ------------------ fiBind :: Platform- -> FloatInBinds -- Binds we're trying to drop- -- as far "inwards" as possible- -> CoreBindWithFVs -- Input binding- -> DVarSet -- Free in scope of binding- -> ( FloatInBinds -- Land these before- , FloatInBind -- The binding itself- , FloatInBinds) -- Land these after+ -> RevFloatInBinds -- Binds we're trying to drop+ -- as far "inwards" as possible+ -> CoreBindWithFVs -- Input binding+ -> DVarSet -- Free in scope of binding+ -> ( RevFloatInBinds -- Land these before+ , FloatInBind -- The binding itself+ , RevFloatInBinds) -- Land these after fiBind platform to_drop (AnnNonRec id ann_rhs@(rhs_fvs, rhs)) body_fvs- = ( extra_binds ++ shared_binds -- Land these before+ = ( shared_binds -- Land these before -- See Note [extra_fvs (1,2)] , FB (unitDVarSet id) rhs_fvs' -- The new binding itself (FloatLet (NonRec id rhs'))@@ -531,10 +577,9 @@ -- We *can't* float into ok-for-speculation unlifted RHSs -- But do float into join points - [shared_binds, extra_binds, rhs_binds, body_binds]- = sepBindsByDropPoint platform False- [extra_fvs, rhs_fvs, body_fvs2]- to_drop+ (shared_binds, [rhs_binds, body_binds])+ = sepBindsByDropPoint platform False to_drop+ extra_fvs [rhs_fvs, body_fvs2] -- Push rhs_binds into the right hand side of the binding rhs' = fiRhs platform rhs_binds id ann_rhs@@ -542,7 +587,7 @@ -- Don't forget the rule_fvs; the binding mentions them! fiBind platform to_drop (AnnRec bindings) body_fvs- = ( extra_binds ++ shared_binds+ = ( shared_binds , FB (mkDVarSet ids) rhs_fvs' (FloatLet (Rec (fi_bind rhss_binds bindings))) , body_binds )@@ -556,17 +601,16 @@ unionDVarSets [ rhs_fvs | (bndr, (rhs_fvs, rhs)) <- bindings , noFloatIntoRhs Recursive bndr rhs ] - (shared_binds:extra_binds:body_binds:rhss_binds)- = sepBindsByDropPoint platform False- (extra_fvs:body_fvs:rhss_fvs)- to_drop+ (shared_binds, body_binds:rhss_binds)+ = sepBindsByDropPoint platform False to_drop+ extra_fvs (body_fvs:rhss_fvs) rhs_fvs' = unionDVarSets rhss_fvs `unionDVarSet` unionDVarSets (map floatedBindsFVs rhss_binds) `unionDVarSet` rule_fvs -- Don't forget the rule variables! -- Push rhs_binds into the right hand side of the binding- fi_bind :: [FloatInBinds] -- one per "drop pt" conjured w/ fvs_of_rhss+ fi_bind :: [RevFloatInBinds] -- One per "drop pt" conjured w/ fvs_of_rhss -> [(Id, CoreExprWithFVs)] -> [(Id, CoreExpr)] @@ -575,7 +619,7 @@ | ((binder, rhs), to_drop) <- zipEqual "fi_bind" pairs to_drops ] -------------------fiRhs :: Platform -> FloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr+fiRhs :: Platform -> RevFloatInBinds -> CoreBndr -> CoreExprWithFVs -> CoreExpr fiRhs platform to_drop bndr rhs | Just join_arity <- isJoinId_maybe bndr , let (bndrs, body) = collectNAnnBndrs join_arity rhs@@ -675,68 +719,84 @@ We have to maintain the order on these drop-point-related lists. -} --- pprFIB :: FloatInBinds -> SDoc+-- pprFIB :: RevFloatInBinds -> SDoc -- pprFIB fibs = text "FIB:" <+> ppr [b | FB _ _ b <- fibs] sepBindsByDropPoint :: Platform- -> Bool -- True <=> is case expression- -> [FreeVarSet] -- One set of FVs per drop point- -- Always at least two long!- -> FloatInBinds -- Candidate floaters- -> [FloatInBinds] -- FIRST one is bindings which must not be floated- -- inside any drop point; the rest correspond- -- one-to-one with the input list of FV sets+ -> Bool -- True <=> is case expression+ -> RevFloatInBinds -- Candidate floaters+ -> FreeVarSet -- here_fvs: if these vars are free in a binding,+ -- don't float that binding inside any drop point+ -> [FreeVarSet] -- fork_fvs: one set of FVs per drop point+ -> ( RevFloatInBinds -- Bindings which must not be floated inside+ , [RevFloatInBinds] ) -- Corresponds 1-1 with the input list of FV sets -- Every input floater is returned somewhere in the result; -- none are dropped, not even ones which don't seem to be -- free in *any* of the drop-point fvs. Why? Because, for example, -- a binding (let x = E in B) might have a specialised version of -- x (say x') stored inside x, but x' isn't free in E or B.+--+-- The here_fvs argument is used for two things:+-- * Avoid shadowing bugs: see Note [Shadowing and name capture]+-- * Drop some of the bindings at the top, e.g. of an application type DropBox = (FreeVarSet, FloatInBinds) -sepBindsByDropPoint platform is_case drop_pts floaters+dropBoxFloats :: DropBox -> RevFloatInBinds+dropBoxFloats (_, floats) = reverse floats++usedInDropBox :: DIdSet -> DropBox -> Bool+usedInDropBox bndrs (db_fvs, _) = db_fvs `intersectsDVarSet` bndrs++initDropBox :: DVarSet -> DropBox+initDropBox fvs = (fvs, [])++sepBindsByDropPoint platform is_case floaters here_fvs fork_fvs | null floaters -- Shortcut common case- = [] : [[] | _ <- drop_pts]+ = ([], [[] | _ <- fork_fvs]) | otherwise- = ASSERT( drop_pts `lengthAtLeast` 2 )- go floaters (map (\fvs -> (fvs, [])) (emptyDVarSet : drop_pts))+ = go floaters (initDropBox here_fvs) (map initDropBox fork_fvs) where- n_alts = length drop_pts+ n_alts = length fork_fvs - go :: FloatInBinds -> [DropBox] -> [FloatInBinds]- -- The *first* one in the argument list is the drop_here set- -- The FloatInBinds in the lists are in the reverse of- -- the normal FloatInBinds order; that is, they are the right way round!+ go :: RevFloatInBinds -> DropBox -> [DropBox]+ -> (RevFloatInBinds, [RevFloatInBinds])+ -- The *first* one in the pair is the drop_here set - go [] drop_boxes = map (reverse . snd) drop_boxes+ go [] here_box fork_boxes+ = (dropBoxFloats here_box, map dropBoxFloats fork_boxes) - go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) drop_boxes@(here_box : fork_boxes)- = go binds new_boxes+ go (bind_w_fvs@(FB bndrs bind_fvs bind) : binds) here_box fork_boxes+ | drop_here = go binds (insert here_box) fork_boxes+ | otherwise = go binds here_box new_fork_boxes where -- "here" means the group of bindings dropped at the top of the fork - (used_here : used_in_flags) = [ fvs `intersectsDVarSet` bndrs- | (fvs, _) <- drop_boxes]+ used_here = bndrs `usedInDropBox` here_box+ used_in_flags = case fork_boxes of+ [] -> []+ [_] -> [True] -- Push all bindings into a single branch+ -- No need to look at its free vars+ _ -> map (bndrs `usedInDropBox`) fork_boxes+ -- Short-cut for the singleton case;+ -- used for lambdas and singleton cases drop_here = used_here || cant_push n_used_alts = count id used_in_flags -- returns number of Trues in list. cant_push- | is_case = n_used_alts == n_alts -- Used in all, don't push- -- Remember n_alts > 1+ | is_case = (n_alts > 1 && n_used_alts == n_alts)+ -- Used in all, muliple branches, don't push || (n_used_alts > 1 && not (floatIsDupable platform bind)) -- floatIsDupable: see Note [Duplicating floats] | otherwise = floatIsCase bind || n_used_alts > 1 -- floatIsCase: see Note [Floating primops] - new_boxes | drop_here = (insert here_box : fork_boxes)- | otherwise = (here_box : new_fork_boxes)- new_fork_boxes = zipWithEqual "FloatIn.sepBinds" insert_maybe fork_boxes used_in_flags @@ -746,9 +806,7 @@ insert_maybe box True = insert box insert_maybe box False = box - go _ _ = panic "sepBindsByDropPoint/go" - {- Note [Duplicating floats] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -765,14 +823,14 @@ so we don't duplicate then. -} -floatedBindsFVs :: FloatInBinds -> FreeVarSet+floatedBindsFVs :: RevFloatInBinds -> FreeVarSet floatedBindsFVs binds = mapUnionDVarSet fbFVs binds fbFVs :: FloatInBind -> DVarSet fbFVs (FB _ fvs _) = fvs -wrapFloats :: FloatInBinds -> CoreExpr -> CoreExpr--- Remember FloatInBinds is in *reverse* dependency order+wrapFloats :: RevFloatInBinds -> CoreExpr -> CoreExpr+-- Remember RevFloatInBinds is in *reverse* dependency order wrapFloats [] e = e wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)
compiler/GHC/CoreToStg.hs view
@@ -375,7 +375,7 @@ -- handle with the function coreToPreStgRhs. coreToStgExpr- :: CoreExpr+ :: HasDebugCallStack => CoreExpr -> CtsM StgExpr -- The second and third components can be derived in a simple bottom up pass, not@@ -389,17 +389,18 @@ coreToStgExpr (Lit (LitNumber LitNumInteger _)) = panic "coreToStgExpr: LitInteger" coreToStgExpr (Lit (LitNumber LitNumNatural _)) = panic "coreToStgExpr: LitNatural" coreToStgExpr (Lit l) = return (StgLit l)-coreToStgExpr (App l@(Lit LitRubbish{}) Type{}) = coreToStgExpr l coreToStgExpr (Var v) = coreToStgApp v [] [] coreToStgExpr (Coercion _) -- See Note [Coercion tokens] = coreToStgApp coercionTokenId [] [] coreToStgExpr expr@(App _ _)- = coreToStgApp f args ticks- where- (f, args, ticks) = myCollectArgs expr-+ = case app_head of+ Var f -> coreToStgApp f args ticks -- Regular application+ Lit l@LitRubbish{} -> return (StgLit l) -- LitRubbish+ _ -> pprPanic "coreToStgExpr - Invalid app head:" (ppr expr)+ where+ (app_head, args, ticks) = myCollectArgs expr coreToStgExpr expr@(Lam _ _) = let (args, body) = myCollectBinders expr@@ -692,7 +693,7 @@ -- Convert the RHS of a binding from Core to STG. This is a wrapper around -- coreToStgExpr that can handle value lambdas.-coreToPreStgRhs :: CoreExpr -> CtsM PreStgRhs+coreToPreStgRhs :: HasDebugCallStack => CoreExpr -> CtsM PreStgRhs coreToPreStgRhs (Cast expr _) = coreToPreStgRhs expr coreToPreStgRhs expr@(Lam _ _) = let@@ -951,13 +952,13 @@ go bs (Cast e _) = go bs e go bs e = (reverse bs, e) --- | Precondition: argument expression is an 'App', and there is a 'Var' at the--- head of the 'App' chain.-myCollectArgs :: CoreExpr -> (Id, [CoreArg], [CoreTickish])+-- | If the argument expression is (potential chain of) 'App', return the head+-- of the app chain, and collect ticks/args along the chain.+myCollectArgs :: HasDebugCallStack => CoreExpr -> (CoreExpr, [CoreArg], [CoreTickish]) myCollectArgs expr = go expr [] [] where- go (Var v) as ts = (v, as, ts)+ go h@(Var _v) as ts = (h, as, ts) go (App f a) as ts = go f (a:as) ts go (Tick t e) as ts = ASSERT2( not (tickishIsCode t) || all isTypeArg as , ppr e $$ ppr as $$ ppr ts )@@ -966,7 +967,7 @@ go (Cast e _) as ts = go e as ts go (Lam b e) as ts | isTyVar b = go e as ts -- Note [Collect args]- go _ _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr)+ go e as ts = (e, as, ts) {- Note [Collect args] ~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Driver/Main.hs view
@@ -1283,19 +1283,29 @@ -- restore old errors logWarnings oldErrs - case (isEmptyBag safeErrs) of- -- Failed safe check- False -> liftIO . throwIO . mkSrcErr $ safeErrs+ logger <- getLogger+ -- Will throw if failed safe check+ --+ -- Zubin: printOrThrowWarnings doesn't actually throw if we+ -- have SevError warnings, so we need to do an additional check+ -- before calling it to see if we need to throw, because SevError+ -- safe haskell warnings are supposed to be fatal.+ -- We don't want to modify printOrThrowWarnings on GHC 9.2 to+ -- perform this check because it affects other error messages (like T10647)+ -- and changes the behavior of the compiler.+ -- This is fixed in GHC 9.4+ when (anyBag isErrorMessage safeErrs) $+ liftIO $ throwIO (mkSrcErr safeErrs)+ liftIO $ printOrThrowWarnings logger dflags safeErrs - -- Passed safe check- True -> do- let infPassed = isEmptyBag infErrs- tcg_env' <- case (not infPassed) of- True -> markUnsafeInfer tcg_env infErrs- False -> return tcg_env- when (packageTrustOn dflags) $ checkPkgTrust pkgReqs- let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed- return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }+ -- No fatal warnings or errors: passed safe check+ let infPassed = isEmptyBag infErrs+ tcg_env' <- case (not infPassed) of+ True -> markUnsafeInfer tcg_env infErrs+ False -> return tcg_env+ when (packageTrustOn dflags) $ checkPkgTrust pkgReqs+ let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed+ return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust } where impInfo = tcg_imports tcg_env -- ImportAvails
compiler/GHC/HsToCore/Expr.hs view
@@ -984,7 +984,8 @@ ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts) ; let match_args (pat, fail_op) (vs,body)- = do { var <- selectSimpleMatchVarL Many pat+ = putSrcSpanDs (getLocA pat) $+ do { var <- selectSimpleMatchVarL Many pat ; match <- matchSinglePatVar var Nothing (StmtCtxt ctx) pat body_ty (cantFailMatchResult body) ; match_code <- dsHandleMonadicFailure ctx pat match fail_op
compiler/GHC/Rename/Bind.hs view
@@ -860,17 +860,15 @@ -- Rename the pragmas and signatures -- Annoyingly the type variables /are/ in scope for signatures, but- -- /are not/ in scope in the SPECIALISE instance pramas; e.g.- -- instance Eq a => Eq (T a) where- -- (==) :: a -> a -> a- -- {-# SPECIALISE instance Eq a => Eq (T [a]) #-}- ; let (spec_inst_prags, other_sigs) = partition isSpecInstLSig sigs+ -- /are not/ in scope in SPECIALISE and SPECIALISE instance pragmas.+ -- See Note [Type variable scoping in SPECIALISE pragmas].+ ; let (spec_prags, other_sigs) = partition (isSpecLSig <||> isSpecInstLSig) sigs bound_nms = mkNameSet (collectHsBindsBinders CollNoDictBinders binds') sig_ctxt | is_cls_decl = ClsDeclCtxt cls | otherwise = InstDeclCtxt bound_nms- ; (spec_inst_prags', sip_fvs) <- renameSigs sig_ctxt spec_inst_prags- ; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $- renameSigs sig_ctxt other_sigs+ ; (spec_prags', spg_fvs) <- renameSigs sig_ctxt spec_prags+ ; (other_sigs', sig_fvs) <- bindLocalNamesFV ktv_names $+ renameSigs sig_ctxt other_sigs -- Rename the bindings RHSs. Again there's an issue about whether the -- type variables from the class/instance head are in scope.@@ -881,8 +879,47 @@ emptyFVs binds_w_dus ; return (mapBag fstOf3 binds_w_dus, bind_fvs) } - ; return ( binds'', spec_inst_prags' ++ other_sigs'- , sig_fvs `plusFV` sip_fvs `plusFV` bind_fvs) }+ ; return ( binds'', spec_prags' ++ other_sigs'+ , sig_fvs `plusFV` spg_fvs `plusFV` bind_fvs) }++{- Note [Type variable scoping in SPECIALISE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When renaming the methods of a class or instance declaration, we must be careful+with the scoping of the type variables that occur in SPECIALISE and SPECIALISE instance+pragmas: the type variables from the class/instance header DO NOT scope over these,+unlike class/instance method type signatures.++Examples:++ 1. SPECIALISE++ class C a where+ meth :: a+ instance C (Maybe a) where+ meth = Nothing+ {-# SPECIALISE INLINE meth :: Maybe [a] #-}++ 2. SPECIALISE instance++ instance Eq a => Eq (T a) where+ (==) :: a -> a -> a+ {-# SPECIALISE instance Eq a => Eq (T [a]) #-}++ In both cases, the type variable `a` mentioned in the PRAGMA is NOT the same+ as the type variable `a` from the instance header.+ For example, the SPECIALISE instance pragma above is a shorthand for++ {-# SPECIALISE instance forall a. Eq a => Eq (T [a]) #-}++ which is alpha-equivalent to++ {-# SPECIALISE instance forall b. Eq b => Eq (T [b]) #-}++ This shows that the type variables are not bound in the header.++ Getting this scoping wrong can lead to out-of-scope type variable errors from+ Core Lint, see e.g. #22913.+-} rnMethodBindLHS :: Bool -> Name -> LHsBindLR GhcPs GhcPs
compiler/GHC/Tc/Errors.hs view
@@ -48,6 +48,7 @@ import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env+import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Data.Bag import GHC.Utils.Error ( pprLocMsgEnvelope )@@ -67,7 +68,7 @@ import qualified GHC.LanguageExtensions as LangExt import GHC.Utils.FV ( fvVarList, unionFV ) -import Control.Monad ( when, unless )+import Control.Monad ( when, foldM, forM_ ) import Data.Foldable ( toList ) import Data.List ( partition, mapAccumL, sortBy, unfoldr ) @@ -740,24 +741,59 @@ reportHoles :: [Ct] -- other (tidied) constraints -> ReportErrCtxt -> [Hole] -> TcM ()-reportHoles tidy_cts ctxt- = mapM_ $ \hole -> unless (ignoreThisHole ctxt hole) $- do { err <- mkHoleError tidy_cts ctxt hole- ; maybeReportHoleError ctxt hole err- ; maybeAddDeferredHoleBinding ctxt err hole }+reportHoles tidy_cts ctxt holes+ = do+ let holes' = filter (keepThisHole ctxt) holes+ -- Zonk and tidy all the TcLclEnvs before calling `mkHoleError`+ -- because otherwise types will be zonked and tidied many times over.+ (tidy_env', lcl_name_cache) <- zonkTidyTcLclEnvs (cec_tidy ctxt) (map (ctl_env . hole_loc) holes')+ let ctxt' = ctxt { cec_tidy = tidy_env' }+ forM_ holes' $ \hole ->+ do { err <- mkHoleError lcl_name_cache tidy_cts ctxt' hole+ ; maybeReportHoleError ctxt hole err+ ; maybeAddDeferredHoleBinding ctxt err hole } -ignoreThisHole :: ReportErrCtxt -> Hole -> Bool+keepThisHole :: ReportErrCtxt -> Hole -> Bool -- See Note [Skip type holes rapidly]-ignoreThisHole ctxt hole+keepThisHole ctxt hole = case hole_sort hole of- ExprHole {} -> False- TypeHole -> ignore_type_hole- ConstraintHole -> ignore_type_hole+ ExprHole {} -> True+ TypeHole -> keep_type_hole+ ConstraintHole -> keep_type_hole where- ignore_type_hole = case cec_type_holes ctxt of- HoleDefer -> True- _ -> False+ keep_type_hole = case cec_type_holes ctxt of+ HoleDefer -> False+ _ -> True +-- | zonkTidyTcLclEnvs takes a bunch of 'TcLclEnv's, each from a Hole.+-- It returns a ('Name' :-> 'Type') mapping which gives the zonked, tidied+-- type for each Id in any of the binder stacks in the 'TcLclEnv's.+-- Since there is a huge overlap between these stacks, is is much,+-- much faster to do them all at once, avoiding duplication.+zonkTidyTcLclEnvs :: TidyEnv -> [TcLclEnv] -> TcM (TidyEnv, NameEnv Type)+zonkTidyTcLclEnvs tidy_env lcls = foldM go (tidy_env, emptyNameEnv) (concatMap tcl_bndrs lcls)+ where+ go envs tc_bndr = case tc_bndr of+ TcTvBndr {} -> return envs+ TcIdBndr id _top_lvl -> go_one (idName id) (idType id) envs+ TcIdBndr_ExpType name et _top_lvl ->+ do { mb_ty <- readExpType_maybe et+ -- et really should be filled in by now. But there's a chance+ -- it hasn't, if, say, we're reporting a kind error en route to+ -- checking a term. See test indexed-types/should_fail/T8129+ -- Or we are reporting errors from the ambiguity check on+ -- a local type signature+ ; case mb_ty of+ Just ty -> go_one name ty envs+ Nothing -> return envs+ }+ go_one name ty (tidy_env, name_env) = do+ if name `elemNameEnv` name_env+ then return (tidy_env, name_env)+ else do+ (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env ty+ return (tidy_env', extendNameEnv name_env name tidy_ty)+ {- Note [Skip type holes rapidly] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have module with a /lot/ of partial type signatures, and we@@ -1193,8 +1229,8 @@ (ct1:_) = cts -----------------mkHoleError :: [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope DecoratedSDoc)-mkHoleError _tidy_simples _ctxt hole@(Hole { hole_occ = occ+mkHoleError :: NameEnv Type -> [Ct] -> ReportErrCtxt -> Hole -> TcM (MsgEnvelope DecoratedSDoc)+mkHoleError _ _tidy_simples _ctxt hole@(Hole { hole_occ = occ , hole_ty = hole_ty , hole_loc = ct_loc }) | isOutOfScopeHole hole@@ -1219,12 +1255,12 @@ boring_type = isTyVarTy hole_ty -- general case: not an out-of-scope error-mkHoleError tidy_simples ctxt hole@(Hole { hole_occ = occ+mkHoleError lcl_name_cache tidy_simples ctxt hole@(Hole { hole_occ = occ , hole_ty = hole_ty , hole_sort = sort , hole_loc = ct_loc })- = do { (ctxt, binds_msg)- <- relevant_bindings False ctxt lcl_env (tyCoVarsOfType hole_ty)+ = do { binds_msg+ <- relevant_bindings False lcl_env lcl_name_cache (tyCoVarsOfType hole_ty) -- The 'False' means "don't filter the bindings"; see Trac #8191 ; show_hole_constraints <- goptM Opt_ShowHoleConstraints@@ -2945,21 +2981,23 @@ -- Put a zonked, tidied CtOrigin into the Ct loc' = setCtLocOrigin loc tidy_orig ct' = setCtLoc ct loc'- ctxt1 = ctxt { cec_tidy = env1 } - ; (ctxt2, doc) <- relevant_bindings want_filtering ctxt1 lcl_env ct_fvs- ; return (ctxt2, doc, ct') }+ ; (env2, lcl_name_cache) <- zonkTidyTcLclEnvs env1 [lcl_env]++ ; doc <- relevant_bindings want_filtering lcl_env lcl_name_cache ct_fvs+ ; let ctxt' = ctxt { cec_tidy = env2 }+ ; return (ctxt', doc, ct') } where loc = ctLoc ct lcl_env = ctLocEnv loc -- slightly more general version, to work also with holes relevant_bindings :: Bool- -> ReportErrCtxt -> TcLclEnv+ -> NameEnv Type -- Cache of already zonked and tidied types -> TyCoVarSet- -> TcM (ReportErrCtxt, SDoc)-relevant_bindings want_filtering ctxt lcl_env ct_tvs+ -> TcM SDoc+relevant_bindings want_filtering lcl_env lcl_name_env ct_tvs = do { dflags <- getDynFlags ; traceTc "relevant_bindings" $ vcat [ ppr ct_tvs@@ -2968,8 +3006,8 @@ , pprWithCommas id [ ppr id | TcIdBndr_ExpType id _ _ <- tcl_bndrs lcl_env ] ] - ; (tidy_env', docs, discards)- <- go dflags (cec_tidy ctxt) (maxRelevantBinds dflags)+ ; (docs, discards)+ <- go dflags (maxRelevantBinds dflags) emptyVarSet [] False (removeBindingShadowing $ tcl_bndrs lcl_env) -- tcl_bndrs has the innermost bindings first,@@ -2979,9 +3017,7 @@ hang (text "Relevant bindings include") 2 (vcat docs $$ ppWhen discards discardMsg) - ctxt' = ctxt { cec_tidy = tidy_env' }-- ; return (ctxt', doc) }+ ; return doc } where run_out :: Maybe Int -> Bool run_out Nothing = False@@ -2991,17 +3027,17 @@ dec_max = fmap (\n -> n - 1) - go :: DynFlags -> TidyEnv -> Maybe Int -> TcTyVarSet -> [SDoc]+ go :: DynFlags -> Maybe Int -> TcTyVarSet -> [SDoc] -> Bool -- True <=> some filtered out due to lack of fuel -> [TcBinder]- -> TcM (TidyEnv, [SDoc], Bool) -- The bool says if we filtered any out+ -> TcM ([SDoc], Bool) -- The bool says if we filtered any out -- because of lack of fuel- go _ tidy_env _ _ docs discards []- = return (tidy_env, reverse docs, discards)- go dflags tidy_env n_left tvs_seen docs discards (tc_bndr : tc_bndrs)+ go _ _ _ docs discards []+ = return (reverse docs, discards)+ go dflags n_left tvs_seen docs discards (tc_bndr : tc_bndrs) = case tc_bndr of TcTvBndr {} -> discard_it- TcIdBndr id top_lvl -> go2 (idName id) (idType id) top_lvl+ TcIdBndr id top_lvl -> go2 (idName id) top_lvl TcIdBndr_ExpType name et top_lvl -> do { mb_ty <- readExpType_maybe et -- et really should be filled in by now. But there's a chance@@ -3010,14 +3046,16 @@ -- Or we are reporting errors from the ambiguity check on -- a local type signature ; case mb_ty of- Just ty -> go2 name ty top_lvl+ Just _ty -> go2 name top_lvl Nothing -> discard_it -- No info; discard } where- discard_it = go dflags tidy_env n_left tvs_seen docs+ discard_it = go dflags n_left tvs_seen docs discards tc_bndrs- go2 id_name id_type top_lvl- = do { (tidy_env', tidy_ty) <- zonkTidyTcType tidy_env id_type+ go2 id_name top_lvl+ = do { let tidy_ty = case lookupNameEnv lcl_name_env id_name of+ Just tty -> tty+ Nothing -> pprPanic "relevant_bindings" (ppr id_name) ; traceTc "relevantBindings 1" (ppr id_name <+> dcolon <+> ppr tidy_ty) ; let id_tvs = tyCoVarsOfType tidy_ty doc = sep [ pprPrefixOcc id_name <+> dcolon <+> ppr tidy_ty@@ -3039,12 +3077,12 @@ else if run_out n_left && id_tvs `subVarSet` tvs_seen -- We've run out of n_left fuel and this binding only -- mentions already-seen type variables, so discard it- then go dflags tidy_env n_left tvs_seen docs+ then go dflags n_left tvs_seen docs True -- Record that we have now discarded something tc_bndrs -- Keep this binding, decrement fuel- else go dflags tidy_env' (dec_max n_left) new_seen+ else go dflags (dec_max n_left) new_seen (doc:docs) discards tc_bndrs }
compiler/GHC/Tc/Instance/Typeable.hs view
@@ -175,7 +175,7 @@ } } } where needs_typeable_binds tc- | tc `elem` [runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon]+ | tc `elem` ghcTypesTypeableTyCons = False | otherwise = isAlgTyCon tc@@ -336,7 +336,15 @@ -- Build TypeRepTodos for types in GHC.Prim ; todo2 <- todoForTyCons gHC_PRIM ghc_prim_module_id ghcPrimTypeableTyCons- ; return ( gbl_env' , [todo1, todo2])++ ; tcg_env <- getGblEnv+ ; let mod_id = case tcg_tr_module tcg_env of -- Should be set by now+ Just mod_id -> mod_id+ Nothing -> pprPanic "tcMkTypeableBinds" empty++ ; todo3 <- todoForTyCons gHC_TYPES mod_id ghcTypesTypeableTyCons++ ; return ( gbl_env' , [todo1, todo2, todo3]) } else do gbl_env <- getGblEnv return (gbl_env, [])@@ -351,11 +359,17 @@ -- Note [Built-in syntax and the OrigNameCache] in "GHC.Iface.Env" for more. ghcPrimTypeableTyCons :: [TyCon] ghcPrimTypeableTyCons = concat- [ [ runtimeRepTyCon, levityTyCon, vecCountTyCon, vecElemTyCon ]- , map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE]+ [ map (tupleTyCon Unboxed) [0..mAX_TUPLE_SIZE] , map sumTyCon [2..mAX_SUM_SIZE] , primTyCons ]++-- | These are types which are defined in GHC.Types but are needed in order to+-- typecheck the other generated bindings, therefore to avoid ordering issues we+-- generate them up-front along with the bindings from GHC.Prim.+ghcTypesTypeableTyCons :: [TyCon]+ghcTypesTypeableTyCons = [ runtimeRepTyCon, levityTyCon+ , vecCountTyCon, vecElemTyCon ] data TypeableStuff = Stuff { platform :: Platform -- ^ Target platform
ghc-lib.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.0 build-type: Simple name: ghc-lib-version: 9.2.5.20221107+version: 9.2.6.20230211 license: BSD3 license-file: LICENSE category: Development@@ -45,7 +45,10 @@ source-repository head type: git location: git@github.com:digital-asset/ghc-lib.git-+flag threaded-rts+ default: True+ manual: True+ description: Pass -DTHREADED_RTS to the C toolchain library default-language: Haskell2010 exposed: False@@ -54,9 +57,13 @@ ghc-lib/stage0/lib ghc-lib/stage0/compiler/build compiler- ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS- cc-options: -DTHREADED_RTS- cpp-options: -DTHREADED_RTS+ if flag(threaded-rts)+ ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS+ cc-options: -DTHREADED_RTS+ cpp-options: -DTHREADED_RTS+ else+ ghc-options: -fobject-code -package=ghc-boot-th+ cpp-options: if !os(windows) build-depends: unix else@@ -79,7 +86,7 @@ process >= 1 && < 1.7, rts, hpc == 0.6.*,- ghc-lib-parser == 9.2.5.20221107+ ghc-lib-parser == 9.2.6.20230211 build-tool-depends: alex:alex >= 3.1, happy:happy >= 1.19.4 other-extensions: BangPatterns
ghc-lib/stage0/lib/GhclibDerivedConstants.h view
@@ -68,29 +68,29 @@ #define OFFSET_stgGCEnter1 -16 #define OFFSET_stgGCFun -8 #define OFFSET_Capability_r 24-#define OFFSET_Capability_lock 1216+#define OFFSET_Capability_lock 1224 #define OFFSET_Capability_no 944 #define REP_Capability_no b32 #define Capability_no(__ptr__) REP_Capability_no[__ptr__+OFFSET_Capability_no] #define OFFSET_Capability_mut_lists 1016 #define REP_Capability_mut_lists b64 #define Capability_mut_lists(__ptr__) REP_Capability_mut_lists[__ptr__+OFFSET_Capability_mut_lists]-#define OFFSET_Capability_context_switch 1184+#define OFFSET_Capability_context_switch 1192 #define REP_Capability_context_switch b32 #define Capability_context_switch(__ptr__) REP_Capability_context_switch[__ptr__+OFFSET_Capability_context_switch]-#define OFFSET_Capability_interrupt 1188+#define OFFSET_Capability_interrupt 1196 #define REP_Capability_interrupt b32 #define Capability_interrupt(__ptr__) REP_Capability_interrupt[__ptr__+OFFSET_Capability_interrupt]-#define OFFSET_Capability_sparks 1320+#define OFFSET_Capability_sparks 1328 #define REP_Capability_sparks b64 #define Capability_sparks(__ptr__) REP_Capability_sparks[__ptr__+OFFSET_Capability_sparks]-#define OFFSET_Capability_total_allocated 1192+#define OFFSET_Capability_total_allocated 1200 #define REP_Capability_total_allocated b64 #define Capability_total_allocated(__ptr__) REP_Capability_total_allocated[__ptr__+OFFSET_Capability_total_allocated]-#define OFFSET_Capability_weak_ptr_list_hd 1168+#define OFFSET_Capability_weak_ptr_list_hd 1176 #define REP_Capability_weak_ptr_list_hd b64 #define Capability_weak_ptr_list_hd(__ptr__) REP_Capability_weak_ptr_list_hd[__ptr__+OFFSET_Capability_weak_ptr_list_hd]-#define OFFSET_Capability_weak_ptr_list_tl 1176+#define OFFSET_Capability_weak_ptr_list_tl 1184 #define REP_Capability_weak_ptr_list_tl b64 #define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl] #define OFFSET_bdescr_start 0
ghc-lib/stage0/lib/settings view
@@ -2,7 +2,7 @@ ,("C compiler command", "cc") ,("C compiler flags", "--target=x86_64-apple-darwin ") ,("C++ compiler flags", "--target=x86_64-apple-darwin ")-,("C compiler link flags", "--target=x86_64-apple-darwin ")+,("C compiler link flags", "--target=x86_64-apple-darwin -Wl,-no_fixup_chains") ,("C compiler supports -no-pie", "NO") ,("Haskell CPP command", "cc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")