Commit 36d29f7c authored by Facundo Domínguez's avatar Facundo Domínguez

StaticPointers: Allow closed vars in the static form.

Summary:
With this patch closed variables are allowed regardless of whether
they are bound at the top level or not.

The FloatOut pass is always performed. When optimizations are
disabled, only expressions that go to the top level are floated.
Thus, the applications of the StaticPtr data constructor are always
floated.

The CoreTidy pass makes sure the floated applications appear in the
symbol table of object files. It also collects the floated bindings
and inserts them in the static pointer table.

The renamer does not check anymore if free variables appearing in the
static form are top-level. Instead, the typechecker looks at the
tct_closed flag to decide if the free variables are closed.

The linter checks that applications of StaticPtr only occur at the
top of top-level bindings after the FloatOut pass.

The field spInfoName of StaticPtrInfo has been removed. It used to
contain the name of the top-level binding that contains the StaticPtr
application. However, this information is no longer available when the
StaticPtr is constructed, as the binding name is determined now by the
FloatOut pass.

Test Plan: ./validate

Reviewers: goldfire, simonpj, austin, hvr, bgamari

Reviewed By: simonpj

Subscribers: thomie, mpickering, mboes

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

GHC Trac Issues: #11656
parent fa86ac7c
......@@ -66,8 +66,10 @@ 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
{-
Note [GHC Formalism]
......@@ -370,7 +372,8 @@ lintCoreBindings dflags pass local_in_scope binds
; mapM lint_bind binds }
where
flags = LF { lf_check_global_ids = check_globals
, lf_check_inline_loop_breakers = check_lbs }
, lf_check_inline_loop_breakers = check_lbs
, lf_check_static_ptrs = check_static_ptrs }
-- See Note [Checking for global Ids]
check_globals = case pass of
......@@ -384,6 +387,14 @@ lintCoreBindings dflags pass local_in_scope binds
CoreDesugarOpt -> False
_ -> True
-- See Note [Checking StaticPtrs]
check_static_ptrs = xopt LangExt.StaticPointers dflags &&
case pass of
CoreDoFloatOutwards _ -> True
CoreTidy -> True
CorePrep -> True
_ -> False
binders = bindersOfBinds binds
(_, dups) = removeDups compare binders
......@@ -460,7 +471,7 @@ lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM ()
lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
= addLoc (RhsOf binder) $
-- Check the rhs
do { ty <- lintCoreExpr rhs
do { ty <- lintRhs rhs
; lintBinder binder -- Check match to RHS type
; binder_ty <- applySubstTy (idType binder)
; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty)
......@@ -530,6 +541,32 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
lintBinder var | isId var = lintIdBndr var $ \_ -> (return ())
| 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.
--
-- 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
, (fun@(Var b), args) <- collectArgs rhs'
, Just con <- isDataConId_maybe b
, dataConName con == staticPtrDataConName
, length args == 5
= flip fix binders0 $ \loopBinders binders -> case binders of
-- imitate @lintCoreExpr (Lam ...)@
var : vars -> addLoc (LambdaBodyOf var) $ lintBinder var $ \var' -> do
body_ty <- loopBinders vars
return $ mkPiType var' body_ty
-- imitate @lintCoreExpr (App ...)@
[] -> do
fun_ty <- lintCoreExpr fun
addLoc (AnExpr rhs') $ foldM lintCoreArg 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 })
| isStableSource src
......@@ -644,9 +681,21 @@ lintCoreExpr (Let (Rec pairs) body)
(_, dups) = removeDups compare bndrs
lintCoreExpr e@(App _ _)
= do { fun_ty <- lintCoreExpr fun
; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args }
= do lf <- getLintFlags
-- 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
-> do
failWithL $ text "Found StaticPtr nested in an expression: " <+>
ppr e
_ -> go
where
go = do { fun_ty <- lintCoreExpr fun
; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args }
(fun, args) = collectArgs e
lintCoreExpr (Lam var expr)
......@@ -1563,11 +1612,14 @@ 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]
}
defaultLintFlags :: LintFlags
defaultLintFlags = LF { lf_check_global_ids = False
, lf_check_inline_loop_breakers = True }
, lf_check_inline_loop_breakers = True
, lf_check_static_ptrs = False
}
newtype LintM a =
LintM { unLintM ::
......@@ -1582,6 +1634,13 @@ type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc)
Before CoreTidy, all locally-bound Ids must be LocalIds, even
top-level ones. See Note [Exported LocalIds] and Trac #9857.
Note [Checking StaticPtrs]
~~~~~~~~~~~~~~~~~~~~~~~~~~
Every occurrence of the data constructor @StaticPtr@ should be moved to the top
level by the FloatOut pass. The linter is checking that no occurrence is left
nested within an expression.
Note [Type substitution]
~~~~~~~~~~~~~~~~~~~~~~~~
Why do we need a type substitution? Consider
......
......@@ -31,7 +31,7 @@ module CoreSyn (
-- ** Simple 'Expr' access functions and predicates
bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
collectBinders, collectTyAndValBinders,
collectBinders, collectTyBinders, collectTyAndValBinders,
collectArgs, collectArgsTicks, flattenBinds,
exprToType, exprToCoercion_maybe,
......
......@@ -589,7 +589,7 @@ addTickHsExpr (ExplicitPArr ty es) =
(return ty)
(mapM (addTickLHsExpr) es)
addTickHsExpr (HsStatic e) = HsStatic <$> addTickLHsExpr e
addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e
addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds })
= do { rec_binds' <- addTickHsRecordBinds rec_binds
......
......@@ -60,7 +60,6 @@ import Coverage
import Util
import MonadUtils
import OrdList
import StaticPtrTable
import UniqFM
import ListSetOps
import Fingerprint
......@@ -312,20 +311,13 @@ deSugar hsc_env
; (ds_fords, foreign_prs) <- dsForeigns fords
; ds_rules <- mapMaybeM dsRule rules
; ds_vects <- mapM dsVect vects
; stBinds <- dsGetStaticBindsVar >>=
liftIO . readIORef
; let hpc_init
| gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
| otherwise = empty
-- Stub to insert the static entries of the
-- module into the static pointer table
spt_init = sptInitCode mod stBinds
; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs
`appOL` toOL (map snd stBinds)
, spec_rules ++ ds_rules, ds_vects
, ds_fords `appendStubC` hpc_init
`appendStubC` spt_init) }
, ds_fords `appendStubC` hpc_init) }
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
......
......@@ -57,8 +57,7 @@ import Outputable
import FastString
import PatSyn
import IfaceEnv
import Data.IORef ( atomicModifyIORef', modifyIORef )
import Data.IORef ( atomicModifyIORef' )
import Control.Monad
import GHC.Fingerprint
......@@ -412,30 +411,27 @@ dsExpr (PArrSeq _ _)
-- shouldn't have let it through
{-
\noindent
\underline{\bf Static Pointers}
~~~~~~~~~~~~~~~
\begin{verbatim}
Static Pointers
~~~~~~~~~~~~~~~
g = ... static f ...
==>
sptEntry:N = StaticPtr
(fingerprintString "pkgKey:module.sptEntry:N")
(StaticPtrInfo "current pkg key" "current module" "sptEntry:0")
f
g = ... sptEntry:N
\end{verbatim}
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
dsExpr (HsStatic _ expr@(L loc _)) = do
expr_ds <- dsLExpr expr
let ty = exprType expr_ds
n' <- mkSptEntryName loc
static_binds_var <- dsGetStaticBindsVar
staticPtrTyCon <- dsLookupTyCon staticPtrTyConName
staticPtrInfoDataCon <- dsLookupDataCon staticPtrInfoDataConName
staticPtrDataCon <- dsLookupDataCon staticPtrDataConName
fingerprintDataCon <- dsLookupDataCon fingerprintDataConName
dflags <- getDynFlags
let (line, col) = case loc of
......@@ -447,43 +443,51 @@ dsExpr (HsStatic expr@(L loc _)) = do
[ Type intTy , Type intTy
, mkIntExprInt dflags line, mkIntExprInt dflags col
]
this_mod <- getModule
info <- mkConApp staticPtrInfoDataCon <$>
(++[srcLoc]) <$>
mapM mkStringExprFS
[ unitIdFS $ moduleUnitId $ nameModule n'
, moduleNameFS $ moduleName $ nameModule n'
, occNameFS $ nameOccName n'
[ unitIdFS $ moduleUnitId this_mod
, moduleNameFS $ moduleName this_mod
]
let tvars = tyCoVarsOfTypeWellScoped ty
speTy = ASSERT( all isTyVar tvars ) -- ty is top-level, so this is OK
mkInvForAllTys tvars $ mkTyConApp staticPtrTyCon [ty]
speId = mkExportedVanillaId n' speTy
fp@(Fingerprint w0 w1) = fingerprintName $ idName speId
fp_core = mkConApp fingerprintDataCon
[ mkWord64LitWordRep dflags w0
, mkWord64LitWordRep dflags w1
]
sp = mkConApp staticPtrDataCon [Type ty, fp_core, info, expr_ds]
liftIO $ modifyIORef static_binds_var ((fp, (speId, mkLams tvars sp)) :)
putSrcSpanDs loc $ return $ mkTyApps (Var speId) (mkTyVarTys tvars)
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
fingerprintName :: Name -> Fingerprint
fingerprintName n = fingerprintString $ unpackFS $ concatFS
[ unitIdFS $ moduleUnitId $ nameModule n
mkStaticPtrFingerprint :: Module -> DsM Fingerprint
mkStaticPtrFingerprint this_mod = do
n <- mkGenPerModuleNum this_mod
return $ fingerprintString $ unpackFS $ concatFS
[ unitIdFS $ moduleUnitId this_mod
, fsLit ":"
, moduleNameFS $ moduleName this_mod
, fsLit ":"
, moduleNameFS (moduleName $ nameModule n)
, fsLit "."
, occNameFS $ occName n
, mkFastString $ 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
\underline{\bf Record construction and update}
......@@ -1011,33 +1015,3 @@ badMonadBind rhs elt_ty
, hang (text "Suppress this warning by saying")
2 (quotes $ text "_ <-" <+> ppr rhs)
]
{-
************************************************************************
* *
\subsection{Static pointers}
* *
************************************************************************
-}
-- | Creates an name for an entry in the Static Pointer Table.
--
-- The name has the form @sptEntry:<N>@ where @<N>@ is generated from a
-- per-module counter.
--
mkSptEntryName :: SrcSpan -> DsM Name
mkSptEntryName loc = do
mod <- getModule
occ <- mkWrapperName "sptEntry"
newGlobalBinder mod occ loc
where
mkWrapperName what
= do dflags <- getDynFlags
thisMod <- getModule
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 thisMod
in (extendModuleEnv mod_env thisMod (num+1), num)
return $ mkVarOcc $ what ++ ":" ++ show wrapperNum
......@@ -1182,7 +1182,7 @@ repE (ArithSeq _ _ aseq) =
repFromThenTo ds1 ds2 ds3
repE (HsSpliceE splice) = repSplice splice
repE (HsStatic e) = repLE e >>= rep2 staticEName . (:[]) . unC
repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC
repE (HsUnboundVar uv) = do
occ <- occNameLit (unboundVarOcc uv)
sname <- repNameS occ
......
......@@ -22,7 +22,7 @@ module DsMonad (
mkPrintUnqualifiedDs,
newUnique,
UniqSupply, newUniqueSupply,
getGhcModeDs, dsGetFamInstEnvs, dsGetStaticBindsVar,
getGhcModeDs, dsGetFamInstEnvs,
dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
PArrBuiltin(..),
......@@ -74,7 +74,6 @@ import ErrUtils
import FastString
import Maybes
import Var (EvVar)
import GHC.Fingerprint
import qualified GHC.LanguageExtensions as LangExt
import Data.IORef
......@@ -148,12 +147,10 @@ initDs :: HscEnv
initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
= do { msg_var <- newIORef (emptyBag, emptyBag)
; static_binds_var <- newIORef []
; pm_iter_var <- newIORef 0
; let dflags = hsc_dflags hsc_env
(ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env
fam_inst_env msg_var
static_binds_var
pm_iter_var
; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
......@@ -229,13 +226,12 @@ initDsTc thing_inside
; tcg_env <- getGblEnv
; msg_var <- getErrsVar
; dflags <- getDynFlags
; static_binds_var <- liftIO $ newIORef []
; pm_iter_var <- liftIO $ newIORef 0
; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
fam_inst_env = tcg_fam_inst_env tcg_env
ds_envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
msg_var static_binds_var pm_iter_var
msg_var pm_iter_var
; setEnvs ds_envs thing_inside
}
......@@ -263,9 +259,8 @@ initTcDsForSolver thing_inside
thing_inside }
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> IORef Messages -> IORef [(Fingerprint, (Id, CoreExpr))]
-> IORef Int -> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var pmvar
-> IORef Messages -> IORef Int -> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
= let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
......@@ -276,7 +271,6 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var pmvar
, ds_msgs = msg_var
, ds_dph_env = emptyGlobalRdrEnv
, ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
, ds_static_binds = static_binds_var
}
lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
, dsl_loc = real_span
......@@ -517,10 +511,6 @@ dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv menv thing_inside
= updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
-- | Gets a reference to the SPT entries created so far.
dsGetStaticBindsVar :: DsM (IORef [(Fingerprint, (Id,CoreExpr))])
dsGetStaticBindsVar = fmap ds_static_binds getGblEnv
discardWarningsDs :: DsM a -> DsM a
-- Ignore warnings inside the thing inside;
-- used to ignore inaccessable cases etc. inside generated code
......
......@@ -797,7 +797,7 @@ cvtl e = wrapL (cvt e)
<- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc))
flds
; return $ mkRdrRecordUpd e' flds' }
cvt (StaticE e) = fmap HsStatic $ cvtl e
cvt (StaticE e) = fmap (HsStatic placeHolderNames) $ cvtl e
cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') }
{- Note [Dropping constructors]
......
......@@ -385,7 +385,7 @@ variables. The action happens in TcBinds.mkExport.
Note [Bind free vars]
~~~~~~~~~~~~~~~~~~~~~
The bind_fvs field of FunBind and PatBind records the free variables
of the definition. It is used for two purposes
of the definition. It is used for the following purposes
a) Dependency analysis prior to type checking
(see TcBinds.tc_group)
......@@ -393,6 +393,10 @@ a) Dependency analysis prior to type checking
b) Deciding whether we can do generalisation of the binding
(see TcBinds.decideGeneralisationPlan)
c) Deciding whether the binding can be used in static forms
(see TcExpr.checkClosedInStaticForm for the HsStatic case and
TcBinds.isClosedBndrGroup).
Specifically,
* bind_fvs includes all free vars that are defined in this module
......
......@@ -30,6 +30,7 @@ import CoreSyn
import Var
import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) )
import Name
import NameSet
import RdrName ( GlobalRdrEnv )
import BasicTypes
import ConLike
......@@ -562,7 +563,8 @@ data HsExpr id
-- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic',
-- For details on above see note [Api annotations] in ApiAnnotation
| HsStatic (LHsExpr id)
| HsStatic (PostRn id NameSet) -- Free variables of the body
(LHsExpr id) -- Body
---------------------------------------
-- The following are commands, not expressions proper
......@@ -920,7 +922,7 @@ ppr_expr (HsTcBracketOut e ps) = ppr e $$ text "pending(tc)" <+> ppr ps
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
= hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd]
ppr_expr (HsStatic e)
ppr_expr (HsStatic _ e)
= hsep [text "static", pprParendLExpr e]
ppr_expr (HsTick tickish exp)
......
......@@ -15,17 +15,21 @@
-- > static void hs_hpc_init_Main(void) {
-- >
-- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL};
-- > extern StgPtr Main_sptEntryZC0_closure;
-- > hs_spt_insert(k0, &Main_sptEntryZC0_closure);
-- > extern StgPtr Main_r2wb_closure;
-- > hs_spt_insert(k0, &Main_r2wb_closure);
-- >
-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
-- > extern StgPtr Main_sptEntryZC1_closure;
-- > hs_spt_insert(k1, &Main_sptEntryZC1_closure);
-- > extern StgPtr Main_r2wc_closure;
-- > hs_spt_insert(k1, &Main_r2wc_closure);
-- >
-- > }
--
-- where the constants are fingerprints produced from the static forms.
--
-- The linker must find the definitions matching the @extern StgPtr <name>@
-- declarations. For this to work, the identifiers of static pointers need to be
-- exported. This is done in TidyPgm.chooseExternalIds.
--
-- There is also a finalization function for the time when the module is
-- unloaded.
--
......@@ -40,54 +44,78 @@
-- >
-- > }
--
module StaticPtrTable (sptInitCode) where
{-# LANGUAGE ViewPatterns #-}
module StaticPtrTable (sptModuleInitCode) where
import CLabel
import CoreSyn
import DataCon
import Id
import Literal
import Module
import Outputable
import Id
import CLabel
import GHC.Fingerprint
import PrelNames
import Data.Maybe
import GHC.Fingerprint
-- | @sptInitCode module statics@ is a C stub to insert the static entries
-- @statics@ of @module@ into the static pointer table.
-- | @sptModuleInitCode module binds@ is a C stub to insert the static entries
-- found in @binds@ of @module@ into the static pointer table.
--
-- Each entry contains the fingerprint used to locate the entry and the
-- top-level binding for the entry.
-- A bind is considered a static entry if it is an application of the
-- data constructor @StaticPtr@.
--
sptInitCode :: Module -> [(Fingerprint, (Id,CoreExpr))] -> SDoc
sptInitCode _ [] = Outputable.empty
sptInitCode 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, (fp, (n, _))) <- 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
]
]
sptModuleInitCode :: Module -> CoreProgram -> SDoc
sptModuleInitCode this_mod binds =
sptInitCode $ catMaybes
$ map (\(b, e) -> ((,) b) <$> staticPtrFp e)
$ flattenBinds 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
fromPlatformWord64Rep (MachWord w) = Just w
fromPlatformWord64Rep (MachWord64 w) = Just w
fromPlatformWord64Rep _ = Nothing
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
]
]
pprFingerprint :: Fingerprint -> SDoc
pprFingerprint (Fingerprint w1 w2) =
......
......@@ -4,7 +4,7 @@
\section{Tidying up Core}
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE CPP, ViewPatterns #-}
module TidyPgm (