Allow top-level string literals in Core (#8472)

This commits relaxes the invariants of the Core syntax so that a
top-level variable can be bound to a primitive string literal of type
Addr#.

This commit:

* Relaxes the invatiants of the Core, and allows top-level bindings whose
  type is Addr# as long as their RHS is either a primitive string literal or
  another variable.

* Allows the simplifier and the full-laziness transformer to float out
  primitive string literals to the top leve.

* Introduces the new StgGenTopBinding type to accomodate top-level Addr#
  bindings.

* Introduces a new type of labels in the object code, with the suffix "_bytes",
  for exported top-level Addr# bindings.

* Makes some built-in rules more robust. This was necessary to keep them
  functional after the above changes.

This is a continuation of D2554.

Rebasing notes:
This had two slightly suspicious performance regressions:

* T12425: bytes allocated regressed by roughly 5%
* T4029: bytes allocated regressed by a bit over 1%
* T13035: bytes allocated regressed by a bit over 5%

These deserve additional investigation.

Rebased by: bgamari.

Test Plan: ./validate --slow

Reviewers: goldfire, trofi, simonmar, simonpj, austin, hvr, bgamari

Reviewed By: trofi, simonpj, bgamari

Subscribers: trofi, simonpj, gridaphobe, thomie

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

GHC Trac Issues: #8472

53 files changed, 830 insertions, 275 deletions

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 0f3410a66e..ee87ef1b37 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -26,6 +26,7 @@ module CLabel (
         mkApEntryLabel,
         mkApInfoTableLabel,
         mkClosureTableLabel,
+        mkBytesLabel,
 
         mkLocalClosureLabel,
         mkLocalInfoTableLabel,
@@ -389,6 +390,9 @@ data IdLabelInfo
 
   | ClosureTable        -- ^ Table of closures for Enum tycons
 
+  | Bytes               -- ^ Content of a string literal. See
+                        -- Note [Bytes label].
+
   deriving (Eq, Ord)
 
 
@@ -474,6 +478,7 @@ mkClosureTableLabel         :: Name -> CafInfo -> CLabel
 mkLocalConInfoTableLabel    :: CafInfo -> Name -> CLabel
 mkLocalConEntryLabel        :: CafInfo -> Name -> CLabel
 mkConInfoTableLabel         :: Name -> CafInfo -> CLabel
+mkBytesLabel                :: Name -> CLabel
 mkClosureLabel name         c     = IdLabel name c Closure
 mkInfoTableLabel name       c     = IdLabel name c InfoTable
 mkEntryLabel name           c     = IdLabel name c Entry
@@ -481,6 +486,7 @@ mkClosureTableLabel name    c     = IdLabel name c ClosureTable
 mkLocalConInfoTableLabel    c con = IdLabel con c ConInfoTable
 mkLocalConEntryLabel        c con = IdLabel con c ConEntry
 mkConInfoTableLabel name    c     = IdLabel name c ConInfoTable
+mkBytesLabel name                 = IdLabel name NoCafRefs Bytes
 
 mkConEntryLabel       :: Name -> CafInfo -> CLabel
 mkConEntryLabel name        c     = IdLabel name c ConEntry
@@ -935,6 +941,7 @@ idInfoLabelType info =
     ConInfoTable  -> DataLabel
     ClosureTable  -> DataLabel
     RednCounts    -> DataLabel
+    Bytes         -> DataLabel
     _             -> CodeLabel
 
 
@@ -1056,6 +1063,11 @@ export this because in other modules we either have
        * A saturated call 'Just x'; allocate using Just_con_info
 Not exporting these Just_info labels reduces the number of symbols
 somewhat.
+
+Note [Bytes label]
+~~~~~~~~~~~~~~~~~~
+For a top-level string literal 'foo', we have just one symbol 'foo_bytes', which
+points to a static data block containing the content of the literal.
 -}
 
 instance Outputable CLabel where
@@ -1234,6 +1246,7 @@ ppIdFlavor x = pp_cSEP <>
                        ConEntry         -> text "con_entry"
                        ConInfoTable     -> text "con_info"
                        ClosureTable     -> text "closure_tbl"
+                       Bytes            -> text "bytes"
                       )
 
 
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index b9981f247b..b5e800a977 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -400,7 +400,7 @@ mkProfLits _ (ProfilingInfo td cd)
 newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
 newStringLit bytes
   = do { uniq <- getUniqueM
-       ; return (mkByteStringCLit uniq bytes) }
+       ; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }
 
 
 -- Misc utils
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index 3260cbab2f..1dab6eeff5 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -72,7 +72,6 @@ import Cmm
 import BlockId
 import CLabel
 import Outputable
-import Unique
 import DynFlags
 import Util
 import CodeGen.Platform
@@ -169,13 +168,13 @@ zeroExpr dflags = CmmLit (zeroCLit dflags)
 mkWordCLit :: DynFlags -> Integer -> CmmLit
 mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)
 
-mkByteStringCLit :: Unique -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
+mkByteStringCLit
+  :: CLabel -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
 -- We have to make a top-level decl for the string,
 -- and return a literal pointing to it
-mkByteStringCLit uniq bytes
-  = (CmmLabel lbl, CmmData (Section sec lbl)  $ Statics lbl [CmmString bytes])
+mkByteStringCLit lbl bytes
+  = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes])
   where
-    lbl = mkStringLitLabel uniq
     -- This can not happen for String literals (as there \NUL is replaced by
     -- C0 80). However, it can happen with Addr# literals.
     sec = if 0 `elem` bytes then ReadOnlyData else CString
diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs
index bb82da265e..a420677625 100644
--- a/compiler/codeGen/StgCmm.hs
+++ b/compiler/codeGen/StgCmm.hs
@@ -24,6 +24,7 @@ import StgCmmHpc
 import StgCmmTicky
 
 import Cmm
+import CmmUtils
 import CLabel
 
 import StgSyn
@@ -45,6 +46,7 @@ import BasicTypes
 import OrdList
 import MkGraph
 
+import qualified Data.ByteString as BS
 import Data.IORef
 import Control.Monad (when,void)
 import Util
@@ -53,7 +55,7 @@ codeGen :: DynFlags
         -> Module
         -> [TyCon]
         -> CollectedCCs                -- (Local/global) cost-centres needing declaring/registering.
-        -> [StgBinding]                -- Bindings to convert
+        -> [StgTopBinding]             -- Bindings to convert
         -> HpcInfo
         -> Stream IO CmmGroup ()       -- Output as a stream, so codegen can
                                         -- be interleaved with output
@@ -113,8 +115,8 @@ This is so that we can write the top level processing in a compositional
 style, with the increasing static environment being plumbed as a state
 variable. -}
 
-cgTopBinding :: DynFlags -> StgBinding -> FCode ()
-cgTopBinding dflags (StgNonRec id rhs)
+cgTopBinding :: DynFlags -> StgTopBinding -> FCode ()
+cgTopBinding dflags (StgTopLifted (StgNonRec id rhs))
   = do  { id' <- maybeExternaliseId dflags id
         ; let (info, fcode) = cgTopRhs dflags NonRecursive id' rhs
         ; fcode
@@ -122,7 +124,7 @@ cgTopBinding dflags (StgNonRec id rhs)
                         -- so we find it when we look up occurrences
         }
 
-cgTopBinding dflags (StgRec pairs)
+cgTopBinding dflags (StgTopLifted (StgRec pairs))
   = do  { let (bndrs, rhss) = unzip pairs
         ; bndrs' <- Prelude.mapM (maybeExternaliseId dflags) bndrs
         ; let pairs' = zip bndrs' rhss
@@ -132,6 +134,13 @@ cgTopBinding dflags (StgRec pairs)
         ; sequence_ fcodes
         }
 
+cgTopBinding dflags (StgTopStringLit id str)
+  = do  { id' <- maybeExternaliseId dflags id
+        ; let label = mkBytesLabel (idName id')
+        ; let (lit, decl) = mkByteStringCLit label (BS.unpack str)
+        ; emitDecl decl
+        ; addBindC (litIdInfo dflags id' mkLFStringLit lit)
+        }
 
 cgTopRhs :: DynFlags -> RecFlag -> Id -> StgRhs -> (CgIdInfo, FCode ())
         -- The Id is passed along for setting up a binding...
diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs
index 3cc0af0669..e799ea6639 100644
--- a/compiler/codeGen/StgCmmClosure.hs
+++ b/compiler/codeGen/StgCmmClosure.hs
@@ -26,6 +26,7 @@ module StgCmmClosure (
         StandardFormInfo,        -- ...ditto...
         mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo,
         mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
+        mkLFStringLit,
         lfDynTag,
         maybeIsLFCon, isLFThunk, isLFReEntrant, lfUpdatable,
 
@@ -332,6 +333,10 @@ mkLFImported id
   where
     arity = idFunRepArity id
 
+-------------
+mkLFStringLit :: LambdaFormInfo
+mkLFStringLit = LFUnlifted
+
 -----------------------------------------------------
 --                Dynamic pointer tagging
 -----------------------------------------------------
diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs
index ba093fee88..3061fb351b 100644
--- a/compiler/codeGen/StgCmmEnv.hs
+++ b/compiler/codeGen/StgCmmEnv.hs
@@ -40,7 +40,10 @@ import MkGraph
 import Name
 import Outputable
 import StgSyn
+import Type
+import TysPrim
 import UniqFM
+import Util
 import VarEnv
 
 -------------------------------------
@@ -125,8 +128,15 @@ getCgIdInfo id
                 -- Should be imported; make up a CgIdInfo for it
           let name = idName id
         ; if isExternalName name then
-              let ext_lbl = CmmLabel (mkClosureLabel name $ idCafInfo id)
-              in return (litIdInfo dflags id (mkLFImported id) ext_lbl)
+              let ext_lbl
+                      | isUnliftedType (idType id) =
+                          -- An unlifted external Id must refer to a top-level
+                          -- string literal. See Note [Bytes label] in CLabel.
+                          ASSERT( idType id `eqType` addrPrimTy )
+                          mkBytesLabel name
+                      | otherwise = mkClosureLabel name $ idCafInfo id
+              in return $
+                  litIdInfo dflags id (mkLFImported id) (CmmLabel ext_lbl)
           else
               cgLookupPanic id -- Bug
         }}}
diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs
index 4a976e68af..295ac15a85 100644
--- a/compiler/codeGen/StgCmmUtils.hs
+++ b/compiler/codeGen/StgCmmUtils.hs
@@ -322,7 +322,7 @@ newStringCLit str = newByteStringCLit (map (fromIntegral . ord) str)
 newByteStringCLit :: [Word8] -> FCode CmmLit
 newByteStringCLit bytes
   = do  { uniq <- newUnique
-        ; let (lit, decl) = mkByteStringCLit uniq bytes
+        ; let (lit, decl) = mkByteStringCLit (mkStringLitLabel uniq) bytes
         ; emitDecl decl
         ; return lit }
 
diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs
index f9e7f863c4..c09b4a0288 100644
--- a/compiler/coreSyn/CoreLint.hs
+++ b/compiler/coreSyn/CoreLint.hs
@@ -30,6 +30,7 @@ import Bag
 import Literal
 import DataCon
 import TysWiredIn
+import TysPrim
 import TcType ( isFloatingTy )
 import Var
 import VarEnv
@@ -480,14 +481,25 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
         -- Check the let/app invariant
         -- See Note [CoreSyn let/app invariant] in CoreSyn
        ; checkL (not (isUnliftedType binder_ty)
-            || (isNonRec rec_flag && exprOkForSpeculation rhs))
+            || (isNonRec rec_flag && exprOkForSpeculation rhs)
+            || exprIsLiteralString rhs)
            (mkRhsPrimMsg binder rhs)
 
