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

4 files changed, 27 insertions, 19 deletions

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)