Never tick primitive string literalswip/libdw-prof

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: austin, scpmw, simonpj, simonmar, dfeuer

Subscribers: dfeuer, simonmar, thomie

Differential Revision: https://phabricator.haskell.org/D3063

4 files changed, 22 insertions, 26 deletions

diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index 27a4c99539..68bf676fb1 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -405,6 +405,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
+primitve 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 3d5f4bcb5a..ca67e24ca3 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -305,6 +305,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 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') }