diff options
Diffstat (limited to 'compiler/simplCore')
| -rw-r--r-- | compiler/simplCore/FloatOut.hs | 33 | ||||
| -rw-r--r-- | compiler/simplCore/Simplify.hs | 8 |
2 files changed, 15 insertions, 26 deletions
diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs index a8223b47b9..25a4e53a77 100644 --- a/compiler/simplCore/FloatOut.hs +++ b/compiler/simplCore/FloatOut.hs @@ -23,7 +23,7 @@ import DynFlags import ErrUtils ( dumpIfSet_dyn ) import Id ( Id, idArity, idType, isBottomingId, isJoinId, isJoinId_maybe ) -import BasicTypes ( TopLevelFlag(..), isTopLevel ) +import Var ( Var ) import SetLevels import UniqSupply ( UniqSupply ) import Bag @@ -737,26 +737,19 @@ atJoinCeiling (fs, floats, expr') wrapTick :: Tickish Id -> FloatBinds -> FloatBinds wrapTick t (FB tops ceils defns) - = FB (mapBag (wrap_bind TopLevel) tops) - (wrap_defns NotTopLevel ceils) - (M.map (M.map (wrap_defns NotTopLevel)) defns) + = FB (mapBag wrap_bind tops) (wrap_defns ceils) + (M.map (M.map wrap_defns) defns) where - wrap_defns toplvl = mapBag (wrap_one toplvl) - - wrap_bind toplvl (NonRec binder rhs) = NonRec binder (maybe_tick toplvl rhs) - wrap_bind toplvl (Rec pairs) = Rec (mapSnd (maybe_tick toplvl) pairs) - - wrap_one toplvl (FloatLet bind) = FloatLet (wrap_bind toplvl bind) - wrap_one toplvl (FloatCase e b c bs) = FloatCase (maybe_tick toplvl e) b c bs - - maybe_tick :: TopLevelFlag -> CoreExpr -> CoreExpr - maybe_tick toplvl e - -- We must take care not to tick top-level literal - -- strings as this violated the Core invariants. See Note [CoreSyn - -- top-level string literals]. - | isTopLevel toplvl && exprIsLiteralString e = e - | exprIsHNF e = tickHNFArgs t e - | otherwise = mkTick t e + wrap_defns = mapBag wrap_one + + wrap_bind (NonRec binder rhs) = NonRec binder (maybe_tick rhs) + wrap_bind (Rec pairs) = Rec (mapSnd maybe_tick pairs) + + wrap_one (FloatLet bind) = FloatLet (wrap_bind bind) + wrap_one (FloatCase e b c bs) = FloatCase (maybe_tick e) b c bs + + maybe_tick e | exprIsHNF e = tickHNFArgs t e + | otherwise = mkTick t e -- we don't need to wrap a tick around an HNF when we float it -- outside a tick: that is an invariant of the tick semantics -- Conversely, inlining of HNFs inside an SCC is allowed, and diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs index b123055387..ed2c9afa6c 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -438,15 +438,11 @@ prepareRhs mode top_lvl occ _ rhs0 -- On the other hand, for scoping ticks we need to be able to -- copy them on the floats, which in turn is only allowed if -- we can obtain non-counting ticks. - | (not (tickishCounts t) || tickishCanSplit t) + | not (tickishCounts t) || tickishCanSplit t = do { (is_exp, floats, rhs') <- go n_val_args rhs - ; let tickIt (id, expr) -- we have to take care not to tick top-level literal -- strings. See Note [CoreSyn top-level string literals]. - | isTopLevel top_lvl && exprIsLiteralString expr - = (id, expr) - | otherwise - = (id, mkTick (mkNoCount t) expr) + ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) floats' = mapLetFloats floats tickIt ; return (is_exp, floats', Tick t rhs') } |