Skip to content

GitLab

Glasgow Haskell Compiler
Glasgow Haskell Compiler
Commit c5452cc1 authored by Facundo Domínguez's avatar Facundo Domínguez
Browse files
Options

Revert "Have addModFinalizer expose the local type environment." 

This reverts commit e5d1ed9c.
parent 54227a45
Hide whitespace changes
Inline Side-by-side
Showing with 206 additions and 305 deletions
compiler/coreSyn/CoreLint.hs
View file @ c5452cc1
......@@ -67,6 +67,7 @@ import Control.Monad
import qualified Control.Monad.Fail as MonadFail
#endif
import MonadUtils
import Data.Function (fix)
import Data.Maybe
import Pair
import qualified GHC.LanguageExtensions as LangExt
......@@ -389,12 +390,12 @@ lintCoreBindings dflags pass local_in_scope binds
_ -> True
-- See Note [Checking StaticPtrs]
check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere
| otherwise = case pass of
CoreDoFloatOutwards _ -> AllowAtTopLevel
CoreTidy -> RejectEverywhere
CorePrep -> AllowAtTopLevel
_ -> AllowAnywhere
check_static_ptrs = xopt LangExt.StaticPointers dflags &&
case pass of
CoreDoFloatOutwards _ -> True
CoreTidy -> True
CorePrep -> True
_ -> False
binders = bindersOfBinds binds
(_, dups) = removeDups compare binders
......@@ -535,32 +536,28 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
| otherwise = return ()
-- | Checks the RHS of top-level bindings. It only differs from 'lintCoreExpr'
-- in that it doesn't reject occurrences of the function 'makeStatic' when they
-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@.
-- in that it doesn't reject applications of the data constructor @StaticPtr@
-- when they appear at the top level.
--
-- See Note [Checking StaticPtrs].
lintRhs :: CoreExpr -> LintM OutType
lintRhs rhs = fmap lf_check_static_ptrs getLintFlags >>= go
where
-- Allow occurrences of 'makeStatic' at the top-level but produce errors
-- otherwise.
go AllowAtTopLevel
| (binders0, rhs') <- collectTyBinders rhs
, Just (fun, t, info, e) <- collectMakeStaticArgs rhs'
= foldr
-- Allow applications of the data constructor @StaticPtr@ at the top
-- but produce errors otherwise.
lintRhs rhs
| (binders0, rhs') <- collectTyBinders rhs
, Just (fun, args) <- collectStaticPtrSatArgs rhs'
= flip fix binders0 $ \loopBinders binders -> case binders of
-- imitate @lintCoreExpr (Lam ...)@
(\var loopBinders ->
addLoc (LambdaBodyOf var) $
lintBinder var $ \var' ->
do { body_ty <- loopBinders
; return $ mkLamType var' body_ty }
)
var : vars -> addLoc (LambdaBodyOf var) $
lintBinder var $ \var' ->
do { body_ty <- loopBinders vars
; return $ mkLamType var' body_ty }
-- imitate @lintCoreExpr (App ...)@
(do fun_ty <- lintCoreExpr fun
addLoc (AnExpr rhs') $ lintCoreArgs fun_ty [Type t, info, e]
)
binders0
go _ = lintCoreExpr rhs
[] -> do
fun_ty <- lintCoreExpr fun
addLoc (AnExpr rhs') $ lintCoreArgs fun_ty args
-- Rejects applications of the data constructor @StaticPtr@ if it finds any.
lintRhs rhs = lintCoreExpr rhs
lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
......@@ -676,10 +673,11 @@ lintCoreExpr e@(App _ _)
-- Check for a nested occurrence of the StaticPtr constructor.
-- See Note [Checking StaticPtrs].
case fun of
Var b | lf_check_static_ptrs lf /= AllowAnywhere
, idName b == makeStaticName
Var b | lf_check_static_ptrs lf
, Just con <- isDataConId_maybe b
, dataConName con == staticPtrDataConName
-> do
failWithL $ text "Found makeStatic nested in an expression: " <+>
failWithL $ text "Found StaticPtr nested in an expression: " <+>
ppr e
_ -> go
where
......@@ -1611,24 +1609,13 @@ data LintEnv
data LintFlags
= LF { lf_check_global_ids :: Bool -- See Note [Checking for global Ids]
, lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers]
, lf_check_static_ptrs :: StaticPtrCheck
-- ^ See Note [Checking StaticPtrs]
, lf_check_static_ptrs :: Bool -- See Note [Checking StaticPtrs]
}
-- See Note [Checking StaticPtrs]
data StaticPtrCheck
= AllowAnywhere
-- ^ Allow 'makeStatic' to occur anywhere.
| AllowAtTopLevel
-- ^ Allow 'makeStatic' calls at the top-level only.
| RejectEverywhere
-- ^ Reject any 'makeStatic' occurrence.
deriving Eq
defaultLintFlags :: LintFlags
defaultLintFlags = LF { lf_check_global_ids = False
, lf_check_inline_loop_breakers = True
, lf_check_static_ptrs = AllowAnywhere
, lf_check_static_ptrs = False
}
newtype LintM a =
......@@ -1648,17 +1635,30 @@ Note [Checking StaticPtrs]
~~~~~~~~~~~~~~~~~~~~~~~~~~
See SimplCore Note [Grand plan for static forms] for an overview.
Every occurrence of the function 'makeStatic' should be moved to the
top level by the FloatOut pass. It's vital that we don't have nested
'makeStatic' occurrences after CorePrep, because we populate the Static
Every occurrence of the data constructor @StaticPtr@ should be moved
to the top level by the FloatOut pass. It's vital that we don't have
nested StaticPtr uses after CorePrep, because we populate the Static
Pointer Table from the top-level bindings. See SimplCore Note [Grand
plan for static forms].
The linter checks that no occurrence is left behind, nested within an
expression. The check is enabled only after the FloatOut, CorePrep,
and CoreTidy passes and only if the module uses the StaticPointers
language extension. Checking more often doesn't help since the condition
doesn't hold until after the first FloatOut pass.
expression. The check is enabled only:
* After the FloatOut, CorePrep, and CoreTidy passes.
We could check more often, but the condition doesn't hold until
after the first FloatOut pass.
* When the module uses the StaticPointers language extension. This is
a little hack. This optimization arose from the need to compile
GHC.StaticPtr, which otherwise would be rejected because of the
following binding for the StaticPtr data constructor itself:
StaticPtr = \a b1 b2 b3 b4 -> StaticPtr a b1 b2 b3 b4
which contains an application of `StaticPtr` nested within the
lambda abstractions. This binding is injected by CorePrep.
Note that GHC.StaticPtr is itself compiled without -XStaticPointers.
Note [Type substitution]
~~~~~~~~~~~~~~~~~~~~~~~~
......
compiler/coreSyn/CoreUtils.hs
View file @ c5452cc1
......@@ -48,13 +48,13 @@ module CoreUtils (
stripTicksE, stripTicksT,
-- * StaticPtr
collectMakeStaticArgs
collectStaticPtrSatArgs
) where
#include "HsVersions.h"
import CoreSyn
import PrelNames ( makeStaticName )
import PrelNames ( staticPtrDataConName )
import PprCore
import CoreFVs( exprFreeVars )
import Var
......@@ -2217,13 +2217,16 @@ isEmptyTy ty
*****************************************************
-}
-- | @collectMakeStaticArgs (makeStatic t info e)@ yields
-- @Just (makeStatic, t, info, e)@.
-- | @collectStaticPtrSatArgs e@ yields @Just (s, args)@ when @e = s args@
-- and @s = StaticPtr@ and the application of @StaticPtr@ is saturated.
--
-- Returns @Nothing@ for every other expression.
collectMakeStaticArgs
:: CoreExpr -> Maybe (CoreExpr, Type, CoreExpr, CoreExpr)
collectMakeStaticArgs e
| (fun@(Var b), [Type t, info, arg], _) <- collectArgsTicks (const True) e
, idName b == makeStaticName = Just (fun, t, info, arg)
collectMakeStaticArgs _ = Nothing
-- 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
compiler/deSugar/DsExpr.hs
View file @ c5452cc1
......@@ -27,6 +27,7 @@ import FamInstEnv( topNormaliseType )
import DsMeta
import HsSyn
import Platform
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types
import TcType
......@@ -55,7 +56,11 @@ import Bag
import Outputable
import PatSyn
import Data.List ( intercalate )
import Data.IORef ( atomicModifyIORef' )
import Control.Monad
import GHC.Fingerprint
{-
************************************************************************
......@@ -418,17 +423,24 @@ dsExpr (PArrSeq _ _)
Static Pointers
~~~~~~~~~~~~~~~
See Note [Grand plan for static forms] in SimplCore for an overview.
g = ... static f ...
==>
g = ... makeStatic (StaticPtrInfo "pkg key" "module" loc) f ...
g = ... StaticPtr
w0 w1
(StaticPtrInfo "current pkg key" "current module" "N")
f
...
Where we obtain w0 and w1 from
Fingerprint w0 w1 = fingerprintString "pkgKey:module:N"
-}
dsExpr (HsStatic _ expr@(L loc _)) = do
expr_ds <- dsLExpr expr
let ty = exprType expr_ds
makeStaticId <- dsLookupGlobalId makeStaticName
staticPtrInfoDataCon <- dsLookupDataCon staticPtrInfoDataConName
staticPtrDataCon <- dsLookupDataCon staticPtrDataConName
dflags <- getDynFlags
let (line, col) = case loc of
......@@ -440,18 +452,48 @@ dsExpr (HsStatic _ expr@(L loc _)) = do
[ Type intTy , Type intTy
, mkIntExprInt dflags line, mkIntExprInt dflags col
]
this_mod <- getModule
staticPtrInfoDataCon <- dsLookupDataCon staticPtrInfoDataConName
info <- mkConApp staticPtrInfoDataCon <$>
(++[srcLoc]) <$>
mapM mkStringExprFS
[ unitIdFS $ moduleUnitId this_mod
, moduleNameFS $ moduleName this_mod
]
Fingerprint w0 w1 <- mkStaticPtrFingerprint this_mod
putSrcSpanDs loc $ return $
mkCoreApps (Var makeStaticId) [ Type ty, info, expr_ds ]
mkConApp staticPtrDataCon [ Type ty
, mkWord64LitWordRep dflags w0
, mkWord64LitWordRep dflags w1
, info
, expr_ds
]
where
-- | Choose either 'Word64#' or 'Word#' to represent the arguments of the
-- 'Fingerprint' data constructor.
mkWord64LitWordRep dflags
| platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64
| otherwise = mkWordLit dflags . toInteger
mkStaticPtrFingerprint :: Module -> DsM Fingerprint
mkStaticPtrFingerprint this_mod = do
n <- mkGenPerModuleNum this_mod
return $ fingerprintString $ intercalate ":"
[ unitIdString $ moduleUnitId this_mod
, moduleNameString $ moduleName this_mod
, show n
]
mkGenPerModuleNum :: Module -> DsM Int
mkGenPerModuleNum this_mod = do
dflags <- getDynFlags
let -- Note [Generating fresh names for ccall wrapper]
-- in compiler/typecheck/TcEnv.hs
wrapperRef = nextWrapperNum dflags
wrapperNum <- liftIO $ atomicModifyIORef' wrapperRef $ \mod_env ->
let num = lookupWithDefaultModuleEnv mod_env 0 this_mod
in (extendModuleEnv mod_env this_mod (num + 1), num)
return wrapperNum
{-
\noindent
......
compiler/main/StaticPtrTable.hs
View file @ c5452cc1
......@@ -46,146 +46,79 @@
--
{-# LANGUAGE ViewPatterns #-}
module StaticPtrTable (sptCreateStaticBinds) where
module StaticPtrTable (sptModuleInitCode) where
-- See SimplCore Note [Grand plan for static forms] for an overview.
-- See SimplCore Note [Grand plan for static forms]
import CLabel
import CoreSyn
import CoreUtils (collectMakeStaticArgs)
import DataCon
import DynFlags
import HscTypes
import Id
import Literal
import Module
import Name
import Outputable
import Platform
import PrelNames
import Type
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State
import Data.List
import Data.Maybe
import GHC.Fingerprint
-- | Replaces all bindings of the form
-- | @sptModuleInitCode module binds@ is a C stub to insert the static entries
-- found in @binds@ of @module@ into the static pointer table.
--
-- > b = /\ ... -> makeStatic info value
-- A bind is considered a static entry if it is an application of the
-- data constructor @StaticPtr@.
--
-- with
--
-- > b = /\ ... -> StaticPtr key info value
--
-- where a distinct key is generated for each binding.
--
-- It also yields the C stub that inserts these bindings into the static
-- pointer table.
sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram
-> IO (SDoc, CoreProgram)
sptCreateStaticBinds hsc_env this_mod binds = do
(fps, binds') <- evalStateT (go [] [] binds) 0
return (sptModuleInitCode this_mod fps, binds')
sptModuleInitCode :: Module -> CoreProgram -> SDoc
sptModuleInitCode this_mod binds =
sptInitCode $ catMaybes
$ map (\(b, e) -> ((,) b) <$> staticPtrFp e)
$ flattenBinds binds
where
go fps bs xs = case xs of
[] -> return (reverse fps, reverse bs)
bnd : xs' -> do
(fps', bnd') <- replaceStaticBind bnd
go (reverse fps' ++ fps) (bnd' : bs) xs'
-- Generates keys and replaces 'makeStatic' with 'StaticPtr'.
--
-- The 'Int' state is used to produce a different key for each binding.
replaceStaticBind :: CoreBind
-> StateT Int IO ([(Id, Fingerprint)], CoreBind)
replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e
return (maybeToList mfp, NonRec b' e')
replaceStaticBind (Rec rbs) = do
(mfps, rbs') <- unzip <$> mapM (uncurry replaceStatic) rbs
return (catMaybes mfps, Rec rbs')
replaceStatic :: Id -> CoreExpr
-> StateT Int IO (Maybe (Id, Fingerprint), (Id, CoreExpr))
replaceStatic b e@(collectTyBinders -> (tvs, e0)) =
case collectMakeStaticArgs e0 of
Nothing -> return (Nothing, (b, e))
Just (_, t, info, arg) -> do
(fp, e') <- mkStaticBind t info arg
return (Just (b, fp), (b, foldr Lam e' tvs))
mkStaticBind :: Type -> CoreExpr -> CoreExpr
-> StateT Int IO (Fingerprint, CoreExpr)
mkStaticBind t info e = do
i <- get
put (i + 1)
let fp@(Fingerprint w0 w1) = mkStaticPtrFingerprint i
dflags = hsc_dflags hsc_env
staticPtrFp :: CoreExpr -> Maybe Fingerprint
staticPtrFp (collectTyBinders -> (_, e))
| (Var v, _ : Lit lit0 : Lit lit1 : _) <- collectArgs e
, Just con <- isDataConId_maybe v
, dataConName con == staticPtrDataConName
, Just w0 <- fromPlatformWord64Rep lit0
, Just w1 <- fromPlatformWord64Rep lit1
= Just $ Fingerprint (fromInteger w0) (fromInteger w1)
staticPtrFp _ = Nothing
staticPtrDataCon <- lift $ lookupDataCon staticPtrDataConName
return (fp, mkConApp staticPtrDataCon
[ Type t
, mkWord64LitWordRep dflags w0
, mkWord64LitWordRep dflags w1
, info
, e ])
fromPlatformWord64Rep (MachWord w) = Just w
fromPlatformWord64Rep (MachWord64 w) = Just w
fromPlatformWord64Rep _ = Nothing
mkStaticPtrFingerprint :: Int -> Fingerprint
mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"
[ unitIdString $ moduleUnitId this_mod
, moduleNameString $ moduleName this_mod
, show n
]
sptInitCode :: [(Id, Fingerprint)] -> SDoc
sptInitCode [] = Outputable.empty
sptInitCode entries = vcat
[ text "static void hs_spt_init_" <> ppr this_mod
<> text "(void) __attribute__((constructor));"
, text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"
, braces $ vcat $
[ text "static StgWord64 k" <> int i <> text "[2] = "
<> pprFingerprint fp <> semi
$$ text "extern StgPtr "
<> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi
$$ text "hs_spt_insert" <> parens
(hcat $ punctuate comma
[ char 'k' <> int i
, char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n))
]
)
<> semi
| (i, (n, fp)) <- zip [0..] entries
]
, text "static void hs_spt_fini_" <> ppr this_mod
<> text "(void) __attribute__((destructor));"
, text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"
, braces $ vcat $
[ text "StgWord64 k" <> int i <> text "[2] = "
<> pprFingerprint fp <> semi
$$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi
| (i, (_, fp)) <- zip [0..] entries
]
]
-- Choose either 'Word64#' or 'Word#' to represent the arguments of the
-- 'Fingerprint' data constructor.
mkWord64LitWordRep dflags
| platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64
| otherwise = mkWordLit dflags . toInteger
lookupDataCon :: Name -> IO DataCon
lookupDataCon n = lookupTypeHscEnv hsc_env n >>=
maybe (getError n) (return . tyThingDataCon)
getError n = pprPanic "sptCreateStaticBinds.get: not found" $
text "Couldn't find" <+> ppr n
-- | @sptModuleInitCode module fps@ is a C stub to insert the static entries
-- of @module@ into the static pointer table.
--
-- @fps@ is a list associating each binding corresponding to a static entry with
-- its fingerprint.
sptModuleInitCode :: Module -> [(Id, Fingerprint)] -> SDoc
sptModuleInitCode _ [] = Outputable.empty
sptModuleInitCode this_mod entries = vcat
[ text "static void hs_spt_init_" <> ppr this_mod
<> text "(void) __attribute__((constructor));"
, text "static void hs_spt_init_" <> ppr this_mod <> text "(void)"
, braces $ vcat $
[ text "static StgWord64 k" <> int i <> text "[2] = "
<> pprFingerprint fp <> semi
$$ text "extern StgPtr "
<> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi
$$ text "hs_spt_insert" <> parens
(hcat $ punctuate comma
[ char 'k' <> int i
, char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n))
]
)
<> semi
| (i, (n, fp)) <- zip [0..] entries
]
, text "static void hs_spt_fini_" <> ppr this_mod
<> text "(void) __attribute__((destructor));"
, text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)"
, braces $ vcat $
[ text "StgWord64 k" <> int i <> text "[2] = "
<> pprFingerprint fp <> semi
$$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi
| (i, (_, fp)) <- zip [0..] entries
]
]
where
pprFingerprint :: Fingerprint -> SDoc
pprFingerprint (Fingerprint w1 w2) =
braces $ hcat $ punctuate comma
......
compiler/main/TidyPgm.hs
View file @ c5452cc1
......@@ -20,7 +20,7 @@ import CoreFVs
import CoreTidy
import CoreMonad
import CorePrep
import CoreUtils (rhsIsStatic)
import CoreUtils (rhsIsStatic, collectStaticPtrSatArgs)
import CoreStats (coreBindsStats, CoreStats(..))
import CoreLint
import Literal
......@@ -373,12 +373,12 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
; type_env2 = extendTypeEnvWithPatSyns tidy_patsyns type_env1
; tidy_type_env = tidyTypeEnv omit_prags type_env2
}
-- See SimplCore Note [Grand plan for static forms]
; (spt_init_code, tidy_binds') <-
sptCreateStaticBinds hsc_env mod tidy_binds
; let { -- See Note [Injecting implicit bindings]
all_tidy_binds = implicit_binds ++ tidy_binds'
-- See Note [Injecting implicit bindings]
; all_tidy_binds = implicit_binds ++ tidy_binds
-- See SimplCore Note [Grand plan for static forms]
; spt_init_code = sptModuleInitCode mod all_tidy_binds
-- Get the TyCons to generate code for. Careful! We must use
-- the untidied TypeEnv here, because we need
......@@ -638,19 +638,27 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
-- same list every time this module is compiled), in contrast to the
-- bindings, which are ordered non-deterministically.
init_work_list = zip init_ext_ids init_ext_ids
init_ext_ids = sortBy (compare `on` getOccName) $ filter is_external binders
init_ext_ids = sortBy (compare `on` getOccName) $
map fst $ filter is_external flatten_binds
-- An Id should be external if either (a) it is exported,
-- (b) it appears in the RHS of a local rule for an imported Id, or
-- (c) it is the vectorised version of an imported Id.
-- (c) it is the vectorised version of an imported Id, or
-- (d) it is a static pointer (see notes in StaticPtrTable.hs).
-- See Note [Which rules to expose]
is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars
|| id `elemVarSet` vect_var_vs
is_external (id, e) = isExportedId id || id `elemVarSet` rule_rhs_vars
|| id `elemVarSet` vect_var_vs
|| isStaticPtrApp e
isStaticPtrApp :: CoreExpr -> Bool
isStaticPtrApp (collectTyBinders -> (_, e)) =
isJust $ collectStaticPtrSatArgs e
rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules
vect_var_vs = mkVarSet [var_v | (var, var_v) <- eltsUDFM vect_vars, isGlobalId var]
binders = map fst $ flattenBinds binds
flatten_binds = flattenBinds binds
binders = map fst flatten_binds
implicit_binders = bindersOfBinds implicit_binds
binder_set = mkVarSet binders
......
compiler/prelude/PrelNames.hs
View file @ c5452cc1
......@@ -383,7 +383,6 @@ basicKnownKeyNames
, ghciIoClassName, ghciStepIoMName
-- StaticPtr
, makeStaticName
, staticPtrTyConName
, staticPtrDataConName, staticPtrInfoDataConName
, fromStaticPtrName
......@@ -522,9 +521,6 @@ gHC_STACK_TYPES = mkBaseModule (fsLit "GHC.Stack.Types")
gHC_STATICPTR :: Module
gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr")
gHC_STATICPTR_INTERNAL :: Module
gHC_STATICPTR_INTERNAL = mkBaseModule (fsLit "GHC.StaticPtr.Internal")
gHC_FINGERPRINT_TYPE :: Module
gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type")
......@@ -1390,10 +1386,6 @@ frontendPluginTyConName :: Name
frontendPluginTyConName = tcQual pLUGINS (fsLit "FrontendPlugin") frontendPluginTyConKey
-- Static pointers
makeStaticName :: Name
makeStaticName =
varQual gHC_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey
staticPtrInfoTyConName :: Name
staticPtrInfoTyConName =
tcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey
......@@ -2228,9 +2220,6 @@ pushCallStackKey = mkPreludeMiscIdUnique 518
fromStaticPtrClassOpKey :: Unique
fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 519
makeStaticKey :: Unique
makeStaticKey = mkPreludeMiscIdUnique 520
{-
************************************************************************
* *
......
compiler/simplCore/SetLevels.hs
View file @ c5452cc1
......@@ -66,7 +66,7 @@ import CoreSyn
import CoreMonad ( FloatOutSwitches(..) )
import CoreUtils ( exprType
, exprOkForSpeculation
, collectMakeStaticArgs
, collectStaticPtrSatArgs
)
import CoreArity ( exprBotStrictness_maybe )
import CoreFVs -- all of it
......@@ -1187,7 +1187,7 @@ newLvlVar lvld_rhs
mk_id uniq rhs_ty
-- See Note [Grand plan for static forms] in SimplCore.
| isJust $ collectMakeStaticArgs $ snd $
| isJust $ collectStaticPtrSatArgs $ snd $
collectTyBinders de_tagged_rhs
= mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
rhs_ty
......
compiler/simplCore/SimplCore.hs
View file @ c5452cc1
......@@ -1044,50 +1044,37 @@ Here is a running example:
in a nested let, we are fine.
* The desugarer replaces the static form with an application of the
function 'makeStatic' (defined in module GHC.StaticPtr.Internal of
data constructor 'StaticPtr' (defined in module GHC.StaticPtr of
base). So we get
f x = let k = map toUpper
in ...(makeStatic (StaticPtrInfo "pkg" "module" location) k)...
in ...(StaticPtr <fingerprint> k)...
* The simplifier runs the FloatOut pass which moves the calls to 'makeStatic'
to the top level. Thus the FloatOut pass is always executed, even when
optimizations are disabled. So we get