Commit 4cdbf802 authored by Peter Wortmann's avatar Peter Wortmann Committed by Austin Seipp

Source notes (CorePrep and Stg support)

This is basically just about continuing maintaining source notes after
the Core stage. Unfortunately, this is more involved as it might seem,
as there are more restrictions on where ticks are allowed to show up.

Notes:

* We replace the StgTick / StgSCC constructors with a unified StgTick
  that can carry any tickish.

* For handling constructor or lambda applications, we generally float
  ticks out.

* Note that thanks to the NonLam placement, we know that source notes
  can never appear on lambdas. This means that as long as we are
  careful to always use mkTick, we will never violate CorePrep
  invariants.

* This is however not automatically true for eta expansion, which
  needs to somewhat awkwardly strip, then re-tick the expression in
  question.

* Where CorePrep floats out lets, we make sure to wrap them in the
  same spirit as FloatOut.

* Detecting selector thunks becomes a bit more involved, as we can run
  into ticks at multiple points.

(From Phabricator D169)
parent 07d604fa
......@@ -31,7 +31,7 @@ import StgCmmClosure
import StgCmmForeign (emitPrimCall)
import MkGraph
import CoreSyn ( AltCon(..) )
import CoreSyn ( AltCon(..), tickishIsCode )
import SMRep
import Cmm
import CmmInfo
......@@ -50,7 +50,6 @@ import Outputable
import FastString
import DynFlags
import Data.Maybe
import Control.Monad
#if __GLASGOW_HASKELL__ >= 709
......@@ -268,14 +267,22 @@ mkRhsClosure dflags bndr _cc _bi
[NonVoid the_fv] -- Just one free var
upd_flag -- Updatable thunk
[] -- A thunk
(StgCase (StgApp scrutinee [{-no args-}])
_ _ _ _ -- ignore uniq, etc.
(AlgAlt _)
[(DataAlt _, params, _use_mask,
(StgApp selectee [{-no args-}]))])
| the_fv == scrutinee -- Scrutinee is the only free variable
&& isJust maybe_offset -- Selectee is a component of the tuple
&& offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough
expr
| let strip = snd . stripStgTicksTop (not . tickishIsCode)
, StgCase (StgApp scrutinee [{-no args-}])
_ _ _ _ -- ignore uniq, etc.
(AlgAlt _)
[(DataAlt _, params, _use_mask, sel_expr)] <- strip expr
, StgApp selectee [{-no args-}] <- strip sel_expr
, the_fv == scrutinee -- Scrutinee is the only free variable
, let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps params)
-- Just want the layout
, Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee)
, let offset_into_int = bytesToWordsRoundUp dflags the_offset
- fixedHdrSizeW dflags
, offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough
= -- NOT TRUE: ASSERT(is_single_constructor)
-- The simplifier may have statically determined that the single alternative
-- is the only possible case and eliminated the others, even if there are
......@@ -284,16 +291,8 @@ mkRhsClosure dflags bndr _cc _bi
-- will evaluate to.
--
-- srt is discarded; it must be empty
cgRhsStdThunk bndr lf_info [StgVarArg the_fv]
where
lf_info = mkSelectorLFInfo bndr offset_into_int
(isUpdatable upd_flag)
(_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps params)
-- Just want the layout
maybe_offset = assocMaybe params_w_offsets (NonVoid selectee)
Just the_offset = maybe_offset
offset_into_int = bytesToWordsRoundUp dflags the_offset
- fixedHdrSizeW dflags
let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]
---------- Note [Ap thunks] ------------------
mkRhsClosure dflags bndr _cc _bi
......
......@@ -66,10 +66,7 @@ cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =
cgExpr (StgOpApp op args ty) = cgOpApp op args ty
cgExpr (StgConApp con args) = cgConApp con args
cgExpr (StgSCC cc tick push expr) = do { emitSetCCC cc tick push; cgExpr expr }
cgExpr (StgTick m n expr) = do dflags <- getDynFlags
emit (mkTickBox dflags m n)
cgExpr expr
cgExpr (StgTick t e) = cgTick t >> cgExpr e
cgExpr (StgLit lit) = do cmm_lit <- cgLit lit
emitReturn [CmmLit cmm_lit]
......@@ -852,3 +849,19 @@ emitEnter fun = do
; return (ReturnedTo lret off)
}
}
------------------------------------------------------------------------
-- Ticks
------------------------------------------------------------------------
-- | Generate Cmm code for a tick. Depending on the type of Tickish,
-- this will either generate actual Cmm instrumentation code, or
-- simply pass on the annotation as a @CmmTickish@.
cgTick :: Tickish Id -> FCode ()
cgTick tick
= do { dflags <- getDynFlags
; case tick of
ProfNote cc t p -> emitSetCCC cc t p
HpcTick m n -> emit (mkTickBox dflags m n)
_other -> return () -- ignore
}
......@@ -116,6 +116,10 @@ The goal of this pass is to prepare for code generation.
special case where we use the S# constructor for Integers that
are in the range of Int.
11. Uphold tick consistency while doing this: We move ticks out of
(non-type) applications where we can, and make sure that we
annotate according to scoping rules when floating.
This is all done modulo type applications and abstractions, so that
when type erasure is done for conversion to STG, we don't end up with
any trivial or useless bindings.
......@@ -404,7 +408,7 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
; (floats2, rhs2) <- float_from_rhs floats1 rhs1
-- Make the arity match up
; (floats3, rhs')
; (floats3, rhs3)
<- if manifestArity rhs1 <= arity
then return (floats2, cpeEtaExpand arity rhs2)
else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
......@@ -414,15 +418,18 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
; return ( addFloat floats2 float
, cpeEtaExpand arity (Var v)) })
-- Wrap floating ticks
; let (floats4, rhs4) = wrapTicks floats3 rhs3
-- Record if the binder is evaluated
-- and otherwise trim off the unfolding altogether
-- It's not used by the code generator; getting rid of it reduces
-- heap usage and, since we may be changing uniques, we'd have
-- to substitute to keep it right
; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
; let bndr' | exprIsHNF rhs3 = bndr `setIdUnfolding` evaldUnfolding
| otherwise = bndr `setIdUnfolding` noUnfolding
; return (floats3, bndr', rhs') }
; return (floats4, bndr', rhs4) }
where
is_strict_or_unlifted = (isStrictDmd dmd) || is_unlifted
......@@ -512,11 +519,13 @@ cpeRhsE env (Let bind expr)
; return (new_binds `appendFloats` floats, body) }
cpeRhsE env (Tick tickish expr)
| ignoreTickish tickish
= cpeRhsE env expr
| otherwise -- Just SCCs actually
| tickishPlace tickish == PlaceNonLam && tickish `tickishScopesLike` SoftScope
= do { (floats, body) <- cpeRhsE env expr
-- See [Floating Ticks in CorePrep]
; return (unitFloat (FloatTick tickish) `appendFloats` floats, body) }
| otherwise
= do { body <- cpeBodyNF env expr
; return (emptyFloats, Tick tickish' body) }
; return (emptyFloats, mkTick tickish' body) }
where
tickish' | Breakpoint n fvs <- tickish
= Breakpoint n (map (lookupCorePrepEnv env) fvs)
......@@ -596,7 +605,7 @@ rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
rhsToBody (Tick t expr)
| tickishScoped t == NoScope -- only float out of non-scoped annotations
= do { (floats, expr') <- rhsToBody expr
; return (floats, Tick t expr') }
; return (floats, mkTick t expr') }
rhsToBody (Cast e co)
-- You can get things like
......@@ -696,8 +705,11 @@ cpeApp env expr
; return (Cast fun' co, hd, ty2, floats, ss) }
collect_args (Tick tickish fun) depth
| ignoreTickish tickish -- Drop these notes altogether
= collect_args fun depth -- They aren't used by the code generator
| tickishPlace tickish == PlaceNonLam
&& tickish `tickishScopesLike` SoftScope
= do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
-- See [Floating Ticks in CorePrep]
; return (fun',hd,fun_ty,addFloat floats (FloatTick tickish),ss) }
-- N-variable fun, better let-bind it
collect_args fun depth
......@@ -818,10 +830,6 @@ of the scope of a `seq`, or dropped the `seq` altogether.
************************************************************************
-}
-- we don't ignore any Tickishes at the moment.
ignoreTickish :: Tickish Id -> Bool
ignoreTickish _ = False
cpe_ExprIsTrivial :: CoreExpr -> Bool
-- Version that doesn't consider an scc annotation to be trivial.
cpe_ExprIsTrivial (Var _) = True
......@@ -925,6 +933,9 @@ tryEtaReducePrep bndrs (Let bind@(NonRec _ r) body)
where
fvs = exprFreeVars r
tryEtaReducePrep bndrs (Tick tickish e)
= fmap (mkTick tickish) $ tryEtaReducePrep bndrs e
tryEtaReducePrep _ _ = Nothing
{-
......@@ -948,11 +959,15 @@ data FloatingBind
Id CpeBody
Bool -- The bool indicates "ok-for-speculation"
-- | See Note [Floating Ticks in CorePrep]
| FloatTick (Tickish Id)
data Floats = Floats OkToSpec (OrdList FloatingBind)
instance Outputable FloatingBind where
ppr (FloatLet b) = ppr b
ppr (FloatCase b r ok) = brackets (ppr ok) <+> ppr b <+> equals <+> ppr r
ppr (FloatTick t) = ppr t
instance Outputable Floats where
ppr (Floats flag fs) = ptext (sLit "Floats") <> brackets (ppr flag) <+>
......@@ -998,6 +1013,7 @@ wrapBinds (Floats _ binds) body
where
mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]
mk_bind (FloatLet bind) body = Let bind body
mk_bind (FloatTick tickish) body = mkTick tickish body
addFloat :: Floats -> FloatingBind -> Floats
addFloat (Floats ok_to_spec floats) new_float
......@@ -1007,6 +1023,7 @@ addFloat (Floats ok_to_spec floats) new_float
check (FloatCase _ _ ok_for_spec)
| ok_for_spec = IfUnboxedOk
| otherwise = NotOkToSpec
check FloatTick{} = OkToSpec
-- The ok-for-speculation flag says that it's safe to
-- float this Case out of a let, and thereby do it more eagerly
-- We need the top-level flag because it's never ok to float
......@@ -1075,6 +1092,9 @@ canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs
rs' = map (subst_expr subst') rs
new_fb = FloatLet (Rec (bs' `zip` rs'))
go (subst, fbs_out) (ft@FloatTick{} : fbs_in)
= go (subst, fbs_out `snocOL` ft) fbs_in
go _ _ = Nothing -- Encountered a caffy binding
------------
......@@ -1222,3 +1242,50 @@ newVar ty
= seqType ty `seq` do
uniq <- getUniqueM
return (mkSysLocal (fsLit "sat") uniq ty)
------------------------------------------------------------------------------
-- Floating ticks
-- ---------------------------------------------------------------------------
--
-- Note [Floating Ticks in CorePrep]
--
-- It might seem counter-intuitive to float ticks by default, given
-- that we don't actually want to move them if we can help it. On the
-- other hand, nothing gets very far in CorePrep anyway, and we want
-- to preserve the order of let bindings and tick annotations in
-- relation to each other. For example, if we just wrapped let floats
-- when they pass through ticks, we might end up performing the
-- following transformation:
--
-- src<...> let foo = bar in baz
-- ==> let foo = src<...> bar in src<...> baz
--
-- Because the let-binding would float through the tick, and then
-- immediately materialize, achieving nothing but decreasing tick
-- accuracy. The only special case is the following scenario:
--
-- let foo = src<...> (let a = b in bar) in baz
-- ==> let foo = src<...> bar; a = src<...> b in baz
--
-- Here we would not want the source tick to end up covering "baz" and
-- therefore refrain from pushing ticks outside. Instead, we copy them
-- into the floating binds (here "a") in cpePair. Note that where "b"
-- or "bar" are (value) lambdas we have to push the annotations
-- further inside in order to uphold our rules.
--
-- All of this is implemented below in @wrapTicks@.
-- | Like wrapFloats, but only wraps tick floats
wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr)
wrapTicks (Floats flag floats0) expr = (Floats flag floats1, expr')
where (floats1, expr') = foldrOL go (nilOL, expr) floats0
go (FloatTick t) (fs, e) = ASSERT(tickishPlace t == PlaceNonLam)
(mapOL (wrap t) fs, mkTick t e)
go other (fs, e) = (other `consOL` fs, e)
wrap t (FloatLet bind) = FloatLet (wrapBind t bind)
wrap t (FloatCase b r ok) = FloatCase b (mkTick t r) ok
wrap _ other = pprPanic "wrapTicks: unexpected float!"
(ppr other)
wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)
wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs)
......@@ -31,6 +31,7 @@ import UniqSupply ( UniqSupply )
import ListSetOps ( removeDups )
import Outputable
import DynFlags
import CoreSyn ( Tickish(..) )
import FastString
import SrcLoc
import Util
......@@ -93,7 +94,8 @@ stgMassageForProfiling dflags mod_name _us stg_binds
do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
do_top_rhs _ (StgRhsClosure _ _ _ _ _ []
(StgSCC _cc False{-not tick-} _push (StgConApp con args)))
(StgTick (ProfNote _cc False{-not tick-} _push)
(StgConApp con args)))
| not (isDllConApp dflags mod_name con args)
-- Trivial _scc_ around nothing but static data
-- Eliminate _scc_ ... and turn into StgRhsCon
......@@ -146,10 +148,15 @@ stgMassageForProfiling dflags mod_name _us stg_binds
do_expr (StgOpApp con args res_ty)
= return (StgOpApp con args res_ty)
do_expr (StgSCC cc tick push expr) = do -- Ha, we found a cost centre!
do_expr (StgTick note@(ProfNote cc _ _) expr) = do
-- Ha, we found a cost centre!
collectCC cc
expr' <- do_expr expr
return (StgSCC cc tick push expr')
return (StgTick note expr')
do_expr (StgTick ti expr) = do
expr' <- do_expr expr
return (StgTick ti expr')
do_expr (StgCase expr fv1 fv2 bndr srt alt_type alts) = do
expr' <- do_expr expr
......@@ -168,10 +175,6 @@ stgMassageForProfiling dflags mod_name _us stg_binds
(b,e) <- do_let b e
return (StgLetNoEscape lvs1 lvs2 b e)
do_expr (StgTick m n expr) = do
expr' <- do_expr expr
return (StgTick m n expr')
do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)
----------------------------------
......@@ -201,7 +204,8 @@ stgMassageForProfiling dflags mod_name _us stg_binds
-- We should really attach (PushCC cc CurrentCCS) to the rhs,
-- but need to reinstate PushCC for that.
do_rhs (StgRhsClosure _closure_cc _bi _fv _u _srt []
(StgSCC cc False{-not tick-} _push (StgConApp con args)))
(StgTick (ProfNote cc False{-not tick-} _push)
(StgConApp con args)))
= do collectCC cc
return (StgRhsCon currentCCS con args)
......
......@@ -151,8 +151,7 @@ statExpr (StgApp _ _) = countOne Applications
statExpr (StgLit _) = countOne Literals
statExpr (StgConApp _ _) = countOne ConstructorApps
statExpr (StgOpApp _ _ _) = countOne PrimitiveApps
statExpr (StgSCC _ _ _ e) = statExpr e
statExpr (StgTick _ _ e) = statExpr e
statExpr (StgTick _ e) = statExpr e
statExpr (StgLetNoEscape _ _ binds body)
= statBinding False{-not top-level-} binds `combineSE`
......
......@@ -130,10 +130,8 @@ unariseExpr us rho (StgLetNoEscape live_in_let live_in_bind bind e)
where
(us1, us2) = splitUniqSupply us
unariseExpr us rho (StgSCC cc bump_entry push_cc e)
= StgSCC cc bump_entry push_cc (unariseExpr us rho e)
unariseExpr us rho (StgTick mod tick_n e)
= StgTick mod tick_n (unariseExpr us rho e)
unariseExpr us rho (StgTick tick e)
= StgTick tick (unariseExpr us rho e)
------------------------
unariseAlts :: UniqSupply -> UnariseEnv -> AltType -> Id -> RepType -> [StgAlt] -> (AltType, [StgAlt])
......
......@@ -317,28 +317,9 @@ mkTopStgRhs :: DynFlags -> Module -> FreeVarsInfo
-> SRT -> Id -> StgBinderInfo -> StgExpr
-> StgRhs
mkTopStgRhs _ _ rhs_fvs srt _ binder_info (StgLam bndrs body)
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
ReEntrant
srt
bndrs body
mkTopStgRhs dflags this_mod _ _ _ _ (StgConApp con args)
| not (isDllConApp dflags this_mod con args) -- Dynamic StgConApps are updatable
= StgRhsCon noCCS con args
mkTopStgRhs _ _ rhs_fvs srt bndr binder_info rhs
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
(getUpdateFlag bndr)
srt
[] rhs
getUpdateFlag :: Id -> UpdateFlag
getUpdateFlag bndr
= if isSingleUsed (idDemandInfo bndr)
then SingleEntry else Updatable
mkTopStgRhs dflags this_mod = mkStgRhs' con_updateable
-- Dynamic StgConApps are updatable
where con_updateable con args = isDllConApp dflags this_mod con args
-- ---------------------------------------------------------------------------
-- Expressions
......@@ -364,13 +345,13 @@ coreToStgExpr
-- should have converted them all to a real core representation.
coreToStgExpr (Lit (LitInteger {})) = panic "coreToStgExpr: LitInteger"
coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet)
coreToStgExpr (Var v) = coreToStgApp Nothing v []
coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId []
coreToStgExpr (Var v) = coreToStgApp Nothing v [] []
coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] []
coreToStgExpr expr@(App _ _)
= coreToStgApp Nothing f args
= coreToStgApp Nothing f args ticks
where
(f, args) = myCollectArgs expr
(f, args, ticks) = myCollectArgs expr
coreToStgExpr expr@(Lam _ _)
= let
......@@ -387,19 +368,14 @@ coreToStgExpr expr@(Lam _ _)
return (result_expr, fvs, escs)
coreToStgExpr (Tick (HpcTick m n) expr)
= do (expr2, fvs, escs) <- coreToStgExpr expr
return (StgTick m n expr2, fvs, escs)
coreToStgExpr (Tick (ProfNote cc tick push) expr)
= do (expr2, fvs, escs) <- coreToStgExpr expr
return (StgSCC cc tick push expr2, fvs, escs)
coreToStgExpr (Tick Breakpoint{} _expr)
= panic "coreToStgExpr: breakpoint should not happen"
coreToStgExpr (Tick _ expr)
= {- dropped for now ... -} coreToStgExpr expr
coreToStgExpr (Tick tick expr)
= do case tick of
HpcTick{} -> return ()
ProfNote{} -> return ()
SourceNote{} -> return ()
Breakpoint{} -> panic "coreToStgExpr: breakpoint should not happen"
(expr2, fvs, escs) <- coreToStgExpr expr
return (StgTick tick expr2, fvs, escs)
coreToStgExpr (Cast expr _)
= coreToStgExpr expr
......@@ -544,11 +520,12 @@ coreToStgApp
-- with specified update flag
-> Id -- Function
-> [CoreArg] -- Arguments
-> [Tickish Id] -- Debug ticks
-> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
coreToStgApp _ f args = do
(args', args_fvs) <- coreToStgArgs args
coreToStgApp _ f args ticks = do
(args', args_fvs, ticks') <- coreToStgArgs args
how_bound <- lookupVarLne f
let
......@@ -617,10 +594,12 @@ coreToStgApp _ f args = do
-- All the free vars of the args are disqualified
-- from being let-no-escaped.
tapp = foldr StgTick app (ticks ++ ticks')
-- Forcing these fixes a leak in the code generator, noticed while
-- profiling for trac #4367
app `seq` fvs `seq` seqVarSet vars `seq` return (
app,
tapp,
fvs,
vars
)
......@@ -632,24 +611,31 @@ coreToStgApp _ f args = do
-- This is the guy that turns applications into A-normal form
-- ---------------------------------------------------------------------------
coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo)
coreToStgArgs :: [CoreArg] -> LneM ([StgArg], FreeVarsInfo, [Tickish Id])
coreToStgArgs []
= return ([], emptyFVInfo)
= return ([], emptyFVInfo, [])
coreToStgArgs (Type _ : args) = do -- Type argument
(args', fvs) <- coreToStgArgs args
return (args', fvs)
(args', fvs, ts) <- coreToStgArgs args
return (args', fvs, ts)
coreToStgArgs (Coercion _ : args) -- Coercion argument; replace with place holder
= do { (args', fvs) <- coreToStgArgs args
; return (StgVarArg coercionTokenId : args', fvs) }
= do { (args', fvs, ts) <- coreToStgArgs args
; return (StgVarArg coercionTokenId : args', fvs, ts) }
coreToStgArgs (Tick t e : args)
= ASSERT( not (tickishIsCode t) )
do { (args', fvs, ts) <- coreToStgArgs (e : args)
; return (args', fvs, t:ts) }
coreToStgArgs (arg : args) = do -- Non-type argument
(stg_args, args_fvs) <- coreToStgArgs args
(stg_args, args_fvs, ticks) <- coreToStgArgs args
(arg', arg_fvs, _escs) <- coreToStgExpr arg
let
fvs = args_fvs `unionFVInfo` arg_fvs
stg_arg = case arg' of
(aticks, arg'') = stripStgTicksTop tickishFloatable arg'
stg_arg = case arg'' of
StgApp v [] -> StgVarArg v
StgConApp con [] -> StgVarArg (dataConWorkId con)
StgLit lit -> StgLitArg lit
......@@ -677,7 +663,7 @@ coreToStgArgs (arg : args) = do -- Non-type argument
-- We also want to check if a pointer is cast to a non-ptr etc
WARN( bad_args, ptext (sLit "Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
return (stg_arg : stg_args, fvs)
return (stg_arg : stg_args, fvs, ticks ++ aticks)
-- ---------------------------------------------------------------------------
......@@ -824,21 +810,31 @@ coreToStgRhs scope_fv_info binders (bndr, rhs) = do
bndr_info = lookupFVInfo scope_fv_info bndr
mkStgRhs :: FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs
mkStgRhs = mkStgRhs' con_updateable
where con_updateable _ _ = False
mkStgRhs _ _ _ _ (StgConApp con args) = StgRhsCon noCCS con args
mkStgRhs rhs_fvs srt _ binder_info (StgLam bndrs body)
mkStgRhs' :: (DataCon -> [StgArg] -> Bool)
-> FreeVarsInfo -> SRT -> Id -> StgBinderInfo -> StgExpr -> StgRhs
mkStgRhs' con_updateable rhs_fvs srt bndr binder_info rhs
| StgLam bndrs body <- rhs
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
ReEntrant
srt bndrs body
mkStgRhs rhs_fvs srt bndr binder_info rhs
(getFVs rhs_fvs)
ReEntrant
srt bndrs body
| StgConApp con args <- unticked_rhs
, not (con_updateable con args)
= StgRhsCon noCCS con args
| otherwise
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
upd_flag srt [] rhs
where
upd_flag = getUpdateFlag bndr
(getFVs rhs_fvs)
upd_flag srt [] rhs
where
(_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs
upd_flag | isSingleUsed (idDemandInfo bndr) = SingleEntry
| otherwise = Updatable
{-
SDM: disabled. Eval/Apply can't handle functions with arity zero very
well; and making these into simple non-updatable thunks breaks other
......@@ -1163,26 +1159,23 @@ myCollectBinders expr
= go [] expr
where
go bs (Lam b e) = go (b:bs) e
go bs e@(Tick t e')
| tickishIsCode t = (reverse bs, e)
| otherwise = go bs e'
-- Ignore only non-code source annotations
go bs (Cast e _) = go bs e
go bs e = (reverse bs, e)
myCollectArgs :: CoreExpr -> (Id, [CoreArg])
myCollectArgs :: CoreExpr -> (Id, [CoreArg], [Tickish Id])
-- We assume that we only have variables
-- in the function position by now
myCollectArgs expr
= go expr []
= go expr [] []
where
go (Var v) as = (v, as)
go (App f a) as = go f (a:as)
go (Tick _ _) _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
go (Cast e _) as = go e as
go (Lam b e) as
| isTyVar b = go e as -- Note [Collect args]
go _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
go (Var v) as ts = (v, as, ts)
go (App f a) as ts = go f (a:as) ts
go (Tick t e) as ts = ASSERT( all isTypeArg as )
go e as (t:ts) -- ticks can appear in type apps
go (Cast e _) as ts = go e as ts
go (Lam b e) as ts
| isTyVar b = go e as ts -- Note [Collect args]
go _ _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
-- Note [Collect args]
-- ~~~~~~~~~~~~~~~~~~~
......
......@@ -187,7 +187,7 @@ lintStgExpr (StgLetNoEscape _ _ binds body) = do
addInScopeVars binders $
lintStgExpr body
lintStgExpr (StgSCC _ _ _ expr) = lintStgExpr expr
lintStgExpr (StgTick _ expr) = lintStgExpr expr
lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
_ <- MaybeT $ lintStgExpr scrut
......@@ -210,8 +210,6 @@ lintStgExpr (StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
where
bad_bndr = mkDefltMsg bndr tc
lintStgExpr e = pprPanic "lintStgExpr" (ppr e)
lintStgAlts :: [StgAlt]
-> Type -- Type of scrutinee
-> LintM (Maybe Type) -- Just ty => type is accurage
......
......@@ -38,6 +38,7 @@ module StgSyn (
stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity,
isDllConApp,
stgArgType,
stripStgTicksTop,
pprStgBinding, pprStgBindings,
pprStgLVs
......@@ -46,8 +47,8 @@ module StgSyn (
#include "HsVersions.h"