Zubin pushed to branch wip/26416 at Glasgow Haskell Compiler / GHC Commits: 8b5979c2 by Zubin Duggal at 2026-02-10T16:01:32+05:30 wip - - - - - 2 changed files: - compiler/GHC/Core/Opt/DmdAnal.hs - compiler/GHC/Types/Demand.hs Changes: ===================================== compiler/GHC/Core/Opt/DmdAnal.hs ===================================== @@ -23,7 +23,7 @@ import GHC.Core.DataCon import GHC.Core.Utils import GHC.Core.TyCon import GHC.Core.Type -import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds ) +import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds, idRuleVars ) import GHC.Core.Coercion ( Coercion ) import GHC.Core.TyCo.FVs ( coVarsOfCos ) import GHC.Core.TyCo.Compare ( eqType ) @@ -1113,7 +1113,8 @@ dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs -- might use arguments that the (optimised) RHS doesn't. -- Any argument with a demand absent in one but not the other can -- be problematic, see #26416 - combined_rhs_dmds = combineUnfoldingDmds env rhs_sd id rhs_dmds + -- Also combine the DmdEnv (free variables) from the unfolding + (unf_fv_env, combined_rhs_dmds) = combineUnfoldingDmds env rhs_sd id rhs_env rhs_dmds (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id ww_arity combined_rhs_dmds (de_div rhs_env) rhs' @@ -1144,7 +1145,10 @@ dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs NonRecursive -> rhs_env -- See Note [Absence analysis for stable unfoldings and RULES] - rhs_env2 = rhs_env1 `plusDmdEnv` demandRootSet env (bndrRuleAndUnfoldingIds id) + -- The unfolding FVs are handled via unf_fv_env from combineUnfoldingDmds. + -- Here we only need demandRoots for RULES. + rhs_env2 = rhs_env1 `plusDmdEnv` unf_fv_env + `plusDmdEnv` demandRootSet env (idRuleVars id) -- See Note [Lazy and unleashable free variables] !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2 @@ -1153,27 +1157,30 @@ splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds) splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs) where (!weak_fvs, !sig_fvs) = partitionVarEnv isWeakDmd fvs --- | If there is a stable unfolding, don't let any demand be absent that --- is also not absent in the unfolding +-- | If there is a stable unfolding, combine argument demands and free variable +-- demands from the unfolding with those from the RHS. -- See Note [Absence analysis for stable unfoldings and RULES], Wrinkle (W3). -combineUnfoldingDmds :: AnalEnv -> SubDemand -> Id -> [Demand] -> [Demand] -combineUnfoldingDmds env rhs_sd id rhs_dmds +-- +-- Returns (combined DmdEnv for free variables, combined arg demands) +-- The DmdEnv is nopDmdEnv if there's no stable unfolding. +combineUnfoldingDmds :: AnalEnv -> SubDemand -> Id -> DmdEnv -> [Demand] -> (DmdEnv, [Demand]) +combineUnfoldingDmds env rhs_sd id rhs_fv_env rhs_dmds | not (isStableUnfolding unf) - = rhs_dmds -- No stable unfolding, nothing to do + = (nopDmdEnv, rhs_dmds) -- No stable unfolding, nothing to do | Just unf_body <- maybeUnfoldingTemplate unf - , let WithDmdType (DmdType _ unf_dmds) _ = dmdAnal env rhs_sd unf_body - , let result = go rhs_dmds unf_dmds - = -- pprTrace "lubUnfoldingDmds" (ppr id $$ ppr rhs_dmds $$ ppr unf_dmds $$ ppr result) $ - result - | otherwise = rhs_dmds + , let WithDmdType (DmdType unf_fv_env unf_dmds) _ = dmdAnal env rhs_sd unf_body + , let combined_dmds = go rhs_dmds unf_dmds + -- Lub the free variable demands from unfolding with RHS + combined_fv_env = lubDmdEnv rhs_fv_env unf_fv_env + = -- pprTrace "combineUnfoldingDmds" (ppr id $$ ppr rhs_dmds $$ ppr unf_dmds $$ ppr combined_dmds) $ + (combined_fv_env, combined_dmds) + | otherwise = (nopDmdEnv, rhs_dmds) where unf = realIdUnfolding id go rhs [] = rhs go [] _ = [] - go (AbsDmd:rhs) (u:unfs) = u : go rhs unfs - go (r:rhs) (AbsDmd:unfs) = r : go rhs unfs - go (r:rhs) (_:unfs) = r : go rhs unfs + go (r:rhs) (u:unfs) = lubUBglbLBDmd r u : go rhs unfs -- | The result type after applying 'idArity' many arguments. Returns 'Nothing' -- when the type doesn't have exactly 'idArity' many arrows. @@ -1555,7 +1562,7 @@ Wrinkles: error instead of the `really important message`. (W3) The SOLUTION above handles /free variables/ of stable unfoldings, but - what about /arguments/? Consider (#25965) + what about /arguments/? Consider (#26416) fromVector :: (Storable a, KnownNat n) => Vector a -> Vector a fromVector v = ... (uses Storable dictionary) ... @@ -1569,9 +1576,18 @@ Wrinkles: dictionary, leading to a segfault! SOLUTION: in `dmdAnalRhsSig`, if the function has a stable unfolding, - analyse it and drop any AbsDmds which are not absent in the unfolding. - This is done by `combineUnfoldingDmds`. This ensures that if the unfolding - uses an argument, it won't be marked as absent. + analyse it with `dmdAnal` and combine the resulting `DmdType` with the + RHS's `DmdType`. This is done by `combineUnfoldingDmds`, which: + + * For argument demands: combines them using `lubUBglbLBDmd`, which takes + the glb (max) of lower bounds (strictness) and lub (max) of upper + bounds (usage). See Note [Combining demands for stable unfoldings]. + This ensures that if the unfolding uses an argument, it won't be + marked as absent, while preserving any strictness the RHS reveals. + + * For free variable demands: combines them using `lubDmdEnv`. This + replaces the `demandRoots` approach for stable unfoldings (though + we still use `demandRoots` for RULES via `idRuleVars`). Note [DmdAnal for DataCon wrappers] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Types/Demand.hs ===================================== @@ -23,6 +23,8 @@ module GHC.Types.Demand ( lubCard, lubDmd, lubSubDmd, -- *** Greatest lower bound glbCard, + -- *** Unfolding combination (glb on strictness, lub on usage) + lubUBglbLBDmd, -- *** Plus plusCard, plusDmd, plusSubDmd, -- *** Multiply @@ -49,7 +51,7 @@ module GHC.Types.Demand ( -- * Demand environments DmdEnv(..), addVarDmdEnv, mkTermDmdEnv, nopDmdEnv, plusDmdEnv, plusDmdEnvs, - multDmdEnv, reuseEnv, + lubDmdEnv, multDmdEnv, reuseEnv, -- * Demand types DmdType(..), dmdTypeDepth, @@ -864,6 +866,77 @@ lubSubDmd sd1@Poly{} sd2 = lubSubDmd sd2 sd1 -- Otherwise (Call `lub` Prod) return Top lubSubDmd _ _ = topSubDmd +{- Note [Combining demands for stable unfoldings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a function has a stable unfolding, the optimised RHS and the unfolding +may have different demand signatures for the same arguments. This can happen +because: + + * The optimised RHS may have had transformations applied that reveal + strictness (e.g., inlining exposes a case on an argument). + + * The optimised RHS may have had transformations applied that drop usage + (e.g., a rewrite rule fires that doesn't use an argument, or a seq on + a dictionary is dropped because dictionaries are known to terminate). + +When we inline the stable unfolding at a call site, we get the unfolding's +behaviour, not the RHS's. So we must be conservative and combine the demands: + + * For strictness (lower bounds): we can take the MAXIMUM (glb). + If the RHS reveals that an argument is strict, that strictness was + always there semantically - the analysis just couldn't see it in the + unfolding. Sound optimisations never make lazy code strict. + + * For usage (upper bounds): we must take the MAXIMUM (lub). + If the unfolding uses an argument but the RHS doesn't, we must not + mark it absent, or we'll replace it with rubbish that the unfolding + will then try to use, causing a segfault. See #26416. + +So for cardinality bounds [l1..u1] from RHS and [l2..u2] from unfolding, +we compute [max(l1,l2)..max(u1,u2)]. + +See Note [Absence analysis for stable unfoldings and RULES] in GHC.Core.Opt.DmdAnal +for the broader context. +-} + +-- | Combine demands for stable unfolding analysis. +-- See Note [Combining demands for stable unfoldings]. +lubUBglbLBCard :: 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)) + +-- | 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 + +lubUBglbLBSubDmd :: 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 +-- Prod +lubUBglbLBSubDmd (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) + | equalLength ds1 ds2 + = mkProd (lubBoxity b1 b2) (strictZipWith lubUBglbLBDmd ds1 ds2) +-- Handle Call +lubUBglbLBSubDmd (Call n1 sd1) (viewCall -> Just (n2, sd2)) = + mkCall (lubUBglbLBCard n1 n2) (lubUBglbLBSubDmd sd1 sd2) +-- Handle Poly +lubUBglbLBSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (lubUBglbLBCard n1 n2) +-- Other Poly case by commutativity +lubUBglbLBSubDmd sd1@Poly{} sd2 = lubUBglbLBSubDmd sd2 sd1 +-- Otherwise (Call `lubUBglbLB` Prod) return Top +lubUBglbLBSubDmd _ _ = topSubDmd + -- | Denotes '+' on 'Demand'. plusDmd :: Demand -> Demand -> Demand plusDmd AbsDmd dmd2 = dmd2 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8b5979c2091d736c2f49f6520d85cabc... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8b5979c2091d736c2f49f6520d85cabc... You're receiving this email because of your account on gitlab.haskell.org.