[commit: ghc] wip/annotate-core: Never tick primitive string literals (806c398)
git at git.haskell.org
git at git.haskell.org
Tue Jul 25 17:54:16 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/annotate-core
Link : http://ghc.haskell.org/trac/ghc/changeset/806c39855db0e5bd6d929b82d2a70c43b2b9a39f/ghc
>---------------------------------------------------------------
commit 806c39855db0e5bd6d929b82d2a70c43b2b9a39f
Author: Ben Gamari <bgamari.foss at gmail.com>
Date: Fri Jul 21 01:23:26 2017 -0400
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
>---------------------------------------------------------------
806c39855db0e5bd6d929b82d2a70c43b2b9a39f
compiler/coreSyn/CoreSyn.hs | 2 ++
compiler/coreSyn/CoreUtils.hs | 5 +++++
compiler/simplCore/FloatOut.hs | 32 ++++++++++++--------------------
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 99478d2..41202c3 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 540a36e..3b80fb6 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 72fc0d1..06062bd 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 91ed644..7b11595 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
More information about the ghc-commits
mailing list