[Git][ghc/ghc][wip/T22725] Fix finaliseArgBoxities for OPAQUE function

Simon Peyton Jones (@simonpj) gitlab at gitlab.haskell.org
Mon Jan 9 23:17:49 UTC 2023



Simon Peyton Jones pushed to branch wip/T22725 at Glasgow Haskell Compiler / GHC


Commits:
7da376f1 by Simon Peyton Jones at 2023-01-09T23:17:50+00:00
Fix finaliseArgBoxities for OPAQUE function

This patch fixes #22502

- - - - -


3 changed files:

- compiler/GHC/Core/Opt/DmdAnal.hs
- + testsuite/tests/simplCore/should_compile/T22502.hs
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/DmdAnal.hs
=====================================
@@ -41,7 +41,6 @@ import GHC.Core.Opt.Arity ( typeArity )
 import GHC.Utils.Misc
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
-import GHC.Data.Maybe
 import GHC.Builtin.PrimOps
 import GHC.Builtin.Types.Prim ( realWorldStatePrimTy )
 import GHC.Types.Unique.Set
@@ -1071,9 +1070,8 @@ dmdAnalRhsSig top_lvl rec_flag env let_dmd id rhs
 
     WithDmdType rhs_dmd_ty rhs' = dmdAnal env rhs_dmd rhs
     DmdType rhs_fv rhs_dmds rhs_div = rhs_dmd_ty
