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

Commits:

6 changed files:

Changes:

  • compiler/GHC/Core/Opt/DmdAnal.hs
    ... ... @@ -23,7 +23,7 @@ import GHC.Core.DataCon
    23 23 
     import GHC.Core.Utils
    24 24 
     import GHC.Core.TyCon
    25 25 
     import GHC.Core.Type
    26 
    -import GHC.Core.FVs      ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds )
    26 
    +import GHC.Core.FVs      ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds, idRuleVars )
    27 27 
     import GHC.Core.Coercion ( Coercion )
    28 28 
     import GHC.Core.TyCo.FVs     ( coVarsOfCos )
    29 29 
     import GHC.Core.TyCo.Compare ( eqType )
    ... ... @@ -1106,8 +1106,18 @@ dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs
    1106 1106
    1107 1107 
         WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_sd rhs
    1108 1108 
         DmdType rhs_env rhs_dmds = rhs_dmd_ty
    1109 
    +
    1110 
    +    -- See Note [Absence analysis for stable unfoldings and RULES]
    1111 
    +    -- If there's a stable unfolding, we need to combine argument demands
    1112 
    +    -- from the unfolding with those from the RHS, because the unfolding
    1113 
    +    -- might use arguments that the (optimised) RHS doesn't.
    1114 
    +    -- Any argument with a demand absent in one but not the other can
    1115 
    +    -- be problematic, see #26416
    1116 
    +    -- Also combine the DmdEnv (free variables) from the unfolding
    1117 
    +    (unf_fv_env, combined_rhs_dmds) = combineUnfoldingDmds env rhs_sd id rhs_env rhs_dmds
    1118 
    +
    1109 1119 
         (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id ww_arity
    1110 
    -                                                      rhs_dmds (de_div rhs_env) rhs'
    1120 
    +                                                      combined_rhs_dmds (de_div rhs_env) rhs'
    1111 1121
    1112 1122 
         dmd_sig_arity = ww_arity + strictCallArity body_sd
    1113 1123 
         sig = mkDmdSigForArity dmd_sig_arity (DmdType sig_env final_rhs_dmds)
    ... ... @@ -1135,7 +1145,10 @@ dmdAnalRhsSig top_lvl rec_flag env let_sd id rhs
    1135 1145 
                     NonRecursive -> rhs_env
    1136 1146
    1137 1147 
         -- See Note [Absence analysis for stable unfoldings and RULES]
    1138 
    -    rhs_env2 = rhs_env1 `plusDmdEnv` demandRootSet env (bndrRuleAndUnfoldingIds id)
    1148 
    +    -- The unfolding FVs are handled via unf_fv_env from combineUnfoldingDmds.
    1149 
    +    -- Here we only need demandRoots for RULES.
    1150 
    +    rhs_env2 = rhs_env1 `plusDmdEnv` unf_fv_env
    1151 
    +                        `plusDmdEnv` demandRootSet env (idRuleVars id)
    1139 1152
    1140 1153 
         -- See Note [Lazy and unleashable free variables]
    1141 1154 
         !(!sig_env, !weak_fvs) = splitWeakDmds rhs_env2
    ... ... @@ -1144,6 +1157,31 @@ splitWeakDmds :: DmdEnv -> (DmdEnv, WeakDmds)
    1144 1157 
     splitWeakDmds (DE fvs div) = (DE sig_fvs div, weak_fvs)
    1145 1158 
       where (!weak_fvs, !sig_fvs) = partitionVarEnv isWeakDmd fvs
    1146 1159
    1160 
    +-- | If there is a stable unfolding, combine argument demands and free variable
    1161 
    +-- demands from the unfolding with those from the RHS.
    1162 
    +-- See Note [Absence analysis for stable unfoldings and RULES], Wrinkle (W3).
    1163 
    +--
    1164 
    +-- Returns (combined DmdEnv for free variables, combined arg demands)
    1165 
    +-- The DmdEnv is nopDmdEnv if there's no stable unfolding.
    1166 
    +combineUnfoldingDmds :: AnalEnv -> SubDemand -> Id -> DmdEnv -> [Demand] -> (DmdEnv, [Demand])
    1167 
    +combineUnfoldingDmds env rhs_sd id rhs_fv_env rhs_dmds
    1168 
    +  | not (isStableUnfolding unf)
    1169 
    +  = (nopDmdEnv, rhs_dmds)  -- No stable unfolding, nothing to do
    1170 
    +
    1171 
    +  | Just unf_body <- maybeUnfoldingTemplate unf
    1172 
    +  , let WithDmdType (DmdType unf_fv_env unf_dmds) _ = dmdAnal env rhs_sd unf_body
    1173 
    +  , let combined_dmds = go rhs_dmds unf_dmds
    1174 
    +        -- Lub the free variable demands from unfolding with RHS
    1175 
    +        combined_fv_env = lubDmdEnv rhs_fv_env unf_fv_env
    1176 
    +  = -- pprTrace "combineUnfoldingDmds" (ppr id $$ ppr rhs_dmds $$ ppr unf_dmds $$ ppr combined_dmds) $
    1177 
    +   (combined_fv_env, combined_dmds)
    1178 
    +  | otherwise = (nopDmdEnv, rhs_dmds)
    1179 
    +  where
    1180 
    +    unf = realIdUnfolding id
    1181 
    +    go rhs          []            = rhs
    1182 
    +    go []           _             = []
    1183 
    +    go (r:rhs)      (u:unfs)      = lubUBglbLBDmd r u : go rhs unfs
    1184 
    +
    1147 1185 
     -- | The result type after applying 'idArity' many arguments. Returns 'Nothing'
    1148 1186 
     -- when the type doesn't have exactly 'idArity' many arrows.
    1149 1187 
     resultType_maybe :: Id -> Maybe Type
    ... ... @@ -1523,6 +1561,34 @@ Wrinkles:
    1523 1561 
         for `sg`, failing to unleash the signature and hence observed an absent
    1524 1562 
         error instead of the `really important message`.
    1525 1563
    1564 
    +  (W3) The SOLUTION above handles /free variables/ of stable unfoldings, but
    1565 
    +    what about /arguments/?  Consider (#26416)
    1566 
    +
    1567 
    +       fromVector :: (Storable a, KnownNat n) => Vector a -> Vector a
    1568 
    +       fromVector v = ... (uses Storable dictionary) ...
    1569 
    +       {-# INLINABLE fromVector #-}
    1570 
    +
    1571 
    +    Suppose that the optimised RHS of `fromVector` somehow discards the use of
    1572 
    +    the Storable dictionary, but the stable unfolding still uses it. Then the
    1573 
    +    demand signature will say that the Storable dictionary argument is absent,
    1574 
    +    and worker/wrapper will replace it with `LitRubbish`.  But when the
    1575 
    +    worker's unfolding is inlined, it will use that rubbish value as a real
    1576 
    +    dictionary, leading to a segfault!
    1577 
    +
    1578 
    +    SOLUTION: in `dmdAnalRhsSig`, if the function has a stable unfolding,
    1579 
    +    analyse it with `dmdAnal` and combine the resulting `DmdType` with the
    1580 
    +    RHS's `DmdType`. This is done by `combineUnfoldingDmds`, which:
    1581 
    +
    1582 
    +      * For argument demands: combines them using `lubUBglbLBDmd`, which takes
    1583 
    +        the glb (max) of lower bounds (strictness) and lub (max) of upper
    1584 
    +        bounds (usage). See Note [Combining demands for stable unfoldings].
    1585 
    +        This ensures that if the unfolding uses an argument, it won't be
    1586 
    +        marked as absent, while preserving any strictness the RHS reveals.
    1587 
    +
    1588 
    +      * For free variable demands: combines them using `lubDmdEnv`. This
    1589 
    +        replaces the `demandRoots` approach for stable unfoldings (though
    1590 
    +        we still use `demandRoots` for RULES via `idRuleVars`).
    1591 
    +
    1526 1592 
     Note [DmdAnal for DataCon wrappers]
    1527 1593 
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    1528 1594 
     We give DataCon wrappers a (necessarily flat) demand signature in
    ... ... @@ -2046,8 +2112,11 @@ finaliseArgBoxities env fn ww_arity arg_dmds div rhs
    2046 2112
    2047 2113 
         arg_triples :: [(Type, StrictnessMark, Demand)]
    2048 2114 
         arg_triples = take ww_arity $
    2049 
    -                  [ (idType bndr, NotMarkedStrict, get_dmd bndr)
    2050 
    -                  | bndr <- bndrs, isRuntimeVar bndr ]
    2115 
    +                  zipWith mk_triple
    2116 
    +                          [ bndr | bndr <- bndrs, isRuntimeVar bndr ]
    2117 
    +                          arg_dmds
    2118 
    +      where
    2119 
    +        mk_triple bndr dmd = (idType bndr, NotMarkedStrict, get_dmd dmd)
    2051 2120
    2052 2121 
         arg_dmds' = ww_arg_dmds ++ map trimBoxity (drop ww_arity arg_dmds)
    2053 2122 
                     -- If ww_arity < length arg_dmds, the leftover ones
    ... ... @@ -2063,12 +2132,10 @@ finaliseArgBoxities env fn ww_arity arg_dmds div rhs
    2063 2132 
                         -- This is the budget initialisation step of
    2064 2133 
                         -- Note [Worker argument budget]
    2065 2134
    2066 
    -    get_dmd :: Id -> Demand
    2067 
    -    get_dmd bndr
    2135 
    +    get_dmd :: Demand -> Demand
    2136 
    +    get_dmd dmd
    2068 2137 
           | is_bot_fn = unboxDeeplyDmd dmd -- See Note [Boxity for bottoming functions],
    2069 2138 
           | otherwise = dmd                --     case (B)
    2070 
    -      where
    2071 
    -        dmd = idDemandInfo bndr
    2072 2139
    2073 2140 
         -- is_bot_fn:  see Note [Boxity for bottoming functions]
    2074 2141 
         is_bot_fn = div == botDiv

  • compiler/GHC/Core/Opt/WorkWrap.hs
    ... ... @@ -547,10 +547,10 @@ tryWW :: WwOpts
    547 547 
                                             -- wrapper.
    548 548 
     tryWW ww_opts is_rec fn_id rhs
    549 549 
       -- See Note [Drop absent bindings]
    550 
    ---  | isAbsDmd (demandInfo fn_info)
    551 
    ---  , not (isJoinId fn_id)
    552 
    ---  , Just filler <- mkAbsentFiller ww_opts fn_id NotMarkedStrict
    553 
    ---  = return [(new_fn_id, filler)]
    550 
    +  | isAbsDmd (demandInfo fn_info)
    551 
    +  , not (isJoinId fn_id)
    552 
    +  , Just filler <- mkAbsentFiller ww_opts fn_id NotMarkedStrict
    553 
    +  = return [(new_fn_id, filler)]
    554 554
    555 555 
       -- See Note [Don't w/w INLINE things]
    556 556 
       | hasInlineUnfolding fn_info

  • compiler/GHC/Types/Demand.hs
    ... ... @@ -23,6 +23,8 @@ module GHC.Types.Demand (
    23 23 
         lubCard, lubDmd, lubSubDmd,
    24 24 
         -- *** Greatest lower bound
    25 25 
         glbCard,
    26 
    +    -- *** Unfolding combination (glb on strictness, lub on usage)
    27 
    +    lubUBglbLBDmd,
    26 28 
         -- *** Plus
    27 29 
         plusCard, plusDmd, plusSubDmd,
    28 30 
         -- *** Multiply
    ... ... @@ -49,7 +51,7 @@ module GHC.Types.Demand (
    49 51
    50 52 
         -- * Demand environments
    51 53 
         DmdEnv(..), addVarDmdEnv, mkTermDmdEnv, nopDmdEnv, plusDmdEnv, plusDmdEnvs,
    52 
    -    multDmdEnv, reuseEnv,
    54 
    +    lubDmdEnv, multDmdEnv, reuseEnv,
    53 55
    54 56 
         -- * Demand types
    55 57 
         DmdType(..), dmdTypeDepth,
    ... ... @@ -864,6 +866,77 @@ lubSubDmd sd1@Poly{} sd2 = lubSubDmd sd2 sd1
    864 866 
     -- Otherwise (Call `lub` Prod) return Top
    865 867 
     lubSubDmd _            _            = topSubDmd
    866 868
    869 
    +{- Note [Combining demands for stable unfoldings]
    870 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    871 
    +When a function has a stable unfolding, the optimised RHS and the unfolding
    872 
    +may have different demand signatures for the same arguments. This can happen
    873 
    +because:
    874 
    +
    875 
    +  * The optimised RHS may have had transformations applied that reveal
    876 
    +    strictness (e.g., inlining exposes a case on an argument).
    877 
    +
    878 
    +  * The optimised RHS may have had transformations applied that drop usage
    879 
    +    (e.g., a rewrite rule fires that doesn't use an argument, or a seq on
    880 
    +    a dictionary is dropped because dictionaries are known to terminate).
    881 
    +
    882 
    +When we inline the stable unfolding at a call site, we get the unfolding's
    883 
    +behaviour, not the RHS's. So we must be conservative and combine the demands:
    884 
    +
    885 
    +  * For strictness (lower bounds): we can take the MAXIMUM (glb).
    886 
    +    If the RHS reveals that an argument is strict, that strictness was
    887 
    +    always there semantically - the analysis just couldn't see it in the
    888 
    +    unfolding. Sound optimisations never make lazy code strict.
    889 
    +
    890 
    +  * For usage (upper bounds): we must take the MAXIMUM (lub).
    891 
    +    If the unfolding uses an argument but the RHS doesn't, we must not
    892 
    +    mark it absent, or we'll replace it with rubbish that the unfolding
    893 
    +    will then try to use, causing a segfault. See #26416.
    894 
    +
    895 
    +So for cardinality bounds [l1..u1] from RHS and [l2..u2] from unfolding,
    896 
    +we compute [max(l1,l2)..max(u1,u2)].
    897 
    +
    898 
    +See Note [Absence analysis for stable unfoldings and RULES] in GHC.Core.Opt.DmdAnal
    899 
    +for the broader context.
    900 
    +-}
    901 
    +
    902 
    +-- | Combine demands for stable unfolding analysis.
    903 
    +-- See Note [Combining demands for stable unfoldings].
    904 
    +lubUBglbLBCard :: Card -> Card -> Card
    905 
    +-- Given Note [Bit vector representation for Card]:
    906 
    +--   * bit 0 (strictness): take AND (glb) - 0 means strict, so 0 wins
    907 
    +--   * bits 1,2 (usage): take OR (lub) - if either uses, result uses
    908 
    +lubUBglbLBCard (Card a) (Card b) = Card ((a .&. b .&. 0b001) .|. ((a .|. b) .&. 0b110))
    909 
    +
    910 
    +-- | See Note [Combining demands for stable unfoldings].
    911 
    +lubUBglbLBDmd :: Demand -> Demand -> Demand
    912 
    +lubUBglbLBDmd BotDmd      dmd2        = dmd2
    913 
    +lubUBglbLBDmd dmd1        BotDmd      = dmd1
    914 
    +lubUBglbLBDmd (n1 :* sd1) (n2 :* sd2) =
    915 
    +  lubUBglbLBCard n1 n2 :* lubUBglbLBSubDmd sd1 sd2
    916 
    +
    917 
    +lubUBglbLBSubDmd :: SubDemand -> SubDemand -> SubDemand
    918 
    +-- Shortcuts for neutral and absorbing elements.
    919 
    +lubUBglbLBSubDmd (Poly Unboxed C_10)  sd                   = sd
    920 
    +lubUBglbLBSubDmd sd                   (Poly Unboxed C_10)  = sd
    921 
    +lubUBglbLBSubDmd sd@(Poly Boxed C_0N) _                    = sd
    922 
    +lubUBglbLBSubDmd _                    sd@(Poly Boxed C_0N) = sd
    923 
    +-- Prod
    924 
    +lubUBglbLBSubDmd (Prod b1 ds1) (Poly b2 n2)
    925 
    +  | let !d = polyFieldDmd b2 n2
    926 
    +  = mkProd (lubBoxity b1 b2) (strictMap (lubUBglbLBDmd d) ds1)
    927 
    +lubUBglbLBSubDmd (Prod b1 ds1) (Prod b2 ds2)
    928 
    +  | equalLength ds1 ds2
    929 
    +  = mkProd (lubBoxity b1 b2) (strictZipWith lubUBglbLBDmd ds1 ds2)
    930 
    +-- Handle Call
    931 
    +lubUBglbLBSubDmd (Call n1 sd1) (viewCall -> Just (n2, sd2)) =
    932 
    +  mkCall (lubUBglbLBCard n1 n2) (lubUBglbLBSubDmd sd1 sd2)
    933 
    +-- Handle Poly
    934 
    +lubUBglbLBSubDmd (Poly b1 n1) (Poly b2 n2) = Poly (lubBoxity b1 b2) (lubUBglbLBCard n1 n2)
    935 
    +-- Other Poly case by commutativity
    936 
    +lubUBglbLBSubDmd sd1@Poly{}   sd2          = lubUBglbLBSubDmd sd2 sd1
    937 
    +-- Otherwise (Call `lubUBglbLB` Prod) return Top
    938 
    +lubUBglbLBSubDmd _            _            = topSubDmd
    939 
    +
    867 940 
     -- | Denotes '+' on 'Demand'.
    868 941 
     plusDmd :: Demand -> Demand -> Demand
    869 942 
     plusDmd AbsDmd      dmd2        = dmd2

  • testsuite/tests/dmdanal/should_run/M1.hs
    1 
    +-- Short module name is essential, or else f doesn't inline
    2 
    +module M1 where
    3 
    +{-# INLINABLE [2] f #-}
    4 
    +f :: Int -> Int -> Float
    5 
    +f !dummy x = if   times dummy 0 x == 1
    6 
    +             then 3.0 else 4.0
    7 
    +
    8 
    +{-# INLINE [0] times #-}
    9 
    +times :: Int -> Int -> Int -> Int
    10 
    +times dummy 0 x = x `seq` ( 0 + big dummy )
    11 
    +times _     a b = a * b
    12 
    +
    13 
    +{-# RULES "times" [1] forall dummy x. times dummy 0 x = 0 + big dummy #-}
    14 
    +
    15 
    +big :: Int -> Int
    16 
    +big x = succ . succ . succ . succ . succ . succ . succ . succ . succ $ x
    17 
    +{-# INLINE big #-}

  • testsuite/tests/dmdanal/should_run/T26416.hs
    1 
    +module Main where
    2 
    +import M1 ( f )
    3 
    +main = print (f 19 12)

  • testsuite/tests/dmdanal/should_run/all.T
    ... ... @@ -34,3 +34,4 @@ test('T22475b', normal, compile_and_run, [''])
    34 34 
     test('T22549', normal, compile_and_run, ['-fdicts-strict -fno-specialise'])
    35 35 
     test('T23208', exit_code(1), multimod_compile_and_run, ['T23208_Lib', 'T23208'])
    36 36 
     test('T25439', normal, compile_and_run, [''])
    37 
    +test('T26416', normal, multimod_compile_and_run, ['T26416','M1.hs'])

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help