diff options
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 39 | ||||
| -rw-r--r-- | compiler/codeGen/StgCmmExpr.hs | 21 | ||||
| -rw-r--r-- | compiler/coreSyn/CorePrep.hs | 95 | ||||
| -rw-r--r-- | compiler/profiling/SCCfinal.hs | 20 | ||||
| -rw-r--r-- | compiler/simplStg/StgStats.hs | 3 | ||||
| -rw-r--r-- | compiler/simplStg/UnariseStg.hs | 6 | ||||
| -rw-r--r-- | compiler/stgSyn/CoreToStg.hs | 145 | ||||
| -rw-r--r-- | compiler/stgSyn/StgLint.hs | 4 | ||||
| -rw-r--r-- | compiler/stgSyn/StgSyn.hs | 60 |
9 files changed, 226 insertions, 167 deletions
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 444112f967..3c17160750 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -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 diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index b2b64f8650..9097e7fa12 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -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 + } diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs index f1bdd73a59..1ca54fe6aa 100644 --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -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) diff --git a/compiler/profiling/SCCfinal.hs b/compiler/profiling/SCCfinal.hs index 9ad5b5fc3d..dfa3d052a4 100644 --- a/compiler/profiling/SCCfinal.hs +++ b/compiler/profiling/SCCfinal.hs @@ -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) diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs index 4823baea3d..dd1f5a64d2 100644 --- a/compiler/simplStg/StgStats.hs +++ b/compiler/simplStg/StgStats.hs @@ -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` diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs index 303bfa74ee..87ce0ed93f 100644 --- a/compiler/simplStg/UnariseStg.hs +++ b/compiler/simplStg/UnariseStg.hs @@ -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]) diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs index 55a31d4255..20bbf3b729 100644 --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -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] -- ~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs index 5bd25e3116..b415b4f2d9 100644 --- a/compiler/stgSyn/StgLint.hs +++ b/compiler/stgSyn/StgLint.hs @@ -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 diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs index 7577e837a8..6c6d4bfb1d 100644 --- a/compiler/stgSyn/StgSyn.hs +++ b/compiler/stgSyn/StgSyn.hs @@ -38,6 +38,7 @@ module StgSyn ( stgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, isDllConApp, stgArgType, + stripStgTicksTop, pprStgBinding, pprStgBindings, pprStgLVs @@ -46,8 +47,8 @@ module StgSyn ( #include "HsVersions.h" import Bitmap -import CoreSyn ( AltCon ) -import CostCentre ( CostCentreStack, CostCentre ) +import CoreSyn ( AltCon, Tickish ) +import CostCentre ( CostCentreStack ) import DataCon import DynFlags import FastString @@ -55,7 +56,7 @@ import ForeignCall ( ForeignCall ) import Id import IdInfo ( mayHaveCafRefs ) import Literal ( Literal, literalType ) -import Module +import Module ( Module ) import Outputable import Packages ( isDllName ) import Platform @@ -143,6 +144,14 @@ stgArgType :: StgArg -> Type stgArgType (StgVarArg v) = idType v stgArgType (StgLitArg lit) = literalType lit + +-- | Strip ticks of a given type from an STG expression +stripStgTicksTop :: (Tickish Id -> Bool) -> StgExpr -> ([Tickish Id], StgExpr) +stripStgTicksTop p = go [] + where go ts (StgTick t e) | p t = go (t:ts) e + go ts other = (reverse ts, other) + + {- ************************************************************************ * * @@ -363,35 +372,18 @@ And so the code for let(rec)-things: (GenStgExpr bndr occ) -- body {- -************************************************************************ -* * -\subsubsection{@GenStgExpr@: @scc@ expressions} -* * -************************************************************************ - -For @scc@ expressions we introduce a new STG construct. --} - - | StgSCC - CostCentre -- label of SCC expression - !Bool -- bump the entry count? - !Bool -- push the cost centre? - (GenStgExpr bndr occ) -- scc expression - -{- -************************************************************************ -* * -\subsubsection{@GenStgExpr@: @hpc@ expressions} -* * -************************************************************************ +%************************************************************************ +%* * +\subsubsection{@GenStgExpr@: @hpc@, @scc@ and other debug annotations} +%* * +%************************************************************************ Finally for @hpc@ expressions we introduce a new STG construct. -} | StgTick - Module -- the module of the source of this tick - Int -- tick number - (GenStgExpr bndr occ) -- sub expression + (Tickish bndr) + (GenStgExpr bndr occ) -- sub expression -- END of GenStgExpr @@ -742,16 +734,12 @@ pprStgExpr (StgLetNoEscape lvs_whole lvs_rhss bind expr) char ']']))) 2 (ppr expr)] -pprStgExpr (StgSCC cc tick push expr) - = sep [ hsep [scc, ppr cc], pprStgExpr expr ] - where - scc | tick && push = ptext (sLit "_scc_") - | tick = ptext (sLit "_tick_") - | otherwise = ptext (sLit "_push_") +pprStgExpr (StgTick tickish expr) + = sdocWithDynFlags $ \dflags -> + if gopt Opt_PprShowTicks dflags + then sep [ ppr tickish, pprStgExpr expr ] + else pprStgExpr expr -pprStgExpr (StgTick m n expr) - = sep [ hsep [ptext (sLit "_tick_"), pprModule m,text (show n)], - pprStgExpr expr ] pprStgExpr (StgCase expr lvs_whole lvs_rhss bndr srt alt_type alts) = sep [sep [ptext (sLit "case"), |