Allow top level ticked string literals

This reverts f5b275a239d2554c4da0b7621211642bf3b10650
and changes the places that looked for `Lit (MachStr _))`
to use `exprIsMbTickedLitString_maybe` to unwrap ticks as
necessary.
Also updated relevant comments.

Test Plan:
I added 3 new tests that previously reproduced.
GHC HEAD now builds with -g

Reviewers: simonpj, simonmar, bgamari, hvr, goldfire

Subscribers: rwbarton, thomie, carter

GHC Trac Issues: #14779

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

15 files changed, 183 insertions, 50 deletions

diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index 4fa342508f..78902dfea4 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -531,7 +531,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
        ; checkL ( isJoinId binder
                || not (isUnliftedType binder_ty)
                || (isNonRec rec_flag && exprOkForSpeculation rhs)
-               || exprIsLiteralString rhs)
+               || exprIsTickedString rhs)
            (badBndrTyMsg binder (text "unlifted"))
 
         -- Check that if the binder is top-level or recursive, it's not
@@ -539,14 +539,14 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
         -- computation to perform, see Note [CoreSyn top-level string literals].
        ; checkL (not (isStrictId binder)
             || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))
-            || exprIsLiteralString rhs)
+            || exprIsTickedString rhs)
            (mkStrictMsg binder)
 
         -- Check that if the binder is at the top level and has type Addr#,
         -- that it is a string literal, see
         -- Note [CoreSyn top-level string literals].
        ; checkL (not (isTopLevel top_lvl_flag && binder_ty `eqType` addrPrimTy)
-                 || exprIsLiteralString rhs)
+                 || exprIsTickedString rhs)
            (mkTopNonLitStrMsg binder)
 
        ; flags <- getLintFlags
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index 27a4c99539..2cb8079feb 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -401,10 +401,10 @@ 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.
+We allow the top-level primitive string literals to be wrapped in Ticks
+in the same way they can be wrapped when nested in an expression.
+CoreToSTG currently discards Ticks around top-level primitive string literals.
+See Trac #14779.
 
 Also see Note [Compilation plan for top-level string literals].
 
@@ -414,7 +414,7 @@ Here is a summary on how top-level string literals are handled by various
 parts of the compilation pipeline.
 
 * In the source language, there is no way to bind a primitive string literal
