Don't mark lambda binders as OtherCon

We used to put OtherCon unfoldings on lambda binders of workers
and sometimes also join points/specializations with with the
assumption that since the wrapper would force these arguments
once we execute the RHS they would indeed be in WHNF.

This was wrong for reasons detailed in #21472. So now we purge
evaluated unfoldings from *all* lambda binders.

This fixes #21472, but at the cost of sometimes not using as efficient a
calling convention. It can also change inlining behaviour as some
occurances will no longer look like value arguments when they did
before.

As consequence we also change how we compute CBV information for
arguments slightly. We now *always* determine the CBV convention
for arguments during tidy. Earlier in the pipeline we merely mark
functions as candidates for having their arguments treated as CBV.

As before the process is described in the relevant notes:
Note [CBV Function Ids]
Note [Attaching CBV Marks to ids]
Note [Never put `OtherCon` unfoldigns on lambda binders]

-------------------------
Metric Decrease:
    T12425
    T13035
    T18223
    T18223
    T18923
    MultiLayerModulesTH_OneShot
Metric Increase:
    WWRec
-------------------------

1 files changed, 56 insertions, 103 deletions

diff --git a/compiler/GHC/Core/Opt/SpecConstr.hs b/compiler/GHC/Core/Opt/SpecConstr.hs
index 8b303f0316..9ef2d3e3e6 100644
--- a/compiler/GHC/Core/Opt/SpecConstr.hs
+++ b/compiler/GHC/Core/Opt/SpecConstr.hs
@@ -628,41 +628,12 @@ regardless of size; and then we needed a way to turn that *off*.  Now
 that we have ForceSpecConstr, this NoSpecConstr is probably redundant.
 (Used only for PArray, TODO: remove?)
 
