[commit: ghc] master: Don't tick top-level string literals (f5b275a)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/f5b275a239d2554c4da0b7621211642bf3b10650/ghc

>---------------------------------------------------------------

commit f5b275a239d2554c4da0b7621211642bf3b10650
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Wed Feb 1 22:48:32 2017 -0500

    Don't tick top-level string literals
    
    This fixes a regression due to D2605 (see #8472) wherein top-level primitive
    strings would fail to be noticed by CoreToStg as they were wrapped in a
    tick. This resulted in a panic in CoreToStg due to inconsistent CAF information
    (or a Core Lint failure, if enabled). Here we document the invariant that
    unlifted expressions can only sit at top-level if of the form `Lit (MachStr
    ...)` with no ticks or other embellishments. Moreover, we fix instance of
    this in `Simplify.prepareRhs` and `FloatOut.wrapTick` where this
    invariant was being broken.
    
    Test Plan: Validate with `-g`. Run testsuite with `WAY=ghci`.
    
    Reviewers: austin, simonpj
    
    Reviewed By: simonpj
    
    Subscribers: simonpj, akio, scpmw, thomie
    
    Differential Revision: https://phabricator.haskell.org/D3051


>---------------------------------------------------------------

f5b275a239d2554c4da0b7621211642bf3b10650
 compiler/coreSyn/CoreSyn.hs    |  5 +++++
 compiler/simplCore/FloatOut.hs | 32 ++++++++++++++++++++------------
 compiler/simplCore/Simplify.hs | 10 ++++++++--
 3 files changed, 33 insertions(+), 14 deletions(-)

diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index f74e3e5..f8cf6f4 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -383,6 +383,11 @@ The solution is simply to allow top-level unlifted binders. We can't allow
 arbitrary unlifted expression at the top-level though, unlifted binders cannot
 be thunks, so we just allow string literals.
 
+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.
+
 Also see Note [Compilation plan for top-level string literals].
 
 Note [Compilation plan for top-level string literals]
diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs
index 17ffba4..4806862 100644
--- a/compiler/simplCore/FloatOut.hs
+++ b/compiler/simplCore/FloatOut.hs
@@ -22,6 +22,7 @@ import ErrUtils         ( dumpIfSet_dyn )
 import Id               ( Id, idArity, idType, isBottomingId,
                           isJoinId, isJoinId_maybe )
 import Var              ( Var )
+import BasicTypes       ( TopLevelFlag(..), isTopLevel )
 import SetLevels
 import UniqSupply       ( UniqSupply )
 import Bag
@@ -735,19 +736,26 @@ atJoinCeiling (fs, floats, expr')
 
 wrapTick :: Tickish Id -> FloatBinds -> FloatBinds
 wrapTick t (FB tops ceils defns)
-  = FB (mapBag wrap_bind tops) (wrap_defns ceils)
-       (M.map (M.map wrap_defns) defns)
+  = FB (mapBag (wrap_bind TopLevel) tops)
+       (wrap_defns NotTopLevel ceils)
+       (M.map (M.map (wrap_defns NotTopLevel)) defns)
   where
-    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
+    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
       -- 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 7c6f875..7357e32 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -566,9 +566,15 @@ 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
-             ; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)
+             ; 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' = seFloats $ env `addFloats` mapFloats env' tickIt
              ; return (is_exp, env' { seFloats = floats' }, Tick t rhs') }