StaticPointers: Allow closed vars in the static form.

Summary:
With this patch closed variables are allowed regardless of whether
they are bound at the top level or not.

The FloatOut pass is always performed. When optimizations are
disabled, only expressions that go to the top level are floated.
Thus, the applications of the StaticPtr data constructor are always
floated.

The CoreTidy pass makes sure the floated applications appear in the
symbol table of object files. It also collects the floated bindings
and inserts them in the static pointer table.

The renamer does not check anymore if free variables appearing in the
static form are top-level. Instead, the typechecker looks at the
tct_closed flag to decide if the free variables are closed.

The linter checks that applications of StaticPtr only occur at the
top of top-level bindings after the FloatOut pass.

The field spInfoName of StaticPtrInfo has been removed. It used to
contain the name of the top-level binding that contains the StaticPtr
application. However, this information is no longer available when the
StaticPtr is constructed, as the binding name is determined now by the
FloatOut pass.

Test Plan: ./validate

Reviewers: goldfire, simonpj, austin, hvr, bgamari

Reviewed By: simonpj

Subscribers: thomie, mpickering, mboes

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

GHC Trac Issues: #11656

3 files changed, 57 insertions, 10 deletions

diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs
index de22e65132..fa4331291b 100644
--- a/compiler/simplCore/CoreMonad.hs
+++ b/compiler/simplCore/CoreMonad.hs
@@ -210,10 +210,12 @@ data FloatOutSwitches = FloatOutSwitches {
 
   floatOutConstants :: Bool,       -- ^ True <=> float constants to top level,
                                    --            even if they do not escape a lambda
-  floatOutOverSatApps :: Bool      -- ^ True <=> float out over-saturated applications
-                                   --            based on arity information.
-                                   -- See Note [Floating over-saturated applications]
-                                   -- in SetLevels
+  floatOutOverSatApps :: Bool,
+                             -- ^ True <=> float out over-saturated applications
+                             --            based on arity information.
+                             -- See Note [Floating over-saturated applications]
+                             -- in SetLevels
+  floatToTopLevelOnly :: Bool      -- ^ Allow floating to the top level only.
   }
 instance Outputable FloatOutSwitches where
     ppr = pprFloatOutSwitches
diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs
index f2d82ac7fa..86442ab54b 100644
--- a/compiler/simplCore/SetLevels.hs
+++ b/compiler/simplCore/SetLevels.hs
@@ -377,6 +377,7 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts
   | [(con@(DataAlt {}), bs, body)] <- alts
   , exprOkForSpeculation scrut'   -- See Note [Check the output scrutinee for okForSpec]
   , not (isTopLvl dest_lvl)       -- Can't have top-level cases
+  , not (floatTopLvlOnly env)     -- Can float anywhere
   =     -- See Note [Floating cases]
         -- Always float the case if possible
         -- Unlike lets we don't insist that it escapes a value lambda
@@ -475,7 +476,9 @@ lvlMFE True env e@(_, AnnCase {})
   = lvlExpr env e     -- Don't share cases
 
 lvlMFE strict_ctxt env ann_expr
-  |  isUnliftedType (exprType expr)
+  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)
+         -- Only floating to the top level is allowed.
+  || isUnliftedType (exprType expr)
          -- Can't let-bind it; see Note [Unlifted MFEs]
          -- This includes coercions, which we don't want to float anyway
          -- NB: no need to substitute cos isUnliftedType doesn't change
@@ -730,7 +733,9 @@ lvlBind env (AnnNonRec bndr rhs)
     is_bot     = exprIsBottom (deAnnotate rhs)
 
 lvlBind env (AnnRec pairs)
