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

Have addModFinalizer expose the local type environment.

Summary:
Kind inference in ghci was interfered when renaming of type splices
introduced the HsSpliced data constructor. This patch has kind
inference skip over it.

Test Plan: ./validate

Reviewers: simonpj, rrnewton, austin, goldfire, bgamari

Reviewed By: goldfire, bgamari

Subscribers: thomie, mboes

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

GHC Trac Issues: #12985
parent f3c7cf9b
......@@ -67,7 +67,6 @@ 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
......@@ -390,12 +389,12 @@ lintCoreBindings dflags pass local_in_scope binds
_ -> True
-- See Note [Checking StaticPtrs]
check_static_ptrs = xopt LangExt.StaticPointers dflags &&
case pass of
CoreDoFloatOutwards _ -> True
CoreTidy -> True
CorePrep -> True
_ -> False
check_static_ptrs | not (xopt LangExt.StaticPointers dflags) = AllowAnywhere
| otherwise = case pass of
CoreDoFloatOutwards _ -> AllowAtTopLevel
CoreTidy -> RejectEverywhere
CorePrep -> AllowAtTopLevel
_ -> AllowAnywhere
binders = bindersOfBinds binds
(_, dups) = removeDups compare binders
......@@ -536,28 +535,32 @@ 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 applications of the data constructor @StaticPtr@
-- when they appear at the top level.
-- in that it doesn't reject occurrences of the function 'makeStatic' when they
-- appear at the top level and @lf_check_static_ptrs == AllowAtTopLevel@.
--
-- See Note [Checking StaticPtrs].
lintRhs :: CoreExpr -> LintM OutType
-- 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
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
-- imitate @lintCoreExpr (Lam ...)@
var : vars -> addLoc (LambdaBodyOf var) $
lintBinder var $ \var' ->
do { body_ty <- loopBinders vars
; return $ mkLamType var' body_ty }
(\var loopBinders ->
addLoc (LambdaBodyOf var) $
lintBinder var $ \var' ->
do { body_ty <- loopBinders
; return $ mkLamType var' body_ty }
)
-- imitate @lintCoreExpr (App ...)@
[] -> 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
(do fun_ty <- lintCoreExpr fun
addLoc (AnExpr rhs') $ lintCoreArgs fun_ty [Type t, info, e]
)
binders0
go _ = lintCoreExpr rhs
lintIdUnfolding :: Id -> Type -> Unfolding -> LintM ()
lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src })
......@@ -673,11 +676,10 @@ 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
, Just con <- isDataConId_maybe b
, dataConName con == staticPtrDataConName
Var b | lf_check_static_ptrs lf /= AllowAnywhere
, idName b == makeStaticName
-> do
failWithL $ text "Found StaticPtr nested in an expression: " <+>
failWithL $ text "Found makeStatic nested in an expression: " <+>
ppr e
_ -> go
where
......@@ -1609,13 +1611,24 @@ 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 :: Bool -- See Note [Checking StaticPtrs]
, lf_check_static_ptrs :: StaticPtrCheck
-- ^ 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 = False
, lf_check_static_ptrs = AllowAnywhere
}
newtype LintM a =
......@@ -1635,30 +1648,17 @@ Note [Checking StaticPtrs]
~~~~~~~~~~~~~~~~~~~~~~~~~~
See SimplCore Note [Grand plan for static forms] for an overview.
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
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
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.
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.
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.
Note [Type substitution]
~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -48,13 +48,13 @@ module CoreUtils (
stripTicksE, stripTicksT,
-- * StaticPtr
collectStaticPtrSatArgs
collectMakeStaticArgs
) where
#include "HsVersions.h"
import CoreSyn
import PrelNames ( staticPtrDataConName )
import PrelNames ( makeStaticName )
import PprCore
import CoreFVs( exprFreeVars )
import Var
......@@ -2217,16 +2217,13 @@ isEmptyTy ty
*****************************************************
-}
-- | @collectStaticPtrSatArgs e@ yields @Just (s, args)@ when @e = s args@
-- and @s = StaticPtr@ and the application of @StaticPtr@ is saturated.
-- | @collectMakeStaticArgs (makeStatic t info e)@ yields
-- @Just (makeStatic, t, info, e)@.
--
-- 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
-- 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
......@@ -27,7 +27,6 @@ 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
......@@ -56,11 +55,7 @@ import Bag
import Outputable
import PatSyn
import Data.List ( intercalate )
import Data.IORef ( atomicModifyIORef' )
import Control.Monad
import GHC.Fingerprint
{-
************************************************************************
......@@ -423,24 +418,17 @@ dsExpr (PArrSeq _ _)
Static Pointers
~~~~~~~~~~~~~~~
See Note [Grand plan for static forms] in SimplCore for an overview.
g = ... static 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"
g = ... makeStatic (StaticPtrInfo "pkg key" "module" loc) f ...
-}
dsExpr (HsStatic _ expr@(L loc _)) = do
expr_ds <- dsLExpr expr
let ty = exprType expr_ds
staticPtrInfoDataCon <- dsLookupDataCon staticPtrInfoDataConName
staticPtrDataCon <- dsLookupDataCon staticPtrDataConName
makeStaticId <- dsLookupGlobalId makeStaticName
dflags <- getDynFlags
let (line, col) = case loc of
......@@ -452,48 +440,18 @@ 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 $
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
putSrcSpanDs loc $ return $
mkCoreApps (Var makeStaticId) [ Type ty, info, expr_ds ]
{-
\noindent
......
......@@ -46,79 +46,146 @@
--
{-# LANGUAGE ViewPatterns #-}
module StaticPtrTable (sptModuleInitCode) where
module StaticPtrTable (sptCreateStaticBinds) where
-- See SimplCore Note [Grand plan for static forms]
-- See SimplCore Note [Grand plan for static forms] for an overview.
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
-- | @sptModuleInitCode module binds@ is a C stub to insert the static entries
-- found in @binds@ of @module@ into the static pointer table.
-- | Replaces all bindings of the form
--
-- A bind is considered a static entry if it is an application of the
-- data constructor @StaticPtr@.
-- > b = /\ ... -> makeStatic info value
--
sptModuleInitCode :: Module -> CoreProgram -> SDoc
sptModuleInitCode this_mod binds =
sptInitCode $ catMaybes
$ map (\(b, e) -> ((,) b) <$> staticPtrFp e)
$ flattenBinds binds
-- 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')
where
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
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
fromPlatformWord64Rep (MachWord w) = Just w
fromPlatformWord64Rep (MachWord64 w) = Just w
fromPlatformWord64Rep _ = Nothing
staticPtrDataCon <- lift $ lookupDataCon staticPtrDataConName
return (fp, mkConApp staticPtrDataCon
[ Type t
, mkWord64LitWordRep dflags w0
, mkWord64LitWordRep dflags w1
, info
, e ])
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
]
]
mkStaticPtrFingerprint :: Int -> Fingerprint
mkStaticPtrFingerprint n = fingerprintString $ intercalate ":"
[ unitIdString $ moduleUnitId this_mod
, moduleNameString $ moduleName this_mod
, show n
]
-- 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
......
......@@ -20,7 +20,7 @@ import CoreFVs
import CoreTidy
import CoreMonad
import CorePrep
import CoreUtils (rhsIsStatic, collectStaticPtrSatArgs)
import CoreUtils (rhsIsStatic)
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 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
}
-- 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'
-- Get the TyCons to generate code for. Careful! We must use
-- the untidied TypeEnv here, because we need
......@@ -638,27 +638,19 @@ 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) $
map fst $ filter is_external flatten_binds
init_ext_ids = sortBy (compare `on` getOccName) $ filter is_external binders
-- 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, or
-- (d) it is a static pointer (see notes in StaticPtrTable.hs).
-- (c) it is the vectorised version of an imported Id.
-- See Note [Which rules to expose]
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
is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars
|| id `elemVarSet` vect_var_vs
rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules
vect_var_vs = mkVarSet [var_v | (var, var_v) <- eltsUDFM vect_vars, isGlobalId var]
flatten_binds = flattenBinds binds
binders = map fst flatten_binds
binders = map fst $ flattenBinds binds
implicit_binders = bindersOfBinds implicit_binds
binder_set = mkVarSet binders
......
......@@ -383,6 +383,7 @@ basicKnownKeyNames
, ghciIoClassName, ghciStepIoMName
-- StaticPtr
, makeStaticName
, staticPtrTyConName
, staticPtrDataConName, staticPtrInfoDataConName
, fromStaticPtrName
......@@ -521,6 +522,9 @@ 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")
......@@ -1386,6 +1390,10 @@ 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
......@@ -2220,6 +2228,9 @@ pushCallStackKey = mkPreludeMiscIdUnique 518
fromStaticPtrClassOpKey :: Unique
fromStaticPtrClassOpKey = mkPreludeMiscIdUnique 519
makeStaticKey :: Unique
makeStaticKey = mkPreludeMiscIdUnique 520
{-
************************************************************************
* *
......
......@@ -66,7 +66,7 @@ import CoreSyn
import CoreMonad ( FloatOutSwitches(..) )
import CoreUtils ( exprType
, exprOkForSpeculation
, collectStaticPtrSatArgs
, collectMakeStaticArgs
)
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 $ collectStaticPtrSatArgs $ snd $
| isJust $ collectMakeStaticArgs $ snd $
collectTyBinders de_tagged_rhs
= mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
rhs_ty
......
......@@ -1044,37 +1044,50 @@ Here is a running example:
in a nested let, we are fine.
* The desugarer replaces the static form with an application of the
data constructor 'StaticPtr' (defined in module GHC.StaticPtr of
function 'makeStatic' (defined in module GHC.StaticPtr.Internal of
base). So we get
f x = let k = map toUpper
in ...(StaticPtr <fingerprint> k)...
in ...(makeStatic (StaticPtrInfo "pkg" "module" location) k)...
* The simplifier runs the FloatOut pass which moves the applications
of 'StaticPtr' to the top level. Thus the FloatOut pass is always
executed, even when optimizations are disabled. So we get