-    -- See Note [Boxity for bottoming functions]
-    (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity rhs' rhs_div
-                                  `orElse` (rhs_dmds, rhs')
+    (final_rhs_dmds, final_rhs) = finaliseArgBoxities env id threshold_arity
+                                                      rhs_dmds rhs_div rhs'
 
     sig = mkDmdSigForArity threshold_arity (DmdType sig_fv final_rhs_dmds rhs_div)
 
@@ -1252,7 +1250,9 @@ The threshold we use is
 * Ordinary bindings: idArity f.
   Why idArity arguments? Because that's a conservative estimate of how many
   arguments we must feed a function before it does anything interesting with
-  them.  Also it elegantly subsumes the trivial RHS and PAP case.
+  them.  Also it elegantly subsumes the trivial RHS and PAP case.  E.g. for
+      f = g
+  we want to use a threshold arity based on g, not 0!
 
   idArity is /at least/ the number of manifest lambdas, but might be higher for
   PAPs and trivial RHS (see Note [Demand analysis for trivial right-hand sides]).
@@ -1902,21 +1902,33 @@ spendTopBudget m (MkB n bg) = MkB (n-m) bg
 positiveTopBudget :: Budgets -> Bool
 positiveTopBudget (MkB n _) = n >= 0
 
-finaliseArgBoxities :: AnalEnv -> Id -> Arity -> CoreExpr -> Divergence
-                    -> Maybe ([Demand], CoreExpr)
-finaliseArgBoxities env fn arity rhs div
-  | arity > count isId bndrs  -- Can't find enough binders
-  = Nothing  -- This happens if we have   f = g
-             -- Then there are no binders; we don't worker/wrapper; and we
-             -- simply want to give f the same demand signature as g
-
-  | otherwise -- NB: arity is the threshold_arity, which might be less than
+finaliseArgBoxities :: AnalEnv -> Id -> Arity
+                    -> [Demand] -> Divergence
+                    -> CoreExpr -> ([Demand], CoreExpr)
+finaliseArgBoxities env fn threshold_arity rhs_dmds div rhs
+
+  -- Check for an OPAQUE function: see Note [OPAQUE pragma]
+  -- In that case, trim off all boxity info from argument demands
+  -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]
+  | isOpaquePragma (idInlinePragma fn)
+  , let trimmed_rhs_dmds = map trimBoxity rhs_dmds
+  = (trimmed_rhs_dmds, add_demands trimmed_rhs_dmds rhs)
+
+  -- Check that we have enough visible binders to match the
+  -- threshold arity; if not, we won't do worker/wrapper
+  -- This happens if we have simply  f=g
+  -- we simply want to give f the same demand signature as g
+  | threshold_arity > count isId bndrs
+  = (rhs_dmds, rhs)
+
+  -- The normal case
+  | otherwise -- NB: threshold_arity might be less than
               -- manifest arity for join points
   = -- pprTrace "finaliseArgBoxities" (
     --   vcat [text "function:" <+> ppr fn
     --        , text "dmds before:" <+> ppr (map idDemandInfo (filter isId bndrs))
     --        , text "dmds after: " <+>  ppr arg_dmds' ]) $
-    Just (arg_dmds', add_demands arg_dmds' rhs)
+    (arg_dmds', add_demands arg_dmds' rhs)
     -- add_demands: we must attach the final boxities to the lambda-binders
     -- of the function, both because that's kosher, and because CPR analysis
     -- uses the info on the binders directly.
@@ -1934,7 +1946,7 @@ finaliseArgBoxities env fn arity rhs div
     (remaining_budget, arg_dmds') = go_args (MkB max_wkr_args remaining_budget) arg_triples
 
     arg_triples :: [(Type, StrictnessMark, Demand)]
-    arg_triples = take arity $
+    arg_triples = take threshold_arity $
                   [ (bndr_ty, NotMarkedStrict, get_dmd bndr bndr_ty)
                   | bndr <- bndrs
                   , isRuntimeVar bndr, let bndr_ty = idType bndr ]
@@ -1950,14 +1962,9 @@ finaliseArgBoxities env fn arity rhs div
       | is_bot_fn = unboxDeeplyDmd dmd
         -- See Note [Boxity for bottoming functions], case (B)
 
-      | is_opaque = trimBoxity dmd
-        -- See Note [OPAQUE pragma]
-        -- See Note [The OPAQUE pragma and avoiding the reboxing of arguments]
-
       | otherwise = dmd
       where
-        dmd       = idDemandInfo bndr
-        is_opaque = isOpaquePragma (idInlinePragma fn)
+        dmd = idDemandInfo bndr
 
     -- is_bot_fn:  see Note [Boxity for bottoming functions]
     is_bot_fn = div == botDiv
@@ -2020,6 +2027,10 @@ finaliseArgBoxities env fn arity rhs div
     add_demands (dmd:dmds) (Lam v e)
       | isTyVar v = Lam v (add_demands (dmd:dmds) e)
       | otherwise = Lam (v `setIdDemandInfo` dmd) (add_demands dmds e)
+    add_demands dmds (Cast e co) = Cast (add_demands dmds e) co
+       -- This case happens for an OPAQUE function, which may look like
+       --     f = (\x y. blah) |> co
+       -- We give it strictness but no boxity
     add_demands dmds e = pprPanic "add_demands" (ppr dmds $$ ppr e)
 
 finaliseLetBoxity


=====================================
testsuite/tests/simplCore/should_compile/T22502.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE MagicHash #-}
+module M where
+
+import GHC.Exts
+import GHC.IO
+
+data T a = MkT !Bool !a
+
+fun :: T a -> IO a
+{-# OPAQUE fun #-}
+fun (MkT _ x) = IO $ \s -> noinline seq# x s
+-- evaluate/seq# should not produce its own eval for x
+-- since it is properly tagged (from a strict field)
+
+-- uses noinline to prevent caseRules from eliding the seq# in Core


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -463,3 +463,4 @@ test('T22459', normal, compile, [''])
 test('T22623', normal, multimod_compile, ['T22623', '-O -v0'])
 test('T22662', normal, compile, [''])
 test('T22725', normal, compile, ['-O'])
+test('T22502', normal, compile, ['-O'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7da376f1a1887fe3e31ee242efe3f73a5525f450

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/7da376f1a1887fe3e31ee242efe3f73a5525f450
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230109/95141f6a/attachment-0001.html>


More information about the ghc-commits mailing list