+section: compiler

+synopsis: Eliminate redundant thunks introduced by tag inference.

+description: {

+  Tag inference is now more precise in tracking function results, eliminating

+  redundant thunks for certain functions that return an unboxed tuple.

+}

+issues: #27005

+mrs: !15688

+            case x<TagVal[TagEPT]> of x' [Occ=Once1] {

+            case y<TagVal[TagEPT]> of y' [Occ=Once1] { __DEFAULT ->

+            case x<TagVal[TagEPT]> of x' [Occ=Once1] {

+Wrinkles:

+

+EPT1:  The proper tag for builtin *unlifted* data types such as `Array#` is

+       not `001` but `000`, which is not a proper tag for lifted data.

+       This means that UnliftedRep is not a proper sub-rep of LiftedRep.

+       SG thinks it would be good to fix this; see #21792.

+EPT2:  The proper tag for PAPs is `000`, so there are values from lifted data types

+       that are EPT with a zero tag.

+EPT3:  Non-pointer values don't have a tag at all, but we still treat them as EPT.

+'TagFun' represents an evaluated function and carries the return-value TagInfo

+for saturated calls. See Note [TagSig and TagInfo] in GHC.Stg.EnforceEpt.TagSig.

+

+Join points (StgLetNoEscape) are treated like functions: they are jumped to,

+never entered via a closure pointer. Even nullary join points get TagFun

+rather than TagVal TagDunno, so their return-value info flows through.

+

+Additionally we also special case bottoming functions.

+See Note [Bottom functions are TagBottoming].

+

+Function values when properly tagged have either their arity, 1 for very large