-  at the top leve.
+  at the top level.
 
 * In Core, we have a special rule that permits top-level Addr# bindings. See
   Note [CoreSyn top-level string literals]. Core-to-core passes may introduce
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 644c0f8a2a..4db9d8fc29 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -29,7 +29,8 @@ module CoreUtils (
         exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
         exprIsBig, exprIsConLike,
         rhsIsStatic, isCheapApp, isExpandableApp,
-        exprIsLiteralString, exprIsTopLevelBindable,
+        exprIsTickedString, exprIsTickedString_maybe,
+        exprIsTopLevelBindable,
         altsAreExhaustive,
 
         -- * Equality
@@ -90,6 +91,7 @@ import BasicTypes       ( Arity, isConLike )
 import Platform
 import Util
 import Pair
+import Data.ByteString     ( ByteString )
 import Data.Function       ( on )
 import Data.List
 import Data.Ord            ( comparing )
@@ -1726,12 +1728,25 @@ exprIsTopLevelBindable :: CoreExpr -> Type -> Bool
 -- Top-level literal strings can't even be wrapped in ticks
 --   see Note [CoreSyn top-level string literals] in CoreSyn
 exprIsTopLevelBindable expr ty
-  = exprIsLiteralString expr
-  || not (isUnliftedType ty)
-
-exprIsLiteralString :: CoreExpr -> Bool
-exprIsLiteralString (Lit (MachStr _)) = True
-exprIsLiteralString _ = False
+  = not (isUnliftedType ty)
+  || exprIsTickedString expr
+
+-- | Check if the expression is zero or more Ticks wrapped around a literal
+-- string.
+exprIsTickedString :: CoreExpr -> Bool
+exprIsTickedString = isJust . exprIsTickedString_maybe
+
+-- | Extract a literal string from an expression that is zero or more Ticks
+-- wrapped around a literal string. Returns Nothing if the expression has a
+-- different shape.
+-- Used to "look through" Ticks in places that need to handle literal strings.
+exprIsTickedString_maybe :: CoreExpr -> Maybe ByteString
+exprIsTickedString_maybe (Lit (MachStr bs)) = Just bs
+exprIsTickedString_maybe (Tick t e)
+  -- we don't tick literals with CostCentre ticks, compare to mkTick
+  | tickishPlace t == PlaceCostCentre = Nothing
+  | otherwise = exprIsTickedString_maybe e
+exprIsTickedString_maybe _ = Nothing
 
 {-
 ************************************************************************
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index d5370805ea..13cb83df14 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -93,8 +93,8 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
         -- See Note [generating code for top-level string literal bindings].
         let (strings, flatBinds) = splitEithers $ do
                 (bndr, rhs) <- flattenBinds binds
-                return $ case rhs of
-                    Lit (MachStr str) -> Left (bndr, str)
+                return $ case exprIsTickedString_maybe rhs of
+                    Just str -> Left (bndr, str)
                     _ -> Right (bndr, simpleFreeVars rhs)
         stringPtrs <- allocateTopStrings hsc_env strings
 
diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs
index 919f61a67e..8f61128038 100644
--- a/compiler/simplCore/CSE.hs
+++ b/compiler/simplCore/CSE.hs
@@ -19,7 +19,7 @@ import Id               ( Id, idType, idInlineActivation, isDeadBinder
                         , zapIdOccInfo, zapIdUsageInfo, idInlinePragma
                         , isJoinId )
 import CoreUtils        ( mkAltExpr, eqExpr
-                        , exprIsLiteralString
+                        , exprIsTickedString
                         , stripTicksE, stripTicksT, mkTicks )
 import CoreFVs          ( exprFreeVars )
 import Type             ( tyConAppArgs )
@@ -349,7 +349,7 @@ cseBind toplevel env (Rec pairs)
 -- which are equal to @out_rhs@.
 cse_bind :: TopLevelFlag -> CSEnv -> (InId, InExpr) -> OutId -> (CSEnv, (OutId, OutExpr))
 cse_bind toplevel env (in_id, in_rhs) out_id
-  | isTopLevel toplevel, exprIsLiteralString in_rhs
+  | isTopLevel toplevel, exprIsTickedString in_rhs
       -- See Note [Take care with literal strings]
   = (env', (out_id, in_rhs))
 
diff --git a/compiler/simplCore/FloatOut.hs b/compiler/simplCore/FloatOut.hs
index a8223b47b9..6cb21f9470 100644
--- a/compiler/simplCore/FloatOut.hs
+++ b/compiler/simplCore/FloatOut.hs
@@ -23,7 +23,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
@@ -737,26 +736,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/SimplEnv.hs b/compiler/simplCore/SimplEnv.hs
index 7f7977dd36..7504fc6c60 100644
--- a/compiler/simplCore/SimplEnv.hs
+++ b/compiler/simplCore/SimplEnv.hs
@@ -496,9 +496,9 @@ unitLetFloat bind = ASSERT(all (not . isJoinId) (bindersOf bind))
     flag (Rec {})                = FltLifted
     flag (NonRec bndr rhs)
       | not (isStrictId bndr)    = FltLifted
-      | exprIsLiteralString rhs  = FltLifted
+      | exprIsTickedString rhs   = FltLifted
           -- String literals can be floated freely.
-          -- See Note [CoreSyn top-level string ltierals] in CoreSyn.
+          -- See Note [CoreSyn top-level string literals] in CoreSyn.
       | exprOkForSpeculation rhs = FltOkSpec  -- Unlifted, and lifted but ok-for-spec (eg HNF)
       | otherwise                = ASSERT2( not (isUnliftedType (idType bndr)), ppr bndr )
                                    FltCareful
diff --git a/compiler/simplCore/Simplify.hs b/compiler/simplCore/Simplify.hs
index b123055387..53e3a210de 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -440,13 +440,7 @@ prepareRhs mode top_lvl occ _ rhs0
         -- we can obtain non-counting ticks.
         | (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') }
 
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index f85382bc55..cb4e7f65d3 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -18,7 +18,8 @@ module CoreToStg ( coreToStg ) where
 import GhcPrelude
 
 import CoreSyn
-import CoreUtils        ( exprType, findDefault, isJoinBind )
+import CoreUtils        ( exprType, findDefault, isJoinBind
+                        , exprIsTickedString_maybe )
 import CoreArity        ( manifestArity )
 import StgSyn
 
@@ -273,8 +274,10 @@ coreTopBindToStg
         -> CoreBind
         -> (IdEnv HowBound, FreeVarsInfo, CollectedCCs, StgTopBinding)
 
-coreTopBindToStg _ _ env body_fvs ccs (NonRec id (Lit (MachStr str)))
+coreTopBindToStg _ _ env body_fvs ccs (NonRec id e)
+  | Just str <- exprIsTickedString_maybe e
   -- top-level string literal
+  -- See Note [CoreSyn top-level string literals] in CoreSyn
   = let
         env' = extendVarEnv env id how_bound
         how_bound = LetBound TopLet 0
diff --git a/testsuite/tests/simplCore/should_compile/T14779a.hs b/testsuite/tests/simplCore/should_compile/T14779a.hs
new file mode 100644
index 0000000000..f2072dc92b
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T14779a.hs
@@ -0,0 +1,34 @@
+{-# OPTIONS_GHC -g -O #-}
+{-# OPTIONS
+  -fno-strictness
+  -fno-case-merge
+  -fno-call-arity
+  -fno-case-folding
+  -fno-cse
+  -fno-do-eta-reduction
+  -fno-do-lambda-eta-expansion
+  -fno-float-in
+  -ffull-laziness
+  -fno-enable-rewrite-rules
+#-}
+-- This used to fail with:
+--
+-- *** Core Lint errors : in result of Simplifier ***
+-- <no location info>: warning:
+--     [RHS of str_sZr :: Addr#]
+--     Recursive or top-level binder has strict demand info: str_sZr
+--     Binder's demand info: <L,U>
+module T14779a where
+
+mkConstr :: String -> String
+mkConstr str = r
+  where
+    r = idx `seq` str
+    idx = eqS r str `seq` [r]
+
+conMkFixed :: String
+conMkFixed = mkConstr "MkFixed"
+
+eqS :: String -> String -> Bool
+eqS [] [] = True
+eqS _ _ = False
diff --git a/testsuite/tests/simplCore/should_compile/T14779b.hs b/testsuite/tests/simplCore/should_compile/T14779b.hs
new file mode 100644
index 0000000000..b3f0ec266b
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T14779b.hs
@@ -0,0 +1,83 @@
+{-# OPTIONS_GHC -g -O #-}
+-- This used to fail with:
+--
+-- *** Core Lint errors : in result of Simplifier ***
+-- <no location info>: warning:
+--     [RHS of str_s2UI :: Addr#]
+--     The type of this binder is unlifted: str_s2UI
+--     Binder's type: Addr#
+
+module T14779b where
+
+data DataType = DataType
+                        { tycon   :: String
+                        , datarep :: DataRep
+                        }
+
+data Constr = Constr
+                        { conrep    :: ConstrRep
+                        , constring :: String
+                        , confields :: [String] -- for AlgRep only
+                        , confixity :: Fixity   -- for AlgRep only
+                        , datatype  :: DataType
+                        }
+
+data DataRep = AlgRep [Constr]
+             | IntRep
+             | FloatRep
+             | CharRep
+             | NoRep
+
+data ConstrRep = AlgConstr    ConIndex
+               | IntConstr    Integer
+               | FloatConstr  Rational
+               | CharConstr   Char
+
+type ConIndex = Int
+
+
+-- | Fixity of constructors
+data Fixity = Prefix
+            | Infix     -- Later: add associativity and precedence
+
+
+mkDataType :: String -> [Constr] -> DataType
+mkDataType str cs = DataType
+                        { tycon   = str
+                        , datarep = AlgRep cs
+                        }
+
+mkConstr :: DataType -> String -> [String] -> Fixity -> Constr
+mkConstr dt str fields fix =
+        Constr
+                { conrep    = AlgConstr idx
+                , constring = str
+                , confields = fields
+                , confixity = fix
+                , datatype  = dt
+                }
+  where
+    idx = head [ i | (c,i) <- dataTypeConstrs dt `zip` [1..],
+                     showConstr c == str ]
+
+dataTypeConstrs :: DataType -> [Constr]
+dataTypeConstrs dt = case datarep dt of
+                        (AlgRep cons) -> cons
+                        _ -> errorWithoutStackTrace $
+                               "Data.Data.dataTypeConstrs is not supported for "
+                                    ++ dataTypeName dt ++
+                                    ", as it is not an algebraic data type."
+dataTypeName :: DataType -> String
+dataTypeName = tycon
+
+showConstr :: Constr -> String
+showConstr = constring
+
+-- | The type parameter should be an instance of 'HasResolution'.
+newtype Fixed a = MkFixed Integer -- ^ @since 4.7.0.0
+        deriving (Eq,Ord)
+
+tyFixed :: DataType
+tyFixed = mkDataType "Data.Fixed.Fixed" [conMkFixed]
+conMkFixed :: Constr
+conMkFixed = mkConstr tyFixed "MkFixed" [] Prefix
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index e681ca7363..362541e136 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -270,6 +270,12 @@ test('T12600',
 test('T13658',
      [when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261))],
      compile, ['-dcore-lint'])
+test('T14779a',
+     [when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261))],
+     compile, ['-dcore-lint'])
+test('T14779b',
+     [when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261))],
+     compile, ['-dcore-lint'])
 test('T13708', normal, compile, [''])
 
 # thunk should inline here, so check whether or not it appears in the Core
diff --git a/testsuite/tests/simplCore/should_run/T14868.hs b/testsuite/tests/simplCore/should_run/T14868.hs
new file mode 100644
index 0000000000..4d32c30eab
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T14868.hs
@@ -0,0 +1,2 @@
+{-# OPTIONS -O -g #-}
+main = print (4, "foo")
diff --git a/testsuite/tests/simplCore/should_run/T14868.stdout b/testsuite/tests/simplCore/should_run/T14868.stdout
new file mode 100644
index 0000000000..5dfd2f7b0d
--- /dev/null
+++ b/testsuite/tests/simplCore/should_run/T14868.stdout
@@ -0,0 +1 @@
+(4,"foo")
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index d922f90e75..d1ea496af3 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -79,3 +79,6 @@ test('T13429_2', normal, compile_and_run, [''])
 test('T13750', normal, compile_and_run, [''])
 test('T14178', normal, compile_and_run, [''])
 test('T14768', reqlib('vector'), compile_and_run, [''])
+test('T14868',
+     [when((arch('powerpc64') or arch('powerpc64le')), expect_broken(11261))],
+     compile_and_run, [''])