{-# LANGUAGE TypeFamilies, DataKinds, GADTs, FlexibleInstances #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-} -- To permit: type instance XLet 'InferTaggedBinders = XLet 'SomePass {-# OPTIONS_GHC -Wname-shadowing #-} module GHC.Stg.EnforceEpt ( enforceEpt ) where import GHC.Prelude hiding (id) import GHC.Core.DataCon import GHC.Core.Type import GHC.Types.Id import GHC.Types.Id.Info (tagSigInfo) import GHC.Types.Name import GHC.Stg.Syntax import GHC.Types.Basic ( CbvMark (..) ) import GHC.Types.Demand (isDeadEndAppSig) import GHC.Types.Unique.Supply (mkSplitUniqSupply) import GHC.Types.RepType (dataConRuntimeRepStrictness) import GHC.Core (AltCon(..)) import Data.List (mapAccumL) import GHC.Utils.Outputable import GHC.Utils.Misc( zipWithEqual, zipEqual, notNull ) import GHC.Stg.EnforceEpt.Types import GHC.Stg.EnforceEpt.Rewrite (rewriteTopBinds) import Data.Maybe import GHC.Types.Name.Env (mkNameEnv, NameEnv) import GHC.Driver.DynFlags import GHC.Utils.Logger import qualified GHC.Unit.Types {- Note [Evaluated and Properly Tagged] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ A pointer is Evaluated and Properly Tagged (EPT) when the pointer (a) points directly to the value (not to an indirection, and not to a thunk) (b) is tagged with the tag corresponding to said value (e.g. constructor tag or arity of a function). A binder is EPT when all the runtime pointers it binds are EPT. Note that a lifted EPT pointer will never point to a thunk, nor will it be tagged `000` (meaning "might be a thunk"). See https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/rts/haskell-execution/pointer-tagging for more information on pointer tagging. Examples: * Case binders are always EPT; hence an eval case x of x' { __DEFAULT -> ... } ensures that x' is EPT even if x was not. * Data constructor bindings let x = Just y in ... are EPT: x will point to the heap-allocated constructor closure for (Just y), and the tag-bits of the pointer will encode the tag for Just (i.e. `010`). * In practice, GHC also guarantees that strict fields (and others) are EPT; see Note [EPT enforcement]. Caveat: Currently, 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. Note [EPT enforcement] ~~~~~~~~~~~~~~~~~~~~~~ The goal of EnforceEPT pass is to mark as many binders as possible as EPT (see Note [Evaluated and Properly Tagged]). To find more EPT binders, it establishes the following EPT INVARIANT: > Any binder of > * a strict field (see Note [Strict fields in Core]), or > * a CBV argument (see Note [CBV Function Ids]) > is EPT. (Note that prior to EPT enforcement, this invariant may *not* always be upheld. An example can be found at the end of this Note.) This is all to optimise code such as the following: data SPair a b = SP !a !b case p :: SP Bool Bool of SP x y -> case x of True -> ... False -> ... We can infer that the strict field x is EPT and hence may safely omit the code to enter x and the check for the presence of a tag that goes along with it. However we still branch on the tag as usual to jump to the True or False case. Note that for every example involving strict fields we could find a similar example using CBV functions, e.g. $wf x[EPT] y = case x of True -> ... False -> ... is the above example translated to use a CBV function $wf. Note that /any/ strict function can in principle be chosen as a CBV function; however, we presently only promote worker functions such as $wf to CBV because we see all its call sites and can use the proper by-value calling convention. More precisely, with -O0, we guarantee that no CBV functions are visible in the interface file, so that naïve clients do not need to know how to call CBV functions. See Note [CBV Function Ids] for more details. Specification ------------- EPT enforcement works like implicit type conversions in C, such as from int to float, only much simpler (no overloaded operations such as +). For EPT enforcement, the "type system" in question is whether a binder is statically EPT. We differentiate "EPT binder" from "non-EPT binder", where the latter means "might be EPT, but we could not prove it so". In this sense, EPT binders form a subtype of non-EPT binders. We differentiate two conversion directions: * Downcast: EPT binders can be converted into non-EPT binders for free. * Upcast: non-EPT binders can be converted into EPT binders by inserting an eval. The EPT invariant expresses type signatures. In particular, these type signatures entail two things: * A _precondition_: Any binder that is passed as a CBV arg/strict field must be EPT (i.e. must have type "EPT binder"). * A _postcondition_: Any binder of a CBV arg/strict field is EPT. EPT enforcement is then simply a matter of figuring out where to insert Upcasts (remember that Downcasts are free). Since Upcasts (evals!) are not free, it is desirable to insert as few as possible. To this end, we run a static *EPT analysis*, the purpose of which is to identify as many EPT binders as possible. Beyond discovering case binders and value bindings, EPT analysis exploits the type signatures provided by the EPT invariant, looks inside returned tuples and does some limited amount of fixpointing. Afterwards, the *EPT rewriter* inserts the actual evals realising Upcasts. Implementation -------------- * EPT analysis is implemented in GHC.Stg.EnforceEpt.inferTags. It attaches its result to /binders/, not occurrence sites. * The EPT rewriter establishes the EPT invariant by inserting evals. That is, if (a) a binder x is used to * construct a strict field (`SP x y`), or * passed as a CBV argument (`$wf x`), and (b) x was not inferred EPT, then the EPT rewriter inserts an eval prior to the call, e.g. case x of x' { __ DEFAULT -> SP x' y }. case x of x' { __ DEFAULT -> $wf x' }. (Recall that the case binder x' is always EPT.) This is implemented in GHC.Stg.EnforceEpt.Rewrite.rewriteTopBinds. This pass also propagates the EPTness from binders to occurrences. It is sound to insert evals on strict fields (Note [Strict fields in Core]), and on CBV arguments as well (Note [CBV Function Ids]). * We also export the EPTness of top level bindings to allow this optimisation to work across module boundaries. NB: The EPT Invariant *must* be upheld, regardless of the optimisation level; hence EPTness is practically part of the internal ABI of a strict data constructor or CBV function. Note [CBV Function Ids] contains the details. * Finally, code generation skips the thunk check when branching on binders that are EPT. This is done by `cgExpr`/`cgCase` in the backend. Evaluation ---------- EPT enforcement can have large impact on spine-strict tree data structure performance. For containers the reduction in runtimes with this optimization was as follows: intmap-benchmarks: 89.30% intset-benchmarks: 90.87% map-benchmarks: 88.00% sequence-benchmarks: 99.84% set-benchmarks: 85.00% set-operations-intmap:88.64% set-operations-map: 74.23% set-operations-set: 76.50% lookupge-intmap: 89.57% lookupge-map: 70.95% With nofib being ~0.3% faster as well. Note that EPT enforcement may cause regressions in rare cases. For example consider this code: foo x = ... let c = StrictJust x in ... When x cannot be inferred EPT, the rewriter transforms to foo x = ... let c = case x of x' -> StrictJust x' in ... which allocates an additional thunk for `c` that returns the constructor. Boo! Note [EPT enforcement lowers strict constructor worker semantics] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In Core, a saturated application of a strict constructor worker evaluates its strict fields and thus is *not* a value; see Note [Strict fields in Core]. This is also the semantics of strict constructor workers in STG *before* EPT enforcement (see Note [EPT enforcement]) However, after enforcing the EPT Invariant, all constructor workers can effectively be lazy. That is, when actually generating code to allocate the data constructor, the code generator does not need to evaluate the argument; that has already been done by the EPT pass. Thus for code-gen reasons (StgToX), all constructor workers are considered lazy after EPT enforcement. Note [Why isn't the EPT Invariant enforced during Core passes?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Recall the definition of the EPT Invariant from Note [EPT enforcement]. Why can't it be established as an invariant right while desugaring to Core? The reason is that some Core optimisations, such as FloatOut, will drop or delay evals whenever they think it useful and thus destroy the Invariant. Example: data Set a = Tip | Bin !a (Set a) (Set a) We start with thk = f () g x = ...(case thk of xv -> Bin xv Tip Tip)... So far so good; the argument to Bin (which is strict) is evaluated. Now we do float-out. And in doing so we do a reverse binder-swap (see Note [Binder-swap during float-out] in SetLevels) thus g x = ...(case thk of xv -> Bin thk Nil Nil)... The goal of the reverse binder-swap is to allow more floating -- and indeed it does! We float the Bin to top level: lvl = Bin thk Tip Tip g x = ...(case thk of xv -> lvl)... Now you can see that the argument of Bin, namely thk, points to the thunk, not to the value as it did before. In short, although it may be rare, the output of Core optimisation passes might destroy the EPT Invariant, hence we need to enforce the EPT invariant *after* passes such as FloatOut. -} {- Note [TagInfo of functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The purpose of tag inference is really to figure out when we don't have to enter value closures. There the meaning of the tag is fairly obvious. For functions we never make use of the tag info so we have two choices: * Treat them as TagDunno * Treat them as TagProper (as they *are* tagged with their arity) and be really careful to make sure we still enter them when needed. As it makes little difference for runtime performance I've treated functions as TagDunno in a few places where it made the code simpler. But besides implementation complexity there isn't any reason why we couldn't be more rigorous in dealing with functions. NB: It turned in #21193 that PAPs get tag zero, so the tag check can't be omitted for functions. So option two isn't really an option without reworking this anyway. Note [EPT enforcement debugging] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ There is a flag -dtag-inference-checks which inserts various compile/runtime checks in order to ensure the EPT Invariant holds. It should cover all places where tags matter and disable optimizations which interfere with checking the invariant like generation of AP-Thunks. Note [Polymorphic StgPass for inferTagExpr] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In order to reach a fixpoint we sometimes have to re-analyse an expression multiple times. But after the initial run the Ast will be parameterized by a different StgPass! To handle this a large part of the analysis is polymorphic over the exact StgPass we are using. Which allows us to run the analysis on the output of itself. Note [EPT enforcement for interpreted code] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The bytecode interpreter has a different behaviour when it comes to the tagging of binders in certain situations than the StgToCmm code generator. a) Tags for let-bindings: When compiling a binding for a constructor like `let x = Just True` Whether `x` will be properly tagged depends on the backend. For the interpreter x points to a BCO which once evaluated returns a properly tagged pointer to the heap object. In the Cmm backend for the same binding we would allocate the constructor right away and x will immediately be represented by a tagged pointer. This means for interpreted code we can not assume let bound constructors are properly tagged. Hence we distinguish between targeting bytecode and native in the analysis. We make this differentiation in `mkLetSig` where we simply never assume lets are tagged when targeting bytecode. b) When referencing ids from other modules the Cmm backend will try to put a proper tag on these references through various means. When doing analysis we usually predict these cases to improve precision of the analysis. But to my knowledge the bytecode generator makes no such attempts so we must not infer imported bindings as tagged. This is handled in GHC.Stg.EnforceEpt.Types.lookupInfo -} {- ********************************************************************* * * EPT enforcement pass * * ********************************************************************* -} enforceEpt :: StgPprOpts -> Bool -> Logger -> (GHC.Unit.Types.Module) -> [CgStgTopBinding] -> IO ([TgStgTopBinding], NameEnv TagSig) enforceEpt ppr_opts !for_bytecode logger this_mod stg_binds = do -- pprTraceM "enforceEpt for " (ppr this_mod <> text " bytecode:" <> ppr for_bytecode) -- Annotate binders with tag information. let (!stg_binds_w_tags) = {-# SCC "StgEptInfer" #-} inferTags for_bytecode stg_binds putDumpFileMaybe logger Opt_D_dump_stg_tags "CodeGenAnal STG:" FormatSTG (pprGenStgTopBindings ppr_opts stg_binds_w_tags) let export_tag_info = collectExportInfo stg_binds_w_tags -- Rewrite STG to uphold the strict field invariant us_t <- mkSplitUniqSupply 't' let rewritten_binds = {-# SCC "StgEptRewrite" #-} rewriteTopBinds this_mod us_t stg_binds_w_tags :: [TgStgTopBinding] return (rewritten_binds,export_tag_info) {- ********************************************************************* * * Main inference algorithm * * ********************************************************************* -} type OutputableInferPass p = (Outputable (TagEnv p) , Outputable (GenStgExpr p) , Outputable (BinderP p) , Outputable (GenStgRhs p)) -- | This constraint encodes the fact that no matter what pass -- we use the Let/Closure extension points are the same as these for -- 'InferTaggedBinders. type InferExtEq i = ( XLet i ~ XLet 'InferTaggedBinders , XLetNoEscape i ~ XLetNoEscape 'InferTaggedBinders , XRhsClosure i ~ XRhsClosure 'InferTaggedBinders) inferTags :: Bool -> [GenStgTopBinding 'CodeGen] -> [GenStgTopBinding 'InferTaggedBinders] inferTags for_bytecode binds = -- pprTrace "Binds" (pprGenStgTopBindings shortStgPprOpts $ binds) $ snd (mapAccumL inferTagTopBind (initEnv for_bytecode) binds) ----------------------- inferTagTopBind :: TagEnv 'CodeGen -> GenStgTopBinding 'CodeGen -> (TagEnv 'CodeGen, GenStgTopBinding 'InferTaggedBinders) inferTagTopBind env (StgTopStringLit id bs) = (env, StgTopStringLit id bs) inferTagTopBind env (StgTopLifted bind) = (env', StgTopLifted bind') where (env', bind') = inferTagBind env bind -- Why is this polymorphic over the StgPass? See Note [Polymorphic StgPass for inferTagExpr] ----------------------- inferTagExpr :: forall p. (OutputableInferPass p, InferExtEq p) => TagEnv p -> GenStgExpr p -> (TagInfo, GenStgExpr 'InferTaggedBinders) inferTagExpr env (StgApp fun args) = --pprTrace "inferTagExpr1" -- (ppr fun <+> ppr args $$ ppr info $$ -- text "deadEndInfo:" <> ppr (isDeadEndId fun, idArity fun, length args) -- ) (info, StgApp fun args) where !fun_arity = idArity fun info -- It's important that we check for bottoms before all else. -- See Note [Bottom functions are TagTagged] and #24806 for why. | isDeadEndAppSig (idDmdSig fun) (length args) = TagTagged | fun_arity == 0 -- Unknown arity => Thunk or unknown call = TagDunno | Just (TagSig res_info) <- tagSigInfo (idInfo fun) , fun_arity == length args -- Saturated = res_info | Just (TagSig res_info) <- lookupSig env fun , fun_arity == length args -- Saturated = res_info | otherwise = --pprTrace "inferAppUnknown" (ppr fun) $ TagDunno inferTagExpr env (StgConApp con cn args tys) = (inferConTag env con args, StgConApp con cn args tys) inferTagExpr _ (StgLit l) = (TagTagged, StgLit l) inferTagExpr env (StgTick tick body) = (info, StgTick tick body') where (info, body') = inferTagExpr env body inferTagExpr _ (StgOpApp op args ty) -- Which primops guarantee to return a properly tagged value? -- Probably none, and that is the conservative assumption anyway. -- (And foreign calls definitely need not make promises.) = (TagDunno, StgOpApp op args ty) inferTagExpr env (StgLet ext bind body) = (info, StgLet ext bind' body') where (env', bind') = inferTagBind env bind (info, body') = inferTagExpr env' body inferTagExpr env (StgLetNoEscape ext bind body) = (info, StgLetNoEscape ext bind' body') where (env', bind') = inferTagBind env bind (info, body') = inferTagExpr env' body inferTagExpr in_env (StgCase scrut bndr ty alts) -- Unboxed tuples get their info from the expression we scrutinise if any | [GenStgAlt{alt_con=DataAlt con, alt_bndrs=bndrs, alt_rhs=rhs}] <- alts , isUnboxedTupleDataCon con , Just infos <- scrut_infos bndrs , let bndrs' = zipWithEqual mk_bndr bndrs infos mk_bndr :: BinderP p -> TagInfo -> (Id, TagSig) mk_bndr tup_bndr tup_info = -- pprTrace "mk_ubx_bndr_info" ( ppr bndr <+> ppr info ) $ (getBinderId in_env tup_bndr, TagSig tup_info) -- no case binder in alt_env here, unboxed tuple binders are dead after unarise alt_env = extendSigEnv in_env bndrs' (info, rhs') = inferTagExpr alt_env rhs = -- pprTrace "inferCase1" ( -- text "scrut:" <> ppr scrut $$ -- text "bndr:" <> ppr bndr $$ -- text "infos" <> ppr infos $$ -- text "out_bndrs" <> ppr bndrs') $ (info, StgCase scrut' (noSig in_env bndr) ty [GenStgAlt{ alt_con=DataAlt con , alt_bndrs=bndrs' , alt_rhs=rhs'}]) | null alts -- Empty case, but I might just be paranoid. = -- pprTrace "inferCase2" empty $ (TagDunno, StgCase scrut' bndr' ty []) -- More than one alternative OR non-TagTuple single alternative. | otherwise = let case_env = extendSigEnv in_env [bndr'] (infos, alts') = unzip [ (info, g {alt_bndrs=bndrs', alt_rhs=rhs'}) | g@GenStgAlt{ alt_con = con , alt_bndrs = bndrs , alt_rhs = rhs } <- alts , let (alt_env,bndrs') = addAltBndrInfo case_env con bndrs (info, rhs') = inferTagExpr alt_env rhs ] alt_info = foldr combineAltInfo TagTagged infos in ( alt_info, StgCase scrut' bndr' ty alts') where -- Single unboxed tuple alternative scrut_infos bndrs = case scrut_info of TagTagged -> Just $ replicate (length bndrs) TagProper TagTuple infos -> Just infos _ -> Nothing (scrut_info, scrut') = inferTagExpr in_env scrut bndr' = (getBinderId in_env bndr, TagSig TagProper) -- Compute binder sigs based on the constructors strict fields. -- NB: Not used if we have tuple info from the scrutinee. addAltBndrInfo :: forall p. TagEnv p -> AltCon -> [BinderP p] -> (TagEnv p, [BinderP 'InferTaggedBinders]) addAltBndrInfo env (DataAlt con) bndrs | not (isUnboxedTupleDataCon con || isUnboxedSumDataCon con) = (out_env, out_bndrs) where marks = dataConRuntimeRepStrictness con :: [StrictnessMark] out_bndrs = zipWith mk_bndr bndrs marks out_env = extendSigEnv env out_bndrs mk_bndr :: (BinderP p -> StrictnessMark -> (Id, TagSig)) mk_bndr bndr mark | isUnliftedType (idType id) || isMarkedStrict mark = (id, TagSig TagProper) | otherwise = noSig env bndr where id = getBinderId env bndr addAltBndrInfo env _ bndrs = (env, map (noSig env) bndrs) ----------------------------- inferTagBind :: (OutputableInferPass p, InferExtEq p) => TagEnv p -> GenStgBinding p -> (TagEnv p, GenStgBinding 'InferTaggedBinders) inferTagBind in_env (StgNonRec bndr rhs) = -- pprTrace "inferBindNonRec" ( -- ppr bndr $$ -- ppr (isDeadEndId id) $$ -- ppr sig) (env', StgNonRec (id, out_sig) rhs') where id = getBinderId in_env bndr (in_sig,rhs') = inferTagRhs id in_env rhs out_sig = mkLetSig in_env in_sig env' = extendSigEnv in_env [(id, out_sig)] inferTagBind in_env (StgRec pairs) = -- pprTrace "rec" (ppr (map fst pairs) $$ ppr (in_env { te_env = out_env }, StgRec pairs')) $ (in_env { te_env = out_env }, StgRec pairs') where (bndrs, rhss) = unzip pairs in_ids = map (getBinderId in_env) bndrs init_sigs = map (initSig) $ zip in_ids rhss (out_env, pairs') = go in_env init_sigs rhss go :: forall q. (OutputableInferPass q , InferExtEq q) => TagEnv q -> [TagSig] -> [GenStgRhs q] -> (TagSigEnv, [((Id,TagSig), GenStgRhs 'InferTaggedBinders)]) go go_env in_sigs go_rhss -- | pprTrace "go" (ppr in_ids $$ ppr in_sigs $$ ppr out_sigs $$ ppr rhss') False -- = undefined | in_sigs == out_sigs = (te_env rhs_env, out_bndrs `zip` rhss') | otherwise = go env' out_sigs rhss' where in_bndrs = in_ids `zip` in_sigs out_bndrs = map updateBndr in_bndrs -- TODO: Keeps in_ids alive rhs_env = extendSigEnv go_env in_bndrs (out_sigs, rhss') = unzip (zipWithEqual anaRhs in_ids go_rhss) env' = makeTagged go_env anaRhs :: Id -> GenStgRhs q -> (TagSig, GenStgRhs 'InferTaggedBinders) anaRhs bnd rhs = let (sig_rhs,rhs') = inferTagRhs bnd rhs_env rhs in (mkLetSig go_env sig_rhs, rhs') updateBndr :: (Id,TagSig) -> (Id,TagSig) updateBndr (v,sig) = (setIdTagSig v sig, sig) initSig :: forall p. (Id, GenStgRhs p) -> TagSig -- Initial signature for the fixpoint loop initSig (_bndr, StgRhsCon {}) = TagSig TagTagged initSig (bndr, StgRhsClosure _ _ _ _ _ _) = fromMaybe defaultSig (idTagSig_maybe bndr) where defaultSig = (TagSig TagTagged) {- Note [Bottom functions are TagTagged] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have a function with two branches with one being bottom, and the other returning a tagged unboxed tuple what is the result? We give it TagTagged! To answer why consider this function: foo :: Bool -> (# Bool, Bool #) foo x = case x of True -> (# True,True #) False -> undefined The true branch is obviously tagged. The other branch isn't. We want to treat the *result* of foo as tagged as well so that the combination of the branches also is tagged if all non-bottom branches are tagged. This is safe because the function is still always called/entered as long as it's applied to arguments. Since the function will never return we can give it safely any tag sig we like. So we give it TagTagged, as it allows the combined tag sig of the case expression to be the combination of all non-bottoming branches. NB: After the analysis is done we go back to treating bottoming functions as untagged to ensure they are evaluated as expected in code like: case bottom_id of { ...} -} ----------------------------- inferTagRhs :: forall p. (OutputableInferPass p, InferExtEq p) => Id -- ^ Id we are binding to. -> TagEnv p -- ^ -> GenStgRhs p -- ^ -> (TagSig, GenStgRhs 'InferTaggedBinders) inferTagRhs bnd_id in_env (StgRhsClosure ext cc upd bndrs body typ) | isDeadEndId bnd_id && (notNull) bndrs -- See Note [Bottom functions are TagTagged] = (TagSig TagTagged, StgRhsClosure ext cc upd out_bndrs body' typ) | otherwise = --pprTrace "inferTagRhsClosure" (ppr (_top, _grp_ids, env,info')) $ (TagSig info', StgRhsClosure ext cc upd out_bndrs body' typ) where out_bndrs | Just marks <- idCbvMarks_maybe bnd_id -- Sometimes an we eta-expand foo with additional arguments after ww, and we also trim -- the list of marks to the last strict entry. So we can conservatively -- assume these are not strict = zipWith (mkArgSig) bndrs (marks ++ repeat NotMarkedCbv) | otherwise = map (noSig env') bndrs :: [(Id,TagSig)] env' = extendSigEnv in_env out_bndrs (info, body') = inferTagExpr env' body info' -- It's a thunk | null bndrs = TagDunno -- TODO: We could preserve tuple fields for thunks -- as well. But likely not worth the complexity. | otherwise = info mkArgSig :: BinderP p -> CbvMark -> (Id,TagSig) mkArgSig bndp mark = let id = getBinderId in_env bndp tag = case mark of MarkedCbv -> TagProper _ | isUnliftedType (idType id) -> TagProper | otherwise -> TagDunno in (id, TagSig tag) inferTagRhs _ env _rhs@(StgRhsCon cc con cn ticks args typ) -- Constructors, which have untagged arguments to strict fields -- become thunks. We encode this by giving changing RhsCon nodes the info TagDunno = --pprTrace "inferTagRhsCon" (ppr grp_ids) $ (TagSig (inferConTag env con args), StgRhsCon cc con cn ticks args typ) -- Adjust let semantics to the targeted backend. -- See Note [EPT enforcement for interpreted code] mkLetSig :: TagEnv p -> TagSig -> TagSig mkLetSig env in_sig | for_bytecode = TagSig TagDunno | otherwise = in_sig where for_bytecode = te_bytecode env {- Note [Constructor TagSigs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @inferConTag@ will infer the proper tag signature for a binding who's RHS is a constructor or a StgConApp expression. Usually these will simply be TagProper. But there are exceptions. If any of the fields in the constructor are strict, but any argument to these fields is not tagged then we will have to case on the argument before storing in the constructor. Which means for let bindings the RHS turns into a thunk which obviously is no longer properly tagged. For example we might start with: let x = f ... let c = StrictPair x True But we know during the rewrite stage x will need to be evaluated in the RHS of `c` so we will infer: let x = f ... let c = StrictPair x True Which in the rewrite stage will then be rewritten into: let x = f ... let c = case x of x' -> StrictPair x' True The other exception is unboxed tuples. These will get a TagTuple signature with a list of TagInfo about their individual binders as argument. As example: let c = True let x = ... let f z = case z of z' -> (# c, x #) Here we will infer for f the Signature . This information will be used if we scrutinize a saturated application of `f` in order to determine the taggedness of the result. That is for `case f x of (# r1,r2 #) -> rhs` we can infer r1 and r2 which allows us to skip all tag checks on `r1` in `rhs`. Things get a bit more complicated with nesting: let closeFd = ... let f x = ... case x of _ -> Solo# closeFd The "natural" signature for the Solo# branch in `f` would be . But we flatten this out to for the time being as it improves compile time and there doesn't seem to huge benefit to doing differently. -} -- See Note [Constructor TagSigs] inferConTag :: TagEnv p -> DataCon -> [StgArg] -> TagInfo inferConTag env con args | isUnboxedTupleDataCon con = TagTuple $ map (flatten_arg_tag . lookupInfo env) args | otherwise = -- pprTrace "inferConTag" -- ( text "con:" <> ppr con $$ -- text "args:" <> ppr args $$ -- text "marks:" <> ppr (dataConRuntimeRepStrictness con) $$ -- text "arg_info:" <> ppr (map (lookupInfo env) args) $$ -- text "info:" <> ppr info) $ info where info = if any arg_needs_eval strictArgs then TagDunno else TagProper strictArgs = zipEqual args (dataConRuntimeRepStrictness con) :: ([(StgArg, StrictnessMark)]) arg_needs_eval (arg,strict) -- lazy args | not (isMarkedStrict strict) = False | tag <- (lookupInfo env arg) -- banged args need to be tagged, or require eval = not (isTaggedInfo tag) flatten_arg_tag (TagTagged) = TagProper flatten_arg_tag (TagProper ) = TagProper flatten_arg_tag (TagTuple _) = TagDunno -- See Note [Constructor TagSigs] flatten_arg_tag (TagDunno) = TagDunno collectExportInfo :: [GenStgTopBinding 'InferTaggedBinders] -> NameEnv TagSig collectExportInfo binds = mkNameEnv bndr_info where bndr_info = concatMap collect binds :: [(Name,TagSig)] collect (StgTopStringLit {}) = [] collect (StgTopLifted bnd) = case bnd of StgNonRec (id,sig) _rhs | TagSig TagDunno <- sig -> [] | otherwise -> [(idName id,sig)] StgRec bnds -> collectRec bnds collectRec :: [(BinderP 'InferTaggedBinders, rhs)] -> [(Name,TagSig)] collectRec [] = [] collectRec (bnd:bnds) | (p,_rhs) <- bnd , (id,sig) <- p , TagSig TagDunno <- sig = (idName id,sig) : collectRec bnds | otherwise = collectRec bnds