Commit fc45f324 authored by Facundo Domínguez's avatar Facundo Domínguez Committed by Austin Seipp

Implement -XStaticValues

Summary:
As proposed in [1], this extension introduces a new syntactic form
`static e`, where `e :: a` can be any closed expression. The static form
produces a value of type `StaticPtr a`, which works as a reference that
programs can "dereference" to get the value of `e` back. References are
like `Ptr`s, except that they are stable across invocations of a
program.

The relevant wiki pages are [2, 3], which describe the motivation/ideas
and implementation plan respectively.

[1] Jeff Epstein, Andrew P. Black, and Simon Peyton-Jones. Towards
Haskell in the cloud. SIGPLAN Not., 46(12):118–129, September 2011. ISSN
0362-1340.
[2] https://ghc.haskell.org/trac/ghc/wiki/StaticPointers
[3] https://ghc.haskell.org/trac/ghc/wiki/StaticPointers/ImplementationPlanAuthored-by: default avatarFacundo Domínguez <facundo.dominguez@tweag.io>
Authored-by: default avatarMathieu Boespflug <m@tweag.io>
Authored-by: default avatarAlexander Vershilov <alexander.vershilov@tweag.io>

Test Plan: `./validate`

Reviewers: hvr, simonmar, simonpj, austin

Reviewed By: simonpj, austin

Subscribers: qnikst, bgamari, mboes, carter, thomie, goldfire

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