-        -- Check that if the binder is top-level or recursive, it's not demanded
+        -- Check that if the binder is top-level or recursive, it's not
+        -- demanded. Primitive string literals are exempt as there is no
+        -- computation to perform, see Note [CoreSyn top-level string literals].
        ; checkL (not (isStrictId binder)
-            || (isNonRec rec_flag && not (isTopLevel top_lvl_flag)))
+            || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))
+            || exprIsLiteralString 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)
+           (mkTopNonLitStrMsg binder)
+
        ; flags <- getLintFlags
        ; when (lf_check_inline_loop_breakers flags
                && isStrongLoopBreaker (idOccInfo binder)
@@ -2033,6 +2045,10 @@ mkNonTopExternalNameMsg :: Id -> MsgDoc
 mkNonTopExternalNameMsg binder
   = hsep [text "Non-top-level binder has an external name:", ppr binder]
 
+mkTopNonLitStrMsg :: Id -> MsgDoc
+mkTopNonLitStrMsg binder
+  = hsep [text "Top-level Addr# binder has a non-literal rhs:", ppr binder]
+
 mkKindErrMsg :: TyVar -> Type -> MsgDoc
 mkKindErrMsg tyvar arg_ty
   = vcat [text "Kinds don't match in type application:",
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs
index c93a121c23..fb650f61be 100644
--- a/compiler/coreSyn/CorePrep.hs
+++ b/compiler/coreSyn/CorePrep.hs
@@ -1168,7 +1168,9 @@ deFloatTop (Floats _ floats)
   = foldrOL get [] floats
   where
     get (FloatLet b) bs = occurAnalyseRHSs b : bs
-    get b            _  = pprPanic "corePrepPgm" (ppr b)
+    get (FloatCase var body _) bs  =
+      occurAnalyseRHSs (NonRec var body) : bs
+    get b _ = pprPanic "corePrepPgm" (ppr b)
 
     -- See Note [Dead code in CorePrep]
     occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr_NoBinderSwap e)
diff --git a/compiler/coreSyn/CoreSubst.hs b/compiler/coreSyn/CoreSubst.hs
index d98536caec..758a17b34d 100644
--- a/compiler/coreSyn/CoreSubst.hs
+++ b/compiler/coreSyn/CoreSubst.hs
@@ -1339,7 +1339,7 @@ than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn
 exprIsLiteral_maybe :: InScopeEnv -> CoreExpr -> Maybe Literal
 -- Same deal as exprIsConApp_maybe, but much simpler
 -- Nevertheless we do need to look through unfoldings for
--- Integer literals, which are vigorously hoisted to top level
+-- Integer and string literals, which are vigorously hoisted to top level
 -- and not subsequently inlined
 exprIsLiteral_maybe env@(_, id_unf) e
   = case e of
diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs
index fd0cf3ed26..4dfd9c3dae 100644
--- a/compiler/coreSyn/CoreSyn.hs
+++ b/compiler/coreSyn/CoreSyn.hs
@@ -191,7 +191,9 @@ These data types are the heart of the compiler
 --
 --    The right hand sides of all top-level and recursive @let@s
 --    /must/ be of lifted type (see "Type#type_classification" for
---    the meaning of /lifted/ vs. /unlifted/).
+--    the meaning of /lifted/ vs. /unlifted/). There is one exception
+--    to this rule, top-level @let@s are allowed to bind primitive
+--    string literals, see Note [CoreSyn top-level string literals].
 --
 --    See Note [CoreSyn let/app invariant]
 --    See Note [Levity polymorphism invariants]
@@ -361,6 +363,46 @@ Note [CoreSyn letrec invariant]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 See #letrec_invariant#
 
+Note [CoreSyn top-level string literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+As an exception to the usual rule that top-level binders must be lifted,
+we allow binding primitive string literals (of type Addr#) of type Addr# at the
+top level. This allows us to share string literals earlier in the pipeline and
+crucially allows other optimizations in the Core2Core pipeline to fire.
+Consider,
+
+  f n = let a::Addr# = "foo"#
+        in \x -> blah
+
+In order to be able to inline `f`, we would like to float `a` to the top.
+Another option would be to inline `a`, but that would lead to duplicating string
+literals, which we want to avoid. See Trac #8472.
+
+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.
+
+Also see Note [Compilation plan for top-level string literals].
+
+Note [Compilation plan for top-level string literals]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+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.
+
+* 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
+  new top-level string literals.
+
+* In STG, top-level string literals are explicitly represented in the syntax
+  tree.
+
+* A top-level string literal may end up exported from a module. In this case,
+  in the object file, the content of the exported literal is given a label with
+  the _bytes suffix.
+
 Note [CoreSyn let/app invariant]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 The let/app invariant
diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs
index 2505fcfff4..b5d248e579 100644
--- a/compiler/coreSyn/CoreUtils.hs
+++ b/compiler/coreSyn/CoreUtils.hs
@@ -29,6 +29,7 @@ module CoreUtils (
         exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprIsWorkFree,
         exprIsBig, exprIsConLike,
         rhsIsStatic, isCheapApp, isExpandableApp,
+        exprIsLiteralString, exprIsTopLevelBindable,
 
         -- * Equality
         cheapEqExpr, cheapEqExpr', eqExpr,
@@ -1581,6 +1582,17 @@ tick is there to tell us that the expression was evaluated, so we
 don't want to discard a seq on it.
 -}
 
+-- | Can we bind this 'CoreExpr' at the top level?
+exprIsTopLevelBindable :: CoreExpr -> Bool
+-- See Note [CoreSyn top-level string literals]
+exprIsTopLevelBindable expr
+  = exprIsLiteralString expr
+  || not (isUnliftedType (exprType expr))
+
+exprIsLiteralString :: CoreExpr -> Bool
+exprIsLiteralString (Lit (MachStr _)) = True
+exprIsLiteralString _ = False
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/ghci/ByteCodeAsm.hs
index 817e379003..9eb730ff1a 100644
--- a/compiler/ghci/ByteCodeAsm.hs
+++ b/compiler/ghci/ByteCodeAsm.hs
@@ -89,9 +89,10 @@ bcoFreeNames bco
 
 -- Top level assembler fn.
 assembleBCOs
-  :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> Maybe ModBreaks
+  :: HscEnv -> [ProtoBCO Name] -> [TyCon] -> [RemotePtr ()]
+  -> Maybe ModBreaks
   -> IO CompiledByteCode
-assembleBCOs hsc_env proto_bcos tycons modbreaks = do
+assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do
   itblenv <- mkITbls hsc_env tycons
   bcos    <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos
   (bcos',ptrs) <- mallocStrings hsc_env bcos
@@ -99,7 +100,7 @@ assembleBCOs hsc_env proto_bcos tycons modbreaks = do
     { bc_bcos = bcos'
     , bc_itbls =  itblenv
     , bc_ffis = concat (map protoBCOFFIs proto_bcos)
-    , bc_strs = ptrs
+    , bc_strs = top_strs ++ ptrs
     , bc_breaks = modbreaks
     }
 
diff --git a/compiler/ghci/ByteCodeGen.hs b/compiler/ghci/ByteCodeGen.hs
index a4373b459f..f4b224d2a5 100644
--- a/compiler/ghci/ByteCodeGen.hs
+++ b/compiler/ghci/ByteCodeGen.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, MagicHash, RecordWildCards #-}
+{-# LANGUAGE CPP, MagicHash, RecordWildCards, BangPatterns #-}
 {-# OPTIONS_GHC -fprof-auto-top #-}
 --
 --  (c) The University of Glasgow 2002-2006
@@ -48,6 +48,7 @@ import SMRep
 import Bitmap
 import OrdList
 import Maybes
+import VarEnv
 
 import Data.List
 import Foreign
@@ -60,6 +61,7 @@ import Control.Arrow ( second )
 
 import Control.Exception
 import Data.Array
+import Data.ByteString (ByteString)
 import Data.Map (Map)
 import Data.IntMap (IntMap)
 import qualified Data.Map as Map
@@ -85,12 +87,18 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
    = withTiming (pure dflags)
                 (text "ByteCodeGen"<+>brackets (ppr this_mod))
                 (const ()) $ do
-        let flatBinds = [ (bndr, simpleFreeVars rhs)
-                        | (bndr, rhs) <- flattenBinds binds]
+        -- Split top-level binds into strings and others.
+        -- 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)
+                    _ -> Right (bndr, simpleFreeVars rhs)
+        stringPtrs <- allocateTopStrings hsc_env strings
 
         us <- mkSplitUniqSupply 'y'
         (BcM_State{..}, proto_bcos) <-
-           runBc hsc_env us this_mod mb_modBreaks $
+           runBc hsc_env us this_mod mb_modBreaks (mkVarEnv stringPtrs) $
              mapM schemeTopBind flatBinds
 
         when (notNull ffis)
@@ -99,7 +107,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
         dumpIfSet_dyn dflags Opt_D_dump_BCOs
            "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos)))
 
-        cbc <- assembleBCOs hsc_env proto_bcos tycs
+        cbc <- assembleBCOs hsc_env proto_bcos tycs (map snd stringPtrs)
           (case modBreaks of
              Nothing -> Nothing
              Just mb -> Just mb{ modBreaks_breakInfo = breakInfo })
@@ -116,6 +124,29 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks
 
   where dflags = hsc_dflags hsc_env
 
+allocateTopStrings
+  :: HscEnv
+  -> [(Id, ByteString)]
+  -> IO [(Var, RemotePtr ())]
+allocateTopStrings hsc_env topStrings = do
+  let !(bndrs, strings) = unzip topStrings
+  ptrs <- iservCmd hsc_env $ MallocStrings strings
+  return $ zip bndrs ptrs
+
+{-
+Note [generating code for top-level string literal bindings]
+
+Here is a summary on how the byte code generator deals with top-level string
+literals:
+
+1. Top-level string literal bindings are spearted from the rest of the module.
+
+2. The strings are allocated via iservCmd, in allocateTopStrings
+
+3. The mapping from binders to allocated strings (topStrings) are maintained in
+   BcM and used when generating code for variable references.
+-}
+
 -- -----------------------------------------------------------------------------
 -- Generating byte code for an expression
 
@@ -136,8 +167,8 @@ coreExprToBCOs hsc_env this_mod expr
       -- the uniques are needed to generate fresh variables when we introduce new
       -- let bindings for ticked expressions
       us <- mkSplitUniqSupply 'y'
-      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ , proto_bco)
-         <- runBc hsc_env us this_mod Nothing $
+      (BcM_State _dflags _us _this_mod _final_ctr mallocd _ _ _, proto_bco)
+         <- runBc hsc_env us this_mod Nothing emptyVarEnv $
               schemeTopBind (invented_id, simpleFreeVars expr)
 
       when (notNull mallocd)
@@ -1356,11 +1387,16 @@ pushAtom d p (AnnVar v)
          -- slots on to the top of the stack.
 
    | otherwise  -- v must be a global variable
-   = do dflags <- getDynFlags
-        let sz :: Word16
-            sz = fromIntegral (idSizeW dflags v)
-        MASSERT(sz == 1)
-        return (unitOL (PUSH_G (getName v)), sz)
+   = do topStrings <- getTopStrings
+        case lookupVarEnv topStrings v of
+            Just ptr -> pushAtom d p $ AnnLit $ MachWord $ fromIntegral $
+              ptrToWordPtr $ fromRemotePtr ptr
+            Nothing -> do
+                dflags <- getDynFlags
+                let sz :: Word16
+                    sz = fromIntegral (idSizeW dflags v)
+                MASSERT(sz == 1)
+                return (unitOL (PUSH_G (getName v)), sz)
 
 
 pushAtom _ _ (AnnLit lit) = do
@@ -1659,6 +1695,8 @@ data BcM_State
                                          -- Should be free()d when it is GCd
         , modBreaks   :: Maybe ModBreaks -- info about breakpoints
         , breakInfo   :: IntMap CgBreakInfo
+        , topStrings  :: IdEnv (RemotePtr ()) -- top-level string literals
+          -- See Note [generating code for top-level string literal bindings].
         }
 
 newtype BcM r = BcM (BcM_State -> IO (BcM_State, r))
@@ -1668,10 +1706,12 @@ ioToBc io = BcM $ \st -> do
   x <- io
   return (st, x)
 
-runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks -> BcM r
+runBc :: HscEnv -> UniqSupply -> Module -> Maybe ModBreaks
+      -> IdEnv (RemotePtr ())
+      -> BcM r
       -> IO (BcM_State, r)
-runBc hsc_env us this_mod modBreaks (BcM m)
-   = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty)
+runBc hsc_env us this_mod modBreaks topStrings (BcM m)
+   = m (BcM_State hsc_env us this_mod 0 [] modBreaks IntMap.empty topStrings)
 
 thenBc :: BcM a -> (a -> BcM b) -> BcM b
 thenBc (BcM expr) cont = BcM $ \st0 -> do
@@ -1746,6 +1786,9 @@ newUnique = BcM $
 getCurrentModule :: BcM Module
 getCurrentModule = BcM $ \st -> return (st, thisModule st)
 
+getTopStrings :: BcM (IdEnv (RemotePtr ()))
+getTopStrings = BcM $ \st -> return (st, topStrings st)
+
 newId :: Type -> BcM Id
 newId ty = do
     uniq <- newUnique
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index b163cbbe21..092f04c1aa 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -1363,7 +1363,7 @@ hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
 
 doCodeGen   :: HscEnv -> Module -> [TyCon]
             -> CollectedCCs
-            -> [StgBinding]
+            -> [StgTopBinding]
             -> HpcInfo
             -> IO (Stream IO CmmGroup ())
          -- Note we produce a 'Stream' of CmmGroups, so that the
@@ -1429,7 +1429,7 @@ doCodeGen hsc_env this_mod data_tycons
 
 
 myCoreToStg :: DynFlags -> Module -> CoreProgram
-            -> IO ( [StgBinding] -- output program
+            -> IO ( [StgTopBinding] -- output program
                   , CollectedCCs) -- cost centre info (declared and used)
 myCoreToStg dflags this_mod prepd_binds = do
     let stg_binds
diff --git a/compiler/prelude/PrelRules.hs b/compiler/prelude/PrelRules.hs
index e98fd9f6a3..c2938c7dfd 100644
--- a/compiler/prelude/PrelRules.hs
+++ b/compiler/prelude/PrelRules.hs
@@ -987,9 +987,9 @@ builtinRules :: [CoreRule]
 builtinRules
   = [BuiltinRule { ru_name = fsLit "AppendLitString",
                    ru_fn = unpackCStringFoldrName,
-                   ru_nargs = 4, ru_try = \_ _ _ -> match_append_lit },
+                   ru_nargs = 4, ru_try = match_append_lit },
      BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName,
-                   ru_nargs = 2, ru_try = \dflags _ _ -> match_eq_string dflags },
+                   ru_nargs = 2, ru_try = match_eq_string },
      BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName,
                    ru_nargs = 2, ru_try = \_ _ _ -> match_inline },
      BuiltinRule { ru_name = fsLit "MagicDict", ru_fn = idName magicDictId,
@@ -1133,37 +1133,42 @@ builtinIntegerRules =
 --      unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n)
 --      =  unpackFoldrCString# "foobaz" c n
 
