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) =
liftM2 ExplicitPArr
(return ty)
(mapM (addTickLHsExpr) es)
addTickHsExpr (HsStatic e) = HsStatic <$> addTickLHsExpr e
addTickHsExpr (RecordCon id ty rec_binds) =
liftM3 RecordCon
(return id)
......
......@@ -49,6 +49,7 @@ import Coverage
import Util
import MonadUtils
import OrdList
import StaticPtrTable
import Data.List
import Data.IORef
import Control.Monad( when )
......@@ -91,7 +92,7 @@ deSugar hsc_env
tcg_tcs = tcs,
tcg_insts = insts,
tcg_fam_insts = fam_insts,
tcg_hpc = other_hpc_info })
tcg_hpc = other_hpc_info})
= do { let dflags = hsc_dflags hsc_env
print_unqual = mkPrintUnqualified dflags rdr_env
......@@ -121,13 +122,20 @@ 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) }
, ds_fords `appendStubC` hpc_init
`appendStubC` spt_init) }
; case mb_res of {
Nothing -> return (msgs, Nothing) ;
......
......@@ -31,6 +31,7 @@ import DsMeta
import HsSyn
import Platform
-- NB: The desugarer, which straddles the source and Core worlds, sometimes
-- needs to see source types
import TcType
......@@ -52,6 +53,7 @@ import VarEnv
import ConLike
import DataCon
import TysWiredIn
import PrelNames
import BasicTypes
import Maybes
import SrcLoc
......@@ -60,7 +62,11 @@ import Bag
import Outputable
import FastString
import IdInfo
import Data.IORef ( atomicModifyIORef, modifyIORef )
import Control.Monad
import GHC.Fingerprint
{-
************************************************************************
......@@ -389,6 +395,78 @@ dsExpr (PArrSeq _ _)
-- the parser shouldn't have generated it and the renamer and typechecker
-- 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
\underline{\bf Record construction and update}
......@@ -857,3 +935,34 @@ badMonadBind rhs elt_ty flag_doc
, hang (ptext (sLit "Suppress this warning by saying"))
2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs)
, 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) =
repFromThenTo ds1 ds2 ds3
repE (HsSpliceE _ splice) = repSplice splice
repE (HsStatic e) = repLE e >>= rep2 staticEName . (:[]) . unC
repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e)
repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e)
repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e)
......@@ -2125,7 +2126,7 @@ templateHaskellNames = [
tupEName, unboxedTupEName,
condEName, multiIfEName, letEName, caseEName, doEName, compEName,
fromEName, fromThenEName, fromToEName, fromThenToEName,
listEName, sigEName, recConEName, recUpdEName,
listEName, sigEName, recConEName, recUpdEName, staticEName,
-- FieldExp
fieldExpName,
-- Body
......@@ -2307,7 +2308,7 @@ clauseName = libFun (fsLit "clause") clauseIdKey
varEName, conEName, litEName, appEName, infixEName, infixAppName,
sectionLName, sectionRName, lamEName, lamCaseEName, tupEName,
unboxedTupEName, condEName, multiIfEName, letEName, caseEName,
doEName, compEName :: Name
doEName, compEName, staticEName :: Name
varEName = libFun (fsLit "varE") varEIdKey
conEName = libFun (fsLit "conE") conEIdKey
litEName = libFun (fsLit "litE") litEIdKey
......@@ -2338,6 +2339,7 @@ listEName = libFun (fsLit "listE") listEIdKey
sigEName = libFun (fsLit "sigE") sigEIdKey
recConEName = libFun (fsLit "recConE") recConEIdKey
recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey
staticEName = libFun (fsLit "staticE") staticEIdKey
-- type FieldExp = ...
fieldExpName :: Name
......@@ -2680,7 +2682,7 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey,
unboxedTupEIdKey, condEIdKey, multiIfEIdKey,
letEIdKey, caseEIdKey, doEIdKey, compEIdKey,
fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,
listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique
listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey :: Unique
varEIdKey = mkPreludeMiscIdUnique 270
conEIdKey = mkPreludeMiscIdUnique 271
litEIdKey = mkPreludeMiscIdUnique 272
......@@ -2707,6 +2709,7 @@ listEIdKey = mkPreludeMiscIdUnique 292
sigEIdKey = mkPreludeMiscIdUnique 293
recConEIdKey = mkPreludeMiscIdUnique 294
recUpdEIdKey = mkPreludeMiscIdUnique 295
staticEIdKey = mkPreludeMiscIdUnique 296
-- type FieldExp = ...
fieldExpIdKey :: Unique
......
......@@ -21,7 +21,7 @@ module DsMonad (
mkPrintUnqualifiedDs,
newUnique,
UniqSupply, newUniqueSupply,
getGhcModeDs, dsGetFamInstEnvs,
getGhcModeDs, dsGetFamInstEnvs, dsGetStaticBindsVar,
dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
PArrBuiltin(..),
......@@ -67,6 +67,7 @@ import Maybes
import Data.IORef
import Control.Monad
import GHC.Fingerprint
{-
************************************************************************
......@@ -166,6 +167,8 @@ data DsGblEnv
-- exported entities of 'Data.Array.Parallel' iff
-- '-XParallelArrays' was given; otherwise, empty
, 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
......@@ -196,8 +199,11 @@ 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 []
; 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 $
loadDAP $
......@@ -272,15 +278,19 @@ initDsTc thing_inside
; tcg_env <- getGblEnv
; msg_var <- getErrsVar
; dflags <- getDynFlags
; static_binds_var <- liftIO $ newIORef []
; 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
ds_envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
msg_var static_binds_var
; setEnvs ds_envs thing_inside
}
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> IORef Messages -> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> 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) }
if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
gbl_env = DsGblEnv { ds_mod = mod
......@@ -290,6 +300,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var
, 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 { ds_meta = emptyNameEnv
, ds_loc = noSrcSpan
......@@ -487,6 +498,10 @@ dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
dsExtendMetaEnv 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
-- Ignore warnings inside the thing inside;
-- 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
TcPluginM
PprTyThing
StaticFlags
StaticPtrTable
SysTools
TidyPgm
Ctype
......
......@@ -688,6 +688,7 @@ cvtl e = wrapL (cvt e)
cvt (RecUpdE e flds) = do { e' <- cvtl e
; flds' <- mapM cvtFld flds
; return $ RecordUpd e' (HsRecFields flds' Nothing) [] [] [] }
cvt (StaticE e) = fmap HsStatic $ cvtl e
{- Note [Dropping constructors]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -347,6 +347,10 @@ data HsExpr id
(LHsCmdTop id) -- body of the abstraction
-- always has an empty stack
---------------------------------------
-- static pointers extension
| HsStatic (LHsExpr id)
---------------------------------------
-- The following are commands, not expressions proper
-- They are only used in the parsing stage and are removed
......@@ -656,6 +660,9 @@ ppr_expr (HsQuasiQuoteE qq) = ppr qq
ppr_expr (HsProc pat (L _ (HsCmdTop 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)
= pprTicks (ppr exp) $
ppr tickish <+> ppr exp
......
......@@ -625,6 +625,7 @@ data ExtensionFlag
| Opt_PatternSynonyms
| Opt_PartialTypeSignatures
| Opt_NamedWildcards
| Opt_StaticPointers
deriving (Eq, Enum, Show)
data SigOf = NotSigOf
......@@ -3124,6 +3125,7 @@ xFlags = [
flagSpec "RoleAnnotations" Opt_RoleAnnotations,
flagSpec "ScopedTypeVariables" Opt_ScopedTypeVariables,
flagSpec "StandaloneDeriving" Opt_StandaloneDeriving,
flagSpec "StaticPointers" Opt_StaticPointers,
flagSpec' "TemplateHaskell" Opt_TemplateHaskell
checkTemplateHaskellOk,
flagSpec "TraditionalRecordSyntax" Opt_TraditionalRecordSyntax,
......
......@@ -558,6 +558,7 @@ data Token
| ITby
| ITusing
| ITpattern
| ITstatic
-- Pragmas
| ITinline_prag InlineSpec RuleMatchInfo
......@@ -744,6 +745,7 @@ reservedWordsFM = listToUFM $
( "family", ITfamily, 0 ),
( "role", ITrole, 0 ),
( "pattern", ITpattern, xbit PatternSynonymsBit),
( "static", ITstatic, 0 ),
( "group", ITgroup, xbit TransformComprehensionsBit),
( "by", ITby, xbit TransformComprehensionsBit),
( "using", ITusing, xbit TransformComprehensionsBit),
......@@ -1117,6 +1119,11 @@ varid span buf len =
return ITcase
maybe_layout keyword
return $ L span keyword
Just (ITstatic, _) -> do
flags <- getDynFlags
if xopt Opt_StaticPointers flags
then return $ L span ITstatic
else return $ L span $ ITvarid fs
Just (keyword, 0) -> do
maybe_layout keyword
return $ L span keyword
......
......@@ -302,6 +302,7 @@ See https://ghc.haskell.org/trac/ghc/wiki/GhcAstAnnotations for some background.
'by' { L _ ITby } -- for list transform extension
'using' { L _ ITusing } -- for list transform extension
'pattern' { L _ ITpattern } -- for pattern synonyms
'static' { L _ ITstatic } -- for static pointers extension
'{-# INLINE' { L _ (ITinline_prag _ _) }
'{-# SPECIALISE' { L _ ITspec_prag }
......@@ -2031,6 +2032,7 @@ hpc_annot :: { Located ([AddAnn],(FastString,(Int,Int),(Int,Int))) }
fexp :: { LHsExpr RdrName }
: fexp aexp { sLL $1 $> $ HsApp $1 $2 }
| 'static' aexp { sLL $1 $> $ HsStatic $2 }
| aexp { $1 }
aexp :: { LHsExpr RdrName }
......
......@@ -349,6 +349,14 @@ basicKnownKeyNames
-- GHCi Sandbox
, ghciIoClassName, ghciStepIoMName
-- StaticPtr
, staticPtrTyConName
, staticPtrDataConName, staticPtrInfoDataConName
-- Fingerprint
, fingerprintDataConName
] ++ case cIntegerLibraryType of
IntegerGMP -> [integerSDataConName]
IntegerGMP2 -> [integerSDataConName]
......@@ -447,6 +455,12 @@ gHC_IP = mkBaseModule (fsLit "GHC.IP")
gHC_PARR' :: Module
gHC_PARR' = mkBaseModule (fsLit "GHC.PArr")
gHC_STATICPTR :: Module
gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr")
gHC_FINGERPRINT_TYPE :: Module
gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type")
mAIN, rOOT_MAIN :: Module
mAIN = mkMainModule_ mAIN_NAME
rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation
......@@ -1159,6 +1173,27 @@ pLUGINS = mkThisGhcModule (fsLit "Plugins")
pluginTyConName :: Name
pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey
-- Static pointers
staticPtrInfoTyConName :: Name
staticPtrInfoTyConName =
tcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey
staticPtrInfoDataConName :: Name
staticPtrInfoDataConName =
conName gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey
staticPtrTyConName :: Name
staticPtrTyConName =
tcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey
staticPtrDataConName :: Name
staticPtrDataConName =
conName gHC_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey
fingerprintDataConName :: Name
fingerprintDataConName =
conName gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey
{-
************************************************************************
* *
......@@ -1476,6 +1511,12 @@ specTyConKey = mkPreludeTyConUnique 177
smallArrayPrimTyConKey = mkPreludeTyConUnique 178
smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 179
staticPtrTyConKey :: Unique
staticPtrTyConKey = mkPreludeTyConUnique 180
staticPtrInfoTyConKey :: Unique
staticPtrInfoTyConKey = mkPreludeTyConUnique 181
---------------- Template Haskell -------------------
-- USES TyConUniques 200-299
-----------------------------------------------------
......@@ -1539,6 +1580,15 @@ gtDataConKey = mkPreludeDataConUnique 29
coercibleDataConKey = mkPreludeDataConUnique 32
staticPtrDataConKey :: Unique
staticPtrDataConKey = mkPreludeDataConUnique 33
staticPtrInfoDataConKey :: Unique
staticPtrInfoDataConKey = mkPreludeDataConUnique 34
fingerprintDataConKey :: Unique
fingerprintDataConKey = mkPreludeDataConUnique 35
{-
************************************************************************
* *
......
......@@ -304,6 +304,43 @@ rnExpr e@(EAsPat {}) = patSynErr e
rnExpr e@(EViewPat {}) = patSynErr e
rnExpr e@(ELazyPat {}) = patSynErr e
{-
************************************************************************
* *
Static values
* *
************************************************************************
For the static form we check that the free variables are all top-level
value bindings. This is done by checking that the name is external or
wired-in. See the Note about the NameSorts in Name.lhs.
-}
rnExpr e@(HsStatic expr) = do
(expr',fvExpr) <- rnLExpr expr
stage <- getStage
case stage of
Brack _ _ -> return () -- Don't check names if we are inside brackets.
-- We don't want to reject cases like:
-- \e -> [| static $(e) |]
-- if $(e) turns out to produce a legal expression.
Splice _ -> addErr $ sep
[ text "static forms cannot be used in splices:"
, nest 2 $ ppr e
]
_ -> do
let isTopLevelName n = isExternalName n || isWiredInName n
case nameSetElems $ filterNameSet (not . isTopLevelName) fvExpr of
[] -> return ()
fvNonGlobal -> addErr $ cat
[ text $ "Only identifiers of top-level bindings can "
++ "appear in the body of the static form:"
, nest 2 $ ppr e
, text "but the following identifiers were found instead:"
, nest 2 $ vcat $ map ppr fvNonGlobal
]
return (HsStatic expr', fvExpr)
{-
************************************************************************
* *
......
......@@ -12,7 +12,7 @@ module TcBinds ( tcLocalBinds, tcTopBinds, tcRecSelBinds,
PragFun, tcSpecPrags, tcVectDecls, mkPragFun,
TcSigInfo(..), TcSigFun,
instTcTySig, instTcTySigFromId, findScopedTyVars,
badBootDeclErr ) where
badBootDeclErr, mkExport ) where
import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun )
import {-# SOURCE #-} TcExpr ( tcMonoExpr )
......
......@@ -487,6 +487,28 @@ tcExpr (HsProc pat cmd) res_ty
= do { (pat', cmd', coi) <- tcProc pat cmd res_ty
; return $ mkHsWrapCo coi (HsProc pat' cmd') }
tcExpr (HsStatic expr) res_ty
= do { staticPtrTyCon <- tcLookupTyCon staticPtrTyConName
; (co, [expr_ty]) <- matchExpectedTyConApp staticPtrTyCon res_ty
; (expr', lie) <- captureConstraints $
addErrCtxt (hang (ptext (sLit "In the body of a static form:"))
2 (ppr expr)
) $
tcPolyExprNC expr expr_ty
-- Require the type of the argument to be Typeable.
-- The evidence is not used, but asking the constraint ensures that
-- the current implementation is as restrictive as future versions
-- of the StaticPointers extension.
; typeableClass <- tcLookupClass typeableClassName
; _ <- emitWanted StaticOrigin $
mkTyConApp (classTyCon typeableClass)
[liftedTypeKind, expr_ty]
-- Insert the static form in a global list for later validation.
; stWC <- tcg_static_wc <$> getGblEnv
; updTcRef stWC (andWC lie)
; return $ mkHsWrapCo co $ HsStatic expr'
}
{-
Note [Rebindable syntax for if]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -749,6 +749,10 @@ zonkExpr env (HsProc pat body)
; new_body <- zonkCmdTop env1 body
; return (HsProc new_pat new_body) }
-- StaticPointers extension
zonkExpr env (HsStatic expr)
= HsStatic <$> zonkLExpr env expr
zonkExpr env (HsWrap co_fn expr)
= do (env1, new_co_fn) <- zonkCoFn env co_fn
new_expr <- zonkExpr env1 expr
......
......@@ -464,6 +464,8 @@ tcRnSrcDecls boot_iface exports decls
; traceTc "Tc8" empty ;
; setEnvs (tcg_env, tcl_env) $
do {
-- wanted constraints from static forms
stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
-- Finish simplifying class constraints
--
......@@ -480,7 +482,7 @@ tcRnSrcDecls boot_iface exports decls
-- * the local env exposes the local Ids to simplifyTop,
-- so that we get better error messages (monomorphism restriction)
new_ev_binds <- {-# SCC "simplifyTop" #-}
simplifyTop lie ;
simplifyTop (andWC stWC lie) ;
traceTc "Tc9" empty ;
failIfErrsM ; -- Don't zonk if there have been errors
......@@ -1669,9 +1671,12 @@ tcGhciStmts stmts
-- Look up the names right in the middle,
-- where they will all be in scope
-- wanted constraints from static forms
stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ;
-- Simplify the context
traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
const_binds <- checkNoErrs (simplifyInteractive lie) ;
const_binds <- checkNoErrs (simplifyInteractive (andWC stWC lie)) ;
-- checkNoErrs ensures that the plan fails if context redn fails
traceTc "TcRnDriver.tcGhciStmts: done" empty ;
......@@ -1756,7 +1761,11 @@ tcRnExpr hsc_env rdr_expr