[commit: ghc] wip/spj-early-inline2: Fix SetLevels for makeStaticPtr (3ca0287)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : wip/spj-early-inline2
Link       : http://ghc.haskell.org/trac/ghc/changeset/3ca0287c527078bfc85e1db19582504f87a533cd/ghc

>---------------------------------------------------------------

commit 3ca0287c527078bfc85e1db19582504f87a533cd
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Feb 14 14:13:16 2017 +0000

    Fix SetLevels for makeStaticPtr
    
    This too is prepartory for my early-inlining patch.  It turned
    out that early inlining exposed a bug in the way that static
    pointers were being floated.


>---------------------------------------------------------------

3ca0287c527078bfc85e1db19582504f87a533cd
 compiler/simplCore/SetLevels.hs | 17 ++++++++++-------
 1 file changed, 10 insertions(+), 7 deletions(-)

diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs
index 4fca18d..f681bf3 100644
--- a/compiler/simplCore/SetLevels.hs
+++ b/compiler/simplCore/SetLevels.hs
@@ -566,12 +566,12 @@ lvlMFE env strict_ctxt ann_expr
          -- or if we are wrapping it in one or more value lambdas
   = do { expr1 <- lvlFloatRhs abs_vars dest_lvl rhs_env NonRecursive join_arity_maybe ann_expr
                   -- Treat the expr just like a right-hand side
-       ; var <- newLvlVar expr1 join_arity_maybe
+       ; var <- newLvlVar expr1 join_arity_maybe is_mk_static
        ; let var2 = annotateBotStr var float_n_lams mb_bot_str
        ; return (Let (NonRec (TB var2 (FloatMe dest_lvl)) expr1)
                      (mkVarApps (Var var2) abs_vars)) }
 
-  -- OK, so the float has an unlifted type
+  -- OK, so the float has an unlifted type (not top-level bindable)
   --     and no new value lambdas (float_is_new_lam is False)
   -- Try for the boxing strategy
   -- See Note [Floating MFEs of unlifted type]
@@ -588,7 +588,7 @@ lvlMFE env strict_ctxt ann_expr
                          Case expr1 (stayPut l1r ubx_bndr) dc_res_ty
                              [(DEFAULT, [], mkConApp dc [Var ubx_bndr])]
 
-       ; var <- newLvlVar float_rhs Nothing
+       ; var <- newLvlVar float_rhs Nothing is_mk_static
        ; let l1u      = incMinorLvlFrom env
              use_expr = Case (mkVarApps (Var var) abs_vars)
                              (stayPut l1u bx_bndr) expr_ty
@@ -626,9 +626,12 @@ lvlMFE env strict_ctxt ann_expr
     join_arity_maybe | need_join = Just (length abs_vars)
                      | otherwise = Nothing
 
+    is_mk_static = isJust (collectMakeStaticArgs expr)
+        -- Yuk: See Note [Grand plan for static forms] in main/StaticPtrTable
+
         -- A decision to float entails let-binding this thing, and we only do
         -- that if we'll escape a value lambda, or will go to the top level.
-    float_me = saves_work || saves_alloc
+    float_me = saves_work || saves_alloc || is_mk_static
 
     -- We can save work if we can move a redex outside a value lambda
     -- But if float_is_new_lam is True, then the redex is wrapped in a
@@ -1503,8 +1506,9 @@ newPolyBndrs dest_lvl
 
 newLvlVar :: LevelledExpr        -- The RHS of the new binding
           -> Maybe JoinArity     -- Its join arity, if it is a join point
+          -> Bool                -- True <=> the RHS looks like (makeStatic ...)
           -> LvlM Id
-newLvlVar lvld_rhs join_arity_maybe
+newLvlVar lvld_rhs join_arity_maybe is_mk_static
   = do { uniq <- getUniqueM
        ; return (add_join_info (mk_id uniq rhs_ty))
        }
@@ -1515,8 +1519,7 @@ newLvlVar lvld_rhs join_arity_maybe
 
     mk_id uniq rhs_ty
       -- See Note [Grand plan for static forms] in StaticPtrTable.
-      | isJust $ collectMakeStaticArgs $ snd $
-        collectTyBinders de_tagged_rhs
+      | is_mk_static
       = mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
                             rhs_ty
       | otherwise