-match_append_lit :: [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_append_lit [Type ty1,
-                    Lit (MachStr s1),
-                    c1,
-                    Var unpk `App` Type ty2
-                             `App` Lit (MachStr s2)
-                             `App` c2
-                             `App` n
-                   ]
+match_append_lit :: RuleFun
+match_append_lit _ id_unf _
+        [ Type ty1
+        , lit1
+        , c1
+        , Var unpk `App` Type ty2
+                   `App` lit2
+                   `App` c2
+                   `App` n
+        ]
   | unpk `hasKey` unpackCStringFoldrIdKey &&
     c1 `cheapEqExpr` c2
+  , Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1
+  , Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2
   = ASSERT( ty1 `eqType` ty2 )
     Just (Var unpk `App` Type ty1
                    `App` Lit (MachStr (s1 `BS.append` s2))
                    `App` c1
                    `App` n)
 
-match_append_lit _ = Nothing
+match_append_lit _ _ _ _ = Nothing
 
 ---------------------------------------------------
 -- The rule is this:
 --      eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2
 
-match_eq_string :: DynFlags -> [Expr CoreBndr] -> Maybe (Expr CoreBndr)
-match_eq_string _ [Var unpk1 `App` Lit (MachStr s1),
-                        Var unpk2 `App` Lit (MachStr s2)]
-  | unpk1 `hasKey` unpackCStringIdKey,
-    unpk2 `hasKey` unpackCStringIdKey
+match_eq_string :: RuleFun
+match_eq_string _ id_unf _
+        [Var unpk1 `App` lit1, Var unpk2 `App` lit2]
+  | unpk1 `hasKey` unpackCStringIdKey
+  , unpk2 `hasKey` unpackCStringIdKey
+  , Just (MachStr s1) <- exprIsLiteral_maybe id_unf lit1
+  , Just (MachStr s2) <- exprIsLiteral_maybe id_unf lit2
   = Just (if s1 == s2 then trueValBool else falseValBool)
 
-match_eq_string _ _ = Nothing
+match_eq_string _ _ _ _ = Nothing
 
 
 ---------------------------------------------------
diff --git a/compiler/profiling/SCCfinal.hs b/compiler/profiling/SCCfinal.hs
index ee37ab14b6..9704e0b132 100644
--- a/compiler/profiling/SCCfinal.hs
+++ b/compiler/profiling/SCCfinal.hs
@@ -42,8 +42,8 @@ stgMassageForProfiling
         :: DynFlags
         -> Module                       -- module name
         -> UniqSupply                   -- unique supply
-        -> [StgBinding]                 -- input
-        -> (CollectedCCs, [StgBinding])
+        -> [StgTopBinding]              -- input
+        -> (CollectedCCs, [StgTopBinding])
 
 stgMassageForProfiling dflags mod_name _us stg_binds
   = let
@@ -69,24 +69,28 @@ stgMassageForProfiling dflags mod_name _us stg_binds
     all_cafs_ccs = mkSingletonCCS all_cafs_cc
 
     ----------
-    do_top_bindings :: [StgBinding] -> MassageM [StgBinding]
+    do_top_bindings :: [StgTopBinding] -> MassageM [StgTopBinding]
 
     do_top_bindings [] = return []
 
-    do_top_bindings (StgNonRec b rhs : bs) = do
+    do_top_bindings (StgTopLifted (StgNonRec b rhs) : bs) = do
         rhs' <- do_top_rhs b rhs
         bs' <- do_top_bindings bs
-        return (StgNonRec b rhs' : bs')
+        return (StgTopLifted (StgNonRec b rhs') : bs')
 
-    do_top_bindings (StgRec pairs : bs) = do
+    do_top_bindings (StgTopLifted (StgRec pairs) : bs) = do
         pairs2 <- mapM do_pair pairs
         bs' <- do_top_bindings bs
-        return (StgRec pairs2 : bs')
+        return (StgTopLifted (StgRec pairs2) : bs')
       where
         do_pair (b, rhs) = do
              rhs2 <- do_top_rhs b rhs
              return (b, rhs2)
 
+    do_top_bindings (b@StgTopStringLit{} : bs) = do
+        bs' <- do_top_bindings bs
+        return (b : bs')
+
     ----------
     do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
 
diff --git a/compiler/simplCore/CSE.hs b/compiler/simplCore/CSE.hs
index 54fbc5008c..e364c31cdc 100644
--- a/compiler/simplCore/CSE.hs
+++ b/compiler/simplCore/CSE.hs
@@ -15,6 +15,7 @@ import Var              ( Var )
 import Id               ( Id, idType, idUnfolding, idInlineActivation
                         , zapIdOccInfo, zapIdUsageInfo )
 import CoreUtils        ( mkAltExpr
+                        , exprIsLiteralString
                         , stripTicksE, stripTicksT, mkTicks )
 import Literal          ( litIsTrivial )
 import Type             ( tyConAppArgs )
@@ -253,22 +254,22 @@ had
 -}
 
 cseProgram :: CoreProgram -> CoreProgram
-cseProgram binds = snd (mapAccumL cseBind emptyCSEnv binds)
+cseProgram binds = snd (mapAccumL (cseBind True) emptyCSEnv binds)
 
-cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind)
-cseBind env (NonRec b e)
+cseBind :: Bool -> CSEnv -> CoreBind -> (CSEnv, CoreBind)
+cseBind toplevel env (NonRec b e)
   = (env2, NonRec b2 e1)
   where
-    e1         = tryForCSE env e
+    e1         = tryForCSE toplevel env e
     (env1, b1) = addBinder env b
     (env2, b2) = addBinding env1 b b1 e1
 
-cseBind env (Rec pairs)
+cseBind toplevel env (Rec pairs)
   = (env2, Rec pairs')
   where
     (bndrs, rhss)  = unzip pairs
     (env1, bndrs1) = addRecBinders env bndrs
-    rhss1          = map (tryForCSE env1) rhss
+    rhss1          = map (tryForCSE toplevel env1) rhss
                      -- Process rhss in extended env1
     (env2, pairs') = foldl do_one (env1, []) (zip3 bndrs bndrs1 rhss1)
     do_one (env, pairs) (b, b1, e1)
@@ -311,8 +312,38 @@ addBinding env in_id out_id rhs'
                    Lit l  -> litIsTrivial l
                    _      -> False
 
-tryForCSE :: CSEnv -> InExpr -> OutExpr
-tryForCSE env expr
+{-
+Note [Take care with literal strings]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Consider this example:
+
+  x = "foo"#
+  y = "foo"#
+  ...x...y...x...y....
+
+We would normally turn this into:
+
+  x = "foo"#
+  y = x
+  ...x...x...x...x....
+
+But this breaks an invariant of Core, namely that the RHS of a top-level binding
+of type Addr# must be a string literal, not another variable. See Note
+[CoreSyn top-level string literals] in CoreSyn.
+
+For this reason, we special case top-level bindings to literal strings and leave
+the original RHS unmodified. This produces:
+
+  x = "foo"#
+  y = "foo"#
+  ...x...x...x...x....
+-}
+
+tryForCSE :: Bool -> CSEnv -> InExpr -> OutExpr
+tryForCSE toplevel env expr
+  | toplevel && exprIsLiteralString expr = expr
+      -- See Note [Take care with literal strings]
   | Just e <- lookupCSEnv env expr'' = mkTicks ticks e
   | otherwise                        = expr'
     -- The varToCoreExpr is needed if we have
@@ -333,12 +364,12 @@ cseExpr env (Type t)              = Type (substTy (csEnvSubst env) t)
 cseExpr env (Coercion c)          = Coercion (substCo (csEnvSubst env) c)
 cseExpr _   (Lit lit)             = Lit lit
 cseExpr env (Var v)               = lookupSubst env v
-cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE env a)
+cseExpr env (App f a)             = App (cseExpr env f) (tryForCSE False env a)
 cseExpr env (Tick t e)            = Tick t (cseExpr env e)
 cseExpr env (Cast e co)           = Cast (cseExpr env e) (substCo (csEnvSubst env) co)
 cseExpr env (Lam b e)             = let (env', b') = addBinder env b
                                     in Lam b' (cseExpr env' e)
-cseExpr env (Let bind e)          = let (env', bind') = cseBind env bind
+cseExpr env (Let bind e)          = let (env', bind') = cseBind False env bind
                                     in Let bind' (cseExpr env' e)
 cseExpr env (Case e bndr ty alts) = cseCase env e bndr ty alts
 
@@ -346,7 +377,7 @@ cseCase :: CSEnv -> InExpr -> InId -> InType -> [InAlt] -> OutExpr
 cseCase env scrut bndr ty alts
   = Case scrut1 bndr3 ty (map cse_alt alts)
   where
-    scrut1 = tryForCSE env scrut
+    scrut1 = tryForCSE False env scrut
 
     bndr1 = zapIdOccInfo bndr
       -- Zapping the OccInfo is needed because the extendCSEnv
@@ -369,14 +400,14 @@ cseCase env scrut bndr ty alts
                 --      case x of { True -> ....True.... }
                 -- Don't replace True by x!
                 -- Hence the 'null args', which also deal with literals and DEFAULT
-        = (DataAlt con, args', tryForCSE new_env rhs)
+        = (DataAlt con, args', tryForCSE False new_env rhs)
         where
           (env', args') = addBinders alt_env args
           new_env       = extendCSEnv env' con_expr con_target
           con_expr      = mkAltExpr (DataAlt con) args' arg_tys
 
     cse_alt (con, args, rhs)
-        = (con, args', tryForCSE env' rhs)
+        = (con, args', tryForCSE False env' rhs)
         where
           (env', args') = addBinders alt_env args
 
diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs
index 0b81f29a7d..955d3ba89d 100644
--- a/compiler/simplCore/SetLevels.hs
+++ b/compiler/simplCore/SetLevels.hs
@@ -67,6 +67,7 @@ import CoreMonad        ( FloatOutSwitches(..) )
 import CoreUtils        ( exprType
                         , isExprLevPoly
                         , exprOkForSpeculation
+                        , exprIsTopLevelBindable
                         , collectMakeStaticArgs
                         )
 import CoreArity        ( exprBotStrictness_maybe )
@@ -494,7 +495,7 @@ lvlMFE strict_ctxt env ann_expr
     lvlExpr env ann_expr
 
   | Just (wrap_float, wrap_use)
-       <- canFloat_maybe rhs_env strict_ctxt float_is_lam expr_ty
+       <- canFloat_maybe rhs_env strict_ctxt float_is_lam expr
   = do { expr1 <- lvlExpr rhs_env ann_expr
        ; let abs_expr = mkLams abs_vars_w_lvls (wrap_float expr1)
        ; var <- newLvlVar abs_expr
@@ -507,7 +508,6 @@ lvlMFE strict_ctxt env ann_expr
 
   where
     expr         = deAnnotate ann_expr
-    expr_ty      = exprType expr
     fvs          = freeVarsOf ann_expr
     is_bot       = isJust mb_bot_str
     mb_bot_str   = exprBotStrictness_maybe expr
@@ -544,12 +544,12 @@ lvlMFE strict_ctxt env ann_expr
 canFloat_maybe :: LevelEnv
                -> Bool      -- Strict context
                -> Bool      -- The float has a value lambda
-               -> Type
+               -> CoreExpr
                -> Maybe ( LevelledExpr -> LevelledExpr   -- Wrep the flaot
                         , LevelledExpr -> LevelledExpr)  -- Wrap the use
 -- See Note [Floating MFEs of unlifted type]
-canFloat_maybe env strict_ctxt float_is_lam expr_ty
-  | float_is_lam || not (isUnliftedType expr_ty)
+canFloat_maybe env strict_ctxt float_is_lam expr
+  | float_is_lam || exprIsTopLevelBindable expr
   = Just (id, id) -- No wrapping needed if the type is lifted, or
                   -- if we are wrapping it in one or more value lambdas
 
@@ -568,6 +568,7 @@ canFloat_maybe env strict_ctxt float_is_lam expr_ty
 
   | otherwise          -- e.g. do not float unboxed tuples
   = Nothing
+  where expr_ty = exprType expr
 
 {- Note [Floating MFEs of unlifted type]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/simplCore/SimplEnv.hs b/compiler/simplCore/SimplEnv.hs
index 8a26220029..99d8291491 100644
--- a/compiler/simplCore/SimplEnv.hs
+++ b/compiler/simplCore/SimplEnv.hs
@@ -332,7 +332,8 @@ data Floats = Floats (OrdList OutBind) FloatFlag
         -- See Note [Simplifier floats]
 
 data FloatFlag
-  = FltLifted   -- All bindings are lifted and lazy
+  = FltLifted   -- All bindings are lifted and lazy *or*
+                --     consist of a single primitive string literal
                 --  Hence ok to float to top level, or recursive
 
   | FltOkSpec   -- All bindings are FltLifted *or*
@@ -395,6 +396,9 @@ unitFloat bind = Floats (unitOL bind) (flag bind)
     flag (Rec {})                = FltLifted
     flag (NonRec bndr rhs)
       | not (isStrictId bndr)    = FltLifted
+      | exprIsLiteralString rhs  = FltLifted
+          -- String literals can be floated freely.
+          -- See Note [CoreSyn top-level string ltierals] 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 2c8ff5e941..9e5c00d284 100644
--- a/compiler/simplCore/Simplify.hs
+++ b/compiler/simplCore/Simplify.hs
@@ -581,7 +581,7 @@ makeTrivialWithInfo :: TopLevelFlag -> SimplEnv
 -- Returned SimplEnv has same substitution as incoming one
 makeTrivialWithInfo top_lvl env context info expr
   | exprIsTrivial expr                          -- Already trivial
-  || not (bindingOk top_lvl expr expr_ty)       -- Cannot trivialise
+  || not (bindingOk top_lvl expr)               -- Cannot trivialise
                                                 --   See Note [Cannot trivialise]
   = return (env, expr)
   | otherwise           -- See Note [Take care] below
@@ -603,11 +603,11 @@ makeTrivialWithInfo top_lvl env context info expr
   where
     expr_ty = exprType expr
 
-bindingOk :: TopLevelFlag -> CoreExpr -> Type -> Bool
+bindingOk :: TopLevelFlag -> CoreExpr -> Bool
 -- True iff we can have a binding of this expression at this level
 -- Precondition: the type is the type of the expression
-bindingOk top_lvl _ expr_ty
-  | isTopLevel top_lvl = not (isUnliftedType expr_ty)
+bindingOk top_lvl expr
+  | isTopLevel top_lvl = exprIsTopLevelBindable expr
   | otherwise          = True
 
 {-
@@ -626,12 +626,16 @@ so we don't want to turn it into
 because we'll just end up inlining x back, and that makes the
 simplifier loop.  Better not to ANF-ise it at all.
 
-A case in point is literal strings (a MachStr is not regarded as
-trivial):
+Literal strings are an exception.
 
    foo = Ptr "blob"#
 
-We don't want to ANF-ise this.
+We want to turn this into:
+
+   foo1 = "blob"#
+   foo = Ptr foo1
+
+See Note [CoreSyn top-level string literals] in CoreSyn.
 
 ************************************************************************
 *                                                                      *
diff --git a/compiler/simplStg/SimplStg.hs b/compiler/simplStg/SimplStg.hs
index 406e415287..08f9d79782 100644
--- a/compiler/simplStg/SimplStg.hs
+++ b/compiler/simplStg/SimplStg.hs
@@ -14,7 +14,7 @@ import StgSyn
 
 import CostCentre       ( CollectedCCs )
 import SCCfinal         ( stgMassageForProfiling )
-import StgLint          ( lintStgBindings )
+import StgLint          ( lintStgTopBindings )
 import StgStats         ( showStgStats )
 import UnariseStg       ( unarise )
 import StgCse           ( stgCse )
@@ -29,8 +29,8 @@ import Control.Monad
 
 stg2stg :: DynFlags                  -- includes spec of what stg-to-stg passes to do
         -> Module                    -- module name (profiling only)
-        -> [StgBinding]              -- input...
-        -> IO ( [StgBinding]         -- output program...
+        -> [StgTopBinding]           -- input...
+        -> IO ( [StgTopBinding]      -- output program...
               , CollectedCCs)        -- cost centre information (declared and used)
 
 stg2stg dflags module_name binds
@@ -48,19 +48,19 @@ stg2stg dflags module_name binds
                 <- foldM do_stg_pass (binds', us0, ccs) (getStgToDo dflags)
 
         ; dumpIfSet_dyn dflags Opt_D_dump_stg "Pre unarise:"
-                        (pprStgBindings processed_binds)
+                        (pprStgTopBindings processed_binds)
 
         ; let un_binds = unarise us1 processed_binds
 
         ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
-                        (pprStgBindings un_binds)
+                        (pprStgTopBindings un_binds)
 
         ; return (un_binds, cost_centres)
    }
 
   where
     stg_linter = if gopt Opt_DoStgLinting dflags
-                 then lintStgBindings
+                 then lintStgTopBindings
                  else ( \ _whodunnit binds -> binds )
 
     -------------------------------------------
diff --git a/compiler/simplStg/StgCse.hs b/compiler/simplStg/StgCse.hs
index 7454d24a2c..3e141439ed 100644
--- a/compiler/simplStg/StgCse.hs
+++ b/compiler/simplStg/StgCse.hs
@@ -240,7 +240,7 @@ substPairs env bndrs = mapAccumL go env bndrs
 
 -- Main entry point
 
-stgCse :: [InStgBinding] -> [OutStgBinding]
+stgCse :: [InStgTopBinding] -> [OutStgTopBinding]
 stgCse binds = snd $ mapAccumL stgCseTopLvl emptyInScopeSet binds
 
 -- Top level bindings.
@@ -250,15 +250,16 @@ stgCse binds = snd $ mapAccumL stgCseTopLvl emptyInScopeSet binds
 -- But we still have to collect the set of in-scope variables, otherwise
 -- uniqAway might shadow a top-level closure.
 
-stgCseTopLvl :: InScopeSet -> InStgBinding -> (InScopeSet, OutStgBinding)
-stgCseTopLvl in_scope (StgNonRec bndr rhs)
+stgCseTopLvl :: InScopeSet -> InStgTopBinding -> (InScopeSet, OutStgTopBinding)
+stgCseTopLvl in_scope t@(StgTopStringLit _ _) = (in_scope, t)
+stgCseTopLvl in_scope (StgTopLifted (StgNonRec bndr rhs))
     = (in_scope'
-      , StgNonRec bndr (stgCseTopLvlRhs in_scope rhs))
+      , StgTopLifted (StgNonRec bndr (stgCseTopLvlRhs in_scope rhs)))
   where in_scope' = in_scope `extendInScopeSet` bndr
 
-stgCseTopLvl in_scope (StgRec eqs)
+stgCseTopLvl in_scope (StgTopLifted (StgRec eqs))
     = ( in_scope'
-      , StgRec [ (bndr, stgCseTopLvlRhs in_scope' rhs) | (bndr, rhs) <- eqs ])
+      , StgTopLifted (StgRec [ (bndr, stgCseTopLvlRhs in_scope' rhs) | (bndr, rhs) <- eqs ]))
   where in_scope' = in_scope `extendInScopeSetList` [ bndr | (bndr, _) <- eqs ]
 
 stgCseTopLvlRhs :: InScopeSet -> InStgRhs -> OutStgRhs
diff --git a/compiler/simplStg/StgStats.hs b/compiler/simplStg/StgStats.hs
index 38544822d2..3f75ae23fa 100644
--- a/compiler/simplStg/StgStats.hs
+++ b/compiler/simplStg/StgStats.hs
@@ -75,7 +75,7 @@ countN = Map.singleton
 ************************************************************************
 -}
 
-showStgStats :: [StgBinding] -> String
+showStgStats :: [StgTopBinding] -> String
 
 showStgStats prog
   = "STG Statistics:\n\n"
@@ -99,10 +99,8 @@ showStgStats prog
     s (SingleEntryBinds _)    = "SingleEntryBinds_Nested    "
     s (UpdatableBinds _)      = "UpdatableBinds_Nested      "
 
-gatherStgStats :: [StgBinding] -> StatEnv
-
-gatherStgStats binds
-  = combineSEs (map (statBinding True{-top-level-}) binds)
+gatherStgStats :: [StgTopBinding] -> StatEnv
+gatherStgStats binds = combineSEs (map statTopBinding binds)
 
 {-
 ************************************************************************
@@ -112,6 +110,10 @@ gatherStgStats binds
 ************************************************************************
 -}
 
+statTopBinding :: StgTopBinding -> StatEnv
+statTopBinding (StgTopStringLit _ _) = countOne Literals
+statTopBinding (StgTopLifted bind) = statBinding True bind
+
 statBinding :: Bool -- True <=> top-level; False <=> nested
             -> StgBinding
             -> StatEnv
diff --git a/compiler/simplStg/UnariseStg.hs b/compiler/simplStg/UnariseStg.hs
index aa42586cd1..3f67bc278f 100644
--- a/compiler/simplStg/UnariseStg.hs
+++ b/compiler/simplStg/UnariseStg.hs
@@ -264,8 +264,13 @@ extendRho rho x (UnaryVal val)
 
 --------------------------------------------------------------------------------
 
-unarise :: UniqSupply -> [StgBinding] -> [StgBinding]
-unarise us binds = initUs_ us (mapM (unariseBinding emptyVarEnv) binds)
+unarise :: UniqSupply -> [StgTopBinding] -> [StgTopBinding]
+unarise us binds = initUs_ us (mapM (unariseTopBinding emptyVarEnv) binds)
+
+unariseTopBinding :: UnariseEnv -> StgTopBinding -> UniqSM StgTopBinding
+unariseTopBinding rho (StgTopLifted bind)
+  = StgTopLifted <$> unariseBinding rho bind
+unariseTopBinding _ bind@StgTopStringLit{} = return bind
 
 unariseBinding :: UnariseEnv -> StgBinding -> UniqSM StgBinding
 unariseBinding rho (StgNonRec x rhs)
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index dcb923afea..37df9e2146 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -196,7 +196,7 @@ import Control.Monad (liftM, ap)
 -- Setting variable info: top-level, binds, RHSs
 -- --------------------------------------------------------------
 
-coreToStg :: DynFlags -> Module -> CoreProgram -> [StgBinding]
+coreToStg :: DynFlags -> Module -> CoreProgram -> [StgTopBinding]
 coreToStg dflags this_mod pgm
   = pgm'
   where (_, _, pgm') = coreTopBindsToStg dflags this_mod emptyVarEnv pgm
@@ -211,7 +211,7 @@ coreTopBindsToStg
     -> Module
     -> IdEnv HowBound           -- environment for the bindings
     -> CoreProgram
-    -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
+    -> (IdEnv HowBound, FreeVarsInfo, [StgTopBinding])
 
 coreTopBindsToStg _      _        env [] = (env, emptyFVInfo, [])
 coreTopBindsToStg dflags this_mod env (b:bs)
@@ -229,7 +229,14 @@ coreTopBindToStg
         -> IdEnv HowBound
         -> FreeVarsInfo         -- Info about the body
         -> CoreBind
-        -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
+        -> (IdEnv HowBound, FreeVarsInfo, StgTopBinding)
+
+coreTopBindToStg _ _ env body_fvs (NonRec id (Lit (MachStr str)))
+  -- top-level string literal
+  = let
+        env' = extendVarEnv env id how_bound
+        how_bound = LetBound TopLet 0
+    in (env', body_fvs, StgTopStringLit id str)
 
 coreTopBindToStg dflags this_mod env body_fvs (NonRec id rhs)
   = let
@@ -241,7 +248,7 @@ coreTopBindToStg dflags this_mod env body_fvs (NonRec id rhs)
               (stg_rhs, fvs') <- coreToTopStgRhs dflags this_mod body_fvs (id,rhs)
               return (stg_rhs, fvs')
 
-        bind = StgNonRec id stg_rhs
+        bind = StgTopLifted $ StgNonRec id stg_rhs
     in
     ASSERT2(consistentCafInfo id bind, ppr id )
       -- NB: previously the assertion printed 'rhs' and 'bind'
@@ -265,7 +272,7 @@ coreTopBindToStg dflags this_mod env body_fvs (Rec pairs)
                let fvs' = unionFVInfos fvss'
                return (stg_rhss, fvs')
 
-        bind = StgRec (zip binders stg_rhss)
+        bind = StgTopLifted $ StgRec (zip binders stg_rhss)
     in
     ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
     (env', fvs' `unionFVInfo` body_fvs, bind)
@@ -275,7 +282,7 @@ coreTopBindToStg dflags this_mod env body_fvs (Rec pairs)
 -- what CoreToStg has figured out about the binding's SRT.  The
 -- CafInfo will be exact in all cases except when CorePrep has
 -- floated out a binding, in which case it will be approximate.
-consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
+consistentCafInfo :: Id -> GenStgTopBinding Var Id -> Bool
 consistentCafInfo id bind
   = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
     safe
diff --git a/compiler/stgSyn/StgLint.hs b/compiler/stgSyn/StgLint.hs
index e31e7ae015..02d989cec0 100644
--- a/compiler/stgSyn/StgLint.hs
+++ b/compiler/stgSyn/StgLint.hs
@@ -6,7 +6,7 @@
 
 {-# LANGUAGE CPP #-}
 
-module StgLint ( lintStgBindings ) where
+module StgLint ( lintStgTopBindings ) where
 
 import StgSyn
 
@@ -54,12 +54,12 @@ generation.  Solution: don't use it!  (KSW 2000-05).
 *                                                                      *
 ************************************************************************
 
-@lintStgBindings@ is the top-level interface function.
+@lintStgTopBindings@ is the top-level interface function.
 -}
 
-lintStgBindings :: String -> [StgBinding] -> [StgBinding]
+lintStgTopBindings :: String -> [StgTopBinding] -> [StgTopBinding]
 
-lintStgBindings whodunnit binds
+lintStgTopBindings whodunnit binds
   = {-# SCC "StgLint" #-}
     case (initL (lint_binds binds)) of
       Nothing  -> binds
@@ -68,17 +68,20 @@ lintStgBindings whodunnit binds
                               text whodunnit <+> text "***",
                         msg,
                         text "*** Offending Program ***",
-                        pprStgBindings binds,
+                        pprStgTopBindings binds,
                         text "*** End of Offense ***"])
   where
-    lint_binds :: [StgBinding] -> LintM ()
+    lint_binds :: [StgTopBinding] -> LintM ()
 
     lint_binds [] = return ()
     lint_binds (bind:binds) = do
-        binders <- lintStgBinds bind
+        binders <- lint_bind bind
         addInScopeVars binders $
             lint_binds binds
 
+    lint_bind (StgTopLifted bind) = lintStgBinds bind
+    lint_bind (StgTopStringLit v _) = return [v]
+
 lintStgArg :: StgArg -> LintM (Maybe Type)
 lintStgArg (StgLitArg lit) = return (Just (literalType lit))
 lintStgArg (StgVarArg v)   = lintStgVar v
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index 48e836cc56..56978f868c 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -14,7 +14,7 @@ generation.
 module StgSyn (
         GenStgArg(..),
 
-        GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
+        GenStgTopBinding(..), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
         GenStgAlt, AltType(..),
 
         UpdateFlag(..), isUpdatable,
@@ -24,11 +24,12 @@ module StgSyn (
         combineStgBinderInfo,
 
         -- a set of synonyms for the most common (only :-) parameterisation
-        StgArg, StgBinding, StgExpr, StgRhs, StgAlt,
+        StgArg,
+        StgTopBinding, StgBinding, StgExpr, StgRhs, StgAlt,
 
         -- a set of synonyms to distinguish in- and out variants
-        InStgArg,  InStgBinding,  InStgExpr,  InStgRhs,  InStgAlt,
-        OutStgArg, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt,
+        InStgArg,  InStgTopBinding,  InStgBinding,  InStgExpr,  InStgRhs,  InStgAlt,
+        OutStgArg, OutStgTopBinding, OutStgBinding, OutStgExpr, OutStgRhs, OutStgAlt,
 
         -- StgOp
         StgOp(..),
@@ -39,13 +40,14 @@ module StgSyn (
         stgArgType,
         stripStgTicksTop,
 
-        pprStgBinding, pprStgBindings
+        pprStgBinding, pprStgTopBindings
     ) where
 
 #include "HsVersions.h"
 
 import CoreSyn     ( AltCon, Tickish )
 import CostCentre  ( CostCentreStack )
+import Data.ByteString ( ByteString )
 import Data.List   ( intersperse )
 import DataCon
 import DynFlags
@@ -79,6 +81,12 @@ with respect to binder and occurrence information (just as in
 @CoreSyn@):
 -}
 
+-- | A top-level binding.
+data GenStgTopBinding bndr occ
+-- See Note [CoreSyn top-level string literals]
+  = StgTopLifted (GenStgBinding bndr occ)
+  | StgTopStringLit bndr ByteString
+
 data GenStgBinding bndr occ
   = StgNonRec bndr (GenStgRhs bndr occ)
   | StgRec    [(bndr, GenStgRhs bndr occ)]
@@ -421,11 +429,13 @@ stgRhsArity (StgRhsCon _ _ _) = 0
 -- is that `TidyPgm` computed the CAF info on the `Id` but some transformations
 -- have taken place since then.
 
-topStgBindHasCafRefs :: GenStgBinding bndr Id -> Bool
-topStgBindHasCafRefs (StgNonRec _ rhs)
+topStgBindHasCafRefs :: GenStgTopBinding bndr Id -> Bool
+topStgBindHasCafRefs (StgTopLifted (StgNonRec _ rhs))
   = topRhsHasCafRefs rhs
-topStgBindHasCafRefs (StgRec binds)
+topStgBindHasCafRefs (StgTopLifted (StgRec binds))
   = any topRhsHasCafRefs (map snd binds)
+topStgBindHasCafRefs StgTopStringLit{}
+  = False
 
 topRhsHasCafRefs :: GenStgRhs bndr Id -> Bool
 topRhsHasCafRefs (StgRhsClosure _ _ _ upd _ body)
@@ -550,6 +560,7 @@ data AltType
 This happens to be the only one we use at the moment.
 -}
 
+type StgTopBinding = GenStgTopBinding Id Id
 type StgBinding  = GenStgBinding  Id Id
 type StgArg      = GenStgArg      Id
 type StgExpr     = GenStgExpr     Id Id
@@ -561,16 +572,18 @@ type StgAlt      = GenStgAlt      Id Id
    See CoreSyn for precedence in Core land
 -}
 
-type InStgBinding  = StgBinding
-type InStgArg      = StgArg
-type InStgExpr     = StgExpr
-type InStgRhs      = StgRhs
-type InStgAlt      = StgAlt
-type OutStgBinding = StgBinding
-type OutStgArg     = StgArg
-type OutStgExpr    = StgExpr
-type OutStgRhs     = StgRhs
-type OutStgAlt     = StgAlt
+type InStgTopBinding  = StgTopBinding
+type InStgBinding     = StgBinding
+type InStgArg         = StgArg
+type InStgExpr        = StgExpr
+type InStgRhs         = StgRhs
+type InStgAlt         = StgAlt
+type OutStgTopBinding = StgTopBinding
+type OutStgBinding    = StgBinding
+type OutStgArg        = StgArg
+type OutStgExpr       = StgExpr
+type OutStgRhs        = StgRhs
+type OutStgAlt        = StgAlt
 
 {-
 
@@ -635,6 +648,15 @@ Robin Popplestone asked for semi-colon separators on STG binds; here's
 hoping he likes terminators instead...  Ditto for case alternatives.
 -}
 
+pprGenStgTopBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
+                 => GenStgTopBinding bndr bdee -> SDoc
+
+pprGenStgTopBinding (StgTopStringLit bndr str)
+  = hang (hsep [pprBndr LetBind bndr, equals])
+        4 (pprHsBytes str <> semi)
+pprGenStgTopBinding (StgTopLifted bind)
+  = pprGenStgBinding bind
+
 pprGenStgBinding :: (OutputableBndr bndr, Outputable bdee, Ord bdee)
                  => GenStgBinding bndr bdee -> SDoc
 
@@ -653,13 +675,18 @@ pprGenStgBinding (StgRec pairs)
 pprStgBinding :: StgBinding -> SDoc
 pprStgBinding  bind  = pprGenStgBinding bind
 
-pprStgBindings :: [StgBinding] -> SDoc
-pprStgBindings binds = vcat $ intersperse blankLine (map pprGenStgBinding binds)
+pprStgTopBindings :: [StgTopBinding] -> SDoc
+pprStgTopBindings binds
+  = vcat $ intersperse blankLine (map pprGenStgTopBinding binds)
 
 instance (Outputable bdee) => Outputable (GenStgArg bdee) where
     ppr = pprStgArg
 
 instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
+                => Outputable (GenStgTopBinding bndr bdee) where
+    ppr = pprGenStgTopBinding
+
+instance (OutputableBndr bndr, Outputable bdee, Ord bdee)
                 => Outputable (GenStgBinding bndr bdee) where
     ppr = pprGenStgBinding
 
diff --git a/docs/core-spec/core-spec.mng b/docs/core-spec/core-spec.mng
index f9db420857..623ba0e596 100644
--- a/docs/core-spec/core-spec.mng
+++ b/docs/core-spec/core-spec.mng
@@ -100,7 +100,9 @@ The datatype that represents expressions:
 There are a few key invariants about expressions:
 \begin{itemize}
 \item The right-hand sides of all top-level and recursive $[[let]]$s
-must be of lifted type.
+must be of lifted type, with one exception: the right-hand side of a top-level
+$[[let]]$ may be of type \texttt{Addr#} if it's a primitive string literal.
+See \verb|#top_level_invariant#| in \ghcfile{coreSyn/CoreSyn.hs}.
 \item The right-hand side of a non-recursive $[[let]]$ and the argument
 of an application may be of unlifted type, but only if the expression
 is ok-for-speculation. See \verb|#let_app_invariant#| in \ghcfile{coreSyn/CoreSyn.lhs}.
diff --git a/testsuite/tests/deSugar/should_compile/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr
index 797c6c7776..a8da44b73f 100644
--- a/testsuite/tests/deSugar/should_compile/T2431.stderr
+++ b/testsuite/tests/deSugar/should_compile/T2431.stderr
@@ -1,6 +1,6 @@
 
 ==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 36, types: 30, coercions: 1}
+Result size of Tidy Core = {terms: 44, types: 34, coercions: 1}
 
 -- RHS size: {terms: 2, types: 4, coercions: 1}
 T2431.$WRefl [InlPrag=INLINE] :: forall a. a :~: a
@@ -21,25 +21,40 @@ absurd :: forall a. (Int :~: Bool) -> a
 [GblId, Arity=1, Caf=NoCafRefs, Str=<L,U>x]
 absurd = \ (@ a) (x :: Int :~: Bool) -> case x of { }
 
--- RHS size: {terms: 2, types: 0, coercions: 0}
-$trModule1 :: GHC.Types.TrName
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+$trModule1 :: GHC.Prim.Addr#
 [GblId, Caf=NoCafRefs]
-$trModule1 = GHC.Types.TrNameS "main"#
+$trModule1 = "main"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
 $trModule2 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs]
-$trModule2 = GHC.Types.TrNameS "T2431"#
+$trModule2 = GHC.Types.TrNameS $trModule1
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+$trModule3 :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs]
+$trModule3 = "T2431"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0}
+$trModule4 :: GHC.Types.TrName
+[GblId, Caf=NoCafRefs]
+$trModule4 = GHC.Types.TrNameS $trModule3
 
 -- RHS size: {terms: 3, types: 0, coercions: 0}
 T2431.$trModule :: GHC.Types.Module
 [GblId, Caf=NoCafRefs]
-T2431.$trModule = GHC.Types.Module $trModule1 $trModule2
+T2431.$trModule = GHC.Types.Module $trModule2 $trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+$tc'Refl1 :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs]
+$tc'Refl1 = "'Refl"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-$tc'Refl1 :: GHC.Types.TrName
+$tc'Refl2 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs]
-$tc'Refl1 = GHC.Types.TrNameS "'Refl"#
+$tc'Refl2 = GHC.Types.TrNameS $tc'Refl1
 
 -- RHS size: {terms: 5, types: 0, coercions: 0}
 T2431.$tc'Refl :: GHC.Types.TyCon
@@ -49,12 +64,17 @@ T2431.$tc'Refl =
     15026191172322750497##
     3898273167927206410##
     T2431.$trModule
-    $tc'Refl1
+    $tc'Refl2
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+$tc:~:1 :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs]
+$tc:~:1 = ":~:"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-$tc:~:1 :: GHC.Types.TrName
+$tc:~:2 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs]
-$tc:~:1 = GHC.Types.TrNameS ":~:"#
+$tc:~:2 = GHC.Types.TrNameS $tc:~:1
 
 -- RHS size: {terms: 5, types: 0, coercions: 0}
 T2431.$tc:~: :: GHC.Types.TyCon
@@ -64,7 +84,7 @@ T2431.$tc:~: =
     9759653149176674453##
     12942818337407067047##
     T2431.$trModule
-    $tc:~:1
+    $tc:~:2
 
 
 
diff --git a/testsuite/tests/numeric/should_compile/T7116.stdout b/testsuite/tests/numeric/should_compile/T7116.stdout
index 9f7837bdc7..7fe4d93d87 100644
--- a/testsuite/tests/numeric/should_compile/T7116.stdout
+++ b/testsuite/tests/numeric/should_compile/T7116.stdout
@@ -1,15 +1,31 @@
 
 ==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 46, types: 23, coercions: 0}
+Result size of Tidy Core = {terms: 50, types: 25, coercions: 0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+T7116.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T7116.$trModule4 = "main"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-T7116.$trModule2 :: GHC.Types.TrName
+T7116.$trModule3 :: GHC.Types.TrName
 [GblId,
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}]
-T7116.$trModule2 = GHC.Types.TrNameS "main"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T7116.$trModule3 = GHC.Types.TrNameS T7116.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+T7116.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T7116.$trModule2 = "T7116"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
 T7116.$trModule1 :: GHC.Types.TrName
@@ -17,8 +33,8 @@ T7116.$trModule1 :: GHC.Types.TrName
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-T7116.$trModule1 = GHC.Types.TrNameS "T7116"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T7116.$trModule1 = GHC.Types.TrNameS T7116.$trModule2
 
 -- RHS size: {terms: 3, types: 0, coercions: 0}
 T7116.$trModule :: GHC.Types.Module
@@ -28,7 +44,7 @@ T7116.$trModule :: GHC.Types.Module
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
 T7116.$trModule =
-  GHC.Types.Module T7116.$trModule2 T7116.$trModule1
+  GHC.Types.Module T7116.$trModule3 T7116.$trModule1
 
 -- RHS size: {terms: 8, types: 3, coercions: 0}
 dr :: Double -> Double
diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T
index 499650bd69..797cbd9d94 100644
--- a/testsuite/tests/perf/compiler/all.T
+++ b/testsuite/tests/perf/compiler/all.T
@@ -39,7 +39,7 @@ test('T1969',
              # 2013-11-13 17 (x86/Windows, 64bit machine)
              # 2015-07-11 21 (x86/Linux, 64bit machine) use +RTS -G1
              # 2016-04-06 30 (x86/Linux, 64bit machine)
-           (wordsize(64), 55, 20)]),
+           (wordsize(64), 68, 20)]),
              #            28 (amd64/Linux)
              #            34 (amd64/Linux)
              # 2012-09-20 23 (amd64/Linux)
@@ -51,6 +51,8 @@ test('T1969',
              # 2013-09-11 30, 15 (adapt to Phab CI)
              # 2015-06-03 41, (amd64/Linux) use +RTS -G1
              # 2015-10-28 55, (amd64/Linux) emit Typeable at definition site
+             # 2016-10-20 68, (amd64/Linux) allow top-level string literals
+             #                See the comment 16 on #8472.
       compiler_stats_num_field('max_bytes_used',
           [(platform('i386-unknown-mingw32'), 5719436, 20),
                                  # 2010-05-17 5717704 (x86/Windows)
@@ -827,7 +829,7 @@ test('T9233',
 test('T10370',
      [ only_ways(['optasm']),
        compiler_stats_num_field('max_bytes_used', # Note [residency]
-          [(wordsize(64), 33049168, 15),
+          [(wordsize(64), 38221184, 15),
           # 2015-10-22    19548720
           # 2016-02-24    22823976   Changing Levity to RuntimeRep; not sure why this regresses though, even after some analysis
           # 2016-04-14    28256896   final demand analyzer run
@@ -838,14 +840,17 @@ test('T10370',
           #     affected stats on bootstrapped GHC.  However,
           #     when I set -i0.01 with profiling, the heap profiles
           #     were identical, so I think it's just GC noise.
+          # 2016-10-20    38221184   Allow top-level string literals.
+          #                          See the comment 16 on #8472.
            (wordsize(32), 11371496, 15),
           # 2015-10-22    11371496
           ]),
        compiler_stats_num_field('peak_megabytes_allocated', # Note [residency]
-          [(wordsize(64), 121, 15),
+          [(wordsize(64), 146, 15),
           # 2015-10-22     76
           # 2016-04-14    101 final demand analyzer run
           # 2016-08-08    121 see above
+          # 2017-01-18    146 Allow top-level string literals in Core
            (wordsize(32),  39, 15),
           # 2015-10-22     39
           ]),
@@ -883,8 +888,9 @@ test('T12227',
 test('T12425',
      [ only_ways(['optasm']),
        compiler_stats_num_field('bytes allocated',
-          [(wordsize(64), 125831400, 5),
+          [(wordsize(64), 133380960, 5),
           # initial:    125831400
+          # 2017-01-18: 133380960  Allow top-level string literals in Core
           ]),
      ],
      compile,
@@ -906,8 +912,9 @@ test('T12234',
 test('T13035',
      [ only_ways(['normal']),
        compiler_stats_num_field('bytes allocated',
-          [(wordsize(64), 90595208, 5),
+          [(wordsize(64), 95269000, 5),
           # 2017-01-05   90595208 initial
+          # 2017-01-19   95269000 Allow top-level string literals in Core
           ]),
      ],
      compile,
diff --git a/testsuite/tests/perf/should_run/T8472.hs b/testsuite/tests/perf/should_run/T8472.hs
new file mode 100644
index 0000000000..24f0ec7811
--- /dev/null
+++ b/testsuite/tests/perf/should_run/T8472.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE MagicHash #-}
+
+module Main (f, main) where
+
+import GHC.Exts(Ptr(..))
+import Foreign.Ptr
+
+-- We should be able to inline this function.
+f :: Ptr Int -> Int -> Int
+f =
+  let x = "foo"#
+  in \p n -> n + (Ptr x `minusPtr` p)
+
+main :: IO ()
+main = print $ x `mod` 2 == (x + 4) `mod` 2
+  where
+    x = go (10000::Int) 4
+    go 0 a = a
+    go n a = go (n-1) (f nullPtr a)
diff --git a/testsuite/tests/perf/should_run/T8472.stdout b/testsuite/tests/perf/should_run/T8472.stdout
new file mode 100644
index 0000000000..0ca95142bb
--- /dev/null
+++ b/testsuite/tests/perf/should_run/T8472.stdout
@@ -0,0 +1 @@
+True
diff --git a/testsuite/tests/perf/should_run/all.T b/testsuite/tests/perf/should_run/all.T
index 333970ca57..1560e7ea2e 100644
--- a/testsuite/tests/perf/should_run/all.T
+++ b/testsuite/tests/perf/should_run/all.T
@@ -446,6 +446,14 @@ test('T9339',
      compile_and_run,
      ['-O2'])
 
+test('T8472',
+     [stats_num_field('bytes allocated',
+                      [ (wordsize(32),    50000, 80)
+                      , (wordsize(64),    51424, 80) ]),
+      only_ways(['normal'])],
+     compile_and_run,
+     ['-O2'])
+
 test('T12996',
      [stats_num_field('bytes allocated',
                       [ (wordsize(64),    76776, 5) ]),
diff --git a/testsuite/tests/perf/space_leaks/all.T b/testsuite/tests/perf/space_leaks/all.T
index 9acd157543..56a58cb586 100644
--- a/testsuite/tests/perf/space_leaks/all.T
+++ b/testsuite/tests/perf/space_leaks/all.T
@@ -64,7 +64,7 @@ test('T4029',
             # 2016-07-13: 92 (amd64/Linux)           Changes to tidyType
             # 2016-09-01: 71 (amd64/Linux)           Restore w/w limit (#11565)
       stats_num_field('max_bytes_used',
-          [(wordsize(64), 21387048 , 5)]),
+          [(wordsize(64), 21670448 , 5)]),
             # 2016-02-26: 24071720 (amd64/Linux)     INITIAL
             # 2016-04-21: 25542832 (amd64/Linux)
             # 2016-05-23: 25247216 (amd64/Linux)     Use -G1
@@ -73,6 +73,7 @@ test('T4029',
             # 2016-09-01: 21648488 (amd64/Linux)     Restore w/w limit (#11565)
             # 2016-10-13: 20325248 (amd64/Linux)     Creep (downwards, yay!)
             # 2016-11-14: 21387048 (amd64/Linux)     Creep back upwards :(
+            # 2017-01-18: 21670448 (amd64/Linux)     Float string literals to toplevel
       extra_hc_opts('+RTS -G1 -RTS' ),
       ],
      ghci_script,
diff --git a/testsuite/tests/roles/should_compile/Roles13.stderr b/testsuite/tests/roles/should_compile/Roles13.stderr
index f74c3abbb9..20206e28df 100644
--- a/testsuite/tests/roles/should_compile/Roles13.stderr
+++ b/testsuite/tests/roles/should_compile/Roles13.stderr
@@ -1,6 +1,6 @@
 
 ==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 51, types: 20, coercions: 5}
+Result size of Tidy Core = {terms: 63, types: 26, coercions: 5}
 
 -- RHS size: {terms: 2, types: 2, coercions: 0}
 convert1 :: Wrap Age -> Wrap Age
@@ -15,25 +15,40 @@ convert =
   `cast` (<Wrap Age>_R -> Roles13.N:Wrap[0] Roles13.N:Age[0]
           :: ((Wrap Age -> Wrap Age) :: *) ~R# ((Wrap Age -> Int) :: *))
 
--- RHS size: {terms: 2, types: 0, coercions: 0}
-$trModule1 :: GHC.Types.TrName
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+$trModule1 :: GHC.Prim.Addr#
 [GblId, Caf=NoCafRefs]
-$trModule1 = GHC.Types.TrNameS "main"#
+$trModule1 = "main"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
 $trModule2 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs]
-$trModule2 = GHC.Types.TrNameS "Roles13"#
+$trModule2 = GHC.Types.TrNameS $trModule1
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+$trModule3 :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs]
+$trModule3 = "Roles13"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0}
+$trModule4 :: GHC.Types.TrName
+[GblId, Caf=NoCafRefs]
+$trModule4 = GHC.Types.TrNameS $trModule3
 
 -- RHS size: {terms: 3, types: 0, coercions: 0}
 Roles13.$trModule :: GHC.Types.Module
 [GblId, Caf=NoCafRefs]
-Roles13.$trModule = GHC.Types.Module $trModule1 $trModule2
+Roles13.$trModule = GHC.Types.Module $trModule2 $trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+$tc'MkAge1 :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs]
+$tc'MkAge1 = "'MkAge"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-$tc'MkAge1 :: GHC.Types.TrName
+$tc'MkAge2 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs]
-$tc'MkAge1 = GHC.Types.TrNameS "'MkAge"#
+$tc'MkAge2 = GHC.Types.TrNameS $tc'MkAge1
 
 -- RHS size: {terms: 5, types: 0, coercions: 0}
 Roles13.$tc'MkAge :: GHC.Types.TyCon
@@ -43,12 +58,17 @@ Roles13.$tc'MkAge =
     1226019810264079099##
     12180888342844277416##
     Roles13.$trModule
-    $tc'MkAge1
+    $tc'MkAge2
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+$tcAge1 :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs]
+$tcAge1 = "Age"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-$tcAge1 :: GHC.Types.TrName
+$tcAge2 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs]
-$tcAge1 = GHC.Types.TrNameS "Age"#
+$tcAge2 = GHC.Types.TrNameS $tcAge1
 
 -- RHS size: {terms: 5, types: 0, coercions: 0}
 Roles13.$tcAge :: GHC.Types.TyCon
@@ -58,12 +78,17 @@ Roles13.$tcAge =
     18304088376370610314##
     1954648846714895105##
     Roles13.$trModule
-    $tcAge1
+    $tcAge2
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+$tc'MkWrap1 :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs]
+$tc'MkWrap1 = "'MkWrap"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-$tc'MkWrap1 :: GHC.Types.TrName
+$tc'MkWrap2 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs]
-$tc'MkWrap1 = GHC.Types.TrNameS "'MkWrap"#
+$tc'MkWrap2 = GHC.Types.TrNameS $tc'MkWrap1
 
 -- RHS size: {terms: 5, types: 0, coercions: 0}
 Roles13.$tc'MkWrap :: GHC.Types.TyCon
@@ -73,12 +98,17 @@ Roles13.$tc'MkWrap =
     12402878715225676312##
     13345418993613492500##
     Roles13.$trModule
-    $tc'MkWrap1
+    $tc'MkWrap2
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+$tcWrap1 :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs]
+$tcWrap1 = "Wrap"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-$tcWrap1 :: GHC.Types.TrName
+$tcWrap2 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs]
-$tcWrap1 = GHC.Types.TrNameS "Wrap"#
+$tcWrap2 = GHC.Types.TrNameS $tcWrap1
 
 -- RHS size: {terms: 5, types: 0, coercions: 0}
 Roles13.$tcWrap :: GHC.Types.TyCon
@@ -88,7 +118,7 @@ Roles13.$tcWrap =
     5278920226786541118##
     14554440859491798587##
     Roles13.$trModule
-    $tcWrap1
+    $tcWrap2
 
 
 
diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile
index 224e84c825..5a465d9818 100644
--- a/testsuite/tests/simplCore/should_compile/Makefile
+++ b/testsuite/tests/simplCore/should_compile/Makefile
@@ -185,3 +185,8 @@ T13025:
 	'$(TEST_HC)' $(TEST_HC_OPTS) -c -O T13025a.hs
 	-'$(TEST_HC)' $(TEST_HC_OPTS) -c -O T13025.hs -ddump-simpl | grep -c HEq_sc
 	# No lines should match 'HEq_sc' so wc should output zeros
+
+.PHONY: str-rules
+str-rules:
+	$(RM) -f str-rules.hi str-rules.o
+	'$(TEST_HC)' $(TEST_HC_OPTS) -c -O str-rules.hs -ddump-simpl | grep -o '"@@@[^"].*"#' | sort
diff --git a/testsuite/tests/simplCore/should_compile/T3234.stderr b/testsuite/tests/simplCore/should_compile/T3234.stderr
index da96b43d9d..9d87b3ecc1 100644
--- a/testsuite/tests/simplCore/should_compile/T3234.stderr
+++ b/testsuite/tests/simplCore/should_compile/T3234.stderr
@@ -1,6 +1,6 @@
 
 ==================== FloatOut stats: ====================
-1 Lets floated to top level; 0 Lets floated elsewhere; from 1 Lambda groups
+2 Lets floated to top level; 0 Lets floated elsewhere; from 1 Lambda groups
 
 
 
@@ -10,9 +10,9 @@
 
 
 ==================== Grand total simplifier statistics ====================
-Total ticks:     51
+Total ticks:     54
 
-14 PreInlineUnconditionally
+15 PreInlineUnconditionally
   1 n
   1 g
   1 a
@@ -27,6 +27,7 @@ Total ticks:     51
   1 a
   1 lvl
   1 lvl
+  1 lvl
 4 PostInlineUnconditionally
   1 c
   1 n
@@ -39,7 +40,7 @@ Total ticks:     51
   1 fold/build
   1 unpack
   1 unpack-list
-2 LetFloatFromLet 2
+4 LetFloatFromLet 4
 25 BetaReduction
   1 a
   1 c
diff --git a/testsuite/tests/simplCore/should_compile/T3717.stderr b/testsuite/tests/simplCore/should_compile/T3717.stderr
index a7c1e55c52..f9adeb28da 100644
--- a/testsuite/tests/simplCore/should_compile/T3717.stderr
+++ b/testsuite/tests/simplCore/should_compile/T3717.stderr
@@ -1,15 +1,31 @@
 
 ==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 32, types: 13, coercions: 0}
+Result size of Tidy Core = {terms: 36, types: 15, coercions: 0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+T3717.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T3717.$trModule4 = "main"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-T3717.$trModule2 :: GHC.Types.TrName
+T3717.$trModule3 :: GHC.Types.TrName
 [GblId,
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}]
-T3717.$trModule2 = GHC.Types.TrNameS "main"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T3717.$trModule3 = GHC.Types.TrNameS T3717.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+T3717.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T3717.$trModule2 = "T3717"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
 T3717.$trModule1 :: GHC.Types.TrName
@@ -17,8 +33,8 @@ T3717.$trModule1 :: GHC.Types.TrName
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-T3717.$trModule1 = GHC.Types.TrNameS "T3717"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T3717.$trModule1 = GHC.Types.TrNameS T3717.$trModule2
 
 -- RHS size: {terms: 3, types: 0, coercions: 0}
 T3717.$trModule :: GHC.Types.Module
@@ -28,7 +44,7 @@ T3717.$trModule :: GHC.Types.Module
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
 T3717.$trModule =
-  GHC.Types.Module T3717.$trModule2 T3717.$trModule1
+  GHC.Types.Module T3717.$trModule3 T3717.$trModule1
 
 Rec {
 -- RHS size: {terms: 10, types: 2, coercions: 0}
diff --git a/testsuite/tests/simplCore/should_compile/T3772.stdout b/testsuite/tests/simplCore/should_compile/T3772.stdout
index d70c0eee55..76936e336f 100644
--- a/testsuite/tests/simplCore/should_compile/T3772.stdout
+++ b/testsuite/tests/simplCore/should_compile/T3772.stdout
@@ -1,6 +1,6 @@
 
 ==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 36, types: 14, coercions: 0}
+Result size of Tidy Core = {terms: 40, types: 16, coercions: 0}
 
 Rec {
 -- RHS size: {terms: 10, types: 2, coercions: 0}
@@ -26,23 +26,39 @@ foo =
     }
     }
 
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+T3772.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T3772.$trModule2 = "T3772"#
+
 -- RHS size: {terms: 2, types: 0, coercions: 0}
 T3772.$trModule1 :: GHC.Types.TrName
 [GblId,
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-T3772.$trModule1 = GHC.Types.TrNameS "T3772"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T3772.$trModule1 = GHC.Types.TrNameS T3772.$trModule2
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+T3772.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T3772.$trModule4 = "main"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-T3772.$trModule2 :: GHC.Types.TrName
+T3772.$trModule3 :: GHC.Types.TrName
 [GblId,
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}]
-T3772.$trModule2 = GHC.Types.TrNameS "main"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T3772.$trModule3 = GHC.Types.TrNameS T3772.$trModule4
 
 -- RHS size: {terms: 3, types: 0, coercions: 0}
 T3772.$trModule :: GHC.Types.Module
@@ -52,7 +68,7 @@ T3772.$trModule :: GHC.Types.Module
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
 T3772.$trModule =
-  GHC.Types.Module T3772.$trModule2 T3772.$trModule1
+  GHC.Types.Module T3772.$trModule3 T3772.$trModule1
 
 
 
diff --git a/testsuite/tests/simplCore/should_compile/T4908.stderr b/testsuite/tests/simplCore/should_compile/T4908.stderr
index 7136bd1f51..e9957bf9de 100644
--- a/testsuite/tests/simplCore/should_compile/T4908.stderr
+++ b/testsuite/tests/simplCore/should_compile/T4908.stderr
@@ -1,15 +1,31 @@
 
 ==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 64, types: 41, coercions: 0}
+Result size of Tidy Core = {terms: 68, types: 43, coercions: 0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+T4908.$trModule4 :: Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T4908.$trModule4 = "main"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-T4908.$trModule2 :: TrName
+T4908.$trModule3 :: TrName
 [GblId,
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}]
-T4908.$trModule2 = GHC.Types.TrNameS "main"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T4908.$trModule3 = GHC.Types.TrNameS T4908.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+T4908.$trModule2 :: Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T4908.$trModule2 = "T4908"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
 T4908.$trModule1 :: TrName
@@ -17,8 +33,8 @@ T4908.$trModule1 :: TrName
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-T4908.$trModule1 = GHC.Types.TrNameS "T4908"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T4908.$trModule1 = GHC.Types.TrNameS T4908.$trModule2
 
 -- RHS size: {terms: 3, types: 0, coercions: 0}
 T4908.$trModule :: Module
@@ -28,7 +44,7 @@ T4908.$trModule :: Module
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
 T4908.$trModule =
-  GHC.Types.Module T4908.$trModule2 T4908.$trModule1
+  GHC.Types.Module T4908.$trModule3 T4908.$trModule1
 
 Rec {
 -- RHS size: {terms: 19, types: 5, coercions: 0}
diff --git a/testsuite/tests/simplCore/should_compile/T4930.stderr b/testsuite/tests/simplCore/should_compile/T4930.stderr
index 7e51aa68be..365584d3d0 100644
--- a/testsuite/tests/simplCore/should_compile/T4930.stderr
+++ b/testsuite/tests/simplCore/should_compile/T4930.stderr
@@ -1,15 +1,31 @@
 
 ==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 45, types: 17, coercions: 0}
+Result size of Tidy Core = {terms: 49, types: 19, coercions: 0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+T4930.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T4930.$trModule4 = "main"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-T4930.$trModule2 :: GHC.Types.TrName
+T4930.$trModule3 :: GHC.Types.TrName
 [GblId,
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}]
-T4930.$trModule2 = GHC.Types.TrNameS "main"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T4930.$trModule3 = GHC.Types.TrNameS T4930.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+T4930.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T4930.$trModule2 = "T4930"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
 T4930.$trModule1 :: GHC.Types.TrName
@@ -17,8 +33,8 @@ T4930.$trModule1 :: GHC.Types.TrName
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-T4930.$trModule1 = GHC.Types.TrNameS "T4930"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T4930.$trModule1 = GHC.Types.TrNameS T4930.$trModule2
 
 -- RHS size: {terms: 3, types: 0, coercions: 0}
 T4930.$trModule :: GHC.Types.Module
@@ -28,7 +44,7 @@ T4930.$trModule :: GHC.Types.Module
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
 T4930.$trModule =
-  GHC.Types.Module T4930.$trModule2 T4930.$trModule1
+  GHC.Types.Module T4930.$trModule3 T4930.$trModule1
 
 Rec {
 -- RHS size: {terms: 23, types: 6, coercions: 0}
diff --git a/testsuite/tests/simplCore/should_compile/T7360.stderr b/testsuite/tests/simplCore/should_compile/T7360.stderr
index 2b0984c8d5..2e387b27bc 100644
--- a/testsuite/tests/simplCore/should_compile/T7360.stderr
+++ b/testsuite/tests/simplCore/should_compile/T7360.stderr
@@ -1,6 +1,6 @@
 
 ==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 82, types: 42, coercions: 0}
+Result size of Tidy Core = {terms: 94, types: 48, coercions: 0}
 
 -- RHS size: {terms: 6, types: 3, coercions: 0}
 T7360.$WFoo3 [InlPrag=INLINE] :: Int -> Foo
@@ -66,14 +66,30 @@ fun2 =
          }
      })
 
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+T7360.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T7360.$trModule4 = "main"#
+
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-T7360.$trModule2 :: GHC.Types.TrName
+T7360.$trModule3 :: GHC.Types.TrName
 [GblId,
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}]
-T7360.$trModule2 = GHC.Types.TrNameS "main"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T7360.$trModule3 = GHC.Types.TrNameS T7360.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+T7360.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T7360.$trModule2 = "T7360"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
 T7360.$trModule1 :: GHC.Types.TrName
@@ -81,8 +97,8 @@ T7360.$trModule1 :: GHC.Types.TrName
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-T7360.$trModule1 = GHC.Types.TrNameS "T7360"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T7360.$trModule1 = GHC.Types.TrNameS T7360.$trModule2
 
 -- RHS size: {terms: 3, types: 0, coercions: 0}
 T7360.$trModule :: GHC.Types.Module
@@ -92,16 +108,24 @@ T7360.$trModule :: GHC.Types.Module
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
 T7360.$trModule =
-  GHC.Types.Module T7360.$trModule2 T7360.$trModule1
+  GHC.Types.Module T7360.$trModule3 T7360.$trModule1
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+T7360.$tc'Foo9 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T7360.$tc'Foo9 = "'Foo3"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-T7360.$tc'Foo6 :: GHC.Types.TrName
+T7360.$tc'Foo8 :: GHC.Types.TrName
 [GblId,
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-T7360.$tc'Foo6 = GHC.Types.TrNameS "'Foo3"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T7360.$tc'Foo8 = GHC.Types.TrNameS T7360.$tc'Foo9
 
 -- RHS size: {terms: 5, types: 0, coercions: 0}
 T7360.$tc'Foo3 :: GHC.Types.TyCon
@@ -115,16 +139,24 @@ T7360.$tc'Foo3 =
     10507205234936349519##
     8302184214013227554##
     T7360.$trModule
-    T7360.$tc'Foo6
+    T7360.$tc'Foo8
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+T7360.$tc'Foo7 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T7360.$tc'Foo7 = "'Foo2"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-T7360.$tc'Foo5 :: GHC.Types.TrName
+T7360.$tc'Foo6 :: GHC.Types.TrName
 [GblId,
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-T7360.$tc'Foo5 = GHC.Types.TrNameS "'Foo2"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T7360.$tc'Foo6 = GHC.Types.TrNameS T7360.$tc'Foo7
 
 -- RHS size: {terms: 5, types: 0, coercions: 0}
 T7360.$tc'Foo2 :: GHC.Types.TyCon
@@ -138,7 +170,15 @@ T7360.$tc'Foo2 =
     9825259700232563546##
     11056638024476048052##
     T7360.$trModule
-    T7360.$tc'Foo5
+    T7360.$tc'Foo6
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+T7360.$tc'Foo5 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+T7360.$tc'Foo5 = "'Foo1"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
 T7360.$tc'Foo4 :: GHC.Types.TrName
@@ -146,8 +186,8 @@ T7360.$tc'Foo4 :: GHC.Types.TrName
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-T7360.$tc'Foo4 = GHC.Types.TrNameS "'Foo1"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T7360.$tc'Foo4 = GHC.Types.TrNameS T7360.$tc'Foo5
 
 -- RHS size: {terms: 5, types: 0, coercions: 0}
 T7360.$tc'Foo1 :: GHC.Types.TyCon
@@ -163,14 +203,22 @@ T7360.$tc'Foo1 =
     T7360.$trModule
     T7360.$tc'Foo4
 
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+T7360.$tcFoo2 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+T7360.$tcFoo2 = "Foo"#
+
 -- RHS size: {terms: 2, types: 0, coercions: 0}
 T7360.$tcFoo1 :: GHC.Types.TrName
 [GblId,
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}]
-T7360.$tcFoo1 = GHC.Types.TrNameS "Foo"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+T7360.$tcFoo1 = GHC.Types.TrNameS T7360.$tcFoo2
 
 -- RHS size: {terms: 5, types: 0, coercions: 0}
 T7360.$tcFoo :: GHC.Types.TyCon
diff --git a/testsuite/tests/simplCore/should_compile/T8274.stdout b/testsuite/tests/simplCore/should_compile/T8274.stdout
index 43830c7135..df8253f510 100644
--- a/testsuite/tests/simplCore/should_compile/T8274.stdout
+++ b/testsuite/tests/simplCore/should_compile/T8274.stdout
@@ -1,12 +1,18 @@
 p = T8274.Positives 42# 4.23# 4.23## '4'# 4##
 n = T8274.Negatives -4# -4.0# -4.0##
-T8274.$trModule2 = GHC.Types.TrNameS "main"#
-T8274.$trModule1 = GHC.Types.TrNameS "T8274"#
-T8274.$tc'Positives1 = GHC.Types.TrNameS "'Positives"#
+T8274.$trModule4 :: Addr#
+T8274.$trModule4 = "main"#
+T8274.$trModule2 :: Addr#
+T8274.$trModule2 = "T8274"#
+T8274.$tc'Positives2 :: Addr#
+T8274.$tc'Positives2 = "'Positives"#
 T8274.$tc'Positives = GHC.Types.TyCon 14732531009298850569## 4925356269917933860## T8274.$trModule T8274.$tc'Positives1
-T8274.$tcP1 = GHC.Types.TrNameS "P"#
+T8274.$tcP2 :: Addr#
+T8274.$tcP2 = "P"#
 T8274.$tcP = GHC.Types.TyCon 11095028091707994303## 9476557054198009608## T8274.$trModule T8274.$tcP1
-T8274.$tc'Negatives1 = GHC.Types.TrNameS "'Negatives"#
+T8274.$tc'Negatives2 :: Addr#
+T8274.$tc'Negatives2 = "'Negatives"#
 T8274.$tc'Negatives = GHC.Types.TyCon 15950179315687996644## 11481167534507418130## T8274.$trModule T8274.$tc'Negatives1
-T8274.$tcN1 = GHC.Types.TrNameS "N"#
+T8274.$tcN2 :: Addr#
+T8274.$tcN2 = "N"#
 T8274.$tcN = GHC.Types.TyCon 7479687563082171902## 17616649989360543185## T8274.$trModule T8274.$tcN1
diff --git a/testsuite/tests/simplCore/should_compile/T9400.stderr b/testsuite/tests/simplCore/should_compile/T9400.stderr
index bab1751a86..92979b36b1 100644
--- a/testsuite/tests/simplCore/should_compile/T9400.stderr
+++ b/testsuite/tests/simplCore/should_compile/T9400.stderr
@@ -1,21 +1,31 @@
 
 ==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 33, types: 20, coercions: 0}
+Result size of Tidy Core = {terms: 37, types: 22, coercions: 0}
 
--- RHS size: {terms: 2, types: 0, coercions: 0}
-$trModule1 :: TrName
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+$trModule1 :: Addr#
 [GblId, Caf=NoCafRefs]
-$trModule1 = GHC.Types.TrNameS "main"#
+$trModule1 = "main"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
 $trModule2 :: TrName
 [GblId, Caf=NoCafRefs]
-$trModule2 = GHC.Types.TrNameS "T9400"#
+$trModule2 = GHC.Types.TrNameS $trModule1
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+$trModule3 :: Addr#
+[GblId, Caf=NoCafRefs]
+$trModule3 = "T9400"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0}
+$trModule4 :: TrName
+[GblId, Caf=NoCafRefs]
+$trModule4 = GHC.Types.TrNameS $trModule3
 
 -- RHS size: {terms: 3, types: 0, coercions: 0}
 T9400.$trModule :: Module
 [GblId, Caf=NoCafRefs]
-T9400.$trModule = GHC.Types.Module $trModule1 $trModule2
+T9400.$trModule = GHC.Types.Module $trModule2 $trModule4
 
 -- RHS size: {terms: 22, types: 15, coercions: 0}
 main :: IO ()
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index 19e9f1d3a4..2ede2468ee 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -263,3 +263,7 @@ test('T13025',
      ['$MAKE -s --no-print-directory T13025'])
 test('T13156', normal, run_command, ['$MAKE -s --no-print-directory T13156'])
 test('T11444', normal, compile, [''])
+test('str-rules',
+     normal,
+     run_command,
+     ['$MAKE -s --no-print-directory str-rules'])
diff --git a/testsuite/tests/simplCore/should_compile/noinline01.stderr b/testsuite/tests/simplCore/should_compile/noinline01.stderr
index b100172381..1bb98e57b4 100644
--- a/testsuite/tests/simplCore/should_compile/noinline01.stderr
+++ b/testsuite/tests/simplCore/should_compile/noinline01.stderr
@@ -9,17 +9,25 @@ Noinline01.g :: GHC.Types.Bool
 [GblId] =
     \u [] Noinline01.f GHC.Types.False;
 
-Noinline01.$trModule2 :: GHC.Types.TrName
+Noinline01.$trModule4 :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs, Unf=OtherCon []] =
+    "main"#;
+
+Noinline01.$trModule3 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []] =
-    NO_CCS GHC.Types.TrNameS! ["main"#];
+    NO_CCS GHC.Types.TrNameS! [Noinline01.$trModule4];
+
+Noinline01.$trModule2 :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs, Unf=OtherCon []] =
+    "Noinline01"#;
 
 Noinline01.$trModule1 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []] =
-    NO_CCS GHC.Types.TrNameS! ["Noinline01"#];
+    NO_CCS GHC.Types.TrNameS! [Noinline01.$trModule2];
 
 Noinline01.$trModule :: GHC.Types.Module
 [GblId, Caf=NoCafRefs, Str=m, Unf=OtherCon []] =
-    NO_CCS GHC.Types.Module! [Noinline01.$trModule2
+    NO_CCS GHC.Types.Module! [Noinline01.$trModule3
                               Noinline01.$trModule1];
 
 
@@ -34,17 +42,25 @@ Noinline01.g :: GHC.Types.Bool
 [GblId] =
     \u [] Noinline01.f GHC.Types.False;
 
-Noinline01.$trModule2 :: GHC.Types.TrName
+Noinline01.$trModule4 :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs, Unf=OtherCon []] =
+    "main"#;
+
+Noinline01.$trModule3 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []] =
-    NO_CCS GHC.Types.TrNameS! ["main"#];
+    NO_CCS GHC.Types.TrNameS! [Noinline01.$trModule4];
+
+Noinline01.$trModule2 :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs, Unf=OtherCon []] =
+    "Noinline01"#;
 
 Noinline01.$trModule1 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []] =
-    NO_CCS GHC.Types.TrNameS! ["Noinline01"#];
+    NO_CCS GHC.Types.TrNameS! [Noinline01.$trModule2];
 
 Noinline01.$trModule :: GHC.Types.Module
 [GblId, Caf=NoCafRefs, Str=m, Unf=OtherCon []] =
-    NO_CCS GHC.Types.Module! [Noinline01.$trModule2
+    NO_CCS GHC.Types.Module! [Noinline01.$trModule3
                               Noinline01.$trModule1];
 
 
diff --git a/testsuite/tests/simplCore/should_compile/par01.stderr b/testsuite/tests/simplCore/should_compile/par01.stderr
index 90d467f71c..4ccb9d892b 100644
--- a/testsuite/tests/simplCore/should_compile/par01.stderr
+++ b/testsuite/tests/simplCore/should_compile/par01.stderr
@@ -1,6 +1,6 @@
 
 ==================== CorePrep ====================
-Result size of CorePrep = {terms: 18, types: 8, coercions: 0}
+Result size of CorePrep = {terms: 22, types: 10, coercions: 0}
 
 Rec {
 -- RHS size: {terms: 7, types: 3, coercions: 0}
@@ -13,21 +13,31 @@ Par01.depth =
     }
 end Rec }
 
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+Par01.$trModule4 :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs, Unf=OtherCon []]
+Par01.$trModule4 = "main"#
+
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-Par01.$trModule2 :: GHC.Types.TrName
+Par01.$trModule3 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []]
-Par01.$trModule2 = GHC.Types.TrNameS "main"#
+Par01.$trModule3 = GHC.Types.TrNameS Par01.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+Par01.$trModule2 :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs, Unf=OtherCon []]
+Par01.$trModule2 = "Par01"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
 Par01.$trModule1 :: GHC.Types.TrName
 [GblId, Caf=NoCafRefs, Str=m1, Unf=OtherCon []]
-Par01.$trModule1 = GHC.Types.TrNameS "Par01"#
+Par01.$trModule1 = GHC.Types.TrNameS Par01.$trModule2
 
 -- RHS size: {terms: 3, types: 0, coercions: 0}
 Par01.$trModule :: GHC.Types.Module
 [GblId, Caf=NoCafRefs, Str=m, Unf=OtherCon []]
 Par01.$trModule =
-  GHC.Types.Module Par01.$trModule2 Par01.$trModule1
+  GHC.Types.Module Par01.$trModule3 Par01.$trModule1
 
 
 
diff --git a/testsuite/tests/simplCore/should_compile/rule2.stderr b/testsuite/tests/simplCore/should_compile/rule2.stderr
index 844afc63d6..572fac36a8 100644
--- a/testsuite/tests/simplCore/should_compile/rule2.stderr
+++ b/testsuite/tests/simplCore/should_compile/rule2.stderr
@@ -10,14 +10,14 @@
 
 
 ==================== Grand total simplifier statistics ====================
-Total ticks:     13
+Total ticks:     15
 
 2 PreInlineUnconditionally
   1 f
   1 lvl
 1 UnfoldingDone 1 Roman.bar
 1 RuleFired 1 foo/bar
-1 LetFloatFromLet 1
+3 LetFloatFromLet 3
 1 EtaReduction 1 ds
 7 BetaReduction
   1 f
diff --git a/testsuite/tests/simplCore/should_compile/spec-inline.stderr b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
index e7fc531a43..0de46d181d 100644
--- a/testsuite/tests/simplCore/should_compile/spec-inline.stderr
+++ b/testsuite/tests/simplCore/should_compile/spec-inline.stderr
@@ -1,15 +1,31 @@
 
 ==================== Tidy Core ====================
-Result size of Tidy Core = {terms: 172, types: 65, coercions: 0}
+Result size of Tidy Core = {terms: 178, types: 68, coercions: 0}
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+Roman.$trModule4 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+Roman.$trModule4 = "main"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
-Roman.$trModule2 :: GHC.Types.TrName
+Roman.$trModule3 :: GHC.Types.TrName
 [GblId,
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 20}]
-Roman.$trModule2 = GHC.Types.TrNameS "main"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+Roman.$trModule3 = GHC.Types.TrNameS Roman.$trModule4
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+Roman.$trModule2 :: GHC.Prim.Addr#
+[GblId,
+ Caf=NoCafRefs,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}]
+Roman.$trModule2 = "Roman"#
 
 -- RHS size: {terms: 2, types: 0, coercions: 0}
 Roman.$trModule1 :: GHC.Types.TrName