-Note [SpecConstr and evaluated unfoldings]
+Note [SpecConstr and strict fields]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-SpecConstr will attach evaldUnfolding unfoldings to function
-arguments representing things that should be fully evaluated
-by the time we execute the RHS.
-
-This primarily concerns strict fields. To give an example in the
-containers package we have a merge function with this specialization:
-
-  "SC:$wmerge01" [2]
-      forall (sc_s5lX :: ghc-prim:GHC.Prim.Int#)
-              (sc_s5lY :: ghc-prim:GHC.Prim.Int#)
-              (sc_s5lZ
-                :: IntMap a_s4UX
-                Unf=OtherCon [])
-              (sc_s5m0
-                :: IntMap a_s4UX
-                Unf=OtherCon [])
-              (sc_s5lW :: ghc-prim:GHC.Prim.Int#)
-              (sc_s5lU :: ghc-prim:GHC.Prim.Int#)
-              (sc_s5lV :: a_s4UX).
-        $wmerge0_s4UK (Data.IntMap.Internal.Tip @a_s4UX sc_s5lU sc_s5lV)
-                      (ghc-prim:GHC.Types.I# sc_s5lW)
-                      (Data.IntMap.Internal.Bin
-                          @a_s4UX sc_s5lX sc_s5lY sc_s5lZ sc_s5m0)
-        = $s$wmerge0_s5m2
-            sc_s5lX sc_s5lY sc_s5lZ sc_s5m0 sc_s5lW sc_s5lU sc_s5lV]
-
-We give sc_s5lZ and sc_s5m0 a evaluated unfolding since they come out of
-strict field fields in the Bin constructor.
-This is especially important since tag inference can then use this
-information to adjust the calling convention of
-`$wmerge0_s4UK` to enforce arguments being passed fully evaluated+tagged.
-See Note [Tag Inference], Note [Strict Worker Ids] for more information on
-how we can take advantage of this.
+We treat strict fields in SpecConstr the same way we do in W/W.
+That is we make the specialized function strict in arguments
+representing strict fields. See Note [Call-by-value for worker args]
+for why we do this.
 
 Note [Specialising on dictionaries]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -797,6 +768,7 @@ specConstrProgram guts
       us     <- getUniqueSupplyM
       (_, annos) <- getFirstAnnotations deserializeWithData guts
       this_mod <- getModule
+      -- pprTraceM "specConstrInput" (ppr $ mg_binds guts)
       let binds' = reverse $ fst $ initUs us $ do
                     -- Note [Top-level recursive groups]
                     (env, binds) <- goEnv (initScEnv (initScOpts dflags this_mod) annos)
@@ -1815,7 +1787,7 @@ spec_one :: ScEnv
 -}
 
 spec_one env fn arg_bndrs body (call_pat, rule_number)
-  | CP { cp_qvars = qvars, cp_args = pats } <- call_pat
+  | CP { cp_qvars = qvars, cp_args = pats, cp_strict_args = cbv_args } <- call_pat
   = do  { spec_uniq <- getUniqueM
         ; let env1 = extendScSubstList (extendScInScope env qvars)
                                        (arg_bndrs `zip` pats)
@@ -1858,17 +1830,14 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
                   , (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
+              spec_id    = asWorkerLikeId $
+                           mkLocalId spec_name Many
                                      (mkLamTypes spec_lam_args spec_body_ty)
                              -- See Note [Transfer strictness]
                              `setIdDmdSig`    spec_sig
@@ -1876,8 +1845,8 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
                              `setIdArity`     spec_arity
                              `asJoinId_maybe` spec_join_arity
 
-                -- Conditionally use result of new worker-wrapper transform
-              spec_rhs   = mkLams spec_lam_args spec_body
+        -- Conditionally use result of new worker-wrapper transform
+              spec_rhs = mkLams spec_lam_args (mkSeqs cbv_args spec_body_ty spec_body)
               rule_rhs = mkVarApps (Var spec_id) $
                               -- This will give us all the arguments we quantify over
                               -- in the rule plus the void argument if present
@@ -1889,25 +1858,39 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
                                   rule_name inline_act fn_name qvars pats rule_rhs
                            -- See Note [Transfer activation]
 
-        -- ; pprTrace "spec_one {" (vcat [ text "function:" <+> ppr fn <+> ppr (idUnique fn)
+        -- ; pprTraceM "spec_one {" (vcat [ text "function:" <+> ppr fn <+> braces (ppr (idUnique fn))
         --                               , text "sc_count:" <+> ppr (sc_count env)
         --                               , text "pats:" <+> ppr pats
         --                               , text "call_pat:" <+> ppr call_pat
         --                               , text "-->" <+> ppr spec_name
         --                               , text "bndrs" <+> ppr arg_bndrs
         --                               , text "extra_bndrs" <+> ppr extra_bndrs
+        --                               , text "cbv_args" <+> ppr cbv_args
         --                               , text "spec_lam_args" <+> ppr spec_lam_args
         --                               , text "spec_call_args" <+> ppr spec_call_args
         --                               , text "rule_rhs" <+> ppr rule_rhs
-        --                               , text "adds_void_worker_arg" <+> ppr adds_void_worker_arg
+        --                               , text "adds_void_worker_arg" <+> ppr add_void_arg
         --                               , text "body" <+> ppr body
         --                               , text "spec_rhs" <+> ppr spec_rhs
-        --                               , text "how_bound" <+> ppr (sc_how_bound env) ]) $
-        --   return ()
+        --                               , text "how_bound" <+> ppr (sc_how_bound env) ])
         ; return (spec_usg, OS { os_pat = call_pat, os_rule = rule
                                , os_id = spec_id
                                , os_rhs = spec_rhs }) }
 
+-- See Note [SpecConstr and strict fields]
+mkSeqs :: [Var] -> Type -> CoreExpr -> CoreExpr
+mkSeqs seqees res_ty rhs =
+  foldr addEval rhs seqees
+    where
+      addEval :: Var -> CoreExpr -> CoreExpr
+      addEval arg_id rhs
+        -- Argument representing strict field and it's worth passing via cbv
+        | shouldStrictifyIdForCbv arg_id
+        = Case (Var arg_id) arg_id res_ty ([Alt DEFAULT [] rhs])
+        | otherwise
+        = rhs
+
+
 {- Note [SpecConst needs to add void args first]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider a function
@@ -2197,13 +2180,15 @@ only in kind-casts, but I'm doing the simple thing for now.
 -}
 
 data CallPat = CP { cp_qvars :: [Var]           -- Quantified variables
-                  , cp_args  :: [CoreExpr] }    -- Arguments
+                  , cp_args  :: [CoreExpr]      -- Arguments
+                  , cp_strict_args :: [Var] }   -- Arguments we want to pass unlifted even if they are boxed
      -- See Note [SpecConstr call patterns]
 
 instance Outputable CallPat where
-  ppr (CP { cp_qvars = qvars, cp_args = args })
+  ppr (CP { cp_qvars = qvars, cp_args = args, cp_strict_args =  strict })
     = text "CP" <> braces (sep [ text "cp_qvars =" <+> ppr qvars <> comma
-                               , text "cp_args =" <+> ppr args ])
+                               , text "cp_args =" <+> ppr args
+                               , text "cp_strict_args = " <> ppr strict ])
 
 callsToNewPats :: ScEnv -> Id
                -> SpecInfo
@@ -2315,16 +2300,16 @@ callToPats :: ScEnv -> [ArgOcc] -> Call -> UniqSM (Maybe CallPat)
 callToPats env bndr_occs call@(Call fn args con_env)
   = do  { let in_scope = substInScope (sc_subst env)
 
-        ; pairs <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args)
+        ; arg_tripples <- zipWith3M (argToPat env in_scope con_env) args bndr_occs (map (const NotMarkedStrict) args)
                    -- This zip trims the args to be no longer than
                    -- the lambdas in the function definition (bndr_occs)
 
           -- Drop boring patterns from the end
           -- See Note [SpecConstr call patterns]
-        ; let pairs' | isJoinId fn = pairs
-                     | otherwise   = dropWhileEnd is_boring pairs
-              is_boring (interesting, _) = not interesting
-              (interesting_s, pats) = unzip pairs'
+        ; let arg_tripples' | isJoinId fn = arg_tripples
+                            | otherwise   = dropWhileEnd is_boring arg_tripples
+              is_boring (interesting, _,_) = not interesting
+              (interesting_s, pats, cbv_ids) = unzip3 arg_tripples'
               interesting           = or interesting_s
 
         ; let pat_fvs = exprsFreeVarsList pats
@@ -2374,7 +2359,7 @@ callToPats env bndr_occs call@(Call fn args con_env)
               --         text "pat_fvs:" <+> ppr pat_fvs
               --       )
               --   ppr (CP { cp_qvars = qvars', cp_args = pats })) >>
-              return (Just (CP { cp_qvars = qvars', cp_args = pats }))
+              return (Just (CP { cp_qvars = qvars', cp_args = pats, cp_strict_args = concat cbv_ids }))
           else return Nothing }
 
     -- argToPat takes an actual argument, and returns an abstracted
@@ -2389,8 +2374,8 @@ argToPat :: ScEnv
          -> CoreArg                     -- A call arg (or component thereof)
          -> ArgOcc
          -> StrictnessMark              -- Tells us if this argument is a strict field of a data constructor
-                                        -- See Note [SpecConstr and evaluated unfoldings]
-         -> UniqSM (Bool, CoreArg)
+                                        -- See Note [SpecConstr and strict fields]
+         -> UniqSM (Bool, CoreArg, [Id])
 
 -- Returns (interesting, pat),
 -- where pat is the pattern derived from the argument
@@ -2415,12 +2400,12 @@ argToPat1 :: ScEnv
   -> Expr CoreBndr
   -> ArgOcc
   -> StrictnessMark
-  -> UniqSM (Bool, Expr CoreBndr)
+  -> UniqSM (Bool, Expr CoreBndr, [Id])
 argToPat1 _env _in_scope _val_env arg@(Type {}) _arg_occ _arg_str
-  = return (False, arg)
+  = return (False, arg, [])
 
-argToPat1 env in_scope val_env (Tick _ arg) arg_occ _arg_str
-  = argToPat env in_scope val_env arg arg_occ _arg_str
+argToPat1 env in_scope val_env (Tick _ arg) arg_occ arg_str
+  = argToPat env in_scope val_env arg arg_occ arg_str
         -- Note [Tick annotations in call patterns]
         -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
         -- Ignore Notes.  In particular, we want to ignore any InlineMe notes
@@ -2444,7 +2429,7 @@ argToPat env in_scope val_env (Case scrut _ _ [(_, _, rhs)]) arg_occ
 
 argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str
   | not (ignoreType env ty2)
-  = do  { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ arg_str
+  = do  { (interesting, arg', strict_args) <- argToPat env in_scope val_env arg arg_occ arg_str
         ; if not interesting then
                 wildCardPat ty2 arg_str
           else do
@@ -2452,7 +2437,7 @@ argToPat1 env in_scope val_env (Cast arg co) arg_occ arg_str
           uniq <- getUniqueM
         ; let co_name = mkSysTvName uniq (fsLit "sg")
               co_var  = mkCoVar co_name (mkCoercionType Representational ty1 ty2)
-        ; return (interesting, Cast arg' (mkCoVarCo co_var)) } }
+        ; return (interesting, Cast arg' (mkCoVarCo co_var), strict_args) } }
   where
     Pair ty1 ty2 = coercionKind co
 
@@ -2488,17 +2473,12 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str
       --       ppr rest_args $$
       --       ppr (map isTypeArg rest_args))
        ; prs <- zipWith3M (argToPat env in_scope val_env) rest_args arg_occs matched_str
-       ; let args' = map snd prs :: [CoreArg]
+       ; let args' = map sndOf3 prs :: [CoreArg]
        ; assertPpr (length con_str == length (filter isRuntimeArg rest_args))
             ( ppr con_str $$ ppr rest_args $$
               ppr (length con_str) $$ ppr (length rest_args)
             ) $ return ()
-      --  ; assert (length con_str == length rest_args) $
-      --    pprTraceM "argToPat"
-      --       ( parens (int $ length con_str) <> ppr con_str  $$
-      --         ppr rest_args $$
-      --         ppr prs)
-       ; return (True, mkConApp dc (ty_args ++ args')) }
+       ; return (True, mkConApp dc (ty_args ++ args'), concat (map thdOf3 prs)) }
   where
     mb_scrut dc = case arg_occ of
                 ScrutOcc bs | Just occs <- lookupUFM bs dc
@@ -2526,7 +2506,7 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str
   --         business of absence analysis, not SpecConstr.)
   --    (b) we know what its value is
   -- In that case it counts as "interesting"
-argToPat1 env in_scope val_env (Var v) arg_occ _arg_str
+argToPat1 env in_scope val_env (Var v) arg_occ arg_str
   | sc_force env || case arg_occ of { ScrutOcc {} -> True
                                     ; UnkOcc      -> False
                                     ; NoOcc       -> False } -- (a)
@@ -2535,7 +2515,8 @@ argToPat1 env in_scope val_env (Var v) arg_occ _arg_str
        -- So sc_keen focused just on f (I# x), where we have freshly-allocated
        -- box that we can eliminate in the caller
   , not (ignoreType env (varType v))
-  = return (True, Var (setStrUnfolding v MarkedStrict))
+  -- See Note [SpecConstr and strict fields]
+  = return (True, Var v, if isMarkedStrict arg_str then [v] else mempty)
   where
     is_value
         | isLocalId v = v `elemInScopeSet` in_scope
@@ -2567,41 +2548,12 @@ argToPat1 env in_scope val_env (Var v) arg_occ _arg_str
 argToPat1 _env _in_scope _val_env arg _arg_occ arg_str
   = wildCardPat (exprType arg) arg_str
 
--- We want the given id to be passed call-by-value if it's MarkedCbv.
--- For some, but not all ids this can be achieved by giving them an OtherCon unfolding.
--- Doesn't touch existing value unfoldings.
--- See Note [SpecConstr and evaluated unfoldings]
-setStrUnfolding :: Id -> StrictnessMark  -> Id
--- setStrUnfolding id str = id
-setStrUnfolding id str
-  -- pprTrace "setStrUnfolding"
-  --   (ppr id <+> ppr (isMarkedCbv str) $$
-  --    ppr (idType id) $$
-  --    text "boxed:" <> ppr (isBoxedType (idType id)) $$
-  --    text "unlifted:" <> ppr (isUnliftedType (idType id))
-  --    )
-  --   False
-  -- = undefined
-  | not (isId id) || isEvaldUnfolding (idUnfolding id)
-  = id
-  | isMarkedStrict str
-  , not $ isUnliftedType (idType id) -- Pointless to stick an evald unfolding on unlifted types
-  = -- trace "setStrUnfolding2" $
-    assert (isId id) $
-    assert (not $ hasCoreUnfolding $ idUnfolding id) $
-    id `setIdUnfolding` evaldUnfolding
-  | otherwise
-  = -- trace "setStrUnfolding3"
-    id
-
 -- | wildCardPats are always boring
-wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg)
+wildCardPat :: Type -> StrictnessMark -> UniqSM (Bool, CoreArg, [Id])
 wildCardPat ty str
   = do { id <- mkSysLocalOrCoVarM (fsLit "sc") Many ty
-       ; let id' = id `setStrUnfolding` str
-       -- See Note [SpecConstr and evaluated unfoldings]
        -- ; pprTraceM "wildCardPat" (ppr id' <+> ppr (idUnfolding id'))
-       ; return (False, varToCoreExpr id') }
+       ; return (False, varToCoreExpr id, if isMarkedStrict str then [id] else []) }
 
 isValue :: ValueEnv -> CoreExpr -> Maybe Value
 isValue _env (Lit lit)
@@ -2659,6 +2611,7 @@ samePat (CP { cp_qvars = vs1, cp_args = as1 })
         (CP { cp_qvars = vs2, cp_args = as2 })
   = all2 same as1 as2
   where
+    -- If the args are the same, their strictness marks will be too so we don't compare those.
     same (Var v1) (Var v2)
         | v1 `elem` vs1 = v2 `elem` vs2
         | v2 `elem` vs2 = False