From d49b2bb21691892ca6ac8f2403e31f2a5e53feb3 Mon Sep 17 00:00:00 2001
From: Takano Akio <tak@anoak.io>
Date: Wed, 18 Jan 2017 18:26:47 -0500
Subject: 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
---
 compiler/stgSyn/CoreToStg.hs | 19 +++++++++++++------
 1 file changed, 13 insertions(+), 6 deletions(-)

(limited to 'compiler/stgSyn/CoreToStg.hs')

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
-- 
cgit v1.2.1