diff --git a/GHC.hs b/GHC.hs --- a/GHC.hs +++ b/GHC.hs @@ -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 diff --git a/GHC/CmmToAsm/AArch64/Instr.hs b/GHC/CmmToAsm/AArch64/Instr.hs --- a/GHC/CmmToAsm/AArch64/Instr.hs +++ b/GHC/CmmToAsm/AArch64/Instr.hs @@ -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) diff --git a/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs b/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs --- a/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +++ b/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs @@ -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" diff --git a/GHC/Core/Opt/Arity.hs b/GHC/Core/Opt/Arity.hs --- a/GHC/Core/Opt/Arity.hs +++ b/GHC/Core/Opt/Arity.hs @@ -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 ; 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) diff --git a/GHC/Core/Opt/DmdAnal.hs b/GHC/Core/Opt/DmdAnal.hs --- a/GHC/Core/Opt/DmdAnal.hs +++ b/GHC/Core/Opt/DmdAnal.hs @@ -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 diff --git a/GHC/Core/Opt/FloatIn.hs b/GHC/Core/Opt/FloatIn.hs --- a/GHC/Core/Opt/FloatIn.hs +++ b/GHC/Core/Opt/FloatIn.hs @@ -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) diff --git a/GHC/Core/Opt/OccurAnal.hs b/GHC/Core/Opt/OccurAnal.hs --- a/GHC/Core/Opt/OccurAnal.hs +++ b/GHC/Core/Opt/OccurAnal.hs @@ -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 } diff --git a/GHC/Core/Unify.hs b/GHC/Core/Unify.hs --- a/GHC/Core/Unify.hs +++ b/GHC/Core/Unify.hs @@ -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 diff --git a/GHC/CoreToStg.hs b/GHC/CoreToStg.hs --- a/GHC/CoreToStg.hs +++ b/GHC/CoreToStg.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~ diff --git a/GHC/Driver/Main.hs b/GHC/Driver/Main.hs --- a/GHC/Driver/Main.hs +++ b/GHC/Driver/Main.hs @@ -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 diff --git a/GHC/HsToCore/Expr.hs b/GHC/HsToCore/Expr.hs --- a/GHC/HsToCore/Expr.hs +++ b/GHC/HsToCore/Expr.hs @@ -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 diff --git a/GHC/Parser.y b/GHC/Parser.y --- a/GHC/Parser.y +++ b/GHC/Parser.y @@ -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 } diff --git a/GHC/Rename/Bind.hs b/GHC/Rename/Bind.hs --- a/GHC/Rename/Bind.hs +++ b/GHC/Rename/Bind.hs @@ -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 diff --git a/GHC/Settings/Config.hs b/GHC/Settings/Config.hs --- a/GHC/Settings/Config.hs +++ b/GHC/Settings/Config.hs @@ -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) diff --git a/GHC/Tc/Errors.hs b/GHC/Tc/Errors.hs --- a/GHC/Tc/Errors.hs +++ b/GHC/Tc/Errors.hs @@ -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 } diff --git a/GHC/Tc/Instance/Typeable.hs b/GHC/Tc/Instance/Typeable.hs --- a/GHC/Tc/Instance/Typeable.hs +++ b/GHC/Tc/Instance/Typeable.hs @@ -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 diff --git a/cbits/keepCAFsForGHCi.c b/cbits/keepCAFsForGHCi.c --- a/cbits/keepCAFsForGHCi.c +++ b/cbits/keepCAFsForGHCi.c @@ -1,15 +1,35 @@ #include +#include +// 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; } + diff --git a/ghc.cabal b/ghc.cabal --- a/ghc.cabal +++ b/ghc.cabal @@ -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