Worker/wrapper: Preserve float barriers (#21150)

Issue #21150 shows that worker/wrapper allocated a worker function for a function with multiple calls that said "called at most once" when the first argument was absent. That's bad! This patch makes it so that WW preserves at least one non-one-shot value lambda (see `Note [Preserving float barriers]`) by passing around `void#` in place of absent arguments. Fixes #21150. Since the fix is pretty similar to `Note [Protecting the last value argument]`, I put the logic in `mkWorkerArgs`. There I realised (#21204) that `-ffun-to-thunk` is basically useless with `-ffull-laziness`, so I deprecated the flag, simplified and split into `needsVoidWorkerArg`/`addVoidWorkerArg`. SpecConstr is another client of that API. Fixes #21204. Metric Decrease: T14683
author: Sebastian Graf <sebastian.graf@kit.edu> 2022-02-28 14:52:36 +0100
committer: Marge Bot <ben+marge-bot@smart-cactus.org> 2022-03-13 18:12:48 -0400
commit: 76b94b726f6e21bb2a46ae04e4a1be2cba45a3dc (patch)
tree: 8db126a5c8718140a6cd7bdd8f3a20df257f580c
parent: ad83553153278947f439951d79a842527f2f0983 (diff)
download: haskell-76b94b726f6e21bb2a46ae04e4a1be2cba45a3dc.tar.gz
12 files changed, 425 insertions, 91 deletions
diff --git a/compiler/GHC/Core/Lint.hs b/compiler/GHC/Core/Lint.hs
index c0cc8b0cfd..adf8124b12 100644
--- a/compiler/GHC/Core/Lint.hs
+++ b/compiler/GHC/Core/Lint.hs
@@ -174,7 +174,7 @@ In the desugarer, it's very very convenient to be able to say (in effect)
         let a = Type Bool in
         let x::a = True in <body>
 That is, use a type let.  See Note [Core type and coercion invariant] in "GHC.Core".
-One place it is used is in mkWorkerArgs; see Note [Join points and beta-redexes]
+One place it is used is in mkWwBodies; see Note [Join points and beta-redexes]
 in GHC.Core.Opt.WorkWrap.Utils.  (Maybe there are other "clients" of this feature; I'm not sure).
 
 * Hence when linting <body> we need to remember that a=Int, else we
diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index 14fe9bec00..d973c75570 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -30,7 +30,7 @@ import GHC.Core.Utils
 import GHC.Core.Unfold
 import GHC.Core.FVs     ( exprsFreeVarsList )
 import GHC.Core.Opt.Monad
-import GHC.Core.Opt.WorkWrap.Utils ( isWorkerSmallEnough, mkWorkerArgs )
+import GHC.Core.Opt.WorkWrap.Utils
 import GHC.Core.DataCon
 import GHC.Core.Coercion hiding( substCo )
 import GHC.Core.Rules
@@ -1771,20 +1771,25 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
 
                 -- And build the results
         ; let spec_body_ty   = exprType spec_body
-              (spec_lam_args1, spec_sig, spec_arity, spec_join_arity)
+              (spec_lam_args1, spec_sig, spec_arity1, spec_join_arity1)
                   = calcSpecInfo fn call_pat extra_bndrs
                   -- Annotate the variables with the strictness information from
                   -- the function (see Note [Strictness information in worker binders])
 
-              (spec_lam_args, spec_call_args,_) = mkWorkerArgs fn False
-                                                    spec_lam_args1 []
-                                                    spec_body_ty
-                -- mkWorkerArgs: usual w/w hack to avoid generating
-                -- a spec_rhs of unlifted type and no args.
-                -- Unlike W/W we don't turn functions into strict workers
-                -- immediately here instead letting tidy handle this.
-                -- For this reason we can ignore the cbv marks.
-                -- See Note [Strict Worker Ids]. See Note [Tag Inference].
+              (spec_lam_args, spec_call_args, spec_arity, spec_join_arity)
+                  | needsVoidWorkerArg fn arg_bndrs spec_lam_args1
+                  , (spec_lam_args, spec_call_args, _) <- addVoidWorkerArg spec_lam_args1 []
+                      -- needsVoidWorkerArg: usual w/w hack to avoid generating
+                      -- a spec_rhs of unlifted type and no args.
+                      -- Unlike W/W we don't turn functions into strict workers
+                      -- immediately here instead letting tidy handle this.
+                      -- For this reason we can ignore the cbv marks.
+                      -- See Note [Strict Worker Ids]. See Note [Tag Inference].
+                  , !spec_arity      <- spec_arity1 + 1
+                  , !spec_join_arity <- fmap (+ 1) spec_join_arity1
+                  = (spec_lam_args,  spec_call_args, spec_arity,  spec_join_arity)
+                  | otherwise
+                  = (spec_lam_args1, spec_lam_args1, spec_arity1, spec_join_arity1)
 
               spec_id    = mkLocalId spec_name Many
                                      (mkLamTypes spec_lam_args spec_body_ty)
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index cbf3a4e10e..d80e78f685 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -1519,7 +1519,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
                  -- Maybe add a void arg to the specialised function,
                  -- to avoid unlifted bindings
                  -- See Note [Specialisations Must Be Lifted]
-                 -- C.f. GHC.Core.Opt.WorkWrap.Utils.mkWorkerArgs
+                 -- C.f. GHC.Core.Opt.WorkWrap.Utils.needsVoidWorkerArg
                  add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn)
                  (spec_bndrs, spec_rhs, spec_fn_ty)
                    | add_void_arg = ( voidPrimId : spec_bndrs1
diff --git a/compiler/GHC/Core/Opt/WorkWrap.hs b/compiler/GHC/Core/Opt/WorkWrap.hs
index f07e8dde37..092fdbb7a7 100644
--- a/compiler/GHC/Core/Opt/WorkWrap.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap.hs
@@ -900,18 +900,6 @@ the original function.
 The demand on the worker is then calculated using mkWorkerDemand, and always of
 the form [Demand=<L,1*(C1(...(C1(U))))>]
 
-
-Note [Do not split void functions]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider this rather common form of binding:
-        $j = \x:Void# -> ...no use of x...
-
-Since x is not used it'll be marked as absent.  But there is no point
-in w/w-ing because we'll simply add (\y:Void#), see GHC.Core.Opt.WorkWrap.Utils.mkWorerArgs.
-
-If x has a more interesting type (eg Int, or Int#), there *is* a point
-in w/w so that we don't pass the argument at all.
-
 Note [Thunk splitting]
 ~~~~~~~~~~~~~~~~~~~~~~
 Suppose x is used strictly; never mind whether it has the CPR
diff --git a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
index 5f450b9316..c62ba572de 100644
--- a/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
+++ b/compiler/GHC/Core/Opt/WorkWrap/Utils.hs
@@ -8,7 +8,8 @@ A library for the ``worker\/wrapper'' back-end to the strictness analyser
 {-# LANGUAGE ViewPatterns #-}
 
 module GHC.Core.Opt.WorkWrap.Utils
-   ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWWstr_one, mkWorkerArgs
+   ( WwOpts(..), initWwOpts, mkWwBodies, mkWWstr, mkWWstr_one
+   , needsVoidWorkerArg, addVoidWorkerArg
    , DataConPatContext(..)
    , UnboxingDecision(..), wantToUnboxArg
    , findTypeShape, IsRecDataConResult(..), isRecDataCon
@@ -141,7 +142,6 @@ data WwOpts
   { wo_fam_envs          :: !FamInstEnvs
   , wo_simple_opts       :: !SimpleOpts
   , wo_cpr_anal          :: !Bool
-  , wo_fun_to_thunk      :: !Bool
 
   -- Used for absent argument error message
   , wo_module            :: !Module
@@ -155,7 +155,6 @@ initWwOpts this_mod dflags fam_envs = MkWwOpts
   { wo_fam_envs          = fam_envs
   , wo_simple_opts       = initSimpleOpts dflags
   , wo_cpr_anal          = gopt Opt_CprAnal dflags
-  , wo_fun_to_thunk      = gopt Opt_FunToThunk dflags
   , wo_module            = this_mod
   , wo_unlift_strict     = gopt Opt_WorkerWrapperUnlift dflags
   }
@@ -240,11 +239,14 @@ mkWwBodies opts fun_id arg_vars res_ty demands res_cpr
         ; let (work_args, work_marks) = unzip work_args_cbv
 
         -- Do CPR w/w.  See Note [Always do CPR w/w]
-        ; (useful2, wrap_fn_cpr, work_fn_cpr, cpr_res_ty)
+        ; (useful2, wrap_fn_cpr, work_fn_cpr)
               <- mkWWcpr_entry opts res_ty' res_cpr
 
-        ; let (work_lam_args, work_call_args, work_call_cbv) = mkWorkerArgs fun_id (wo_fun_to_thunk opts)
-                                                                 work_args work_marks cpr_res_ty
+        ; let (work_lam_args, work_call_args, work_call_cbv)
+                | needsVoidWorkerArg fun_id arg_vars work_args
+                = addVoidWorkerArg work_args work_marks
+                | otherwise
+                = (work_args, work_args, work_marks)
 
               call_work work_fn  = mkVarApps (Var work_fn) work_call_args
               call_rhs fn_rhs = mkAppsBeta fn_rhs fn_args
@@ -347,9 +349,19 @@ function for the worker:
     of the fun body in the next run of the Simplifier, but CoreLint will complain
     in the meantime, so zap it.
 
-We zap in mkWwBodies because we need the zapped variables both when binding them
-in mkWWstr (mkAbsentFiller, specifically) and in mkWorkerArgs, where we produce
-the call to the fun body.
+We zap in mkWwBodies because we need the zapped variables when binding them in
+mkWWstr (mkAbsentFiller, specifically).
+
+Note [Do not split void functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this rather common form of binding:
+        $j = \x:Void# -> ...no use of x...
+
+Since x is not used it'll be marked as absent.  But there is no point
+in w/w-ing because we'll simply add (\y:Void#), see addVoidWorkerArg.
+
+If x has a more interesting type (eg Int, or Int#), there *is* a point
+in w/w so that we don't pass the argument at all.
 
 ************************************************************************
 *                                                                      *
@@ -369,44 +381,29 @@ add a void argument.  E.g.
 We use the state-token type which generates no code.
 -}
 
--- | Prevent a function from becoming a thunk by adding a void argument if
--- required.
-mkWorkerArgs :: Id      -- The wrapper Id
-             -> Bool    -- Allow fun->thunk conversion.
-             -> [Var]
-             -> [CbvMark]
-             -> Type    -- Type of body
-             -> ([Var], -- Lambda bound args
-                 [Var], -- Args at call site
-                 [CbvMark] -- cbv semantics for the worker args.
-                 )
-mkWorkerArgs wrap_id fun_to_thunk args cbv_marks res_ty
-    | not (isJoinId wrap_id) -- Join Ids never need an extra arg
-    , not (any isId args)    -- No existing value lambdas
-    , needs_a_value_lambda   -- and we need to add one
-    = (args ++ [voidArgId], args ++ [voidPrimId], cbv_marks ++ [NotMarkedCbv])
-
-    | otherwise
-    = (args, args, cbv_marks)
-    where
-      -- If fun_to_thunk is False we always keep at least one value
-      --   argument: see Note [Protecting the last value argument]
-      -- If it is True, we only need to keep a value argument if
-      --   the result type is (or might be) unlifted, in which case
-      --   dropping the last arg would mean we wrongly used call-by-value
-      needs_a_value_lambda
-        = not fun_to_thunk
-          || might_be_unlifted
-
-      -- Might the result be lifted?
-      --     False => definitely lifted
-      --     True  => might be unlifted
-      -- We may encounter a representation-polymorphic result, in which case we
-      -- conservatively assume that we have laziness that needs
-      -- preservation. See #15186.
-      might_be_unlifted = case isLiftedType_maybe res_ty of
-                            Just lifted -> not lifted
-                            Nothing     -> True
+-- | Whether the worker needs an additional `Void#` arg as per
+-- Note [Protecting the last value argument] or
+-- Note [Preserving float barriers].
+needsVoidWorkerArg :: Id -> [Var] -> [Var] -> Bool
+needsVoidWorkerArg fn_id wrap_args work_args
+  =  not (isJoinId fn_id) && no_value_arg -- See Note [Protecting the last value argument]
+  || needs_float_barrier                  -- See Note [Preserving float barriers]
+  where
+    no_value_arg        = all (not . isId) work_args
+    is_float_barrier v  = isId v && hasNoOneShotInfo (idOneShotInfo v)
+    wrap_had_barrier    = any is_float_barrier wrap_args
+    work_has_barrier    = any is_float_barrier work_args
+    needs_float_barrier = wrap_had_barrier && not work_has_barrier
+
+-- | Inserts a `Void#` arg before the first value argument (but after leading type args).
+addVoidWorkerArg :: [Var] -> [CbvMark]
+                 -> ([Var],     -- Lambda bound args
+                     [Var],     -- Args at call site
+                     [CbvMark]) -- cbv semantics for the worker args.
+addVoidWorkerArg work_args cbv_marks
+  = (ty_args ++ voidArgId:rest, ty_args ++ voidPrimId:rest, NotMarkedCbv:cbv_marks)
+  where
+    (ty_args, rest) = break isId work_args
 
 {-
 Note [Protecting the last value argument]
@@ -414,13 +411,71 @@ Note [Protecting the last value argument]
 If the user writes (\_ -> E), they might be intentionally disallowing
 the sharing of E. Since absence analysis and worker-wrapper are keen
 to remove such unused arguments, we add in a void argument to prevent
-the function from becoming a thunk.
+the function from becoming a thunk.  Three reasons why turning a function
+into a thunk might be bad:
+
+1) It can create a space leak. e.g.
+      f x = let y () = [1..x]
+            in (sum (y ()) + length (y ()))
+   As written it'll calculate [1..x] twice, and avoid keeping a big
+   list around.  (Of course let-floating may introduce the leak; but
+   at least w/w doesn't.)
 
-The user can avoid adding the void argument with the -ffun-to-thunk
-flag. However, this can create sharing, which may be bad in two ways. 1) It can
-create a space leak. 2) It can prevent inlining *under a lambda*. If w/w
-removes the last argument from a function f, then f now looks like a thunk, and
-so f can't be inlined *under a lambda*.
+2) It can prevent inlining *under a lambda*. e.g.
+       g = \y. [1..100]
+       f = \t. g ()
+   Here we can inline g under the \t.  But we won't if we remove the \y.
+
+3) It can create an unlifted binding.  E.g.
+       g :: Int -> Int#
+       g = \x. 30#
+   Removing the \x would leave an unlifted binding.
+
+NB: none of these apply to a join point.
+
+Note [Preserving float barriers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider
+```
+let
+  t = sum [0..x]
+  f a{os} b[Dmd=A] c{os} = ... t ...
+in f 1 2 3 + f 4 5 6
+```
+Here, we would like to drop the argument `b` because it's absent. But doing so
+leaves behind only one-shot lambdas, `$wf a{os} c{os} = ...`, and then the
+Simplifier will inline `t` into `$wf`, because `$wf` says "I'm only called
+once". That's bad, because we lost sharing of `t`! Similarly, FloatIn would
+happily float `t` into `$wf`, see Note [Floating in past a lambda group].
+
+Why does floating happen after dropping `b` but not before? Because `b` was the
+only non-one-shot value lambda left, acting as our "float barrier".
+
+Definition:  A float barrier is a non-one-shot value lambda.
+Key insight: If `f` had a float barrier, `$wf` has to have one, too.
+
+To this end, in `needsVoidWorkerArg`, we check whether the wrapper had a float
+barrier and if the worker has none so far. If that is the case, we add a `Void#`
+argument at the end as an artificial float barrier.
+
+The issue is tracked in #21150. It came up when compiling GHC itself, in
+GHC.Tc.Gen.Bind.mkEdges. There the key_map thunk was inlined after WW dropped a
+leading absent non-one-shot arg. Here are some example wrapper arguments of
+which some are absent or one-shot and the resulting worker arguments:
+
+  * \a{Abs}.\b{os}.\c{os}... ==> \b{os}.\c{os}.\(_::Void#)...
+    Wrapper arg `a` was the only float barrier and had been dropped. Hence Void#
+  * \a{Abs,os}.\b{os}.\c... ==> \b{os}.\c...
+    Worker arg `c` is a float barrier.
+  * \a.\b{Abs}.\c{os}... ==> \a.\c{os}...
+    Worker arg `a` is a float barrier.
+  * \a{os}.\b{Abs,os}.\c{os}... ==> \a{os}.\c{os}...
+    Wrapper didn't have a float barrier, no need for Void#.
+  * \a{Abs,os}.... ==> ... (no value lambda left)
+    This examples simply demonstrates that preserving float barriers is not
+    enough to subsume Note [Protecting the last value argument].
+
+Executable examples in T21150.
 
 Note [Join points and beta-redexes]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1301,12 +1356,10 @@ mkWWcpr_entry
   -> Cpr                               -- CPR analysis results
   -> UniqSM (Bool,            -- Is w/w'ing useful?
              CoreExpr -> CoreExpr,     -- New wrapper. 'nop_fn' if not useful
-             CoreExpr -> CoreExpr,     -- New worker.  'nop_fn' if not useful
-             Type)                     -- Type of worker's body.
-                                       -- Just the input body_ty if not useful
+             CoreExpr -> CoreExpr)     -- New worker.  'nop_fn' if not useful
 -- ^ Entrypoint to CPR W/W. See Note [Worker/wrapper for CPR] for an overview.
 mkWWcpr_entry opts body_ty body_cpr
-  | not (wo_cpr_anal opts) = return (badWorker, nop_fn, nop_fn, body_ty)
+  | not (wo_cpr_anal opts) = return (badWorker, nop_fn, nop_fn)
   | otherwise = do
     -- Part (1)
     res_bndr <- mk_res_bndr body_ty
@@ -1322,10 +1375,9 @@ mkWWcpr_entry opts body_ty body_cpr
     -- Stacking unboxer (work_fn) and builder (wrap_fn) together
     let wrap_fn      = unbox_transit_tup rebuilt_result                 -- 3 2
         work_fn body = bind_res_bndr body (work_unpack_res transit_tup) -- 1 2 3
-        work_body_ty = exprType transit_tup
     return $ if not useful
-                then (badWorker, nop_fn, nop_fn, body_ty)
-                else (goodWorker, wrap_fn, work_fn, work_body_ty)
+                then (badWorker, nop_fn, nop_fn)
+                else (goodWorker, wrap_fn, work_fn)
 
 -- | Part (1) of Note [Worker/wrapper for CPR].
 mk_res_bndr :: Type -> UniqSM Id
diff --git a/compiler/GHC/Driver/Flags.hs b/compiler/GHC/Driver/Flags.hs
index 21530048f2..21649c9c54 100644
--- a/compiler/GHC/Driver/Flags.hs
+++ b/compiler/GHC/Driver/Flags.hs
@@ -217,7 +217,7 @@ data GeneralFlag
    | Opt_CmmControlFlow
    | Opt_AsmShortcutting
    | Opt_OmitYields
-   | Opt_FunToThunk               -- allow GHC.Core.Opt.WorkWrap.Utils.mkWorkerArgs to remove all value lambdas
+   | Opt_FunToThunk               -- deprecated
    | Opt_DictsStrict                     -- be strict in argument dictionaries
    | Opt_DmdTxDictSel              -- ^ deprecated, no effect and behaviour is now default.
                                    -- Allowed switching of a special demand transformer for dictionary selectors
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 26d34b63af..49e322bbd2 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -3379,7 +3379,8 @@ fFlagsDeps = [
   flagSpec "ignore-optim-changes"             Opt_IgnoreOptimChanges,
   flagSpec "ignore-hpc-changes"               Opt_IgnoreHpcChanges,
   flagSpec "full-laziness"                    Opt_FullLaziness,
-  flagSpec "fun-to-thunk"                     Opt_FunToThunk,
+  depFlagSpec' "fun-to-thunk"                 Opt_FunToThunk
+      (useInstead "-f" "full-laziness"),
   flagSpec "gen-manifest"                     Opt_GenManifest,
   flagSpec "ghci-history"                     Opt_GhciHistory,
   flagSpec "ghci-leak-check"                  Opt_GhciLeakCheck,
diff --git a/docs/users_guide/using-optimisation.rst b/docs/users_guide/using-optimisation.rst
index 390b179f33..ab49f08ade 100644
--- a/docs/users_guide/using-optimisation.rst
+++ b/docs/users_guide/using-optimisation.rst
@@ -561,8 +561,7 @@ by saying ``-fno-wombat``.
         them.
 
 .. ghc-flag:: -ffun-to-thunk
-    :shortdesc: Allow worker-wrapper to convert a function closure into a thunk
-        if the function does not use any of its arguments. Off by default.
+    :shortdesc: *(deprecated)* superseded by -ffull-laziness.
     :type: dynamic
     :reverse: -fno-fun-to-thunk
     :category:
@@ -574,6 +573,16 @@ by saying ``-fno-wombat``.
     thereby perhaps creating a space leak and/or disrupting inlining.
     This flag allows worker/wrapper to remove *all* value lambdas.
 
+    This flag was ineffective in the presence of :ghc-flag:`-ffull-laziness`,
+    which would flout a thunk out of a constant worker function *even though*
+    :ghc-flag:`-ffun-to-thunk` was off.
+
+    Hence use of this flag is deprecated since GHC 9.4.1 and we rather suggest
+    to pass ``-fno-full-laziness`` instead. That implies there's no way for
+    worker/wrapper to turn a function into a thunk in the presence of
+    ``-fno-full-laziness``. If that is inconvenient for you, please leave a
+    comment `on the issue tracker (#21204) <https://gitlab.haskell.org/ghc/ghc/-/issues/21204>`__.
+
 .. ghc-flag:: -fignore-asserts
     :shortdesc: Ignore assertions in the source. Implied by :ghc-flag:`-O`.
     :type: dynamic
diff --git a/testsuite/tests/simplCore/should_compile/T19794.hs b/testsuite/tests/simplCore/should_compile/T19794.hs
index c8f6897468..2518586db6 100644
--- a/testsuite/tests/simplCore/should_compile/T19794.hs
+++ b/testsuite/tests/simplCore/should_compile/T19794.hs
@@ -1,5 +1,9 @@
 {-# LANGUAGE MagicHash #-}
-{-# OPTIONS_GHC -ffun-to-thunk #-}   -- This is essential for the test
+-- -ffun-to-thunk is essential for the test, but the flag had been deprecated in
+-- 9.4 and is off by default. It doesn't hurt to keep the regression test, though,
+-- in case we accidentally drop the logic for
+-- Note [Protecting the last value argument].
+-- {-# OPTIONS_GHC -ffun-to-thunk #-}
 
 module Foo where
 import GHC.Exts
diff --git a/testsuite/tests/stranal/should_compile/T21150.hs b/testsuite/tests/stranal/should_compile/T21150.hs
new file mode 100644
index 0000000000..520b7d9d77
--- /dev/null
+++ b/testsuite/tests/stranal/should_compile/T21150.hs
@@ -0,0 +1,37 @@
+-- | The idea here is that t* should never be inlined into g*.
+-- That may happen if the absent arguments of g* are dropped without care,
+-- making $wg* appear as if all its lambdas are oneShot afterwards.
+--
+-- So in these cases, we replace absent args with `Void#` instead in order
+-- to preserve lambda groups.
+module T21150 where
+
+import GHC.Exts
+
+f :: Int -> Int -> Int -> Maybe Int
+f x y z = (+) <$> g x y z <*> g x z y
+  where
+    t :: Int
+    t = sum [0..x]
+    g :: Int -> Int -> Int -> Maybe Int
+    g _ = oneShot $ \_ -> oneShot $ \z -> Just (y + z + t)
+    {-# NOINLINE g #-}
+
+f2 :: Int -> Int -> Int -> Maybe Int
+f2 x y z = (+) <$> g' y <*> g' z
+  where
+    t2 :: Int
+    t2 = sum [0..x]
+    g' = g2 x
+    g2 :: Int -> Int -> Maybe Int
+    g2 = oneShot $ \y _ -> Just (y + z + t2)
+    {-# NOINLINE g2 #-}
+
+f3 :: Int -> Int -> Int -> Maybe Int
+f3 x y z = (+) <$> g3 x y z <*> g3 x z y
+  where
+    t3 :: Int
+    t3 = sum [0..x]
+    g3 :: Int -> Int -> Int -> Maybe Int
+    g3 = oneShot $ \y z _ -> Just (y + z + t3)
+    {-# NOINLINE g3 #-}
diff --git a/testsuite/tests/stranal/should_compile/T21150.stderr b/testsuite/tests/stranal/should_compile/T21150.stderr
new file mode 100644
index 0000000000..fc70e22563
--- /dev/null
+++ b/testsuite/tests/stranal/should_compile/T21150.stderr
@@ -0,0 +1,237 @@
+
+==================== Exitification transformation ====================
+Result size of Exitification transformation
+  = {terms: 242, types: 140, coercions: 0, joins: 3/9}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+$trModule = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+$trModule = "T21150"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+T21150.$trModule :: GHC.Types.Module
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+T21150.$trModule = GHC.Types.Module $trModule $trModule
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 0#
+
+-- RHS size: {terms: 70, types: 37, coercions: 0, joins: 1/3}
+f3 :: Int -> Int -> Int -> Maybe Int
+[LclIdX,
+ Arity=3,
+ Str=<L><L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 0 0] 279 10}]
+f3
+  = \ (x :: Int) (y :: Int) (z :: Int) ->
+      let {
+        t3 :: Int
+        [LclId,
+         Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False,
+                 WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 77 0}]
+        t3
+          = case x of { I# y ->
+            case ># 0# y of {
+              __DEFAULT ->
+                joinrec {
+                  $wgo3 [InlPrag=[2], Occ=LoopBreaker] :: Int# -> Int# -> Int
+                  [LclId[JoinId(2)(Nothing)],
+                   Arity=2,
+                   Str=<L><L>,
+                   Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True,
+                           WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0] 40 10}]
+                  $wgo3 (x :: Int#) (ww :: Int#)
+                    = case ==# x y of {
+                        __DEFAULT -> jump $wgo3 (+# x 1#) (+# ww x);
+                        1# -> GHC.Types.I# (+# ww x)
+                      }; } in
+                jump $wgo3 0# 0#;
+              1# -> lvl
+            }
+            } } in
+      let {
+        $wg3 [InlPrag=NOINLINE] :: Int -> Int -> (# Int #)
+        [LclId,
+         Arity=2,
+         Str=<L><L>,
+         Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True,
+                 WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 20] 42 10}]
+        $wg3
+          = \ (v [OS=OneShot] :: Int) (z :: Int) ->
+              (# case v of { I# x ->
+                 case z of { I# y ->
+                 case t3 of { I# y -> GHC.Types.I# (+# (+# x y) y) }
+                 }
+                 } #) } in
+      case $wg3 x y of { (# ww #) ->
+      case $wg3 x z of { (# ww #) ->
+      GHC.Maybe.Just @Int (GHC.Num.$fNumInt_$c+ ww ww)
+      }
+      }
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 0#
+
+-- RHS size: {terms: 69, types: 36, coercions: 0, joins: 1/3}
+$wf2 [InlPrag=[2]] :: Int -> Int -> Maybe Int
+[LclId,
+ Arity=2,
+ Str=<L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 20] 279 10}]
+$wf2
+  = \ (x :: Int) (z :: Int) ->
+      let {
+        t2 :: Int
+        [LclId,
+         Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False,
+                 WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 77 0}]
+        t2
+          = case x of { I# y ->
+            case ># 0# y of {
+              __DEFAULT ->
+                joinrec {
+                  $wgo3 [InlPrag=[2], Occ=LoopBreaker] :: Int# -> Int# -> Int
+                  [LclId[JoinId(2)(Nothing)],
+                   Arity=2,
+                   Str=<L><L>,
+                   Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True,
+                           WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0] 40 10}]
+                  $wgo3 (x :: Int#) (ww :: Int#)
+                    = case ==# x y of {
+                        __DEFAULT -> jump $wgo3 (+# x 1#) (+# ww x);
+                        1# -> GHC.Types.I# (+# ww x)
+                      }; } in
+                jump $wgo3 0# 0#;
+              1# -> lvl
+            }
+            } } in
+      let {
+        $wg2 [InlPrag=NOINLINE] :: Int -> (# #) -> (# Int #)
+        [LclId,
+         Arity=2,
+         Str=<L><L>,
+         Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True,
+                 WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 0] 42 10}]
+        $wg2
+          = \ (v [OS=OneShot] :: Int) _ [Occ=Dead] ->
+              (# case v of { I# x ->
+                 case z of { I# y ->
+                 case t2 of { I# y -> GHC.Types.I# (+# (+# x y) y) }
+                 }
+                 } #) } in
+      case $wg2 x GHC.Prim.(##) of { (# ww #) ->
+      case $wg2 x GHC.Prim.(##) of { (# ww #) ->
+      GHC.Maybe.Just @Int (GHC.Num.$fNumInt_$c+ ww ww)
+      }
+      }
+
+-- RHS size: {terms: 6, types: 3, coercions: 0, joins: 0/0}
+f2 [InlPrag=[2]] :: Int -> Int -> Int -> Maybe Int
+[LclIdX,
+ Arity=3,
+ Str=<L><A><L>,
+ Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True,
+         Guidance=ALWAYS_IF(arity=3,unsat_ok=True,boring_ok=True)
+         Tmpl= \ (x [Occ=Once1] :: Int)
+                 _ [Occ=Dead, Dmd=A]
+                 (z [Occ=Once1] :: Int) ->
+                 $wf2 x z}]
+f2 = \ (x :: Int) _ [Occ=Dead, Dmd=A] (z :: Int) -> $wf2 x z
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+lvl :: Int
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
+lvl = GHC.Types.I# 0#
+
+-- RHS size: {terms: 70, types: 37, coercions: 0, joins: 1/3}
+f :: Int -> Int -> Int -> Maybe Int
+[LclIdX,
+ Arity=3,
+ Str=<L><L><L>,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 20 0] 279 10}]
+f = \ (x :: Int) (y :: Int) (z :: Int) ->
+      let {
+        t :: Int
+        [LclId,
+         Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False,
+                 WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 77 0}]
+        t = case x of { I# y ->
+            case ># 0# y of {
+              __DEFAULT ->
+                joinrec {
+                  $wgo3 [InlPrag=[2], Occ=LoopBreaker] :: Int# -> Int# -> Int
+                  [LclId[JoinId(2)(Nothing)],
+                   Arity=2,
+                   Str=<L><L>,
+                   Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True,
+                           WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 0] 40 10}]
+                  $wgo3 (x :: Int#) (ww :: Int#)
+                    = case ==# x y of {
+                        __DEFAULT -> jump $wgo3 (+# x 1#) (+# ww x);
+                        1# -> GHC.Types.I# (+# ww x)
+                      }; } in
+                jump $wgo3 0# 0#;
+              1# -> lvl
+            }
+            } } in
+      let {
+        $wg [InlPrag=NOINLINE] :: Int -> (# #) -> (# Int #)
+        [LclId,
+         Arity=2,
+         Str=<L><L>,
+         Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True,
+                 WorkFree=True, Expandable=True, Guidance=IF_ARGS [20 0] 42 10}]
+        $wg
+          = \ (v [OS=OneShot] :: Int) _ [Occ=Dead] ->
+              (# case y of { I# x ->
+                 case v of { I# y ->
+                 case t of { I# y -> GHC.Types.I# (+# (+# x y) y) }
+                 }
+                 } #) } in
+      case $wg z GHC.Prim.(##) of { (# ww #) ->
+      case $wg y GHC.Prim.(##) of { (# ww #) ->
+      GHC.Maybe.Just @Int (GHC.Num.$fNumInt_$c+ ww ww)
+      }
+      }
+
+
+
diff --git a/testsuite/tests/stranal/should_compile/all.T b/testsuite/tests/stranal/should_compile/all.T
index ac35fc42ce..042ee9dd44 100644
--- a/testsuite/tests/stranal/should_compile/all.T
+++ b/testsuite/tests/stranal/should_compile/all.T
@@ -80,4 +80,5 @@ test('T20510', [ grep_errmsg(r'jump \$wgo') ], compile, ['-dsuppress-uniques -dd
 test('T20746', normal, compile, ['-dsuppress-uniques -ddump-simpl'])
 test('T20746b', normal, compile, ['-dsuppress-uniques -ddump-simpl -dno-typeable-binds'])
 test('T20817', [ grep_errmsg(r'Str') ], compile, ['-dsuppress-uniques -ddump-stranal'])
-
+# T21150: Check that t{,1,2} haven't been inlined.
+test('T21150', [ grep_errmsg(r'( t\d? :: Int)') ], compile, ['-dsuppress-uniques -ddump-exitify'])
author	Sebastian Graf <sebastian.graf@kit.edu>	2022-02-28 14:52:36 +0100
committer	Marge Bot <ben+marge-bot@smart-cactus.org>	2022-03-13 18:12:48 -0400
commit	76b94b726f6e21bb2a46ae04e4a1be2cba45a3dc (patch)
tree	8db126a5c8718140a6cd7bdd8f3a20df257f580c
parent	ad83553153278947f439951d79a842527f2f0983 (diff)
download	haskell-76b94b726f6e21bb2a46ae04e4a1be2cba45a3dc.tar.gz