diff options
author | Ben Gamari <bgamari.foss@gmail.com> | 2017-07-21 01:23:26 -0400 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2017-07-21 07:49:16 -0400 |
commit | 806c39855db0e5bd6d929b82d2a70c43b2b9a39f (patch) | |
tree | 2c8ec2d2e30ece1f96570ce897c9962a851d315a | |
parent | 70ace6abcfddd004e7df90daddea2652f535946f (diff) | |
download | haskell-806c39855db0e5bd6d929b82d2a70c43b2b9a39f.tar.gz |
Never tick primitive string literals
Summary:
This is a more aggressive approach to the problem initially solved in
f5b275a239d2554c4da0b7621211642bf3b10650, where top-level primitive string
literals were being wrapped by ticks. This breaks the Core invariant descirbed
in Note [CoreSyn top-level string literals]. However, the previous approach was
incomplete and left several places where inappropriate ticks could sneak in.
This commit kills the problem at the source: we simply never tick any primitive
string literal expression. The assumption here is that these expressions are
destined for the top-level, where they cannot be ticked, anyways. So even if
they haven't been floated out yet there is no reason to tick them.
This partially reverts commit f5b275a239d2554c4da0b7621211642bf3b10650.
Test Plan: Validate with `-g`
Reviewers: scpmw, simonmar, dfeuer, simonpj, austin
Subscribers: dfeuer, simonmar, thomie
Differential Revision: https://phabricator.haskell.org/D3063
-rw-r--r-- | compiler/coreSyn/CoreSyn.hs | 2 | ||||
-rw-r--r-- | compiler/coreSyn/CoreUtils.hs | 5 | ||||
-rw-r--r-- | compiler/simplCore/FloatOut.hs | 32 | ||||
-rw-r--r-- | compiler/simplCore/Simplify.hs | 15 |
4 files changed, 22 insertions, 32 deletions
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index 99478d2b66..41202c3355 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -402,6 +402,8 @@ It is important to note that top-level primitive string literals cannot be wrapped in Ticks, as is otherwise done with lifted bindings. CoreToStg expects to see just a plain (Lit (MachStr ...)) expression on the RHS of primitive string bindings; anything else and things break. CoreLint checks this invariant. +To ensure that ticks don't sneak in CoreUtils.mkTick refuses to wrap any +primitive string expression with a tick. Also see Note [Compilation plan for top-level string literals]. diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index 540a36e0a1..3b80fb623a 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -300,6 +300,11 @@ mkTick t orig_expr = mkTick' id id orig_expr -> CoreExpr mkTick' top rest expr = case expr of + -- Never tick primitive string literals. These should ultimately float up to + -- the top-level where they must be unadorned. See Note + -- [CoreSyn top-level string literals] for details. + _ | exprIsLiteralString expr -> expr + -- Cost centre ticks should never be reordered relative to each -- other. Therefore we can stop whenever two collide. Tick t2 e diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs index 72fc0d1ff7..06062bd442 100644 --- a/compiler/simplCore/FloatOut.hs +++ b/compiler/simplCore/FloatOut.hs @@ -21,7 +21,6 @@ import DynFlags import ErrUtils ( dumpIfSet_dyn ) import Id ( Id, idArity, idType, isBottomingId, isJoinId, isJoinId_maybe ) -import BasicTypes ( TopLevelFlag(..), isTopLevel ) import SetLevels import UniqSupply ( UniqSupply ) import Bag @@ -735,26 +734,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 91ed644057..7b115957e4 100644 --- a/compiler/simplCore/Simplify.hs +++ b/compiler/simplCore/Simplify.hs @@ -611,19 +611,10 @@ prepareRhs top_lvl env0 id 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, env', rhs') <- go n_val_args (zapFloats env) rhs - -- env' has the extra let-bindings from - -- the makeTrivial calls in 'go'; no join floats - ; 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) - floats' = seLetFloats env `addFlts` - mapFloats (seLetFloats env') tickIt + ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr) + floats' = seLetFloats env `addFlts` mapFloats (seLetFloats env') tickIt ; return (is_exp, env' { seLetFloats = floats' }, Tick t rhs') } go _ env other |