ghc 9.2.5 → 9.2.6
raw patch · 18 files changed
+650/−259 lines, 18 filesdep ~ghc-bootdep ~ghc-heapdep ~ghciPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: ghc-boot, ghc-heap, ghci
API changes (from Hackage documentation)
- GHC.CmmToAsm.AArch64.Instr: instance GHC.Show.Show GHC.CmmToAsm.AArch64.Instr.Instr
- GHC.Utils.Binary: instance GHC.Utils.Binary.Binary Data.ByteString.Internal.ByteString
+ GHC.CmmToAsm.AArch64.Instr: instrCon :: Instr -> String
+ GHC.Core.Opt.FloatIn: instance GHC.Utils.Outputable.Outputable GHC.Core.Opt.FloatIn.FloatInBind
+ GHC.Utils.Binary: instance GHC.Utils.Binary.Binary Data.ByteString.Internal.Type.ByteString
Files
- GHC.hs +8/−2
- GHC/CmmToAsm/AArch64/Instr.hs +78/−11
- GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +2/−4
- GHC/Core/Opt/Arity.hs +6/−3
- GHC/Core/Opt/DmdAnal.hs +144/−15
- GHC/Core/Opt/FloatIn.hs +158/−100
- GHC/Core/Opt/OccurAnal.hs +28/−21
- GHC/Core/Unify.hs +15/−13
- GHC/CoreToStg.hs +13/−12
- GHC/Driver/Main.hs +22/−12
- GHC/HsToCore/Expr.hs +2/−1
- GHC/Parser.y +1/−1
- GHC/Rename/Bind.hs +47/−10
- GHC/Settings/Config.hs +1/−1
- GHC/Tc/Errors.hs +80/−42
- GHC/Tc/Instance/Typeable.hs +18/−4
- cbits/keepCAFsForGHCi.c +23/−3
- ghc.cabal +4/−4
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
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)
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"
GHC/Core/Opt/Arity.hs view
@@ -791,7 +791,7 @@ andArityType env at1 (AT [] div2) = andWithTail env div2 at1 andWithTail :: ArityEnv -> Divergence -> ArityType -> ArityType-andWithTail env div1 at2@(AT lams2 _)+andWithTail env div1 at2 | isDeadEndDiv div1 -- case x of { T -> error; F -> \y.e } = at2 -- Note [ABot branches: max arity wins] @@ -799,7 +799,7 @@ = AT [] topDiv | otherwise -- case x of { T -> plusInt <expensive>; F -> \y.e }- = AT lams2 topDiv -- We know div1 = topDiv+ = takeWhileOneShot at2 -- We know div1 = topDiv -- See Note [Combining case branches: andWithTail] @@ -2004,8 +2004,11 @@ , let (subst', tv') = substVarBndr subst tv = go (n-1) res_ty subst' (tv' : rev_bs) (e `App` varToCoreExpr tv') | Just (mult, arg_ty, res_ty) <- splitFunTy_maybe ty+ -- The varToCoreExpr is important: `tv` might be a coercion variable , let (subst', b) = freshEtaId n subst (Scaled mult arg_ty)- = go (n-1) res_ty subst' (b : rev_bs) (e `App` Var b)+ = go (n-1) res_ty subst' (b : rev_bs) (e `App` varToCoreExpr b)+ -- The varToCoreExpr is important: `b` might be a coercion variable+ | otherwise = pprPanic "etaBodyForJoinPoint" $ int need_args $$ ppr body $$ ppr (exprType body)
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
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)
GHC/Core/Opt/OccurAnal.hs view
@@ -1725,7 +1725,7 @@ -> CoreExpr -- RHS -> (UsageDetails, CoreExpr) occAnalRhs env is_rec mb_join_arity rhs- = case occAnalLamOrRhs env bndrs body of { (body_usage, bndrs', body') ->+ = case occAnalLamOrRhs env1 bndrs body of { (body_usage, bndrs', body') -> let final_bndrs | isRec is_rec = bndrs' | otherwise = markJoinOneShots mb_join_arity bndrs' -- For a /non-recursive/ join point we can mark all@@ -1737,6 +1737,7 @@ in (rhs_usage, mkLams final_bndrs body') } where (bndrs, body) = collectBinders rhs+ env1 = addInScope env bndrs occAnalUnfolding :: OccEnv -> RecFlag@@ -2005,7 +2006,7 @@ occAnal env expr@(Lam _ _) = -- See Note [Occurrence analysis for lambda binders]- case occAnalLamOrRhs env bndrs body of { (usage, tagged_bndrs, body') ->+ case occAnalLamOrRhs env1 bndrs body of { (usage, tagged_bndrs, body') -> let expr' = mkLams tagged_bndrs body' usage1 = markAllNonTail usage@@ -2015,6 +2016,7 @@ (final_usage, expr') } where (bndrs, body) = collectBinders expr+ env1 = addInScope env bndrs occAnal env (Case scrut bndr ty alts) = case occAnal (scrutCtxt env alts) scrut of { (scrut_usage, scrut') ->@@ -2284,12 +2286,13 @@ -- See Note [The binder-swap substitution] -- If x :-> (y, co) is in the env,- -- then please replace x by (y |> sym mco)- -- Invariant of course: idType x = exprType (y |> sym mco)- , occ_bs_env :: VarEnv (OutId, MCoercion)- , occ_bs_rng :: VarSet -- Vars free in the range of occ_bs_env+ -- then please replace x by (y |> mco)+ -- Invariant of course: idType x = exprType (y |> mco)+ , occ_bs_env :: !(IdEnv (OutId, MCoercion)) -- Domain is Global and Local Ids -- Range is just Local Ids+ , occ_bs_rng :: !VarSet+ -- Vars (TyVars and Ids) free in the range of occ_bs_env } @@ -2578,25 +2581,29 @@ (BS3) We need care when shadowing. Suppose [x :-> b] is in occ_bs_env, and we encounter:- - \x. blah- Here we want to delete the x-binding from occ_bs_env+ (i) \x. blah+ Here we want to delete the x-binding from occ_bs_env - - \b. blah- This is harder: we really want to delete all bindings that- have 'b' free in the range. That is a bit tiresome to implement,- so we compromise. We keep occ_bs_rng, which is the set of- free vars of rng(occc_bs_env). If a binder shadows any of these- variables, we discard all of occ_bs_env. Safe, if a bit- brutal. NB, however: the simplifer de-shadows the code, so the- next time around this won't happen.+ (ii) \b. blah+ This is harder: we really want to delete all bindings that+ have 'b' free in the range. That is a bit tiresome to implement,+ so we compromise. We keep occ_bs_rng, which is the set of+ free vars of rng(occc_bs_env). If a binder shadows any of these+ variables, we discard all of occ_bs_env. Safe, if a bit+ brutal. NB, however: the simplifer de-shadows the code, so the+ next time around this won't happen. These checks are implemented in addInScope.+ (i) is needed only for Ids, but (ii) is needed for tyvars too (#22623)+ because if occ_bs_env has [x :-> ...a...] where `a` is a tyvar, we+ must not replace `x` by `...a...` under /\a. ...x..., or similarly+ under a case pattern match that binds `a`. - The occurrence analyser itself does /not/ do cloning. It could, in- principle, but it'd make it a bit more complicated and there is no- great benefit. The simplifer uses cloning to get a no-shadowing- situation, the care-when-shadowing behaviour above isn't needed for- long.+ An alternative would be for the occurrence analyser to do cloning as+ it goes. In principle it could do so, but it'd make it a bit more+ complicated and there is no great benefit. The simplifer uses+ cloning to get a no-shadowing situation, the care-when-shadowing+ behaviour above isn't needed for long. (BS4) The domain of occ_bs_env can include GlobaIds. Eg case M.foo of b { alts }
GHC/Core/Unify.hs view
@@ -1114,20 +1114,11 @@ ; unless (um_inj_tf env) $ -- See (end of) Note [Specification of unification] don'tBeSoSure MARTypeFamily $ unify_tys env noninj_tys1 noninj_tys2 } - | Just (tc1, _) <- mb_tc_app1- , not (isGenerativeTyCon tc1 Nominal)- -- E.g. unify_ty (F ty1) b = MaybeApart- -- because the (F ty1) behaves like a variable- -- NB: if unifying, we have already dealt- -- with the 'ty2 = variable' case- = maybeApart MARTypeFamily+ | isTyFamApp mb_tc_app1 -- A (not-over-saturated) type-family application+ = maybeApart MARTypeFamily -- behaves like a type variable; might match - | Just (tc2, _) <- mb_tc_app2- , not (isGenerativeTyCon tc2 Nominal)- , um_unif env- -- E.g. unify_ty [a] (F ty2) = MaybeApart, when unifying (only)- -- because the (F ty2) behaves like a variable- -- NB: we have already dealt with the 'ty1 = variable' case+ | isTyFamApp mb_tc_app2 -- A (not-over-saturated) type-family application+ , um_unif env -- behaves like a type variable; might unify = maybeApart MARTypeFamily where@@ -1215,6 +1206,17 @@ go _ _ = surelyApart -- Possibly different saturations of a polykinded tycon -- See Note [Polykinded tycon applications]++isTyFamApp :: Maybe (TyCon, [Type]) -> Bool+-- True if we have a saturated or under-saturated type family application+-- If it is /over/ saturated then we return False. E.g.+-- unify_ty (F a b) (c d) where F has arity 1+-- we definitely want to decompose that type application! (#22647)+isTyFamApp (Just (tc, tys))+ = not (isGenerativeTyCon tc Nominal) -- Type family-ish+ && not (tys `lengthExceeds` tyConArity tc) -- Not over-saturated+isTyFamApp Nothing+ = False --------------------------------- uVar :: UMEnv
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] ~~~~~~~~~~~~~~~~~~~~~~
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
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
GHC/Parser.y view
@@ -3727,7 +3727,7 @@ -- *after* we see the close paren. field :: { Located FastString }- : VARID { sL1 $1 $! getVARID $1 }+ : varid { reLocN $ fmap (occNameFS . rdrNameOcc) $1 } qvarid :: { LocatedN RdrName } : varid { $1 }
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
GHC/Settings/Config.hs view
@@ -22,7 +22,7 @@ cProjectName = "The Glorious Glasgow Haskell Compilation System" cBooterVersion :: String-cBooterVersion = "9.2.4"+cBooterVersion = "9.2.5" cStage :: String cStage = show (2 :: Int)
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 }
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
cbits/keepCAFsForGHCi.c view
@@ -1,15 +1,35 @@ #include <Rts.h>+#include <ghcversion.h> +// Note [keepCAFsForGHCi]+// ~~~~~~~~~~~~~~~~~~~~~~ // This file is only included in the dynamic library. // It contains an __attribute__((constructor)) function (run prior to main()) // which sets the keepCAFs flag in the RTS, before any Haskell code is run. // This is required so that GHCi can use dynamic libraries instead of HSxyz.o // files.+//+// For static builds we have to guarantee that the linker loads this object file+// to ensure the constructor gets run and not discarded. If the object is part of+// an archive and not otherwise referenced the linker would ignore the object.+// To avoid this:+// * When initializing a GHC session in initGhcMonad we assert keeping cafs has been+// enabled by calling keepCAFsForGHCi.+// * This causes the GHC module from the ghc package to carry a reference to this object+// file.+// * Which in turn ensures the linker doesn't discard this object file, causing+// the constructor to be run, allowing the assertion to succeed in the first place+// as keepCAFs will have been set already during initialization of constructors. -static void keepCAFsForGHCi(void) __attribute__((constructor)); -static void keepCAFsForGHCi(void)++bool keepCAFsForGHCi(void) __attribute__((constructor));++bool keepCAFsForGHCi(void) {- keepCAFs = 1;+ bool was_set = keepCAFs;+ setKeepCAFs();+ return was_set; }+
ghc.cabal view
@@ -3,7 +3,7 @@ Cabal-Version: 1.22 Name: ghc-Version: 9.2.5+Version: 9.2.6 License: BSD3 License-File: LICENSE Author: The GHC Team@@ -71,9 +71,9 @@ hpc == 0.6.*, transformers == 0.5.*, exceptions == 0.10.*,- ghc-boot == 9.2.5,- ghc-heap == 9.2.5,- ghci == 9.2.5+ ghc-boot == 9.2.6,+ ghc-heap == 9.2.6,+ ghci == 9.2.6 if os(windows) Build-Depends: Win32 >= 2.3 && < 2.13