diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2017-02-14 14:13:16 +0000 |
|---|---|---|
| committer | David Feuer <David.Feuer@gmail.com> | 2017-02-20 19:08:41 -0500 |
| commit | 3ca0287c527078bfc85e1db19582504f87a533cd (patch) | |
| tree | 7157c38a5b88da297f8c6a32ee14a7cc2d1981d0 | |
| parent | f484a24716acb9eccf10dfd11f8a25ca01df056c (diff) | |
| download | haskell-3ca0287c527078bfc85e1db19582504f87a533cd.tar.gz | |
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.
| -rw-r--r-- | compiler/simplCore/SetLevels.hs | 17 |
1 files changed, 10 insertions, 7 deletions
diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index 4fca18d9f2..f681bf3a25 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 |