+arities, or zero for PAPs (#21193) as tag. However the runtime currently doesn't

+maintain the EPT status of function pointers. So while we keep track of

+evaluated function binders using 'TagFun' this has a weaker guarantee than for

+values. For functions it only represents a pointer to an evaluated function, but

+doesn't give any guarantee about the function's pointer tag.

+

+Sadly because PAPs get tag zero (#21193), other issues in the RTS (#21193) and

+the potential of over/underapplication of arguments, even evaluated function

+binders still require inspection of their closure before they can be applied.

+That is, even if we have

+

+    case f of f' -> ... f' x ...

+

+the code for `f' x` can't be made meaningfully more efficient by knowing `f'` is

+already evaluated.

+

+However tracking evaluation status for functions is still worthwhile, as we rely

+on the EPT pass to force strict constructor fields. For an application

+`StrictJust f` we would usually insert an eval of `f` around the constructor

+application. However if we infer `f` to be already evaluated we can avoid this,

+which was a significant performance benefit in #27005. Similarly we can still

+turn redundant eval-cases on functions into a no-op.

+         -- See Note [Bottom functions are TagBottoming] and #24806 for why.

+         = TagBottoming

+         -- Imported function with known return tag

+         | Just (TagFun res_info) <- tagSigInfo (idInfo fun)

+         -- Local function with known return tag

+         | Just res_info <- lookupReturnInfo env fun

+  = (TagEPT, StgLit l)

+            (getBinderId in_env tup_bndr, TagVal tup_info)

+        alt_info = foldr combineAltInfo TagBottoming infos

+      TagBottoming -> Just $ replicate (length bndrs) TagBottoming

+    bndr' = (getBinderId in_env bndr, TagVal TagEPT)

+      = (id, TagVal TagEPT)

+    (in_sig, rhs') = inferTagRhs id in_env rhs

+    go :: forall q. (OutputableInferPass q , InferExtEq q)

+       => TagEnv q -> [TagSig] -> [GenStgRhs q]

+       -> (TagSigEnv, [((Id,TagSig), GenStgRhs 'InferTaggedBinders)])

+       | otherwise           = go env' out_sigs rhss'

+            let (sig_rhs, rhs') = inferTagRhs bnd rhs_env rhs

+-- Initial signature for the fixpoint loop.

+initSig (_bndr, StgRhsCon {})

+  = TagVal TagBottoming

+initSig (bndr, StgRhsClosure _ _ _ bndrs _ _)

+  | notNull bndrs || isJoinId bndr

+  = fromMaybe (TagFun TagBottoming) (idTagSig_maybe bndr)

+  | otherwise  -- thunk

+  = fromMaybe (TagVal TagBottoming) (idTagSig_maybe bndr)

+

+{- Note [Bottom functions are TagBottoming]

+unboxed tuple what is the result? We give it TagBottoming!

+So we give it TagBottoming, as it allows the combined tag sig of the case expression

+  | isDeadEndId bnd_id && is_fun_or_join

+  -- See Note [Bottom functions are TagBottoming]

+  = ( TagFun TagBottoming

+    , StgRhsClosure ext cc upd out_bndrs body' typ)

+  | is_fun_or_join

+  = ( TagFun info

+    , StgRhsClosure ext cc upd out_bndrs body' typ)

+  | otherwise  -- thunk (never a join point)

+  = ( TagVal TagDunno

+    , StgRhsClosure ext cc upd out_bndrs body' typ)

+    -- Join points are treated like functions. See Note [TagInfo of functions]

+    is_fun_or_join = notNull bndrs || isJoinId bnd_id

+

+            MarkedCbv -> TagEPT

+              | isUnliftedType (idType id) -> TagEPT

+      in (id, TagVal tag)

+    (TagVal (inferConTag env con args), StgRhsCon cc con cn ticks args typ)

+  | for_bytecode = TagVal TagDunno

+  | otherwise    = in_sig

+Usually these will simply be TagEPT. But there are exceptions.

+    let x<TagVal[TagDunno]> = f ...

+    let c<TagVal[TagEPT]> = StrictPair x True

+    let x<TagVal[TagDunno]> = f ...

+    let c<TagVal[TagDunno]> = StrictPair x True

+    let x<TagVal[TagDunno]> = f ...

+    let c<TagVal[TagDunno]> = case x of x' -> StrictPair x' True

+    let c<TagVal[TagEPT]> = True

+    let x<TagVal[TagDunno]> = ...

+    let f<?> z = case z of z'<TagVal[TagEPT]> -> (# c, x #)

+Here we will infer for f the Signature <TagFun[TagTuple[TagEPT,TagDunno]]>.

+r1<TagVal[TagEPT]> and r2<TagVal[TagDunno]> which allows us to skip all tag checks on `r1`

+    let closeFd<TagFun[...]> = ...

+We only keep track of function return types for bindings, not values:

+TagInfo has no constructor for "function with return info". Therefore the

+signature of `f` becomes <TagFun[TagTuple[TagEPT]]>. We lose the information

+about the return type of `closeFd`.

+    info = if any arg_needs_eval strictArgs then TagDunno else TagEPT

+    flatten_arg_tag TagBottoming    = TagEPT

+    flatten_arg_tag TagEPT          = TagEPT

+    flatten_arg_tag (TagTuple _)    = TagDunno -- See Note [Constructor TagSigs]

+    flatten_arg_tag TagDunno        = TagDunno

+          | TagVal TagDunno     <- sig -> []

+          | TagVal TagBottoming <- sig -> []

+    collectRec (((id,sig), _rhs) : bnds)

+      | TagVal TagDunno     <- sig = collectRec bnds

+      | TagVal TagBottoming <- sig = collectRec bnds

+      | otherwise                  = (idName id, sig) : collectRec bnds

+    -- See Note [Bottom functions are TagBottoming]

+                                    (TagVal TagDunno)

+                    TagFun _             -> True  -- function closure is tagged

+                    TagVal TagDunno      -> False

+                    TagVal TagEPT        -> True

+                    TagVal TagBottoming  -> True

+                    TagVal (TagTuple _)  -> True  -- Consider unboxed tuples tagged.

+                    LFUnlifted {}  -- Unboxed, tagging irrelevant

+    if is_tagged then return $! setIdTagSig v (TagVal TagEPT)

+-- Note [TagSig and TagInfo]

+-- ~~~~~~~~~~~~~~~~~~~~~~~~~

+-- 'TagSig' describes a *binding*; 'TagInfo' describes a *runtime value*.

+--

+-- A binding denotes either a value or a function:

+--

+--   * 'TagVal' i   — the binding holds a value whose runtime shape is 'i'.

+--                    'i' covers thunks (TagDunno), evaluated/tagged heap

+--                    pointers (TagEPT), unboxed tuples (TagTuple), and

+--                    bottoming computations (TagBottoming).

+--

+--   * 'TagFun' i   — the binding is a function or join point. A function

+--                    closure is always EPT. 'i' describes what a

+--                    *saturated call* returns.

+--                    See Note [TagInfo of functions] in GHC.Stg.EnforceEpt.

+--

+-- This split keeps 'combineAltInfo' at the value level: case alternatives

+-- combine 'TagInfo', not 'TagSig'. An alternative that returns a function

+-- closure gets 'TagEPT' (closure pointer is tagged) with no tracked return

+-- info — the return info only matters once the function is applied, and at

+-- that point it's looked up from the binding's 'TagSig' via

+-- 'lookupReturnInfo'.

+

+-- | The signature attached to a binding.

+data TagSig

+  = TagVal TagInfo        -- ^ A value binding (thunk, constructor, etc.)

+  | TagFun TagInfo        -- ^ A function/join-point binding; carries the

+                          -- TagInfo of saturated-call return values.

+                          -- See Note [TagInfo of functions].

+-- Note [TagInfo lattice]

+-- ~~~~~~~~~~~~~~~~~~~~~~

+-- The TagInfo lattice describes what we know about whether a runtime value

+-- is properly tagged (pointer tag bits set for heap pointers):

+--

+--   TagBottoming (bottom) ⊑ {TagEPT, TagTuple _} ⊑ TagDunno (top)

+--

+-- TagBottoming is the identity element for 'combineAltInfo': it is used as

+-- the initial signature in fixpoint loops and for dead-end (bottoming)

+-- computations, since their return value can be given any tag — they never

+-- actually return.

+

+-- | What we know about a runtime value.

+  = TagDunno            -- ^ We don't know anything about the tag.

+  | TagTuple [TagInfo]  -- ^ An unboxed tuple with taginfo for each element.

+  | TagEPT              -- ^ An evaluated and properly tagged value.

+                        -- See Note [Evaluated and Properly Tagged].

+  | TagBottoming        -- ^ Bottom of the domain.

+                        -- See Note [Bottom functions are TagBottoming] in GHC.Stg.EnforceEpt.

+  ppr TagBottoming      = text "TagBottoming"

+  ppr TagDunno          = text "TagDunno"

+  ppr TagEPT            = text "TagEPT"

+  ppr (TagTuple tis)    = text "TagTuple" <> brackets (pprWithCommas ppr tis)

+  put_ bh TagDunno        = putByte bh 1

+  put_ bh TagEPT          = putByte bh 3

+  put_ bh TagBottoming    = putByte bh 4

+                          3 -> return TagEPT

+                          4 -> return TagBottoming

+  ppr (TagVal ti) = char '<' <> text "TagVal" <> brackets (ppr ti) <> char '>'

+  ppr (TagFun ti) = char '<' <> text "TagFun" <> brackets (ppr ti) <> char '>'

+

+  put_ bh (TagVal ti) = putByte bh 1 >> put_ bh ti

+  put_ bh (TagFun ti) = putByte bh 2 >> put_ bh ti

+  get bh = do tag <- getByte bh

+              case tag of 1 -> TagVal <$> get bh

+                          2 -> TagFun <$> get bh

+                          _ -> panic ("get TagSig " ++ show tag)

+-- | Is the given binding known to be properly tagged (or irrelevant, as for

+-- unboxed values and bottoming computations)?

+isTaggedSig (TagFun _)  = True

+isTaggedSig (TagVal ti) = isTaggedInfo ti

+

+-- | Is the given value-level tag known to be properly tagged?

+-- NB: unboxed tuples are *not* treated as tagged here; they are handled

+-- specially by the rewriter (which considers them already evaluated).

+isTaggedInfo :: TagInfo -> Bool

+isTaggedInfo TagEPT       = True

+isTaggedInfo TagBottoming = True

+isTaggedInfo _            = False

+seqTagSig (TagVal ti) = seqTagInfo ti

+seqTagSig (TagFun ti) = seqTagInfo ti

+seqTagInfo TagBottoming   = ()

+seqTagInfo TagEPT         = ()

+seqTagInfo (TagTuple tis) = foldl' (\_unit info -> seqTagInfo info) () tis

+-- | Combine TagInfo from the alternatives of a case expression.

+-- Note that this operates at the value level: case alternatives return

+-- values. See Note [TagSig and TagInfo].

+combineAltInfo TagBottoming    ti              = ti

+combineAltInfo ti              TagBottoming    = ti

+combineAltInfo TagDunno        TagDunno        = TagDunno

+combineAltInfo TagDunno        TagEPT          = TagDunno

+combineAltInfo TagDunno        (TagTuple {})   = TagDunno

+combineAltInfo TagEPT          TagDunno        = TagDunno

+combineAltInfo (TagTuple {})   TagDunno        = TagDunno

+combineAltInfo TagEPT          TagEPT          = TagEPT

+-- TagEPT/TagTuple are incompatible (can arise with rep-polymorphic

+-- results, see #26107); fall through to TagDunno.

+combineAltInfo TagEPT          (TagTuple {})   = TagDunno

+combineAltInfo (TagTuple {})   TagEPT          = TagDunno

+  | isUnliftedType (idType var) = (var, TagVal TagEPT)

+  | otherwise = (var, TagVal TagDunno)

+-- | Look up the return-value tag of a function for saturated call analysis.

+-- Returns 'Just retInfo' if the function binding has a 'TagFun' signature,

+-- 'Nothing' otherwise.

+lookupReturnInfo :: TagEnv p -> Id -> Maybe TagInfo

+lookupReturnInfo env fun = case lookupVarEnv (te_env env) fun of

+  Just (TagFun ret_info) -> Just ret_info

+  Just (TagVal _)        -> Nothing

+  Nothing                -> Nothing

+

+-- | Look up a value-level tag for an argument: either from the env (where

+-- a function-typed argument flattens to TagEPT — its closure is tagged)

+-- or derived from information on the variable itself.

+  = TagEPT

+  = TagEPT

+  -- Variables in the environment. A function binding flattens to TagEPT

+  -- since a function closure pointer is properly tagged; its return info

+  -- is not relevant when the function is used as a value.

+  | Just sig <- lookupVarEnv (te_env env) var

+  = case sig of

+      TagVal info -> info

+      TagFun _    -> TagEPT

+              -> TagEPT

+              -> TagEPT

+              -> TagEPT

+  = TagEPT

+isDunnoSig (TagVal TagDunno) = True

+isDunnoSig _                 = False

+-- | Extend the tag environment.

+          GHC.Internal.Data.Either.Left e [Occ=Once1] -> wild<TagVal[TagEPT]>;

+  [HasNoCafRefs, TagSig: <TagFun[TagEPT]>,

+   LambdaFormInfo: LFReEntrant 1, Arity: 1, Strictness: <1!A>, CPR: 1,

+module Main (main) where

+import GHC.Exts.Heap (GenClosure(..), getClosureData)

+import T27005_aux (T(..), S(..), f)

+import System.Exit

+

+main :: IO ()

+main = do

+    let !t = MkT (MkS (pure ()) 0)

+    dup <- f t

+    c <- getClosureData dup

+    case c of

+      ThunkClosure{} -> putStrLn "FAIL" >> exitFailure

+      APClosure{}    -> putStrLn "FAIL" >> exitFailure

+      _              -> putStrLn "OK"