Zubin pushed to branch wip/26416 at Glasgow Haskell Compiler / GHC Commits: 7b4eb1a1 by Zubin Duggal at 2026-03-10T17:18:49+05:30 wip - - - - - 3 changed files: - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Types/Demand.hs - + testsuite/tests/dmdanal/should_run/T26416.stdout Changes: ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -1141,7 +1141,7 @@ dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs -- See Note [Absence analysis for stable unfoldings and RULES] -- The unfolding FVs are already included in full_rhs_env via addUnfoldingDemands. -- Here we only need demandRoots for RULES. - rhs_env2 = rhs_env1 `plusDmdEnv` demandRootSet env (idRuleVars id) + rhs_env2 = rhs_env1 `plusDmdEnv` demandRootSet env (filterVarSet isId (idRuleVars id)) -- See Note [Lazy and unleashable free variables] !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2 @@ -1160,7 +1160,7 @@ addUnfoldingDemands env rhs_sd id rhs_dmd_ty , Just unf_body <- maybeUnfoldingTemplate unf , let WithDmdType unf_dmd_ty _ = dmdAnal env rhs_sd unf_body = -- pprTrace "addUnfoldingDemands" (ppr id $$ ppr rhs_dmd_ty $$ ppr unf_dmd_ty) $ - lubUBglbLBDmdType rhs_dmd_ty unf_dmd_ty + maxDmdType rhs_dmd_ty unf_dmd_ty | otherwise = rhs_dmd_ty -- No stable unfolding, nothing to do @@ -1504,10 +1504,21 @@ and transform to Now if f is subsequently inlined, we'll use 'g' and ... disaster. -SOLUTION: if f has a stable unfolding, treat every free variable as a -/demand root/, that is: Analyse it as if it was a variable occurring in a +SOLUTION for stable unfoldings: in `dmdAnalRhsSig`, if the function has a +stable unfolding, analyse it with `dmdAnal` and combine the resulting `DmdType` +with the RHS's `DmdType`. This is done by `addUnfoldingDemands`, which uses +`maxDmdType` to combine both argument demands and free variable demands. +See Note [Combining demands for stable unfoldings] in GHC.Types.Demand for +details of the combining operation. + +This handles both the free variables and arguments of stable unfoldings in one +go. For example, in the scenario above, the unfolding's `DmdType` will mention +`g` as a free variable, so `maxDmdType` will keep it alive. + +SOLUTION for RULES: treat every Id free in the RHS of a RULE as a +/demand root/, that is: analyse it as if it was a variable occurring in a 'topDmd' context. This is done in `demandRoot` (which we also use for exported -top-level ids). Do the same for Ids free in the RHS of any RULES for f. +top-level ids). Wrinkles: @@ -1524,7 +1535,7 @@ Wrinkles: this, that actually happened in practice. (W2) You might wonder why we don't simply take the free vars of the - unfolding/RULE and map them to topDmd. The reason is that any of the free vars + RULE and map them to topDmd. The reason is that any of the free vars might have demand signatures themselves that in turn demand transitive free variables and that we hence need to unleash! This came up in #23208. Consider @@ -1546,7 +1557,7 @@ Wrinkles: for `sg`, failing to unleash the signature and hence observed an absent error instead of the `really important message`. - (W3) The SOLUTION above handles /free variables/ of stable unfoldings, but + (W3) The stable unfolding solution above handles /free variables/, but what about /arguments/? Consider (#26416) fromVector :: (Storable a, KnownNat n) => Vector a -> Vector a @@ -1560,15 +1571,9 @@ Wrinkles: worker's unfolding is inlined, it will use that rubbish value as a real dictionary, leading to a segfault! - SOLUTION: in `dmdAnalRhsSig`, if the function has a stable unfolding, - analyse it with `dmdAnal` and combine the resulting `DmdType` with the - RHS's `DmdType`. This is done by `addUnfoldingDemands`, which uses - `lubUBglbLBDmdType` to combine both argument demands and free variable - demands. See Note [Combining demands for stable unfoldings] in - GHC.Types.Demand for details of the combining operation. - - This replaces the `demandRoots` approach for stable unfoldings (though - we still use `demandRoots` for RULES via `idRuleVars`). + `addUnfoldingDemands` handles this too: since `maxDmdType` combines both + the argument demands and free variable demands from the unfolding's + `DmdType` with the RHS's, argument absence is correctly prevented. Note [DmdAnal for DataCon wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2052,8 +2057,15 @@ finaliseArgBoxities :: AnalEnv -> Id -> Arity -- If: (dmds', rhs') = finaliseArgBoxitities ... dmds .. rhs -- Then: -- dmds' is the same as dmds (including length), except for boxity info --- rhs' is the same as rhs, except for dmd info on lambda binders +-- rhs' is the same as rhs, except that the idDemandInfo on the outer +-- lambda binders now includes the same finalised boxity info as dmds' -- NB: For join points, length dmds might be greater than ww_arity +-- +-- IMPORTANT: The lambda binders of rhs' must carry the final demand info, +-- because worker/wrapper drives decisions from the idDemandInfo on the lambdas +-- (see mkWwstr_one), NOT from the strictness signature of the function. +-- So the demands must reflect both the unfolding combination (from +-- addUnfoldingDemands) and the boxity finalisation done here. finaliseArgBoxities env fn ww_arity arg_dmds div rhs -- Check for an OPAQUE function: see Note [OPAQUE pragma] @@ -2097,7 +2109,7 @@ finaliseArgBoxities env fn ww_arity arg_dmds div rhs [ bndr | bndr <- bndrs, isRuntimeVar bndr ] arg_dmds where - mk_triple bndr dmd = (idType bndr, NotMarkedStrict, get_dmd dmd) + mk_triple bndr arg_dmd = (idType bndr, NotMarkedStrict, get_dmd arg_dmd) arg_dmds' = ww_arg_dmds ++ map trimBoxity (drop ww_arity arg_dmds) -- If ww_arity < length arg_dmds, the leftover ones ===================================== compiler/GHC/Types/Demand.hs ===================================== @@ -23,8 +23,8 @@ module GHC.Types.Demand ( lubCard, lubDmd, lubSubDmd, -- *** Greatest lower bound glbCard, - -- *** Unfolding combination (glb on strictness, lub on usage) - lubUBglbLBDmd, + -- *** Maximum (glb on strictness, lub on usage) + maxCard, maxDmd, -- *** Plus plusCard, plusDmd, plusSubDmd, -- *** Multiply @@ -57,7 +57,7 @@ module GHC.Types.Demand ( DmdType(..), dmdTypeDepth, -- ** Algebra nopDmdType, botDmdType, - lubDmdType, lubUBglbLBDmdType, plusDmdType, multDmdType, discardArgDmds, + lubDmdType, maxDmdType, plusDmdType, multDmdType, discardArgDmds, -- ** Other operations peelFV, findIdDemand, addDemand, splitDmdTy, deferAfterPreciseException, @@ -899,43 +899,46 @@ See Note [Absence analysis for stable unfoldings and RULES] in GHC.Core.Opt.DmdA for the broader context. -} --- | Combine demands for stable unfolding analysis. +-- | Takes the maximum of both the lower and upper bound of two 'Card's. +-- Semantically, this is glb on lower (strictness) and lub on upper (usage). -- See Note [Combining demands for stable unfoldings]. -lubUBglbLBCard :: Card -> Card -> Card +maxCard :: Card -> Card -> Card -- Given Note [Bit vector representation for Card]: -- * bit 0 (strictness): take AND (glb) - 0 means strict, so 0 wins -- * bits 1,2 (usage): take OR (lub) - if either uses, result uses -lubUBglbLBCard (Card a) (Card b) = Card ((a .&. b .&. 0b001) .|. ((a .|. b) .&. 0b110)) +maxCard (Card a) (Card b) = Card ((a .&. b .&. 0b001) .|. ((a .|. b) .&. 0b110)) --- | See Note [Combining demands for stable unfoldings]. -lubUBglbLBDmd :: Demand -> Demand -> Demand -lubUBglbLBDmd BotDmd dmd2 = dmd2 -lubUBglbLBDmd dmd1 BotDmd = dmd1 -lubUBglbLBDmd (n1 :* sd1) (n2 :* sd2) = - lubUBglbLBCard n1 n2 :* lubUBglbLBSubDmd sd1 sd2 +-- | Takes the maximum of both the lower and upper bounds of two 'Demand's. +-- Semantically, glb on lower (strictness) and lub on upper (usage). +-- See Note [Combining demands for stable unfoldings]. +maxDmd :: Demand -> Demand -> Demand +maxDmd BotDmd dmd2 = dmd2 +maxDmd dmd1 BotDmd = dmd1 +maxDmd (n1 :* sd1) (n2 :* sd2) = + maxCard n1 n2 :* maxSubDmd sd1 sd2 -lubUBglbLBSubDmd :: SubDemand -> SubDemand -> SubDemand +maxSubDmd :: SubDemand -> SubDemand -> SubDemand -- Shortcuts for neutral and absorbing elements. -lubUBglbLBSubDmd (Poly Unboxed C_10) sd = sd -lubUBglbLBSubDmd sd (Poly Unboxed C_10) = sd -lubUBglbLBSubDmd sd@(Poly Boxed C_0N) _ = sd -lubUBglbLBSubDmd _ sd@(Poly Boxed C_0N) = sd +maxSubDmd (Poly Unboxed C_00) sd = sd +maxSubDmd sd (Poly Unboxed C_00) = sd +maxSubDmd sd@(Poly Boxed C_1N) _ = sd +maxSubDmd _ sd@(Poly Boxed C_1N) = sd -- Prod -lubUBglbLBSubDmd (Prod b1 ds1) (Poly b2 n2) +maxSubDmd (Prod b1 ds1) (Poly b2 n2) | let !d = polyFieldDmd b2 n2 - = mkProd (lubBoxity b1 b2) (strictMap (lubUBglbLBDmd d) ds1) -lubUBglbLBSubDmd (Prod b1 ds1) (Prod b2 ds2) + = mkProd (lubBoxity b1 b2) (strictMap (maxDmd d) ds1) +maxSubDmd (Prod b1 ds1) (Prod b2 ds2) | equalLength ds1 ds2 - = mkProd (lubBoxity b1 b2) (strictZipWith lubUBglbLBDmd ds1 ds2) + = mkProd (lubBoxity b1 b2) (strictZipWith maxDmd ds1 ds2) -- Handle Call -lubUBglbLBSubDmd (Call n1 sd1) (viewCall -> Just (n2, sd2)) = - mkCall (lubUBglbLBCard n1 n2) (lubUBglbLBSubDmd sd1 sd2) +maxSubDmd (Call n1 sd1) (viewCall -> Just (n2, sd2)) = + mkCall (maxCard n1 n2) (maxSubDmd sd1 sd2) -- Handle Poly -lubUBglbLBSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (lubUBglbLBCard n1 n2) +maxSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (maxCard n1 n2) -- Other Poly case by commutativity -lubUBglbLBSubDmd sd1@Poly{} sd2 = lubUBglbLBSubDmd sd2 sd1 --- Otherwise (Call `lubUBglbLB` Prod) return Top -lubUBglbLBSubDmd _ _ = topSubDmd +maxSubDmd sd1@Poly{} sd2 = maxSubDmd sd2 sd1 +-- Otherwise (Call `max` Prod) return Top +maxSubDmd _ _ = topSubDmd -- | Denotes '+' on 'Demand'. plusDmd :: Demand -> Demand -> Demand @@ -1909,22 +1912,22 @@ lubDmdType d1 d2 = DmdType lub_fv lub_ds -- | Combine two 'DmdType's for stable unfolding analysis. -- See Note [Combining demands for stable unfoldings]. -lubUBglbLBDmdType :: DmdType -> DmdType -> DmdType -lubUBglbLBDmdType (DmdType fv1 ds1) (DmdType fv2 ds2) +maxDmdType :: DmdType -> DmdType -> DmdType +maxDmdType (DmdType fv1 ds1) (DmdType fv2 ds2) = DmdType combined_fv combined_ds where - combined_fv = lubUBglbLBDmdEnv fv1 fv2 + combined_fv = maxDmdEnv fv1 fv2 combined_ds = go ds1 ds2 -- If lists have different lengths, keep remaining ds1 (from RHS) go rhs [] = rhs go [] _ = [] - go (r:rhs) (u:unfs) = lubUBglbLBDmd r u : go rhs unfs + go (r:rhs) (u:unfs) = maxDmd r u : go rhs unfs -- | See Note [Combining demands for stable unfoldings]. -lubUBglbLBDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv -lubUBglbLBDmdEnv (DE fv1 d1) (DE fv2 d2) = DE combined_fv combined_div +maxDmdEnv :: DmdEnv -> DmdEnv -> DmdEnv +maxDmdEnv (DE fv1 d1) (DE fv2 d2) = DE combined_fv combined_div where - combined_fv = plusVarEnv_CD lubUBglbLBDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2) + combined_fv = plusVarEnv_CD maxDmd fv1 (defaultFvDmd d1) fv2 (defaultFvDmd d2) combined_div = lubDivergence d1 d2 discardArgDmds :: DmdType -> DmdEnv ===================================== testsuite/tests/dmdanal/should_run/T26416.stdout ===================================== @@ -0,0 +1 @@ +4.0 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7b4eb1a18a1cccc96785a4a0c5147204... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7b4eb1a18a1cccc96785a4a0c5147204... You're receiving this email because of your account on gitlab.haskell.org.