@@ -17,8 +33,8 @@ Roman.$trModule1 :: GHC.Types.TrName
  Caf=NoCafRefs,
  Str=m1,
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
-         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 20}]
-Roman.$trModule1 = GHC.Types.TrNameS "Roman"#
+         WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+Roman.$trModule1 = GHC.Types.TrNameS Roman.$trModule2
 
 -- RHS size: {terms: 3, types: 0, coercions: 0}
 Roman.$trModule :: GHC.Types.Module
@@ -28,16 +44,18 @@ Roman.$trModule :: GHC.Types.Module
  Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
          WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
 Roman.$trModule =
-  GHC.Types.Module Roman.$trModule2 Roman.$trModule1
+  GHC.Types.Module Roman.$trModule3 Roman.$trModule1
+
+-- RHS size: {terms: 1, types: 0, coercions: 0}
+lvl :: GHC.Prim.Addr#
+[GblId, Caf=NoCafRefs]
+lvl = "spec-inline.hs:(19,5)-(29,25)|function go"#
 
 -- RHS size: {terms: 2, types: 2, coercions: 0}
 Roman.foo3 :: Int
 [GblId, Str=x]
 Roman.foo3 =
-  Control.Exception.Base.patError
-    @ 'GHC.Types.LiftedRep
-    @ Int
-    "spec-inline.hs:(19,5)-(29,25)|function go"#
+  Control.Exception.Base.patError @ 'GHC.Types.LiftedRep @ Int lvl
 
 Rec {
 -- RHS size: {terms: 55, types: 9, coercions: 0}
diff --git a/testsuite/tests/simplCore/should_compile/str-rules.hs b/testsuite/tests/simplCore/should_compile/str-rules.hs
new file mode 100644
index 0000000000..a94df9958c
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/str-rules.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE MagicHash #-}
+import GHC.CString (unpackFoldrCString#, unpackCString#)
+import GHC.Base (eqString)
+main :: IO ()
+main = do
+  let mix c n = fromEnum c + n
+  n <- readLn
+
+  print $
+    -- We expect the two literals to be concatenated, resulting in "@@@ ab"
+    unpackFoldrCString# "@@@ a"# mix
+      (unpackFoldrCString# "b"# mix n)
+
+  if eqString (unpackCString# "x"#) (unpackCString# "y"#)
+    then putStrLn $ unpackCString# "@@@ c"# -- this should be optimized out
+    else putStrLn $ unpackCString# "@@@ d"#
+
+  if eqString (unpackCString# "foo"#) (unpackCString# "foo"#)
+    then putStrLn $ unpackCString# "@@@ e"#
+    else putStrLn $ unpackCString# "@@@ f"# -- this should be optimized out
diff --git a/testsuite/tests/simplCore/should_compile/str-rules.stdout b/testsuite/tests/simplCore/should_compile/str-rules.stdout
new file mode 100644
index 0000000000..a3f3ae899d
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/str-rules.stdout
@@ -0,0 +1,3 @@
+"@@@ ab"#
+"@@@ d"#
+"@@@ e"#