diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 68a79878d3b390e57c123db92212569a294a534e..7189800f6ee89fc710a70f42feec73e668b5a473 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -265,7 +265,7 @@ mkRhsClosure dflags bndr _cc upd_flag -- Updatable thunk [] -- A thunk expr - | let strip = snd . stripStgTicksTop (not . tickishIsCode) + | let strip = stripStgTicksTopE (not . tickishIsCode) , StgCase (StgApp scrutinee [{-no args-}]) _ -- ignore bndr (AlgAlt _) diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs index 6c59ebb08172ce2804a418310d8099fedbf58e49..dae1e351eb177ccbb9d82c2e027d022c59d60dbb 100644 --- a/compiler/stgSyn/CoreToStg.hs +++ b/compiler/stgSyn/CoreToStg.hs @@ -716,7 +716,7 @@ mkTopStgRhs dflags this_mod ccs bndr rhs , ccs ) where - (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs + unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry | otherwise = Updatable @@ -758,7 +758,7 @@ mkStgRhs bndr rhs currentCCS upd_flag [] rhs where - (_, unticked_rhs) = stripStgTicksTop (not . tickishIsCode) rhs + unticked_rhs = stripStgTicksTopE (not . tickishIsCode) rhs upd_flag | isUsedOnce (idDemandInfo bndr) = SingleEntry | otherwise = Updatable diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs index 2372e3ed27f437509d6637d6d4a39983ca36cad1..e6a12053990b9259a7b239e8b58b9ab2cc8fb85a 100644 --- a/compiler/stgSyn/StgSyn.hs +++ b/compiler/stgSyn/StgSyn.hs @@ -50,7 +50,7 @@ module StgSyn ( topStgBindHasCafRefs, stgArgHasCafRefs, stgRhsArity, isDllConApp, stgArgType, - stripStgTicksTop, + stripStgTicksTop, stripStgTicksTopE, stgCaseBndrInScope, pprStgBinding, pprGenStgTopBindings, pprStgTopBindings @@ -163,12 +163,18 @@ stgArgType (StgVarArg v) = idType v stgArgType (StgLitArg lit) = literalType lit --- | Strip ticks of a given type from an STG expression +-- | Strip ticks of a given type from an STG expression. stripStgTicksTop :: (Tickish Id -> Bool) -> GenStgExpr p -> ([Tickish Id], GenStgExpr p) stripStgTicksTop p = go [] where go ts (StgTick t e) | p t = go (t:ts) e go ts other = (reverse ts, other) +-- | Strip ticks of a given type from an STG expression returning only the expression. +stripStgTicksTopE :: (Tickish Id -> Bool) -> GenStgExpr p -> GenStgExpr p +stripStgTicksTopE p = go + where go (StgTick t e) | p t = go e + go other = other + -- | Given an alt type and whether the program is unarised, return whether the -- case binder is in scope. --