-  | not (profitableFloat env dest_lvl)
+  |  floatTopLvlOnly env && not (isTopLvl dest_lvl)
+         -- Only floating to the top level is allowed.
+  || not (profitableFloat env dest_lvl)
   = do { let bind_lvl = incMinorLvl (le_ctxt_lvl env)
              (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs
        ; rhss' <- mapM (lvlExpr env') rhss
@@ -979,6 +984,9 @@ floatConsts le = floatOutConstants (le_switches le)
 floatOverSat :: LevelEnv -> Bool
 floatOverSat le = floatOutOverSatApps (le_switches le)
 
+floatTopLvlOnly :: LevelEnv -> Bool
+floatTopLvlOnly le = floatToTopLevelOnly (le_switches le)
+
 setCtxtLvl :: LevelEnv -> Level -> LevelEnv
 setCtxtLvl env lvl = env { le_ctxt_lvl = lvl }
 
diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs
index 1ff0cee4f3..654fd521bd 100644
--- a/compiler/simplCore/SimplCore.hs
+++ b/compiler/simplCore/SimplCore.hs
@@ -53,6 +53,7 @@ import Maybes
 import UniqSupply       ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
 import Outputable
 import Control.Monad
+import qualified GHC.LanguageExtensions as LangExt
 
 #ifdef GHCI
 import DynamicLoading   ( loadPlugins )
@@ -128,6 +129,7 @@ getCoreToDo dflags
     rules_on      = gopt Opt_EnableRewriteRules           dflags
     eta_expand_on = gopt Opt_DoLambdaEtaExpansion         dflags
     ww_on         = gopt Opt_WorkerWrapper                dflags
+    static_ptrs   = xopt LangExt.StaticPointers           dflags
 
     maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase)
 
@@ -201,8 +203,15 @@ getCoreToDo dflags
 
     core_todo =
      if opt_level == 0 then
-       [ vectorisation
-       , CoreDoSimplify max_iter
+       [ vectorisation,
+         -- Static forms are moved to the top level with the FloatOut pass.
+         -- See Note [Grand plan for static forms].
+         runWhen static_ptrs $ CoreDoFloatOutwards FloatOutSwitches {
+                                 floatOutLambdas   = Just 0,
+                                 floatOutConstants = True,
+                                 floatOutOverSatApps = False,
+                                 floatToTopLevelOnly = True },
+         CoreDoSimplify max_iter
              (base_mode { sm_phase = Phase 0
                         , sm_names = ["Non-opt simplification"] })
        ]
@@ -230,7 +239,8 @@ getCoreToDo dflags
            CoreDoFloatOutwards FloatOutSwitches {
                                  floatOutLambdas   = Just 0,
                                  floatOutConstants = True,
-                                 floatOutOverSatApps = False },
+                                 floatOutOverSatApps = False,
+                                 floatToTopLevelOnly = False },
                 -- Was: gentleFloatOutSwitches
                 --
                 -- I have no idea why, but not floating constants to
@@ -281,7 +291,8 @@ getCoreToDo dflags
            CoreDoFloatOutwards FloatOutSwitches {
                                  floatOutLambdas     = floatLamArgs dflags,
                                  floatOutConstants   = True,
-                                 floatOutOverSatApps = True },
+                                 floatOutOverSatApps = True,
+                                 floatToTopLevelOnly = False },
                 -- nofib/spectral/hartel/wang doubles in speed if you
                 -- do full laziness late in the day.  It only happens
                 -- after fusion and other stuff, so the early pass doesn't
@@ -977,3 +988,29 @@ transferIdInfo exported_id local_id
                                (ruleInfo local_info)
         -- Remember to set the function-name field of the
         -- rules as we transfer them from one function to another
+
+
+-- Note [Grand plan for static forms]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- Static forms go through the compilation phases as follows:
+--
+-- The renamer looks for out-of-scope names in the body of the static form.
+-- If all names are in scope, the free variables of the body are stored in AST
+-- at the location of the static form.
+--
+-- The typechecker verifies that all free variables occurring in the static form
+-- are closed (see Note [Bindings with closed types] in TcRnTypes).
+--
+-- The desugarer replaces the static form with an application of the data
+-- constructor 'StaticPtr' (defined in module GHC.StaticPtr of base).
+--
+-- The simplifier runs the FloatOut pass which moves the applications of
+-- 'StaticPtr' to the top level. Thus the FloatOut pass is always executed,
+-- event when optimizations are disabled.
+--
+-- The CoreTidy pass produces a C function which inserts all the floated
+-- 'StaticPtr' in the static pointer table (See StaticPtrTable.hs).
+-- This pass also exports the Ids of floated 'StaticPtr's so they can be linked
+-- with the C function.
+--