diff options
| author | Facundo Domínguez <facundo.dominguez@tweag.io> | 2014-01-29 12:43:03 -0200 |
|---|---|---|
| committer | Facundo Domínguez <facundo.dominguez@tweag.io> | 2014-12-02 12:55:30 -0200 |
| commit | 79c87c039c47be0baf7a6dd33ecf5434daa1501c (patch) | |
| tree | d8d97a28d3989bf7848a5c3f8f6a4697de72fd5c | |
| parent | a2c0a8dd15de2023e17078fa5f421ba581b3a5fa (diff) | |
| download | haskell-wip/static-pointers.tar.gz | |
Implement -XStaticValues.wip/static-pointers
Contains contributions from Alexander Vershilov and Mathieu Boespflug.
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.
In essence the extension collects the arguments of the static form into
a global static pointer table. The expressions can be looked up by a
fingerprint computed from the package, the module and a fresh name
given to the expression. For more details we refer to the users guide
section contained in the patch.
The extension is a contribution to the Cloud Haskell ecosystem
(distributed-process and related), and thus has the potential to foster
Haskell as a programming language for distributed systems.
The immediate improvement brought by the extension is the elimination of
remote tables from Cloud Haskell applications. Such applications contain
table fragments spread throughout multiple modules and packages.
Eliminating these fragments saves the programmer the burden required to
construct and assemble the global remote table, a verbose and
error-prone process, even with the help of Template Haskell, that
moreover pollutes the export lists of all modules.
[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.
70 files changed, 1128 insertions, 30 deletions
diff --git a/compiler/deSugar/Coverage.lhs b/compiler/deSugar/Coverage.lhs index 5e7289f00c..935f24e36b 100644 --- a/compiler/deSugar/Coverage.lhs +++ b/compiler/deSugar/Coverage.lhs @@ -534,6 +534,9 @@ addTickHsExpr (ExplicitPArr ty es) = liftM2 ExplicitPArr (return ty) (mapM (addTickLHsExpr) es) + +addTickHsExpr e@(HsStatic _) = return e + addTickHsExpr (RecordCon id ty rec_binds) = liftM3 RecordCon (return id) diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index e2170e7dd4..2ec2aebbe8 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -49,6 +49,7 @@ import Coverage import Util import MonadUtils import OrdList +import SPT import Data.List import Data.IORef import Control.Monad( when ) @@ -91,7 +92,8 @@ deSugar hsc_env tcg_tcs = tcs, tcg_insts = insts, tcg_fam_insts = fam_insts, - tcg_hpc = other_hpc_info }) + tcg_hpc = other_hpc_info, + tcg_static_binds = static_binds_var }) = do { let dflags = hsc_dflags hsc_env print_unqual = mkPrintUnqualified dflags rdr_env @@ -121,23 +123,36 @@ deSugar hsc_env ; (ds_fords, foreign_prs) <- dsForeigns fords ; ds_rules <- mapMaybeM dsRule rules ; ds_vects <- mapM dsVect vects + ; stBinds <- dsGetStaticBindsVar >>= liftIO . readIORef + ; let core_prs' = core_prs `appOL` toOL stBinds ; let hpc_init | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info | otherwise = empty + ; -- Collects the sptEntries of the module + let spt_init = sptInitCode mod stBinds ; return ( ds_ev_binds - , foreign_prs `appOL` core_prs `appOL` spec_prs + , foreign_prs `appOL` core_prs' `appOL` spec_prs , 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) ; - Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords) -> do + Just (ds_ev_binds, all_prs, {-st_binds,-} all_rules, vects0, ds_fords) -> - do { -- Add export flags to bindings - keep_alive <- readIORef keep_var + do { st_binds' <- readIORef static_binds_var + -- Add export flags to bindings + ; keep_alive <- readIORef keep_var + -- ; let static_names = map (map (idName . fst)) $ [ st_binds', st_binds ] + -- keep_alive_all = foldl addListToNameSet keep_alive static_names ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules - final_prs = addExportFlagsAndRules target export_set keep_alive - rules_for_locals (fromOL all_prs) + final_prs = addExportFlagsAndRules + target export_set keep_alive + rules_for_locals $ fromOL $ all_prs + + -- target export_set keep_alive_all + -- rules_for_locals $ fromOL $ + -- all_prs `appOL` + -- toOL st_binds' `appOL` toOL st_binds final_pgm = combineEvBinds ds_ev_binds final_prs -- Notice that we put the whole lot in a big Rec, even the foreign binds diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs index ce2d5a5d4a..e9c06fa812 100644 --- a/compiler/deSugar/DsExpr.lhs +++ b/compiler/deSugar/DsExpr.lhs @@ -62,6 +62,10 @@ import Bag import Outputable import FastString +import IdInfo +-- import Module ( HasModule(..), lookupWithDefaultModuleEnv, extendModuleEnv ) +import Data.IORef ( atomicModifyIORef, modifyIORef ) + import Control.Monad \end{code} @@ -413,6 +417,51 @@ dsExpr (PArrSeq _ _) \end{code} \noindent +\underline{\bf Static Pointers} +% ~~~~~~~~~~~~~~~ +\begin{verbatim} + static f +==> + StaticPtr (StaticName "pkg id of f" "module of f" "f") +\end{verbatim} + +\begin{code} +dsExpr (HsStatic expr@(L loc _)) = do + expr_ds <- dsLExpr expr + let ty = exprType expr_ds + case dropTypeApps expr_ds of + Var _ -> return () + _ -> do + failWithDs $ cat + [ ptext (sLit "The argument of a static form can be only a name") + , ptext (sLit "but found: static") <+> parens (ppr expr) + ] + n' <- mkSptEntryName loc + static_binds_var <- dsGetStaticBindsVar + + let mod = nameModule n' + pkgKey = modulePackageKey mod + pkgName = packageKeyString pkgKey + + -- create static name + nm <- fmap (mkConApp staticNameDataCon) $ + mapM mkStringExprFS + [ fsLit pkgName + , moduleNameFS $ moduleName mod + , occNameFS $ nameOccName n' + ] + let tvars = varSetElems $ tyVarsOfType ty + speId = mkExportedLocalId VanillaId n' staticSptEntryTy + spe = mkConApp staticSptEntryDataCon + [Type (mkForAllTys tvars ty), nm, mkLams tvars expr_ds] + liftIO $ modifyIORef static_binds_var ((speId, spe) :) + putSrcSpanDs loc $ return $ mkConApp staticPtrDataCon [Type ty, nm, expr_ds] + where + dropTypeApps (App e (Type _)) = dropTypeApps e + dropTypeApps e = e +\end{code} + +\noindent \underline{\bf Record construction and update} % ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For record construction we do this (assuming T has three arguments) @@ -887,3 +936,32 @@ badMonadBind rhs elt_ty flag_doc 2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs) , ptext (sLit "or by using the flag") <+> flag_doc ] \end{code} + +%************************************************************************ +%* * +\subsection{Static pointers} +%* * +%************************************************************************ + + +-- mkStaticRhs :: CoreExpr -> + +\begin{code} +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 +\end{code} diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 083c466baa..e344070df1 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1075,6 +1075,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) @@ -2105,7 +2106,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 @@ -2287,7 +2288,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 @@ -2318,6 +2319,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 @@ -2657,7 +2659,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 @@ -2684,6 +2686,7 @@ listEIdKey = mkPreludeMiscIdUnique 292 sigEIdKey = mkPreludeMiscIdUnique 293 recConEIdKey = mkPreludeMiscIdUnique 294 recUpdEIdKey = mkPreludeMiscIdUnique 295 +staticEIdKey = mkPreludeMiscIdUnique 296 -- type FieldExp = ... fieldExpIdKey :: Unique diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index c017a7cc01..ea4f581880 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -21,7 +21,7 @@ module DsMonad ( mkPrintUnqualifiedDs, newUnique, UniqSupply, newUniqueSupply, - getGhcModeDs, dsGetFamInstEnvs, + getGhcModeDs, dsGetFamInstEnvs, dsGetStaticBindsVar, dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon, PArrBuiltin(..), @@ -167,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 [(Id,CoreExpr)] + -- ^ Bindings resulted from floating static forms } instance ContainsModule DsGblEnv where @@ -197,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 $ @@ -276,12 +281,15 @@ initDsTc thing_inside ; 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 = tcg_static_binds tcg_env + 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 [(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 @@ -291,6 +299,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 @@ -496,6 +505,9 @@ dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a dsExtendMetaEnv menv thing_inside = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside + +dsGetStaticBindsVar :: DsM (IORef [(Id,CoreExpr)]) +dsGetStaticBindsVar = fmap ds_static_binds getGblEnv \end{code} \begin{code} diff --git a/compiler/deSugar/SPT.lhs b/compiler/deSugar/SPT.lhs new file mode 100644 index 0000000000..b5823413e0 --- /dev/null +++ b/compiler/deSugar/SPT.lhs @@ -0,0 +1,88 @@ +% +% Code generation for the Static Pointer Table +% +% (c) 2014 I/O Tweag +% +\begin{code} +module SPT (sptInitCode) where + +import CoreSyn +import Module +import Outputable +import Id +import Name +import CLabel +import FastString +import Foreign.Ptr +import GHC.Fingerprint +import qualified Data.ByteString.Unsafe as BS +import System.IO.Unsafe (unsafePerformIO) +\end{code} + +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) +{ + extern StgPtr Main_sptEntryZC0_closure; + extern StgPtr Main_sptEntryZC1_closure; + hs_spt_insert( (StgWord64[2]){16252233376642134256ULL,7370534374097506082ULL} + , &Main_sptEntryZC0_closure + ); + hs_spt_insert( (StgWord64[2]){12545634534567898323ULL,5409674567544156781ULL} + , &Main_sptEntryZC1_closure + ); +} + +where constants are values of a fingerprint of the triplet +(package_id, module_name, sptEntry:N). + +\begin{code} +sptInitCode :: Module -> [(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 $ + [ ptext (sLit "extern StgPtr ") + <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) + <> semi + | (n, _) <- entries ] ++ + [ ptext (sLit "hs_spt_insert") + <> parens (hcat $ punctuate comma + [ pprFingerprint $ fingerprintId n + , ptext (sLit "&") <> ppr (mkClosureLabel (idName n) (idCafInfo n)) + ]) + <> semi + | (n, _) <- entries ] + ] +\end{code} + +\begin{code} +fingerprintId :: Id -> Fingerprint +fingerprintId n = + fingerprintString (unpackFS name) + where + name = concatFS [ packageKeyFS $ modulePackageKey $ nameModule $ idName n + , fsLit ":" + , moduleNameFS (moduleName $ nameModule $ idName n) + , fsLit "." + , occNameFS $ occName $ idName n + ] + +pprFingerprint :: Fingerprint -> SDoc +pprFingerprint (Fingerprint w1 w2) = + ptext (sLit "(StgWord64[2])") + <> (braces $ hcat $ punctuate comma [integer (fromIntegral w1) <> ptext (sLit "ULL") + ,integer (fromIntegral w2) <> ptext (sLit "ULL") + ]) +\end{code} + diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 6422eb7ce9..6d167e5dba 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -319,6 +319,7 @@ Library PlatformConstants PprTyThing StaticFlags + SPT SysTools TidyPgm Ctype diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 9ad594c698..896bc69622 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -673,6 +673,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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/hsSyn/HsExpr.lhs b/compiler/hsSyn/HsExpr.lhs index eaac719df9..b9547db9b6 100644 --- a/compiler/hsSyn/HsExpr.lhs +++ b/compiler/hsSyn/HsExpr.lhs @@ -277,6 +277,10 @@ data HsExpr id -- 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 -- immediately in parser.RdrHsSyn.checkCommand @@ -567,6 +571,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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 043174f3b0..e170b8f72c 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -604,6 +604,7 @@ data ExtensionFlag | Opt_NegativeLiterals | Opt_EmptyCase | Opt_PatternSynonyms + | Opt_StaticPointers deriving (Eq, Enum, Show) data SigOf = NotSigOf @@ -2960,7 +2961,8 @@ xFlags = [ ( "UndecidableInstances", Opt_UndecidableInstances, nop ), ( "UnicodeSyntax", Opt_UnicodeSyntax, nop ), ( "UnliftedFFITypes", Opt_UnliftedFFITypes, nop ), - ( "ViewPatterns", Opt_ViewPatterns, nop ) + ( "ViewPatterns", Opt_ViewPatterns, nop ), + ( "StaticPointers", Opt_StaticPointers, nop ) ] defaultFlags :: Settings -> [GeneralFlag] diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index 6d05bb9d6d..d2803dbc3f 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -545,6 +545,7 @@ data Token | ITby | ITusing | ITpattern + | ITstatic -- Pragmas | ITinline_prag InlineSpec RuleMatchInfo @@ -728,6 +729,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), @@ -1100,6 +1102,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 diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 2e1b777bb3..096d1d998b 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -273,6 +273,7 @@ incorrect. '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 } @@ -1599,6 +1600,7 @@ hpc_annot :: { Located (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 } diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 6e40546d2c..e7464a2a19 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -452,6 +452,9 @@ gHC_IP = mkBaseModule (fsLit "GHC.IP") gHC_PARR' :: Module gHC_PARR' = mkBaseModule (fsLit "GHC.PArr") +gHC_STATICPTR :: Module +gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr") + mAIN, rOOT_MAIN :: Module mAIN = mkMainModule_ mAIN_NAME rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation @@ -1483,6 +1486,18 @@ specTyConKey = mkPreludeTyConUnique 177 smallArrayPrimTyConKey = mkPreludeTyConUnique 178 smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 179 +staticPtrTyConKey :: Unique +staticPtrTyConKey = mkPreludeTyConUnique 180 + +staticNameTyConKey :: Unique +staticNameTyConKey = mkPreludeTyConUnique 181 + +staticSptEntryTyConKey :: Unique +staticSptEntryTyConKey = mkPreludeTyConUnique 182 + +staticSptEntryConKey :: Unique +staticSptEntryConKey = mkPreludeTyConUnique 183 + ---------------- Template Haskell ------------------- -- USES TyConUniques 200-299 ----------------------------------------------------- @@ -1545,6 +1560,16 @@ eqDataConKey = mkPreludeDataConUnique 28 gtDataConKey = mkPreludeDataConUnique 29 coercibleDataConKey = mkPreludeDataConUnique 32 + +staticPtrDataConKey :: Unique +staticPtrDataConKey = mkPreludeDataConUnique 33 + +staticNameDataConKey :: Unique +staticNameDataConKey = mkPreludeDataConUnique 34 + +staticSptConKey :: Unique +staticSptConKey = mkPreludeDataConUnique 35 + \end{code} %************************************************************************ diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index f4dca9a0de..e7dd7df46c 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -1,4 +1,4 @@ -% +, alpha% % (c) The GRASP Project, Glasgow University, 1994-1998 % \section[TysWiredIn]{Wired-in knowledge about {\em non-primitive} types} @@ -67,6 +67,12 @@ module TysWiredIn ( parrTyCon, parrFakeCon, isPArrTyCon, isPArrFakeCon, parrTyCon_RDR, parrTyConName, + -- * StaticPtr + staticPtrTyCon, staticPtrTyConName, + staticPtrDataCon, staticNameDataCon, + staticSptEntryTy, staticSptEntryTyCon, + staticSptEntryTyConName, staticSptEntryDataCon, + -- * Equality predicates eqTyCon_RDR, eqTyCon, eqTyConName, eqBoxDataCon, coercibleTyCon, coercibleDataCon, coercibleClass, @@ -151,6 +157,8 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because , wordTyCon , listTyCon , parrTyCon + , staticPtrTyCon + , staticNameTyCon , eqTyCon , coercibleTyCon , typeNatKindCon @@ -216,6 +224,24 @@ parrTyConName = mkWiredInTyConName BuiltInSyntax parrDataConName = mkWiredInDataConName UserSyntax gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon +staticPtrTyConName, staticPtrDataConName :: Name +staticPtrTyConName = mkWiredInTyConName UserSyntax + gHC_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey staticPtrTyCon +staticPtrDataConName = mkWiredInDataConName UserSyntax + gHC_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey staticPtrDataCon + +staticNameTyConName, staticNameDataConName :: Name +staticNameTyConName = mkWiredInTyConName UserSyntax + gHC_STATICPTR (fsLit "StaticName") staticNameTyConKey staticNameTyCon +staticNameDataConName = mkWiredInDataConName UserSyntax + gHC_STATICPTR (fsLit "StaticName") staticNameDataConKey staticNameDataCon + +staticSptEntryTyConName, staticSptEntryDataConName :: Name +staticSptEntryTyConName = mkWiredInTyConName UserSyntax + gHC_STATICPTR (fsLit "SptEntry") staticSptEntryTyConKey staticSptEntryTyCon +staticSptEntryDataConName = mkWiredInDataConName UserSyntax + gHC_STATICPTR (fsLit "SptEntry") staticSptEntryConKey staticNameDataCon + boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR, eqTyCon_RDR :: RdrName boolTyCon_RDR = nameRdrName boolTyConName @@ -850,6 +876,64 @@ isPArrFakeCon :: DataCon -> Bool isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon) \end{code} +StaticPtr + +\begin{code} +staticPtrTyCon :: TyCon +staticPtrTyCon = + pcNonRecDataTyCon staticPtrTyConName Nothing alpha_tyvar [staticPtrDataCon] + +staticPtrDataCon :: DataCon +staticPtrDataCon = + pcDataCon staticPtrDataConName alpha_tyvar [staticNameTy, alphaTy] staticPtrTyCon + +staticNameTy :: Type +staticNameTy = mkTyConTy staticNameTyCon + +staticNameTyCon :: TyCon +staticNameTyCon = + pcNonRecDataTyCon staticNameTyConName Nothing [] [staticNameDataCon] + +staticNameDataCon :: DataCon +staticNameDataCon = + pcDataCon staticNameDataConName [] (replicate 3 stringTy) staticNameTyCon + +staticSptEntryTy :: Type +staticSptEntryTy = mkTyConTy staticSptEntryTyCon + +staticSptEntryTyCon :: TyCon +staticSptEntryTyCon = + pcNonRecDataTyCon staticSptEntryTyConName Nothing [] [staticSptEntryDataCon] + +staticSptEntryDataCon :: DataCon +staticSptEntryDataCon = + let dc_name = staticSptEntryDataConName + arg_tys = [ staticNameTy, alphaTy ] + modu = ASSERT( isExternalName dc_name ) + nameModule dc_name + wrk_key = incrUnique (nameUnique dc_name) + wrk_occ = mkDataConWorkerOcc (nameOccName dc_name) + wrk_name = mkWiredInName modu wrk_occ wrk_key + (AnId (dataConWorkId data_con)) UserSyntax + data_con = mkDataCon + dc_name + False + (map (const HsNoBang) arg_tys) + [] -- No labelled fields + [] -- No univerally quantified type variables + [alphaTyVar] -- Existentially quantified type variables + [] -- No equality spec + [] -- No theta + arg_tys -- Argument types + staticSptEntryTy -- Result type + staticSptEntryTyCon -- Representation type constructor + [] -- No stupid theta + (mkDataConWorkId wrk_name data_con) -- Worker Id + NoDataConRep -- No data constructor representation + + in data_con +\end{code} + Promoted Booleans \begin{code} diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index b24956c85e..be9d9116d8 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -310,6 +310,39 @@ 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. + +\begin{code} +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. + _ -> do + let isTopLevelName n = isExternalName n || isWiredInName n + case nameSetToList $ filterNameSet (not . isTopLevelName) fvExpr of + [] -> return () + fvNonGlobal -> addErr $ cat + [ ptext $ sLit $ "Only identifiers of top-level bindings can " + ++ "appear in the body of the static form:" + , nest 2 $ ppr e + , ptext $ sLit "but the following identifiers were found instead:" + , nest 2 $ vcat $ map ppr fvNonGlobal + ] + return (HsStatic expr', fvExpr) +\end{code} + +%************************************************************************ +%* * Arrow notation %* * %************************************************************************ diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index c2af40703d..26c6e76f3d 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -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 ) diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs index a242ed77d2..ee73e5dc9f 100644 --- a/compiler/typecheck/TcExpr.lhs +++ b/compiler/typecheck/TcExpr.lhs @@ -23,6 +23,7 @@ import HsSyn import TcHsSyn import TcRnMonad import TcUnify +import TcValidity import BasicTypes import Inst import TcBinds @@ -38,6 +39,9 @@ import DsMonad hiding (Splice) import Id import ConLike import DataCon +-- import IdInfo +-- import Module ( HasModule(..), lookupWithDefaultModuleEnv, extendModuleEnv ) +-- import Data.IORef ( atomicModifyIORef ) import PatSyn import RdrName import Name @@ -484,6 +488,32 @@ tcExpr (HsDo do_or_lc stmts _) res_ty tcExpr (HsProc pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty ; return $ mkHsWrapCo coi (HsProc pat' cmd') } + +tcExpr (HsStatic expr@(L loc _)) res_ty + = do { (co, [expr_ty]) <- matchExpectedTyConApp staticPtrTyCon res_ty + ; (((expr',errCtx), untch), lie) <- captureConstraints $ + captureUntouchables $ + addErrCtxt (hang (ptext (sLit "In the body of a static form:")) + 2 (ppr expr) + ) $ + liftM2 (,) (tcPolyExprNC expr expr_ty) getErrCtxt + ; lieTcRef <- tcl_lie <$> getLclEnv + ; updTcRef lieTcRef (`andWC` lie) + -- Keep the name in case it is not used anywhere else. + ; case expr of + L _ (HsVar n) -> keepAlive n + _ -> return () + -- Require the type of the argument to be Typeable. + ; (typeableClass, _) <- tcClass typeableClassName + ; _ <- instCall StaticOrigin [expr_ty] + [ mkTyConApp (classTyCon typeableClass) + [liftedTypeKind, expr_ty] + ] + -- Insert the static form in a global list for later validation. + ; stOccsVar <- tcg_static_occs <$> getGblEnv + ; updTcRef stOccsVar ((expr_ty, lie, untch, loc, errCtx) :) + ; return $ mkHsWrapCo co $ HsStatic expr' + } \end{code} Note [Rebindable syntax for if] diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index 1a91f10e66..23407639f2 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -736,6 +736,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 diff --git a/compiler/typecheck/TcHsType.lhs b/compiler/typecheck/TcHsType.lhs index d6f237f64f..c6363c9811 100644 --- a/compiler/typecheck/TcHsType.lhs +++ b/compiler/typecheck/TcHsType.lhs @@ -15,7 +15,7 @@ module TcHsType ( -- Type checking type and class decls kcLookupKind, kcTyClTyVars, tcTyClTyVars, tcHsConArgType, tcDataKindSig, - tcClassSigType, + tcClassSigType, tcClass, -- Kind-checking types -- No kind generalisation, no checkValidType diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 893e0290da..730db77c7b 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -37,6 +37,9 @@ import TcHsSyn import TcExpr import TcRnMonad import TcEvidence +import TcType (Untouchables) +import TysWiredIn (staticPtrTyCon) +import TcValidity import PprTyThing( pprTyThing ) import Coercion( pprCoAxiom ) import FamInst @@ -473,6 +476,12 @@ tcRnSrcDecls boot_iface decls simplifyTop lie ; traceTc "Tc9" empty ; + failIfErrsM ; + + ((), lie2) <- captureConstraints checkStaticPointers ; + new_ev_binds2 <- {-# SCC "simplifyTop" #-} + simplifyTop lie2 ; + failIfErrsM ; -- Don't zonk if there have been errors -- It's a waste of time; and we may get debug warnings -- about strangely-typed TyCons! @@ -488,7 +497,8 @@ tcRnSrcDecls boot_iface decls tcg_rules = rules, tcg_vects = vects, tcg_fords = fords } = tcg_env - ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ; + ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds + `unionBags` new_ev_binds2 } ; (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') <- {-# SCC "zonkTopDecls" #-} @@ -1641,8 +1651,11 @@ tcGhciStmts stmts -- OK, we're ready to typecheck the stmts traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; ((tc_stmts, ids), lie) <- captureConstraints $ - tc_io_stmts $ \ _ -> - mapM tcLookupId names ; + (tc_io_stmts $ \ _ -> + mapM tcLookupId names) + -- Ignore bindings for static pointers + <* checkStaticPointers ; + -- Look up the names right in the middle, -- where they will all be in scope @@ -1731,6 +1744,8 @@ tcRnExpr hsc_env rdr_expr captureUntouchables $ tcInferRho rn_expr ; ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ + -- Ignore bindings for static pointers + checkStaticPointers >> {-# SCC "simplifyInfer" #-} simplifyInfer untch False {- No MR for now -} @@ -1817,8 +1832,13 @@ tcRnDeclsi hsc_env local_decls = new_ev_binds <- simplifyTop lie failIfErrsM - let TcGblEnv { tcg_type_env = type_env, - tcg_binds = binds, + ((), lie2) <- captureConstraints checkStaticPointers + new_ev_binds2 <- {-# SCC "simplifyTop" #-} + simplifyTop lie2 + + failIfErrsM + let TcGblEnv { tcg_binds = binds, + tcg_type_env = type_env, tcg_sigs = sig_ns, tcg_ev_binds = cur_ev_binds, tcg_imp_specs = imp_specs, @@ -1826,6 +1846,7 @@ tcRnDeclsi hsc_env local_decls = tcg_vects = vects, tcg_fords = fords } = tcg_env all_ev_binds = cur_ev_binds `unionBags` new_ev_binds + `unionBags` new_ev_binds2 (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords @@ -2090,3 +2111,37 @@ ppr_tydecls tycons where ppr_tycon tycon = vcat [ ppr (tyThingToIfaceDecl (ATyCon tycon)) ] \end{code} + +%************************************************************************ +%* * + checkStaticPointers +%* * +%************************************************************************ + +\begin{code} +-- | Checks that the static forms have valid types when generalized. +-- +-- The type @StaticPtr tau@ is valid if it is predicative, that is, tau is unqualified +-- and monomorphic. +-- +checkStaticPointers :: TcM () +checkStaticPointers = do + stOccsVar <- tcg_static_occs <$> getGblEnv + stOccs <- readTcRef stOccsVar + writeTcRef stOccsVar [] + mapM_ checkStaticPointer stOccs + where + checkStaticPointer :: + (TcType, WantedConstraints, Untouchables, SrcSpan, [ErrCtxt]) -> TcM () + checkStaticPointer (ty, lie, untch, loc, errCtx) = + setSrcSpan loc $ setErrCtxt errCtx $ do + fresh_name <- newSysName $ mkVarOccFS $ fsLit "static" + (_, dicts, _, _) <- simplifyInfer untch + False -- No MR + [(fresh_name, ty)] + lie + + let expr_qty = mkPiTypes dicts ty + zty <- zonkTcType $ mkTyConApp staticPtrTyCon [ expr_qty ] + void $ tryM $ checkValidType StaticCtxt zty +\end{code} diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index cd414999af..e2f032fbfe 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -97,6 +97,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this Nothing -> newIORef emptyNameEnv } ; dependent_files_var <- newIORef [] ; + static_occs_var <- newIORef [] ; + static_binds_var <- newIORef [] ; #ifdef GHCI th_topdecls_var <- newIORef [] ; th_topnames_var <- newIORef emptyNameSet ; @@ -162,7 +164,9 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_hpc = False, tcg_main = Nothing, tcg_safeInfer = infer_var, - tcg_dependent_files = dependent_files_var + tcg_dependent_files = dependent_files_var, + tcg_static_occs = static_occs_var, + tcg_static_binds = static_binds_var } ; lcl_env = TcLclEnv { tcl_errs = errs_var, diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index e1762a8f73..bcaad8925d 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -87,6 +87,7 @@ module TcRnTypes( #include "HsVersions.h" import HsSyn +import CoreSyn import HscTypes import TcEvidence import Type @@ -283,6 +284,8 @@ data TcGblEnv -- rule -- -- * Top-level variables appearing free in a TH bracket + -- + -- * Top-level variables introduced by the static form tcg_th_used :: TcRef Bool, -- ^ @True@ <=> Template Haskell syntax used. @@ -354,9 +357,26 @@ data TcGblEnv tcg_main :: Maybe Name, -- ^ The Name of the main -- function, if this module is -- the main module. - tcg_safeInfer :: TcRef Bool -- Has the typechecker + tcg_safeInfer :: TcRef Bool, -- Has the typechecker -- inferred this module -- as -XSafe (Safe Haskell) + tcg_static_occs :: TcRef [( TcType + , WantedConstraints + , Untouchables + , SrcSpan + , [ErrCtxt] + )], + -- ^ Occurrences of static forms + -- + -- Each entry holds the type of the body of the static form, + -- the constraints the body requires, the location of the static + -- form and the error context to use when reporting errors. + + tcg_static_binds :: IORef [(Id,CoreExpr)] + -- ^ Bindings resulted from floating static forms + -- + -- The typechecker needs to carry this information when desugaring + -- splices that contain static forms. } -- Note [Signature parameters in TcGblEnv and DynFlags] @@ -1875,6 +1895,7 @@ data CtOrigin | HoleOrigin | UnboundOccurrenceOf RdrName | ListOrigin -- An overloaded list + | StaticOrigin -- A static form ctoHerald :: SDoc ctoHerald = ptext (sLit "arising from") @@ -1953,5 +1974,6 @@ pprCtO (TypeEqOrigin t1 t2) = ptext (sLit "a type equality") <+> sep [ppr t1, c pprCtO AnnOrigin = ptext (sLit "an annotation") pprCtO HoleOrigin = ptext (sLit "a use of") <+> quotes (ptext $ sLit "_") pprCtO ListOrigin = ptext (sLit "an overloaded list") +pprCtO StaticOrigin = ptext (sLit "a static form") pprCtO _ = panic "pprCtOrigin" \end{code} diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs index dba1be8964..cfbbb918a8 100644 --- a/compiler/typecheck/TcType.lhs +++ b/compiler/typecheck/TcType.lhs @@ -379,6 +379,7 @@ data UserTypeCtxt -- e.g. (f e) where f has a higher-rank type -- We might want to elaborate this | GhciCtxt -- GHCi command :kind <type> + | StaticCtxt -- Static form | ClassSCCtxt Name -- Superclasses of a class | SigmaCtxt -- Theta part of a normal for-all type @@ -534,6 +535,7 @@ pprUserTypeCtxt InstDeclCtxt = ptext (sLit "an instance declaration") pprUserTypeCtxt SpecInstCtxt = ptext (sLit "a SPECIALISE instance pragma") pprUserTypeCtxt GenSigCtxt = ptext (sLit "a type expected by the context") pprUserTypeCtxt GhciCtxt = ptext (sLit "a type in a GHCi command") +pprUserTypeCtxt StaticCtxt = ptext (sLit "a static form") pprUserTypeCtxt (ClassSCCtxt c) = ptext (sLit "the super-classes of class") <+> quotes (ppr c) pprUserTypeCtxt SigmaCtxt = ptext (sLit "the context of a polymorphic type") pprUserTypeCtxt (DataTyCtxt tc) = ptext (sLit "the context of the data type declaration for") <+> quotes (ppr tc) diff --git a/compiler/typecheck/TcValidity.lhs b/compiler/typecheck/TcValidity.lhs index 8381533a28..d7e568b7e9 100644 --- a/compiler/typecheck/TcValidity.lhs +++ b/compiler/typecheck/TcValidity.lhs @@ -175,6 +175,7 @@ checkValidType ctxt ty SpecInstCtxt -> rank1 ThBrackCtxt -> rank1 GhciCtxt -> ArbitraryRank + StaticCtxt -> MustBeMonoType _ -> panic "checkValidType" -- Can't happen; not used for *user* sigs diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index edd1ccc277..b09ac530de 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -9981,6 +9981,130 @@ Assertion failures can be caught, see the documentation for the </sect1> +<!-- =============================== STATIC POINTERS =========================== --> + +<sect1 id="static-pointers"> +<title>Static pointers +<indexterm><primary>Static pointers</primary></indexterm> +</title> + +<para> +The language extension <literal>-XStaticPointers</literal> adds a new +syntactic form <literal>static <replaceable>e</replaceable></literal>, +which stands for a reference to the closed expression +<replaceable>e</replaceable>. This reference is stable and portable, +in the sense that it remains valid across different processes on +possibly different machines. Thus, a process can create a reference +and send it to another process that can resolve it to +<replaceable>e</replaceable>. +</para> +<para> +With this extension turned on, <literal>static</literal> is no longer +a valid identifier. +</para> +<para> +Static pointers were first proposed in the paper <ulink +url="http://research.microsoft.com/en-us/um/people/simonpj/papers/parallel/remote.pdf"> +Towards Haskell in the cloud</ulink>, Jeff Epstein, Andrew P. Black and Simon +Peyton-Jones, Proceedings of the 4th ACM Symposium on Haskell, pp. +118-129, ACM, 2011. +</para> + +<sect2 id="using-static-pointers"> +<title>Using static pointers</title> + +<para> +The information contained in the reference is used by +<ulink url="&libraryBaseLocation;/GHC.StaticPtr.html#v%3AdeRefStaticPtr"><literal>deRefStaticPtr</literal></ulink> +to locate the values at runtime using a global and immutable table called +the Static Pointer Table. The compiler includes entries in this table for +all static forms found in the linked modules. +</para> + +<para> +The body <literal>e</literal> of a <literal>static +e</literal> expression must be a closed expression. That is, there can +be no free variables occurring in <literal>e</literal>, i.e. lambda- +or let-bound variables bound locally in the context of the expression. +</para> + +<para> +All of the following are permissible: +<programlisting> +inc :: Int -> Int +inc x = x + 1 + +ref1 = static 1 +ref2 = static inc +ref3 = static (inc 1) +ref4 = static ((\x -> x + 1) (1 :: Int)) +ref5 y = static (let x = 1 in x) +</programlisting> +While the following definitions are rejected: +<programlisting> +ref6 = let x = 1 in static x +ref7 y = static (let x = 1 in y) +</programlisting> +Note that currently, the body <literal>e</literal> in <literal>static +e</literal> is restricted to a single identifier when at the GHCi +prompt. +</para> +</sect2> + +<sect2 id="typechecking-static-pointers"> +<title>Static semantics of static pointers</title> + +<para> + +Informally, if we have a closed expression +<programlisting> +e :: forall a_1 ... a_n . t +</programlisting> +the static form is of type +<programlisting> +static e :: (Typeable a_1, ... , Typeable a_n) => StaticPtr t +</programlisting> +Furthermore, type <literal>t</literal> is constrained to have a +<literal>Typeable</literal> instance. + +The following are therefore illegal: +<programlisting> +static show -- No Typeable instance for (Show a => a -> String) +static Control.Monad.ST.runST -- No Typeable instance for ((forall s. ST s a) -> a) +</programlisting> + +That being said, with the appropriate use of wrapper datatypes, the +above limitations induce no loss of generality: +<programlisting> +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DerivingDataTypeable #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StaticPointers #-} + +import Control.Monad.ST +import GHC.StaticPtr + +data Dict c = c => Dict + deriving Typeable + +g1 :: Typeable a => StaticPtr (Dict (Show a) -> a -> String) +g1 = static (\Dict -> show) + +data Rank2Wrapper f = R2W (forall s. f s) + deriving Typeable +newtype Flip f a s = Flip { unFlip :: f s a } + deriving Typeable + +g2 :: Typeable a => StaticPtr (Rank2Wrapper (Flip ST a) -> a) +g2 = static (\(R2W f) -> runST (unFlip f)) +</programlisting> +</para> +</sect2> + +</sect1> + <!-- =============================== PRAGMAS =========================== --> diff --git a/includes/HsFFI.h b/includes/HsFFI.h index d51ee04b67..f778478e11 100644 --- a/includes/HsFFI.h +++ b/includes/HsFFI.h @@ -161,6 +161,8 @@ extern void hs_free_stable_ptr_unsafe (HsStablePtr sp); extern void hs_free_stable_ptr (HsStablePtr sp); extern void hs_free_fun_ptr (HsFunPtr fp); +extern StgPtr hs_spt_lookup(StgWord64 key[2]); + /* -------------------------------------------------------------------------- */ #ifdef __cplusplus diff --git a/includes/Rts.h b/includes/Rts.h index 6bf7650f69..6869cc384b 100644 --- a/includes/Rts.h +++ b/includes/Rts.h @@ -238,6 +238,7 @@ INLINE_HEADER Time fsecondsToTime (double t) #include "rts/Utils.h" #include "rts/PrimFloat.h" #include "rts/Main.h" +#include "rts/SPT.h" /* Misc stuff without a home */ DLL_IMPORT_RTS extern char **prog_argv; /* so we can get at these from Haskell */ diff --git a/includes/rts/SPT.h b/includes/rts/SPT.h new file mode 100644 index 0000000000..8c5f8ab1a9 --- /dev/null +++ b/includes/rts/SPT.h @@ -0,0 +1,32 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team, 2008-2009 + * + * Initialization of the Static Pointer Table + * + * Do not #include this file directly: #include "Rts.h" instead. + * + * To understand the structure of the RTS headers, see the wiki: + * http://ghc.haskell.org/trac/ghc/wiki/Commentary/SourceTree/Includes + * + * -------------------------------------------------------------------------- */ + +#ifndef RTS_SPT_H +#define RTS_SPT_H + +/** Inserts an entry in the Static Pointer Table. + * + * The key is a fingerprint computed from the StaticName of a static pointer + * and the spe_closure is a pointer to the closure defining the table entry + * (GHC.SptEntry). + * + * A stable pointer to the closure is made to prevent it from being garbage + * collected while the entry exists on the table. + * + * This function is called from the code generated by + * compiler/deSugar/SPT.sptInitCode + * + * */ +void hs_spt_insert (StgWord64 key[2],void* spe_closure); + +#endif /* RTS_HPC_H */ diff --git a/libraries/base/GHC/StaticPtr.hs b/libraries/base/GHC/StaticPtr.hs new file mode 100644 index 0000000000..e7277ddbb4 --- /dev/null +++ b/libraries/base/GHC/StaticPtr.hs @@ -0,0 +1,107 @@ +----------------------------------------------------------------------------- +-- | +-- Module : GHC.StaticPtr +-- Copyright : (C) 2014 I/O Tweag +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Symbolic references to values. +-- +-- References to values are usually implemented with memory addresses, and this +-- is practical when communicating values between the different pieces of a +-- single process. +-- +-- When values are communicated across different processes running in possibly +-- different machines, though, addresses are no longer useful since each +-- process may use different addresses to store a given value. +-- +-- To solve such concern, the references provided by this module indicate +-- package, module and name of a value. This information could be used to locate +-- the value in different processes. +-- +-- Currently, the main use case for references is the StaticPointers language +-- extension. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ExistentialQuantification #-} +module GHC.StaticPtr + ( StaticPtr + , staticName + , StaticName(..) + , DynStaticPtr(..) + , SptEntry + , deRefStaticPtr + , encodeStaticPtr + , decodeStaticPtr + ) where + +import Data.Typeable (Typeable) +import Data.Char +import Foreign.C.String ( withCString, CString ) +import Foreign.Marshal ( withArray ) +import Foreign.Ptr ( castPtr ) +import GHC.Exts ( addrToAny# ) +import GHC.Ptr ( Ptr(..), nullPtr ) +import GHC.Fingerprint ( Fingerprint(..), fingerprintString ) +import Numeric +import System.Info ( os ) +import System.IO.Unsafe ( unsafePerformIO ) +import Unsafe.Coerce ( unsafeCoerce ) + + +-- | A reference to a top-level value of type 'a'. +data StaticPtr a = StaticPtr StaticName a + deriving (Read, Show, Typeable) + +staticName :: StaticPtr a -> StaticName +staticName (StaticPtr n _) = n + +-- | Identification of top-level values +-- +-- > StaticName package_id module_name value_name +-- +data StaticName = StaticName String String String + deriving (Read, Show, Typeable) + +-- | Entries of the static pointer table. +data SptEntry = forall a . SptEntry StaticName a + +-- | Dynamic static pointer. +data DynStaticPtr = forall a . DSP (StaticPtr a) + +-- | Encodes static pointer in the form that can be later serialized. +encodeStaticPtr :: StaticPtr a -> Fingerprint +encodeStaticPtr = fingerprintStaticName . staticName + +-- | Decodes an encoded pointer. It looks up a static pointer in +-- entry in the static pointer table. +decodeStaticPtr :: Fingerprint -> Maybe DynStaticPtr +decodeStaticPtr key = unsafePerformIO $ + fmap (fmap (\(SptEntry s v) -> DSP $ StaticPtr s v)) (sptLookup key) + +-- | Dereferences a static pointer. +deRefStaticPtr :: StaticPtr a -> a +deRefStaticPtr p@(StaticPtr s v) = v + +fingerprintStaticName :: StaticName -> Fingerprint +fingerprintStaticName (StaticName pkg m valsym) = + fingerprintString $ concat [pkg, ":", m, ".", valsym] + +sptLookup :: Fingerprint -> IO (Maybe SptEntry) +sptLookup (Fingerprint w1 w2) = do + ptr@(Ptr addr) <- withArray [w1,w2] (hs_spt_lookup . castPtr) + if (ptr == nullPtr) + then return Nothing + else case addrToAny# addr of + (# spe #) -> return (Just spe) + +foreign import ccall unsafe hs_spt_lookup :: Ptr () -> IO (Ptr a) diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index c3f4d28a1e..b857db4853 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -252,6 +252,7 @@ Library GHC.Ptr GHC.Read GHC.Real + GHC.StaticPtr GHC.ST GHC.STRef GHC.Show diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index e038a3ba6b..ac277b78fa 100644 --- a/libraries/template-haskell/Language/Haskell/TH.hs +++ b/libraries/template-haskell/Language/Haskell/TH.hs @@ -90,7 +90,7 @@ module Language.Haskell.TH( normalB, guardedB, normalG, normalGE, patG, patGE, match, clause, -- *** Expressions - dyn, global, varE, conE, litE, appE, uInfixE, parensE, + dyn, global, varE, conE, litE, appE, uInfixE, parensE, staticE, infixE, infixApp, sectionL, sectionR, lamE, lam1E, lamCaseE, tupE, condE, multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE, fieldExp, diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs index efe597275b..97a5a9efe5 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -296,6 +296,9 @@ stringE = litE . stringL fieldExp :: Name -> ExpQ -> Q (Name, Exp) fieldExp s e = do { e' <- e; return (s,e') } +staticE :: ExpQ -> ExpQ +staticE = fmap StaticE + -- ** 'arithSeqE' Shortcuts fromE :: ExpQ -> ExpQ fromE x = do { a <- x; return (ArithSeqE (FromR a)) } diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs index 5f3a0c6c9b..0f828eb98b 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs @@ -172,6 +172,8 @@ pprExp _ (ListE es) = brackets $ sep $ punctuate comma $ map ppr es pprExp i (SigE e t) = parensIf (i > noPrec) $ ppr e <+> text "::" <+> ppr t pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs) pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs) +pprExp i (StaticE e) = parensIf (i >= appPrec) $ + text "static"<+> pprExp appPrec e pprFields :: [(Name,Exp)] -> Doc pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e) diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs index ddbe3a98e2..0c75fb99b8 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -1145,6 +1145,7 @@ data Exp | SigE Exp Type -- ^ @{ e :: t }@ | RecConE Name [FieldExp] -- ^ @{ T { x = y, z = w } }@ | RecUpdE Exp [FieldExp] -- ^ @{ (f x) { z = w } }@ + | StaticE Exp -- ^ @{ static e }@ deriving( Show, Eq, Data, Typeable, Generic ) type FieldExp = (Name,Exp) diff --git a/rts/Hash.c b/rts/Hash.c index b91d70c219..1c167168d2 100644 --- a/rts/Hash.c +++ b/rts/Hash.c @@ -16,6 +16,10 @@ #include <string.h> +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + #define HSEGSIZE 1024 /* Size of a single hash table segment */ /* Also the minimum size of a hash table */ #define HDIRSIZE 1024 /* Size of the segment directory */ @@ -99,6 +103,31 @@ hashStr(HashTable *table, char *key) return bucket; } +int +hashFingerprint(HashTable *table, uint64_t *key) +{ + int h, bucket; + char *s; + + s = (char *)key; + size_t i; + for (i=0, h=0; i< sizeof(uint64_t)*2; ++i, ++s) { + h *= 128; + h += *s; + h = h % 1048583; /* some random large prime */ + } + + /* Mod the size of the hash table (a power of 2) */ + bucket = h & table->mask1; + + if (bucket < table->split) { + /* Mod the size of the expanded hash table (also a power of 2) */ + bucket = h & table->mask2; + } + + return bucket; +} + static int compareWord(StgWord key1, StgWord key2) { @@ -111,6 +140,11 @@ compareStr(StgWord key1, StgWord key2) return (strcmp((char *)key1, (char *)key2) == 0); } +static int +compareFingerprint(uint64_t *ptra, uint64_t *ptrb) { + return (ptra[0]-ptrb[0]==0ULL)?((ptra[1] - ptrb[1] == 0ULL)?0:1):1; +} + /* ----------------------------------------------------------------------------- * Allocate a new segment of the dynamically growing hash table. @@ -387,6 +421,13 @@ allocStrHashTable(void) (CompareFunction *)compareStr); } +HashTable * +allocFpHashTable(void) +{ + return allocHashTable_((HashFunction *)hashFingerprint, + (CompareFunction *)compareFingerprint); +} + void exitHashTable(void) { diff --git a/rts/Hash.h b/rts/Hash.h index d22caba555..0d9df2ea98 100644 --- a/rts/Hash.h +++ b/rts/Hash.h @@ -9,6 +9,10 @@ #ifndef HASH_H #define HASH_H +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + #include "BeginPrivate.h" typedef struct hashtable HashTable; /* abstract */ @@ -27,6 +31,10 @@ int keyCountHashTable (HashTable *table); */ HashTable * allocStrHashTable ( void ); +/* Hash table access where the keys are fingerprints {uint64_t[2]} + */ +HashTable * allocFpHashTable ( void ); + #define lookupStrHashTable(table, key) \ (lookupHashTable(table, (StgWord)key)) @@ -42,6 +50,8 @@ typedef int CompareFunction(StgWord key1, StgWord key2); HashTable * allocHashTable_(HashFunction *hash, CompareFunction *compare); int hashWord(HashTable *table, StgWord key); int hashStr(HashTable *table, char *key); +int hashFingerprint(HashTable *table, uint64_t* key); + /* Freeing hash tables */ diff --git a/rts/Linker.c b/rts/Linker.c index 2c74a0dd35..0e2f3bd8e7 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -1414,6 +1414,8 @@ typedef struct _RtsSymbolVal { SymI_HasProto(stopProfTimer) \ SymI_HasProto(atomic_inc) \ SymI_HasProto(atomic_dec) \ + SymI_HasProto(hs_spt_lookup) \ + SymI_HasProto(hs_spt_insert) \ RTS_USER_SIGNALS_SYMBOLS \ RTS_INTCHAR_SYMBOLS diff --git a/rts/SPT.c b/rts/SPT.c new file mode 100644 index 0000000000..63a3b12d4e --- /dev/null +++ b/rts/SPT.c @@ -0,0 +1,20 @@ +/* + * (c)2014 Tweag I/O + */ + +#include "Rts.h" +#include "Hash.h" + +static HashTable * spt = NULL; + +void hs_spt_insert(StgWord64 key[2],void *spe_closure) { + if (spt == NULL) + spt = allocFpHashTable(); + + getStablePtr(spe_closure); + insertHashTable(spt, (StgWord)key, spe_closure); +} + +StgPtr hs_spt_lookup(StgWord64 key[2]) { + return lookupHashTable(spt, (StgWord)key); +} diff --git a/testsuite/tests/codeGen/should_run/CgStaticPointers.hs b/testsuite/tests/codeGen/should_run/CgStaticPointers.hs new file mode 100644 index 0000000000..bc11f4b076 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/CgStaticPointers.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StaticPointers #-} + +-- |A test to load symbols produced by the static form. +-- +-- First we have this program load itself using the GHC API. +-- Then we look for the symbols that the static form should have +-- exposed and use the values found at the symbol addresses. +-- +module Main(main) where + +import Data.Typeable +import GHC.StaticPtr + +main :: IO () +main = do + -- For some reason, removing the type signature below causes @g@ to appear + -- in the desugarer with a coercion like: + -- main@main:Main.g{v r20J} |> (Sub cobox_a36d{v}[lid]) + print $ deRefStaticPtr (static g :: StaticPtr String) + -- For some reason, removing the type signature below causes an assertion + -- failure in the compiler: + -- + -- ASSERT failed! file compiler/typecheck/TcType.lhs line 645 + print $ deRefStaticPtr (static t_field :: StaticPtr (T Char -> Char)) $ T 'b' + +g :: String +g = "found" + +data T a = T { t_field :: a } + deriving Typeable diff --git a/testsuite/tests/codeGen/should_run/CgStaticPointers.stdout b/testsuite/tests/codeGen/should_run/CgStaticPointers.stdout new file mode 100644 index 0000000000..f867935850 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/CgStaticPointers.stdout @@ -0,0 +1,2 @@ +"found" +'b' diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T index 03106d4791..ae6874900e 100644 --- a/testsuite/tests/codeGen/should_run/all.T +++ b/testsuite/tests/codeGen/should_run/all.T @@ -114,6 +114,9 @@ test('T8103', only_ways(['normal']), compile_and_run, ['']) test('T7953', reqlib('random'), compile_and_run, ['']) test('T8256', reqlib('vector'), compile_and_run, ['']) test('T6084',normal, compile_and_run, ['-O2']) +test('CgStaticPointers', + [ when(compiler_lt('ghc', '7.9'), skip) ], + compile_and_run, ['']) test('StaticArraySize', normal, compile_and_run, ['-O2']) test('StaticByteArraySize', normal, compile_and_run, ['-O2']) test('CopySmallArray', normal, compile_and_run, ['']) diff --git a/testsuite/tests/deSugar/should_run/DsStaticPointers.hs b/testsuite/tests/deSugar/should_run/DsStaticPointers.hs new file mode 100644 index 0000000000..7bc0265a41 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/DsStaticPointers.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StaticPointers #-} + +import Data.Typeable +import GHC.StaticPtr + +main = putStr $ unlines $ map show names + where + names = + [ -- unStaticPtr $ static g + staticName $ (static id :: StaticPtr (Int -> Int)) + -- , unStaticPtr $ static (&&) + , staticName $ (static t_field :: StaticPtr (T Int -> Int)) + ] + +g :: Int -> Int +g = id + +data T a = T { t_field :: a } + deriving Typeable diff --git a/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout b/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout new file mode 100644 index 0000000000..c362ee455d --- /dev/null +++ b/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout @@ -0,0 +1,2 @@ +StaticName "main" "Main" "sptEntry:0" +StaticName "main" "Main" "sptEntry:1" diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T index 233f6485d9..9e3d1ea894 100644 --- a/testsuite/tests/deSugar/should_run/all.T +++ b/testsuite/tests/deSugar/should_run/all.T @@ -40,4 +40,6 @@ test('mc08', normal, compile_and_run, ['']) test('T5742', normal, compile_and_run, ['']) test('DsLambdaCase', when(compiler_lt('ghc', '7.5'), skip), compile_and_run, ['']) test('DsMultiWayIf', when(compiler_lt('ghc', '7.5'), skip), compile_and_run, ['']) +test('DsStaticPointers', + when(compiler_lt('ghc', '7.9'), skip), compile_and_run, ['']) test('T8952', normal, compile_and_run, ['']) diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index 40ddb4b66b..51e49053a6 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -34,7 +34,8 @@ expectedGhcOnlyExtensions = ["RelaxedLayout", "AlternativeLayoutRule", "AlternativeLayoutRuleTransitional", "JavaScriptFFI", - "PatternSynonyms"] + "PatternSynonyms", + "StaticValues"] expectedCabalOnlyExtensions :: [String] expectedCabalOnlyExtensions = ["Generics", diff --git a/testsuite/tests/parser/should_compile/RdrNoStaticPointers01.hs b/testsuite/tests/parser/should_compile/RdrNoStaticPointers01.hs new file mode 100644 index 0000000000..b6f088527f --- /dev/null +++ b/testsuite/tests/parser/should_compile/RdrNoStaticPointers01.hs @@ -0,0 +1,7 @@ +-- Tests that when the StaticPointers extension is not enabled +-- the static identifier can be used as a regular Haskell +-- identifier. +module RdrNoStaticPointers01 where + +f :: Int -> Int +f static = static diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T index e9cc99e959..13acedf014 100644 --- a/testsuite/tests/parser/should_compile/all.T +++ b/testsuite/tests/parser/should_compile/all.T @@ -96,4 +96,5 @@ test('T5243', extra_clean(['T5243A.hi', 'T5243A.o']), multimod_compile, ['T5243','']) test('T7118', normal, compile, ['']) test('T7776', normal, compile, ['']) -test('T5682', normal, compile, [''])
\ No newline at end of file +test('RdrNoStaticPointers01', when(compiler_lt('ghc', '7.9'), skip), compile, ['']) +test('T5682', normal, compile, ['']) diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail01.hs b/testsuite/tests/rename/should_fail/RnStaticPointersFail01.hs new file mode 100644 index 0000000000..18631a2dc5 --- /dev/null +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail01.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE StaticPointers #-} + +module RnStaticPointersFail01 where + +f x = static x diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr b/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr new file mode 100644 index 0000000000..b7ff89c886 --- /dev/null +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr @@ -0,0 +1,6 @@ + +RnStaticPointersFail01.hs:5:7: + Only identifiers of top-level bindings can appear in the body of the static form: + static x + but the following identifiers were found instead: + x diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail02.hs b/testsuite/tests/rename/should_fail/RnStaticPointersFail02.hs new file mode 100644 index 0000000000..599cf53076 --- /dev/null +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail02.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE StaticPointers #-} + +module RnStaticPointersFail02 where + +f = static T + +data T = TDataCons diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail02.stderr b/testsuite/tests/rename/should_fail/RnStaticPointersFail02.stderr new file mode 100644 index 0000000000..6524702276 --- /dev/null +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail02.stderr @@ -0,0 +1,8 @@ + +RnStaticPointersFail02.hs:5:5: + Only identifiers of top-level bindings can appear in the body of the static form: + static T + but the following identifiers were found instead: + T + +RnStaticPointersFail02.hs:5:12: Not in scope: data constructor ‘T’ diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs new file mode 100644 index 0000000000..7f777727d3 --- /dev/null +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE StaticPointers #-} + +module RnStaticPointersFail03 where + +f x = static x diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr new file mode 100644 index 0000000000..771cdd2921 --- /dev/null +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr @@ -0,0 +1,6 @@ + +RnStaticPointersFail03.hs:5:7: + Only identifiers of top-level bindings can appear in the body of the static form: + static x + but the following identifiers were found instead: + x diff --git a/testsuite/tests/rename/should_fail/all.T b/testsuite/tests/rename/should_fail/all.T index f2664dc2bf..f6ace100e5 100644 --- a/testsuite/tests/rename/should_fail/all.T +++ b/testsuite/tests/rename/should_fail/all.T @@ -111,6 +111,12 @@ test('T7906', normal, compile_fail, ['']) test('T7937', normal, compile_fail, ['']) test('T7943', normal, compile_fail, ['']) test('T8448', normal, compile_fail, ['']) +test('RnStaticPointersFail01', + when(compiler_lt('ghc', '7.9'), skip), compile_fail, ['']) +test('RnStaticPointersFail02', + when(compiler_lt('ghc', '7.9'), skip), compile_fail, ['']) +test('RnStaticPointersFail03', + when(compiler_lt('ghc', '7.9'), skip), compile_fail, ['']) test('T9006', extra_clean(['T9006a.hi', 'T9006a.o']), multimod_compile_fail, ['T9006', '-v0']) diff --git a/testsuite/tests/rts/GcStaticPointers.hs b/testsuite/tests/rts/GcStaticPointers.hs new file mode 100644 index 0000000000..e68f8b22c3 --- /dev/null +++ b/testsuite/tests/rts/GcStaticPointers.hs @@ -0,0 +1,33 @@ +-- A test to show that -XStaticPointers keeps generated CAFs alive. +{-# LANGUAGE StaticPointers #-} +module Main where + +import GHC.StaticPtr + +import Control.Concurrent +import Data.Maybe (fromJust) +import GHC.Fingerprint +import System.Mem +import System.Mem.Weak +import Unsafe.Coerce (unsafeCoerce) + +nats :: [Integer] +nats = [0 .. ] + +-- Just a StaticPtr to some CAF so that we can deRef it. +nats_fp :: Fingerprint +nats_fp = encodeStaticPtr (static nats :: StaticPtr [Integer]) + +main = do + let z = nats !! 400 + print z + performGC + addFinalizer z (putStrLn "finalizer z") + print z + performGC + threadDelay 1000000 + case decodeStaticPtr nats_fp of + Just (DSP p) -> print (deRefStaticPtr (unsafeCoerce p) !! 800 :: Integer) + -- Uncommenting the next line keeps primes alive and would prevent a segfault + -- if nats were garbage collected. + -- print (nats !! 900) diff --git a/testsuite/tests/rts/GcStaticPointers.stdout b/testsuite/tests/rts/GcStaticPointers.stdout new file mode 100644 index 0000000000..f3c61da20a --- /dev/null +++ b/testsuite/tests/rts/GcStaticPointers.stdout @@ -0,0 +1,3 @@ +400 +400 +800 diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T index 6d0859432b..cbd5d095b5 100644 --- a/testsuite/tests/rts/all.T +++ b/testsuite/tests/rts/all.T @@ -242,6 +242,10 @@ test('rdynamic', [ unless(opsys('linux') or opsys('mingw32'), skip) ], compile_and_run, ['-rdynamic -package ghc']) +test('GcStaticPointers', + [ when(compiler_lt('ghc', '7.9'), skip) ], + compile_and_run, ['']) + # 251 = RTS exit code for "out of memory" test('overflow1', [ exit_code(251) ], compile_and_run, ['']) test('overflow2', [ exit_code(251) ], compile_and_run, ['']) diff --git a/testsuite/tests/th/TH_StaticPointers.hs b/testsuite/tests/th/TH_StaticPointers.hs new file mode 100644 index 0000000000..f8045426cc --- /dev/null +++ b/testsuite/tests/th/TH_StaticPointers.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StaticPointers #-} + +-- |A test to load symbols produced by the static form. +-- +-- First we have this program load itself using the GHC API. +-- Then we look for the symbols that the static form should have +-- exposed and use the values found at the symbol addresses. +-- +-- Note that we lookup for 'g' in symbol tables which does not appear +-- in the export list of Main. +-- +module Main(main) where + +import GHC.StaticPtr + +main = print $ deRefStaticPtr $([| static g :: StaticPtr String |]) + +g = "found" diff --git a/testsuite/tests/th/TH_StaticPointers.stdout b/testsuite/tests/th/TH_StaticPointers.stdout new file mode 100644 index 0000000000..e4c4f00788 --- /dev/null +++ b/testsuite/tests/th/TH_StaticPointers.stdout @@ -0,0 +1 @@ +"found" diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 90efcbd427..0dc352bdcd 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -319,6 +319,9 @@ test('T8577', ['T8577', '-v0 ' + config.ghc_th_way_flags]) test('T8633', normal, compile_and_run, ['']) test('T8625', normal, ghci_script, ['T8625.script']) +test('TH_StaticPointers', + [ when(compiler_lt('ghc', '7.9'), skip) ], + compile_and_run, ['']) test('T8759', normal, compile_fail, ['-v0']) test('T8759a', normal, compile_fail, ['-v0']) test('T7021', diff --git a/testsuite/tests/typecheck/should_compile/TcStaticPointers01.hs b/testsuite/tests/typecheck/should_compile/TcStaticPointers01.hs new file mode 100644 index 0000000000..0f1421ee6b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/TcStaticPointers01.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE StaticPointers #-} + +module StaticPointers01 where + +import GHC.StaticPtr + +f0 :: StaticPtr (Int -> Int) +f0 = static g + +f1 :: StaticPtr (Bool -> Bool -> Bool) +f1 = static (&&) + +g :: Int -> Int +g = id diff --git a/testsuite/tests/typecheck/should_compile/TcStaticPointers02.hs b/testsuite/tests/typecheck/should_compile/TcStaticPointers02.hs new file mode 100644 index 0000000000..3a7461e5ba --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/TcStaticPointers02.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StaticPointers #-} + +module StaticPointers02 where + +import GHC.StaticPtr +import Data.Typeable + +f2 :: Typeable a => StaticPtr (a -> a) +f2 = static id + +f4 :: Typeable a => StaticPtr (T a -> a) +f4 = static t_field + +g :: Int -> Int +g = id + +data T a = T { t_field :: a } + deriving Typeable diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index ef830d14d5..b9d1d4c725 100644 --- a/testsuite/tests/typecheck/should_compile/all.T +++ b/testsuite/tests/typecheck/should_compile/all.T @@ -416,6 +416,8 @@ test('T8474', normal, compile, ['']) test('T8563', normal, compile, ['']) test('T8565', normal, compile, ['']) test('T8644', normal, compile, ['']) +test('TcStaticPointers01', when(compiler_lt('ghc', '7.9'), skip), compile, ['']) +test('TcStaticPointers02', when(compiler_lt('ghc', '7.9'), skip), compile, ['']) test('T8762', normal, compile, ['']) test('MutRec', normal, compile, ['']) test('T8856', normal, compile, ['']) diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.hs b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.hs new file mode 100644 index 0000000000..7221b7369b --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE StaticPointers #-} + +module StaticPointersFail01 where + +import GHC.StaticPtr + +f0 :: StaticPtr Int +f0 = static g + +g :: Int -> Int +g = id diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.stderr b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.stderr new file mode 100644 index 0000000000..e41ec7443d --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail01.stderr @@ -0,0 +1,6 @@ + +TcStaticPointersFail01.hs:8:13: + Couldn't match expected type ‘Int’ with actual type ‘Int -> Int’ + Probable cause: ‘g’ is applied to too few arguments + In the body of a static form: g + In the expression: static g diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.hs b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.hs new file mode 100644 index 0000000000..3b4d0ff661 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE StaticPointers #-} +{-# LANGUAGE ImpredicativeTypes #-} + +module StaticPointersFail02 where + +import GHC.StaticPtr + +f1 :: StaticPtr ((forall a . a -> a) -> b) +f1 = static (undefined :: (forall a . a -> a) -> b) + +f2 :: StaticPtr (Monad m => a -> m a) +f2 = static return diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr new file mode 100644 index 0000000000..5b6f56ad16 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr @@ -0,0 +1,13 @@ + +TcStaticPointersFail02.hs:9:6: + No instance for (Data.Typeable.Internal.Typeable b) + arising from a static form + In the expression: static (undefined :: (forall a. a -> a) -> b) + In an equation for ‘f1’: + f1 = static (undefined :: (forall a. a -> a) -> b) + +TcStaticPointersFail02.hs:12:6: + No instance for (Data.Typeable.Internal.Typeable Monad) + arising from a static form + In the expression: static return + In an equation for ‘f2’: f2 = static return diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.hs b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.hs new file mode 100644 index 0000000000..58e06ee1d8 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE StaticPointers #-} + +module StaticPointersFail03 where + +import GHC.StaticPtr +import Data.Typeable + +f1 :: (Typeable a, Typeable m, Monad m) => a -> m a +f1 = deRefStaticPtr (static return) diff --git a/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr new file mode 100644 index 0000000000..025744a285 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr @@ -0,0 +1,6 @@ + +TcStaticPointersFail03.hs:9:29: + Illegal polymorphic or qualified type: Monad m => a -> m a + In the body of a static form: return + In the first argument of ‘deRefStaticPtr’, namely ‘(static return)’ + In the expression: deRefStaticPtr (static return) diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T index 2b128dc004..d899e9edb1 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -330,6 +330,12 @@ test('ContextStack2', normal, compile_fail, ['-ftype-function-depth=10']) test('T8570', extra_clean(['T85570a.o', 'T8570a.hi','T85570b.o', 'T8570b.hi']), multimod_compile_fail, ['T8570', '-v0']) test('T8603', normal, compile_fail, ['']) +test('TcStaticPointersFail01', + when(compiler_lt('ghc', '7.9'), skip), compile_fail, ['']) +test('TcStaticPointersFail02', + when(compiler_lt('ghc', '7.9'), skip), compile_fail, ['']) +test('TcStaticPointersFail03', + when(compiler_lt('ghc', '7.9'), skip), compile_fail, ['']) test('T8806', normal, compile_fail, ['']) test('T8912', normal, compile_fail, ['']) test('T9033', normal, compile_fail, ['']) |