Fix SetLevels for makeStaticPtr
authorSimon Peyton Jones <simonpj@microsoft.com>
Sun, 26 Feb 2017 18:51:57 +0000 (13:51 -0500)
committerBen Gamari <ben@smart-cactus.org>
Sun, 26 Feb 2017 19:56:21 +0000 (14:56 -0500)
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.

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

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

compiler/simplCore/SetLevels.hs

index 22d4048..7b17c8d 100644 (file)
@@ -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
@@ -1499,8 +1502,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))
        }
@@ -1511,8 +1515,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