GHC Trac Issues: #7015
parent e5974f8f
...@@ -533,6 +533,9 @@ addTickHsExpr (ExplicitPArr ty es) = ...@@ -533,6 +533,9 @@ addTickHsExpr (ExplicitPArr ty es) =
liftM2 ExplicitPArr liftM2 ExplicitPArr
(return ty) (return ty)
(mapM (addTickLHsExpr) es) (mapM (addTickLHsExpr) es)
addTickHsExpr (HsStatic e) = HsStatic <$> addTickLHsExpr e
addTickHsExpr (RecordCon id ty rec_binds) = addTickHsExpr (RecordCon id ty rec_binds) =
liftM3 RecordCon liftM3 RecordCon
(return id) (return id)
......
...@@ -49,6 +49,7 @@ import Coverage ...@@ -49,6 +49,7 @@ import Coverage
import Util import Util
import MonadUtils import MonadUtils
import OrdList import OrdList
import StaticPtrTable
import Data.List import Data.List
import Data.IORef import Data.IORef
import Control.Monad( when ) import Control.Monad( when )
...@@ -91,7 +92,7 @@ deSugar hsc_env ...@@ -91,7 +92,7 @@ deSugar hsc_env
tcg_tcs = tcs, tcg_tcs = tcs,
tcg_insts = insts, tcg_insts = insts,
tcg_fam_insts = fam_insts, tcg_fam_insts = fam_insts,
tcg_hpc = other_hpc_info }) tcg_hpc = other_hpc_info})
= do { let dflags = hsc_dflags hsc_env = do { let dflags = hsc_dflags hsc_env
print_unqual = mkPrintUnqualified dflags rdr_env print_unqual = mkPrintUnqualified dflags rdr_env
...@@ -121,13 +122,20 @@ deSugar hsc_env ...@@ -121,13 +122,20 @@ deSugar hsc_env
; (ds_fords, foreign_prs) <- dsForeigns fords ; (ds_fords, foreign_prs) <- dsForeigns fords
; ds_rules <- mapMaybeM dsRule rules ; ds_rules <- mapMaybeM dsRule rules
; ds_vects <- mapM dsVect vects ; ds_vects <- mapM dsVect vects
; stBinds <- dsGetStaticBindsVar >>=
liftIO . readIORef
; let hpc_init ; let hpc_init
| gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info
| otherwise = empty | 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 ; return ( ds_ev_binds
, foreign_prs `appOL` core_prs `appOL` spec_prs , foreign_prs `appOL` core_prs `appOL` spec_prs
`appOL` toOL (map snd stBinds)
, spec_rules ++ ds_rules, ds_vects , spec_rules ++ ds_rules, ds_vects
, ds_fords `appendStubC` hpc_init) } , ds_fords `appendStubC` hpc_init
`appendStubC` spt_init) }
; case mb_res of { ; case mb_res of {
Nothing -> return (msgs, Nothing) ; Nothing -> return (msgs, Nothing) ;
......
...@@ -31,6 +31,7 @@ import DsMeta ...@@ -31,6 +31,7 @@ import DsMeta
import HsSyn import HsSyn
import Platform
-- NB: The desugarer, which straddles the source and Core worlds, sometimes -- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types -- needs to see source types
import TcType import TcType
...@@ -52,6 +53,7 @@ import VarEnv ...@@ -52,6 +53,7 @@ import VarEnv
import ConLike import ConLike
import DataCon import DataCon
import TysWiredIn import TysWiredIn
import PrelNames
import BasicTypes import BasicTypes
import Maybes import Maybes
import SrcLoc import SrcLoc
...@@ -60,7 +62,11 @@ import Bag ...@@ -60,7 +62,11 @@ import Bag
import Outputable import Outputable
import FastString import FastString
import IdInfo
import Data.IORef ( atomicModifyIORef, modifyIORef )
import Control.Monad import Control.Monad
import GHC.Fingerprint
{- {-
************************************************************************ ************************************************************************
...@@ -389,6 +395,78 @@ dsExpr (PArrSeq _ _) ...@@ -389,6 +395,78 @@ dsExpr (PArrSeq _ _)
-- the parser shouldn't have generated it and the renamer and typechecker -- the parser shouldn't have generated it and the renamer and typechecker
-- shouldn't have let it through -- shouldn't have let it through
{-
\noindent
\underline{\bf Static Pointers}
~~~~~~~~~~~~~~~
\begin{verbatim}
g = ... static f ...
==>
sptEntry:N = StaticPtr
(fingerprintString "pkgId:module.sptEntry:N")
(StaticPtrInfo "current pkg id" "current module" "sptEntry:0")
f
g = ... sptEntry:N
\end{verbatim}
-}
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
RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r
, srcLocCol $ realSrcSpanStart r
)
_ -> (0, 0)
srcLoc = mkCoreConApps (tupleCon BoxedTuple 2)
[ Type intTy , Type intTy
, mkIntExprInt dflags line, mkIntExprInt dflags col
]
info <- mkConApp staticPtrInfoDataCon <$>
(++[srcLoc]) <$>
mapM mkStringExprFS
[ packageKeyFS $ modulePackageKey $ nameModule n'
, moduleNameFS $ moduleName $ nameModule n'
, occNameFS $ nameOccName n'
]
let tvars = varSetElems $ tyVarsOfType ty
speTy = mkForAllTys tvars $ mkTyConApp staticPtrTyCon [ty]
speId = mkExportedLocalId VanillaId 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) (map mkTyVarTy tvars)
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
[ packageKeyFS $ modulePackageKey $ nameModule n
, fsLit ":"
, moduleNameFS (moduleName $ nameModule n)
, fsLit "."
, occNameFS $ occName n
]
{- {-
\noindent \noindent
\underline{\bf Record construction and update} \underline{\bf Record construction and update}
...@@ -857,3 +935,34 @@ badMonadBind rhs elt_ty flag_doc ...@@ -857,3 +935,34 @@ badMonadBind rhs elt_ty flag_doc
, hang (ptext (sLit "Suppress this warning by saying")) , hang (ptext (sLit "Suppress this warning by saying"))
2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs) 2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs)
, ptext (sLit "or by using the flag") <+> flag_doc ] , ptext (sLit "or by using the flag") <+> flag_doc ]
{-
************************************************************************
* *
\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
uniq <- newUnique
mod <- getModule
occ <- mkWrapperName "sptEntry"
return $ mkExternalName uniq 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
...@@ -1092,6 +1092,7 @@ repE (ArithSeq _ _ aseq) = ...@@ -1092,6 +1092,7 @@ repE (ArithSeq _ _ aseq) =
repFromThenTo ds1 ds2 ds3 repFromThenTo ds1 ds2 ds3
repE (HsSpliceE _ splice) = repSplice splice repE (HsSpliceE _ splice) = repSplice splice
repE (HsStatic e) = repLE e >>= rep2 staticEName . (:[]) . unC
repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e) repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
...@@ -2125,7 +2126,7 @@ templateHaskellNames = [ ...@@ -2125,7 +2126,7 @@ templateHaskellNames = [
tupEName, unboxedTupEName, tupEName, unboxedTupEName,
condEName, multiIfEName, letEName, caseEName, doEName, compEName, condEName, multiIfEName, letEName, caseEName, doEName, compEName,
fromEName, fromThenEName, fromToEName, fromThenToEName, fromEName, fromThenEName, fromToEName, fromThenToEName,
listEName, sigEName, recConEName, recUpdEName, listEName, sigEName, recConEName, recUpdEName, staticEName,
-- FieldExp -- FieldExp
fieldExpName, fieldExpName,
-- Body -- Body
...@@ -2307,7 +2308,7 @@ clauseName = libFun (fsLit "clause") clauseIdKey ...@@ -2307,7 +2308,7 @@ clauseName = libFun (fsLit "clause") clauseIdKey
varEName, conEName, litEName, appEName, infixEName, infixAppName, varEName, conEName, litEName, appEName, infixEName, infixAppName,
sectionLName, sectionRName, lamEName, lamCaseEName, tupEName, sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
unboxedTupEName, condEName, multiIfEName, letEName, caseEName, unboxedTupEName, condEName, multiIfEName, letEName, caseEName,
doEName, compEName :: Name doEName, compEName, staticEName :: Name
varEName = libFun (fsLit "varE") varEIdKey varEName = libFun (fsLit "varE") varEIdKey
conEName = libFun (fsLit "conE") conEIdKey conEName = libFun (fsLit "conE") conEIdKey
litEName = libFun (fsLit "litE") litEIdKey litEName = libFun (fsLit "litE") litEIdKey
...@@ -2338,6 +2339,7 @@ listEName = libFun (fsLit "listE") listEIdKey ...@@ -2338,6 +2339,7 @@ listEName = libFun (fsLit "listE") listEIdKey
sigEName = libFun (fsLit "sigE") sigEIdKey sigEName = libFun (fsLit "sigE") sigEIdKey
recConEName = libFun (fsLit "recConE") recConEIdKey recConEName = libFun (fsLit "recConE") recConEIdKey
recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
staticEName = libFun (fsLit "staticE") staticEIdKey
-- type FieldExp = ... -- type FieldExp = ...
fieldExpName :: Name fieldExpName :: Name
...@@ -2680,7 +2682,7 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey, ...@@ -2680,7 +2682,7 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
unboxedTupEIdKey, condEIdKey, multiIfEIdKey, unboxedTupEIdKey, condEIdKey, multiIfEIdKey,
letEIdKey, caseEIdKey, doEIdKey, compEIdKey, letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey :: Unique
varEIdKey = mkPreludeMiscIdUnique 270 varEIdKey = mkPreludeMiscIdUnique 270
conEIdKey = mkPreludeMiscIdUnique 271 conEIdKey = mkPreludeMiscIdUnique 271
litEIdKey = mkPreludeMiscIdUnique 272 litEIdKey = mkPreludeMiscIdUnique 272
...@@ -2707,6 +2709,7 @@ listEIdKey = mkPreludeMiscIdUnique 292 ...@@ -2707,6 +2709,7 @@ listEIdKey = mkPreludeMiscIdUnique 292
sigEIdKey = mkPreludeMiscIdUnique 293 sigEIdKey = mkPreludeMiscIdUnique 293
recConEIdKey = mkPreludeMiscIdUnique 294 recConEIdKey = mkPreludeMiscIdUnique 294
recUpdEIdKey = mkPreludeMiscIdUnique 295 recUpdEIdKey = mkPreludeMiscIdUnique 295
staticEIdKey = mkPreludeMiscIdUnique 296
-- type FieldExp = ... -- type FieldExp = ...
fieldExpIdKey :: Unique fieldExpIdKey :: Unique
......
...@@ -21,7 +21,7 @@ module DsMonad ( ...@@ -21,7 +21,7 @@ module DsMonad (
mkPrintUnqualifiedDs, mkPrintUnqualifiedDs,
newUnique, newUnique,
UniqSupply, newUniqueSupply, UniqSupply, newUniqueSupply,
getGhcModeDs, dsGetFamInstEnvs, getGhcModeDs, dsGetFamInstEnvs, dsGetStaticBindsVar,
dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon, dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
PArrBuiltin(..), PArrBuiltin(..),
...@@ -67,6 +67,7 @@ import Maybes ...@@ -67,6 +67,7 @@ import Maybes
import Data.IORef import Data.IORef
import Control.Monad import Control.Monad
import GHC.Fingerprint
{- {-
************************************************************************ ************************************************************************
...@@ -166,6 +167,8 @@ data DsGblEnv ...@@ -166,6 +167,8 @@ data DsGblEnv
-- exported entities of 'Data.Array.Parallel' iff -- exported entities of 'Data.Array.Parallel' iff
-- '-XParallelArrays' was given; otherwise, empty -- '-XParallelArrays' was given; otherwise, empty
, ds_parr_bi :: PArrBuiltin -- desugarar names for '-XParallelArrays' , ds_parr_bi :: PArrBuiltin -- desugarar names for '-XParallelArrays'
, ds_static_binds :: IORef [(Fingerprint, (Id,CoreExpr))]
-- ^ Bindings resulted from floating static forms
} }
instance ContainsModule DsGblEnv where instance ContainsModule DsGblEnv where
...@@ -196,8 +199,11 @@ initDs :: HscEnv ...@@ -196,8 +199,11 @@ initDs :: HscEnv
initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
= do { msg_var <- newIORef (emptyBag, emptyBag) = do { msg_var <- newIORef (emptyBag, emptyBag)
; static_binds_var <- newIORef []
; let dflags = hsc_dflags hsc_env ; let dflags = hsc_dflags hsc_env
(ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env
fam_inst_env msg_var
static_binds_var
; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $ ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
loadDAP $ loadDAP $
...@@ -272,15 +278,19 @@ initDsTc thing_inside ...@@ -272,15 +278,19 @@ initDsTc thing_inside
; tcg_env <- getGblEnv ; tcg_env <- getGblEnv
; msg_var <- getErrsVar ; msg_var <- getErrsVar
; dflags <- getDynFlags ; dflags <- getDynFlags
; static_binds_var <- liftIO $ newIORef []
; let type_env = tcg_type_env tcg_env ; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env rdr_env = tcg_rdr_env tcg_env
fam_inst_env = tcg_fam_inst_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 ds_envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
msg_var static_binds_var
; setEnvs ds_envs thing_inside ; setEnvs ds_envs thing_inside
} }
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> IORef Messages -> (DsGblEnv, DsLclEnv) mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var -> IORef Messages -> IORef [(Fingerprint, (Id, CoreExpr))]
-> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var
= let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) } = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod) if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
gbl_env = DsGblEnv { ds_mod = mod gbl_env = DsGblEnv { ds_mod = mod
...@@ -290,6 +300,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var ...@@ -290,6 +300,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var
, ds_msgs = msg_var , ds_msgs = msg_var
, ds_dph_env = emptyGlobalRdrEnv , ds_dph_env = emptyGlobalRdrEnv
, ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi" , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
, ds_static_binds = static_binds_var
} }
lcl_env = DsLclEnv { ds_meta = emptyNameEnv lcl_env = DsLclEnv { ds_meta = emptyNameEnv
, ds_loc = noSrcSpan , ds_loc = noSrcSpan
...@@ -487,6 +498,10 @@ dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a ...@@ -487,6 +498,10 @@ dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv menv thing_inside dsExtendMetaEnv menv thing_inside
= updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside = updLclEnv (\env -> env { ds_meta = ds_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 discardWarningsDs :: DsM a -> DsM a
-- Ignore warnings inside the thing inside; -- Ignore warnings inside the thing inside;
-- used to ignore inaccessable cases etc. inside generated code -- used to ignore inaccessable cases etc. inside generated code
......
-- | Code generation for the Static Pointer Table
--
-- (c) 2014 I/O Tweag
--
-- Each module that uses 'static' keyword declares an initialization function of
-- the form hs_spt_init_<module>() which is emitted into the _stub.c file and
-- annotated with __attribute__((constructor)) so that it gets executed at
-- startup time.
--
-- The function's purpose is to call hs_spt_insert to insert the static
-- pointers of this module in the hashtable of the RTS, and it looks something
-- like this:
--
-- > static void hs_hpc_init_Main(void) __attribute__((constructor));
-- > 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);
-- >
-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL};
-- > extern StgPtr Main_sptEntryZC1_closure;
-- > hs_spt_insert(k1, &Main_sptEntryZC1_closure);
-- >
-- > }
--
-- where constants are values of a fingerprint of the string
-- "<package_id>:<module_name>.sptEntry:<N>"
--
module StaticPtrTable (sptInitCode) where
import CoreSyn
import Module
import Outputable
import Id
import CLabel
import GHC.Fingerprint
-- | @sptInitCode module statics@ is a C stub to insert the static entries
-- @statics@ 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.
--
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
]
]
where
pprFingerprint :: Fingerprint -> SDoc
pprFingerprint (Fingerprint w1 w2) =
braces $ hcat $ punctuate comma
[ integer (fromIntegral w1) <> text "ULL"
, integer (fromIntegral w2) <> text "ULL"
]
...@@ -323,6 +323,7 @@ Library ...@@ -323,6 +323,7 @@ Library
TcPluginM TcPluginM
PprTyThing PprTyThing
StaticFlags StaticFlags
StaticPtrTable
SysTools SysTools
TidyPgm TidyPgm
Ctype Ctype
......
...@@ -688,6 +688,7 @@ cvtl e = wrapL (cvt e) ...@@ -688,6 +688,7 @@ cvtl e = wrapL (cvt e)
cvt (RecUpdE e flds) = do { e' <- cvtl e cvt (RecUpdE e flds) = do { e' <- cvtl e
; flds' <- mapM cvtFld flds ; flds' <- mapM cvtFld flds
; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] } ; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
cvt (StaticE e) = fmap HsStatic $ cvtl e
{- Note [Dropping constructors] {- Note [Dropping constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
...@@ -347,6 +347,10 @@ data HsExpr id ...@@ -347,6 +347,10 @@ data HsExpr id
(LHsCmdTop id) -- body of the abstraction (LHsCmdTop id) -- body of the abstraction
-- always has an empty stack -- always has an empty stack
---------------------------------------
-- static pointers extension
| HsStatic (LHsExpr id)
--------------------------------------- ---------------------------------------
-- The following are commands, not expressions proper -- The following are commands, not expressions proper
-- They are only used in the parsing stage and are removed -- They are only used in the parsing stage and are removed
...@@ -656,6 +660,9 @@ ppr_expr (HsQuasiQuoteE qq) = ppr qq ...@@ -656,6 +660,9 @@ ppr_expr (HsQuasiQuoteE qq) = ppr qq
ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _))) ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _)))
= hsep [ptext (sLit "proc"), ppr pat, ptext (sLit "->"), ppr cmd] = hsep [ptext (sLit "proc"), ppr pat, ptext (sLit "->"), ppr cmd]
ppr_expr (HsStatic e)
= hsep [ptext (sLit "static"), pprParendExpr e]
ppr_expr (HsTick tickish exp) ppr_expr (HsTick tickish exp)
= pprTicks (ppr exp) $ = pprTicks (ppr exp) $
ppr tickish <+> ppr exp ppr tickish <+> ppr exp
......
...@@ -625,6 +625,7 @@ data ExtensionFlag ...@@ -625,6 +625,7 @@ data ExtensionFlag
| Opt_PatternSynonyms | Opt_PatternSynonyms
| Opt_PartialTypeSignatures | Opt_PartialTypeSignatures
| Opt_NamedWildcards | Opt_NamedWildcards
| Opt_StaticPointers
deriving (Eq, Enum, Show) deriving (Eq, Enum, Show)
data SigOf = NotSigOf data SigOf = NotSigOf
...@@ -3124,6 +3125,7 @@ xFlags = [ ...@@ -3124,6 +3125,7 @@ xFlags = [
flagSpec "RoleAnnotations" Opt_RoleAnnotations, flagSpec "RoleAnnotations" Opt_RoleAnnotations,
flagSpec "ScopedTypeVariables" Opt_ScopedTypeVariables, flagSpec "ScopedTypeVariables" Opt_ScopedTypeVariables,
flagSpec "StandaloneDeriving" Opt_StandaloneDeriving, flagSpec "StandaloneDeriving" Opt_StandaloneDeriving,
flagSpec "StaticPointers" Opt_StaticPointers,
flagSpec' "TemplateHaskell" Opt_TemplateHaskell flagSpec' "TemplateHaskell" Opt_TemplateHaskell
checkTemplateHaskellOk, checkTemplateHaskellOk,
flagSpec "TraditionalRecordSyntax" Opt_TraditionalRecordSyntax, flagSpec "TraditionalRecordSyntax" Opt_TraditionalRecordSyntax,
......
...@@ -558,6 +558,7 @@ data Token ...@@ -558,6 +558,7 @@ data Token
| ITby | ITby
| ITusing | ITusing
| ITpattern | ITpattern
| ITstatic
-- Pragmas -- Pragmas
| ITinline_prag InlineSpec RuleMatchInfo | ITinline_prag InlineSpec RuleMatchInfo
...@@ -744,6 +745,7 @@ reservedWordsFM = listToUFM $ ...@@ -744,6 +745,7 @@ reservedWordsFM = listToUFM $
( "family", ITfamily, 0 ), ( "family", ITfamily, 0 ),
( "role", ITrole, 0 ), ( "role", ITrole, 0 ),