GitLab

Zubin pushed to branch wip/26416 at Glasgow Haskell Compiler / GHC

Commits:

5ffe38ea

by Zubin Duggal at 2025-12-23T19:37:01+05:30

DmdAnal: Don't give an absent demand signature to an argument if the argument doesn't
also have an absent demand signature in its unfolding.

Otherwise, in some cases we might mark an argument as absent and generate a LitRubbish for
it, but then the function might inline and turn out to actually use this argument, resulting
in a run time crash.

Partially addresses #26416.

There may still be cases where an absent argument turns out to be used due to a rule firing.

3 changed files:

compiler/GHC/Core/Opt/DmdAnal.hs
+ testsuite/tests/dmdanal/should_run/M1.hs
+ testsuite/tests/dmdanal/should_run/T26416.hs

Changes:

compiler/GHC/Core/Opt/DmdAnal.hs

@@ -1106,8 +1106,17 @@ dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs
      WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_sd rhs
      DmdType rhs_env rhs_dmds = rhs_dmd_ty
++
 +    -- See Note [Absence analysis for stable unfoldings and RULES]
 +    -- If there's a stable unfolding, we need to combine argument demands
 +    -- from the unfolding with those from the RHS, because the unfolding
 +    -- 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
++
      (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id ww_arity
 -                                                      rhs_dmds (de_div rhs_env) rhs'
 +                                                      combined_rhs_dmds (de_div rhs_env) rhs'
      dmd_sig_arity = ww_arity + strictCallArity body_sd
      sig = mkDmdSigForArity dmd_sig_arity (DmdType sig_env final_rhs_dmds)
@@ -1144,6 +1153,27 @@ 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
 +-- See Note [Absence analysis for stable unfoldings and RULES], Wrinkle (W3).
 +combineUnfoldingDmds :: AnalEnv -> SubDemand -> Id -> [Demand] -> [Demand]
 +combineUnfoldingDmds env rhs_sd id rhs_dmds
 +  | not (isStableUnfolding unf)
 +  = 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
 +  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
++
  -- | The result type after applying 'idArity' many arguments. Returns 'Nothing'
  -- when the type doesn't have exactly 'idArity' many arrows.
  resultType_maybe :: Id -> Maybe Type
@@ -1523,6 +1553,25 @@ 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
 +    what about /arguments/?  Consider (#25965)
++
 +       fromVector :: (Storable a, KnownNat n) => Vector a -> Vector a
 +       fromVector v = ... (uses Storable dictionary) ...
 +       {-# INLINABLE fromVector #-}
++
 +    Suppose that the optimised RHS of `fromVector` somehow discards the use of
 +    the Storable dictionary, but the stable unfolding still uses it. Then the
 +    demand signature will say that the Storable dictionary argument is absent,
 +    and worker/wrapper will replace it with `LitRubbish`.  But when the
 +    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 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.
++
  Note [DmdAnal for DataCon wrappers]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  We give DataCon wrappers a (necessarily flat) demand signature in
@@ -2046,8 +2095,11 @@ finaliseArgBoxities env fn ww_arity arg_dmds div rhs
      arg_triples :: [(Type, StrictnessMark, Demand)]
      arg_triples = take ww_arity $
 -                  [ (idType bndr, NotMarkedStrict, get_dmd bndr)
 -                  | bndr <- bndrs, isRuntimeVar bndr ]
 +                  zipWith mk_triple
 +                          [ bndr | bndr <- bndrs, isRuntimeVar bndr ]
 +                          arg_dmds
 +      where
 +        mk_triple bndr dmd = (idType bndr, NotMarkedStrict, get_dmd dmd)
      arg_dmds' = ww_arg_dmds ++ map trimBoxity (drop ww_arity arg_dmds)
                  -- If ww_arity < length arg_dmds, the leftover ones
@@ -2063,12 +2115,10 @@ finaliseArgBoxities env fn ww_arity arg_dmds div rhs
                      -- This is the budget initialisation step of
                      -- Note [Worker argument budget]
 -    get_dmd :: Id -> Demand
 -    get_dmd bndr
 +    get_dmd :: Demand -> Demand
 +    get_dmd dmd
        | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions],
        | otherwise = dmd                --     case (B)
 -      where
 -        dmd = idDemandInfo bndr
      -- is_bot_fn:  see Note [Boxity for bottoming functions]
      is_bot_fn = div == botDiv

testsuite/tests/dmdanal/should_run/M1.hs

 +-- Short module name is essential, or else f doesn't inline
 +module M1 where
 +{-# INLINABLE [2] f #-}
 +f :: Int -> Int -> Float
 +f !dummy x = if   times dummy 0 x == 1
 +             then 3.0 else 4.0
++
 +{-# INLINE [0] times #-}
 +times :: Int -> Int -> Int -> Int
 +times dummy 0 x = x `seq` ( 0 + big dummy )
 +times _     a b = a * b
++
 +{-# RULES "times" [1] forall dummy x. times dummy 0 x = 0 + big dummy #-}
++
 +big :: Int -> Int
 +big x = succ . succ . succ . succ . succ . succ . succ . succ . succ $ x
 +{-# INLINE big #-}

testsuite/tests/dmdanal/should_run/T26416.hs

 +module Main where
 +import M1 ( f )
 +main = print (f 19 12)