Commit dd92c67b authored by Facundo Domínguez's avatar Facundo Domínguez

Stop the simplifier from removing StaticPtr binds.

Summary:
We have the FloatOut pass create exported ids for floated StaticPtr
bindings. The simplifier doesn't try to remove those.

This patch also improves on 7fc20b by making a common definition
collectStaticPtrSatArgs to test for StaticPtr binds.

Fixes #12207.

Test Plan: ./validate

Reviewers: simonpj, austin, bgamari, simonmar, goldfire

Reviewed By: simonpj

Subscribers: thomie

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

GHC Trac Issues: #12207
parent dc62a222
......@@ -552,10 +552,7 @@ lintRhs :: CoreExpr -> LintM OutType
-- but produce errors otherwise.
lintRhs rhs
| (binders0, rhs') <- collectTyBinders rhs
, (fun@(Var b), args, _) <- collectArgsTicks (const True) rhs'
, Just con <- isDataConId_maybe b
, dataConName con == staticPtrDataConName
, length args == 5
, Just (fun, args) <- collectStaticPtrSatArgs rhs'
= flip fix binders0 $ \loopBinders binders -> case binders of
-- imitate @lintCoreExpr (Lam ...)@
var : vars -> addLoc (LambdaBodyOf var) $
......
......@@ -45,12 +45,16 @@ module CoreUtils (
-- * Working with ticks
stripTicksTop, stripTicksTopE, stripTicksTopT,
stripTicksE, stripTicksT
stripTicksE, stripTicksT,
-- * StaticPtr
collectStaticPtrSatArgs
) where
#include "HsVersions.h"
import CoreSyn
import PrelNames ( staticPtrDataConName )
import PprCore
import CoreFVs( exprFreeVars )
import Var
......@@ -2203,3 +2207,25 @@ isEmptyTy ty
= True
| otherwise
= False
{-
*****************************************************
*
* StaticPtr
*
*****************************************************
-}
-- | @collectStaticPtrSatArgs e@ yields @Just (s, args)@ when @e = s args@
-- and @s = StaticPtr@ and the application of @StaticPtr@ is saturated.
--
-- Yields @Nothing@ otherwise.
collectStaticPtrSatArgs :: Expr b -> Maybe (Expr b, [Arg b])
collectStaticPtrSatArgs e
| (fun@(Var b), args, _) <- collectArgsTicks (const True) e
, Just con <- isDataConId_maybe b
, dataConName con == staticPtrDataConName
, length args == 5
= Just (fun, args)
collectStaticPtrSatArgs _
= Nothing
......@@ -20,11 +20,10 @@ import CoreFVs
import CoreTidy
import CoreMonad
import CorePrep
import CoreUtils (rhsIsStatic)
import CoreUtils (rhsIsStatic, collectStaticPtrSatArgs)
import CoreStats (coreBindsStats, CoreStats(..))
import CoreLint
import Literal
import PrelNames
import Rules
import PatSyn
import ConLike
......@@ -655,11 +654,8 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
|| isStaticPtrApp e
isStaticPtrApp :: CoreExpr -> Bool
isStaticPtrApp (collectTyBinders -> (_, e))
| (Var v, _) <- collectArgs e
, Just con <- isDataConId_maybe v
= dataConName con == staticPtrDataConName
isStaticPtrApp _ = False
isStaticPtrApp (collectTyBinders -> (_, e)) =
isJust $ collectStaticPtrSatArgs e
rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules
vect_var_vs = mkVarSet [var_v | (var, var_v) <- nameEnvElts vect_vars, isGlobalId var]
......
......@@ -64,7 +64,11 @@ module SetLevels (
import CoreSyn
import CoreMonad ( FloatOutSwitches(..) )
import CoreUtils ( exprType, exprOkForSpeculation, exprIsBottom )
import CoreUtils ( exprType
, exprOkForSpeculation
, exprIsBottom
, collectStaticPtrSatArgs
)
import CoreArity ( exprBotStrictness_maybe )
import CoreFVs -- all of it
import CoreSubst
......@@ -86,6 +90,7 @@ import Outputable
import FastString
import UniqDFM
import FV
import Data.Maybe
{-
************************************************************************
......@@ -1099,7 +1104,8 @@ newLvlVar :: LevelledExpr -- The RHS of the new binding
-> LvlM Id
newLvlVar lvld_rhs is_bot
= do { uniq <- getUniqueM
; return (add_bot_info (mkLocalIdOrCoVar (mk_name uniq) rhs_ty)) }
; return (add_bot_info (mk_id uniq))
}
where
add_bot_info var -- We could call annotateBotStr always, but the is_bot
-- flag just tells us when we don't need to do so
......@@ -1107,7 +1113,13 @@ newLvlVar lvld_rhs is_bot
| otherwise = var
de_tagged_rhs = deTagExpr lvld_rhs
rhs_ty = exprType de_tagged_rhs
mk_name uniq = mkSystemVarName uniq (mkFastString "lvl")
mk_id uniq
-- See Note [Grand plan for static forms] in SimplCore.
| isJust (collectStaticPtrSatArgs lvld_rhs)
= mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
rhs_ty
| otherwise
= mkLocalIdOrCoVar (mkSystemVarName uniq (mkFastString "lvl")) rhs_ty
cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
cloneCaseBndrs env@(LE { le_subst = subst, le_lvl_env = lvl_env, le_env = id_env })
......
......@@ -1029,8 +1029,22 @@ Here is a running example:
executed, even when optimizations are disabled. So we get
k = map toUpper
lvl = StaticPtr <fingerprint> k
f x = ...lvl...
static_ptr = StaticPtr <fingerprint> k
f x = ...static_ptr...
The FloatOut pass is careful to produce an /exported/ Id for a floated
'StaticPtr', so the binding is not removed by the simplifier (see #12207).
E.g. the code for `f` above might look like
static_ptr = StaticPtr <fingerprint> k
f x = ...(staticKey static_ptr)...
which might correctly be simplified to
f x = ...<fingerprint>...
BUT the top-level binding for static_ptr must remain, so that it can be
collected to populate the Static Pointer Table.
* The CoreTidy pass produces a C function which inserts all the
floated 'StaticPtr' in the static pointer table (see the call to
......
......@@ -117,9 +117,7 @@ test('T8103', only_ways(['normal']), compile_and_run, [''])
test('T7953', reqlib('random'), compile_and_run, [''])
test('T8256', normal, compile_and_run, ['-dcore-lint -O1'])
test('T6084',normal, compile_and_run, ['-O2'])
test('CgStaticPointers',
[when(doing_ghci(), extra_hc_opts('-fobject-code')),
expect_broken_for(12207, opt_ways)],
test('CgStaticPointers', [when(doing_ghci(), extra_hc_opts('-fobject-code'))],
compile_and_run, [''])
test('StaticArraySize', [when(doing_ghci(), extra_hc_opts('-fobject-code'))],
compile_and_run, ['-O2'])
......
......@@ -275,13 +275,9 @@ test('rdynamic', [ unless(opsys('linux') or opsys('mingw32'), skip)
],
compile_and_run, ['-rdynamic -package ghc'])
test('GcStaticPointers',
[when(doing_ghci(), extra_hc_opts('-fobject-code')),
expect_broken_for(12207, opt_ways)],
test('GcStaticPointers', [when(doing_ghci(), extra_hc_opts('-fobject-code'))],
compile_and_run, [''])
test('ListStaticPointers',
[when(doing_ghci(), extra_hc_opts('-fobject-code')),
expect_broken_for(12207, opt_ways)],
test('ListStaticPointers', [when(doing_ghci(), extra_hc_opts('-fobject-code'))],
compile_and_run, [''])
# 251 = RTS exit code for "out of memory"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment