diff options
71 files changed, 1164 insertions, 20 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 8ae893314f..f57cc9e9f6 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -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) diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index ac4bdb2b33..d6ccdaf359 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -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) ; diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index e94936d48c..d252d91894 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -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 {- ************************************************************************ @@ -391,6 +397,78 @@ dsExpr (PArrSeq _ _) {- \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} ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For record construction we do this (assuming T has three arguments) @@ -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 diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 2addbdf554..b236f9cc7b 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -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 diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index 9c987a24b6..7c5619982e 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -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 diff --git a/compiler/deSugar/StaticPtrTable.hs b/compiler/deSugar/StaticPtrTable.hs new file mode 100644 index 0000000000..d4cad0e03e --- /dev/null +++ b/compiler/deSugar/StaticPtrTable.hs @@ -0,0 +1,75 @@ +-- | 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" + ] diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 5c9f17ac01..21aa732398 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -323,6 +323,7 @@ Library TcPluginM PprTyThing StaticFlags + StaticPtrTable SysTools TidyPgm Ctype diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 8dc60d6831..e6120976b2 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 1861811570..384222b6a0 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -348,6 +348,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 @@ -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 diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 64a81fc4d5..d6b75afecc 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -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, diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x index d7ee0b6d77..596f3bd1cf 100644 --- a/compiler/parser/Lexer.x +++ b/compiler/parser/Lexer.x @@ -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 diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index c7143ae345..ed111c0402 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -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 } diff --git a/compiler/prelude/PrelNames.hs b/compiler/prelude/PrelNames.hs index 65eaebb2db..0964dd42e5 100644 --- a/compiler/prelude/PrelNames.hs +++ b/compiler/prelude/PrelNames.hs @@ -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 + {- ************************************************************************ * * diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index a0b5a1537c..475554727e 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -307,6 +307,43 @@ 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) + +{- +************************************************************************ +* * Arrow notation * * ************************************************************************ diff --git a/compiler/typecheck/TcBinds.hs b/compiler/typecheck/TcBinds.hs index 79f630ef79..a0bc89e535 100644 --- a/compiler/typecheck/TcBinds.hs +++ b/compiler/typecheck/TcBinds.hs @@ -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.hs b/compiler/typecheck/TcExpr.hs index 9503d2b950..9a60ffb8ba 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index 8ad8fe2ca0..f14c490844 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -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 diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index 6a52de9cae..8ad52ba069 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -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 False {- No MR for now -} [(fresh_it, res_ty)] lie ; - _ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings + -- wanted constraints from static forms + stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef ; + + -- Ignore the dictionary bindings + _ <- simplifyInteractive (andWC stWC lie_top) ; let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ; zonkTcType all_expr_ty @@ -1833,7 +1842,11 @@ tcRnDeclsi hsc_env local_decls = captureConstraints $ tc_rn_src_decls emptyModDetails local_decls setEnvs (tcg_env, tclcl_env) $ do - new_ev_binds <- simplifyTop lie + -- wanted constraints from static forms + stWC <- tcg_static_wc <$> getGblEnv >>= readTcRef + + new_ev_binds <- simplifyTop (andWC stWC lie) + failIfErrsM let TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs index 2672067cbc..dbc8b41a92 100644 --- a/compiler/typecheck/TcRnMonad.hs +++ b/compiler/typecheck/TcRnMonad.hs @@ -94,6 +94,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this Nothing -> newIORef emptyNameEnv } ; dependent_files_var <- newIORef [] ; + static_wc_var <- newIORef emptyWC ; #ifdef GHCI th_topdecls_var <- newIORef [] ; th_topnames_var <- newIORef emptyNameSet ; @@ -161,7 +162,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this tcg_main = Nothing, tcg_safeInfer = infer_var, tcg_dependent_files = dependent_files_var, - tcg_tc_plugins = [] + tcg_tc_plugins = [], + tcg_static_wc = static_wc_var } ; lcl_env = TcLclEnv { tcl_errs = errs_var, diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 9bc793a831..17d84cbfda 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -91,6 +91,7 @@ module TcRnTypes( #include "HsVersions.h" import HsSyn +import CoreSyn import HscTypes import TcEvidence import Type @@ -381,7 +382,10 @@ data TcGblEnv -- as -XSafe (Safe Haskell) -- | A list of user-defined plugins for the constraint solver. - tcg_tc_plugins :: [TcPluginSolver] + tcg_tc_plugins :: [TcPluginSolver], + + tcg_static_wc :: TcRef WantedConstraints + -- ^ Wanted constraints of static forms. } -- Note [Signature parameters in TcGblEnv and DynFlags] @@ -1904,6 +1908,7 @@ data CtOrigin | HoleOrigin | UnboundOccurrenceOf RdrName | ListOrigin -- An overloaded list + | StaticOrigin -- A static form ctoHerald :: SDoc ctoHerald = ptext (sLit "arising from") @@ -1975,6 +1980,7 @@ 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" {- diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 2c6cb6a6d3..e12703fd71 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -10388,6 +10388,131 @@ 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> +Each reference is given a key which can be used to locate it at runtime with +<ulink url="&libraryBaseLocation;/GHC.StaticPtr.html#v%3AunsafeLookupStaticPtr"><literal>unsafeLookupStaticPtr</literal></ulink> +which uses 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. The value can be obtained from the reference via +<ulink url="&libraryBaseLocation;/GHC.StaticPtr.html#v%3AdeRefStaticPtr"><literal>deRefStaticPtr</literal></ulink> +</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..20be3606ed 100644 --- a/includes/HsFFI.h +++ b/includes/HsFFI.h @@ -161,6 +161,10 @@ 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]); +extern int hs_spt_keys(StgPtr keys[], int szKeys); +extern int hs_spt_key_count (void); + /* -------------------------------------------------------------------------- */ #ifdef __cplusplus diff --git a/includes/Rts.h b/includes/Rts.h index 6bf7650f69..77eeb31f3a 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/StaticPtrTable.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/StaticPtrTable.h b/includes/rts/StaticPtrTable.h new file mode 100644 index 0000000000..8b56510223 --- /dev/null +++ b/includes/rts/StaticPtrTable.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_STATICPTRTABLE_H +#define RTS_STATICPTRTABLE_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/StaticPtrTable.sptInitCode + * + * */ +void hs_spt_insert (StgWord64 key[2],void* spe_closure); + +#endif /* RTS_STATICPTRTABLE_H */ diff --git a/libraries/base/GHC/StaticPtr.hs b/libraries/base/GHC/StaticPtr.hs new file mode 100644 index 0000000000..b92b843989 --- /dev/null +++ b/libraries/base/GHC/StaticPtr.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnboxedTuples #-} +{-# LANGUAGE ExistentialQuantification #-} +----------------------------------------------------------------------------- +-- | +-- 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 offer a key +-- that can be used to locate the values on each process. Each process maintains +-- a global and inmutable table of references which can be looked up with a +-- given key. This table is known as the Static Pointer Table. The reference can +-- then be dereferenced to obtain the value. +-- +----------------------------------------------------------------------------- + +module GHC.StaticPtr + ( StaticPtr + , deRefStaticPtr + , StaticKey + , staticKey + , unsafeLookupStaticPtr + , StaticPtrInfo(..) + , staticPtrInfo + , staticPtrKeys + ) where + +import Data.Typeable (Typeable) +import Foreign.C.Types (CInt(..)) +import Foreign.Marshal (allocaArray, peekArray, withArray) +import Foreign.Ptr (castPtr) +import GHC.Exts (addrToAny#) +import GHC.Ptr (Ptr(..), nullPtr) +import GHC.Fingerprint (Fingerprint(..)) +import System.IO.Unsafe (unsafePerformIO) + + +-- | A reference to a value of type 'a'. +data StaticPtr a = StaticPtr StaticKey StaticPtrInfo a + deriving Typeable + +-- | Dereferences a static pointer. +deRefStaticPtr :: StaticPtr a -> a +deRefStaticPtr (StaticPtr _ _ v) = v + +-- | A key for `StaticPtrs` that can be serialized and used with +-- 'unsafeLookupStaticPtr'. +type StaticKey = Fingerprint + +-- | The 'StaticKey' that can be used to look up the given 'StaticPtr'. +staticKey :: StaticPtr a -> StaticKey +staticKey (StaticPtr k _ _) = k + +-- | Looks up a 'StaticPtr' by its 'StaticKey'. +-- +-- If the 'StaticPtr' is not found returns @Nothing@. +-- +-- This function is unsafe because the program behavior is undefined if the type +-- of the returned 'StaticPtr' does not match the expected one. +-- +unsafeLookupStaticPtr :: StaticKey -> Maybe (StaticPtr a) +unsafeLookupStaticPtr k = unsafePerformIO $ sptLookup k + +-- | Miscelaneous information available for debugging purposes. +data StaticPtrInfo = StaticPtrInfo + { -- | PackageId of the package where the static pointer is defined + spInfoPackageId :: String + -- | Name of the module where the static pointer is defined + , spInfoModuleName :: String + -- | An internal name that is distinct for every static pointer defined in + -- a given module. + , spInfoName :: String + -- | Source location of the definition of the static pointer as a + -- @(Line, Column)@ pair. + , spIntoSrcLoc :: (Int, Int) + } + deriving (Show, Typeable) + +-- | 'StaticPtrInfo' of the given 'StaticPtr'. +staticPtrInfo :: StaticPtr a -> StaticPtrInfo +staticPtrInfo (StaticPtr _ n _) = n + +-- | Like 'unsafeLookupStaticPtr' but evaluates in 'IO'. +sptLookup :: StaticKey -> IO (Maybe (StaticPtr a)) +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) + +-- | A list of all known keys. +staticPtrKeys :: [StaticKey] +staticPtrKeys = unsafePerformIO $ do + keyCount <- hs_spt_key_count + allocaArray (fromIntegral keyCount) $ \p -> do + count <- hs_spt_keys p keyCount + peekArray (fromIntegral count) p >>= + mapM (\pa -> peekArray 2 pa >>= \[w1, w2] -> return $ Fingerprint w1 w2) +{-# NOINLINE staticPtrKeys #-} + +foreign import ccall unsafe hs_spt_key_count :: IO CInt + +foreign import ccall unsafe hs_spt_keys :: Ptr a -> CInt -> IO CInt diff --git a/libraries/base/base.cabal b/libraries/base/base.cabal index e39a08d401..c5c4a159ae 100644 --- a/libraries/base/base.cabal +++ b/libraries/base/base.cabal @@ -255,6 +255,7 @@ Library GHC.Real GHC.RTS.Flags GHC.ST + GHC.StaticPtr GHC.STRef GHC.Show GHC.Stable diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs index 050ac85272..b3ac97b5a4 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 bfba99a487..8aed78d70b 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs @@ -296,6 +296,10 @@ stringE = litE . stringL fieldExp :: Name -> ExpQ -> Q (Name, Exp) fieldExp s e = do { e' <- e; return (s,e') } +-- | @staticE x = [| static x |]@ +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 0e5ced9152..425834b164 100644 --- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs +++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs @@ -1160,6 +1160,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..1881092851 100644 --- a/rts/Hash.c +++ b/rts/Hash.c @@ -206,6 +206,29 @@ lookupHashTable(HashTable *table, StgWord key) return NULL; } +// Puts up to keys_sz keys of the hash table into the given array. Returns the +// actual amount of keys that have been retrieved. +// +// If the table is modified concurrently, the function behavior is undefined. +// +int keysHashTable(HashTable *table, StgWord keys[], int szKeys) { + int segment; + int k = 0; + for(segment=0;segment<HDIRSIZE && table->dir[segment];segment+=1) { + int index; + for(index=0;index<HSEGSIZE;index+=1) { + HashList *hl; + for(hl=table->dir[segment][index];hl;hl=hl->next) { + if (k == szKeys) + return k; + keys[k] = hl->key; + k += 1; + } + } + } + return k; +} + /* ----------------------------------------------------------------------------- * We allocate the hashlist cells in large chunks to cut down on malloc * overhead. Although we keep a free list of hashlist cells, we make diff --git a/rts/Hash.h b/rts/Hash.h index d22caba555..e802644659 100644 --- a/rts/Hash.h +++ b/rts/Hash.h @@ -21,6 +21,13 @@ void * removeHashTable ( HashTable *table, StgWord key, void *data ); int keyCountHashTable (HashTable *table); +// Puts up to keys_sz keys of the hash table into the given array. Returns the +// actual amount of keys that have been retrieved. +// +// If the table is modified concurrently, the function behavior is undefined. +// +int keysHashTable(HashTable *table, StgWord keys[], int szKeys); + /* Hash table access where the keys are C strings (the strings are * assumed to be allocated by the caller, and mustn't be deallocated * until the corresponding hash table entry has been removed). diff --git a/rts/Linker.c b/rts/Linker.c index 5c7a64e91d..4a0e5eadb1 100644 --- a/rts/Linker.c +++ b/rts/Linker.c @@ -1418,6 +1418,10 @@ typedef struct _RtsSymbolVal { SymI_HasProto(stopProfTimer) \ SymI_HasProto(atomic_inc) \ SymI_HasProto(atomic_dec) \ + SymI_HasProto(hs_spt_lookup) \ + SymI_HasProto(hs_spt_insert) \ + SymI_HasProto(hs_spt_keys) \ + SymI_HasProto(hs_spt_key_count) \ RTS_USER_SIGNALS_SYMBOLS \ RTS_INTCHAR_SYMBOLS diff --git a/rts/RtsStartup.c b/rts/RtsStartup.c index b8201e1651..490f2ead38 100644 --- a/rts/RtsStartup.c +++ b/rts/RtsStartup.c @@ -32,6 +32,7 @@ #include "sm/BlockAlloc.h" #include "Trace.h" #include "Stable.h" +#include "StaticPtrTable.h" #include "Hash.h" #include "Profiling.h" #include "Timer.h" @@ -395,6 +396,9 @@ hs_exit_(rtsBool wait_foreign) /* free file locking tables, if necessary */ freeFileLocking(); + /* free the Static Pointer Table */ + exitStaticPtrTable(); + /* free the stable pointer table */ exitStableTables(); diff --git a/rts/StaticPtrTable.c b/rts/StaticPtrTable.c new file mode 100644 index 0000000000..bd450809d0 --- /dev/null +++ b/rts/StaticPtrTable.c @@ -0,0 +1,57 @@ +/* + * (c)2014 Tweag I/O + * + * The Static Pointer Table implementation. + * + * https://ghc.haskell.org/trac/ghc/wiki/StaticPointers + * https://ghc.haskell.org/trac/ghc/wiki/StaticPointers/ImplementationPlan + * + */ + +#include "Rts.h" +#include "StaticPtrTable.h" +#include "Hash.h" + +static HashTable * spt = NULL; + +/// Hash function for the SPT. +static int hashFingerprint(HashTable *table, StgWord64 key[2]) { + // Take half of the key to compute the hash. + return hashWord(table, (StgWord)key[1]); +} + +/// Comparison function for the SPT. +static int compareFingerprint(StgWord64 ptra[2], StgWord64 ptrb[2]) { + return ptra[0] == ptrb[0] && ptra[1] == ptrb[1]; +} + +void hs_spt_insert(StgWord64 key[2],void *spe_closure) { + // hs_spt_insert is called from constructor functions, so + // the SPT needs to be initialized here. + if (spt == NULL) + spt = allocHashTable_( (HashFunction *)hashFingerprint + , (CompareFunction *)compareFingerprint + ); + + getStablePtr(spe_closure); + insertHashTable(spt, (StgWord)key, spe_closure); +} + +StgPtr hs_spt_lookup(StgWord64 key[2]) { + return spt ? lookupHashTable(spt, (StgWord)key) : NULL; +} + +int hs_spt_keys(StgPtr keys[], int szKeys) { + return spt ? keysHashTable(spt, (StgWord*)keys, szKeys) : 0; +} + +int hs_spt_key_count() { + return spt ? keyCountHashTable(spt) : 0; +} + +void exitStaticPtrTable() { + if (spt) { + freeHashTable(spt, NULL); + spt = NULL; + } +} diff --git a/rts/StaticPtrTable.h b/rts/StaticPtrTable.h new file mode 100644 index 0000000000..4ad126cc38 --- /dev/null +++ b/rts/StaticPtrTable.h @@ -0,0 +1,19 @@ +/*----------------------------------------------------------------------------- + * + * (c)2014 Tweag I/O + * + * Prototypes for StaticPtrTable.c + * + * -------------------------------------------------------------------------- */ + +#ifndef STATICPTRTABLE_H +#define STATICPTRTABLE_H + +#include "BeginPrivate.h" + +/** Frees the Static Pointer Table. */ +void exitStaticPtrTable ( void ); + +#include "EndPrivate.h" + +#endif /* STATICPTRTABLE_H */ diff --git a/testsuite/tests/codeGen/should_run/CgStaticPointers.hs b/testsuite/tests/codeGen/should_run/CgStaticPointers.hs new file mode 100644 index 0000000000..5576f431e8 --- /dev/null +++ b/testsuite/tests/codeGen/should_run/CgStaticPointers.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StaticPointers #-} + +-- | A test to use symbols produced by the static form. +module Main(main) where + +import Data.Typeable +import GHC.StaticPtr + +main :: IO () +main = do + print $ lookupKey (static (id . id)) (1 :: Int) + print $ lookupKey (static method :: StaticPtr (Char -> Int)) 'a' + print $ deRefStaticPtr (static g) + print $ deRefStaticPtr p0 'a' + print $ deRefStaticPtr (static t_field) $ T 'b' + +lookupKey :: StaticPtr a -> a +lookupKey p = case unsafeLookupStaticPtr (staticKey p) of + Just p -> deRefStaticPtr p + Nothing -> error $ "couldn't find " ++ show (staticPtrInfo p) + +g :: String +g = "found" + +p0 :: Typeable a => StaticPtr (a -> a) +p0 = static (\x -> x) + +data T a = T { t_field :: a } + deriving Typeable + +class C1 a where + method :: a -> Int + +instance C1 Char where + method = const 0 diff --git a/testsuite/tests/codeGen/should_run/CgStaticPointers.stdout b/testsuite/tests/codeGen/should_run/CgStaticPointers.stdout new file mode 100644 index 0000000000..7b31e7fa2c --- /dev/null +++ b/testsuite/tests/codeGen/should_run/CgStaticPointers.stdout @@ -0,0 +1,5 @@ +1 +0 +"found" +'a' +'b' diff --git a/testsuite/tests/codeGen/should_run/all.T b/testsuite/tests/codeGen/should_run/all.T index f157287c79..89f62781eb 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..7f61bc56f5 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/DsStaticPointers.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StaticPointers #-} + +import Data.Typeable +import GHC.StaticPtr + +main = putStr $ unlines $ map show names + where + names = + [ staticPtrInfo $ static g + , staticPtrInfo $ (static id :: StaticPtr (Int -> Int)) + , staticPtrInfo $ (p0 :: StaticPtr (Int -> Int)) + , staticPtrInfo $ (static method :: StaticPtr (Char -> Int)) + , staticPtrInfo $ (static t_field :: StaticPtr (T Int -> Int)) + ] + +g :: Int -> Int +g = id + +p0 :: Typeable a => StaticPtr (a -> a) +p0 = static (\x -> x) + +data T a = T { t_field :: a } + deriving Typeable + +class C1 a where + method :: a -> Int + +instance C1 Char where + method = const 0 diff --git a/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout b/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout new file mode 100644 index 0000000000..55ec658828 --- /dev/null +++ b/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout @@ -0,0 +1,5 @@ +StaticPtrInfo {spInfoPackageId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:1", spIntoSrcLoc = (10,32)} +StaticPtrInfo {spInfoPackageId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:2", spIntoSrcLoc = (11,33)} +StaticPtrInfo {spInfoPackageId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:0", spIntoSrcLoc = (21,13)} +StaticPtrInfo {spInfoPackageId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:3", spIntoSrcLoc = (13,33)} +StaticPtrInfo {spInfoPackageId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:4", spIntoSrcLoc = (14,33)} diff --git a/testsuite/tests/deSugar/should_run/all.T b/testsuite/tests/deSugar/should_run/all.T index 7e1618b7e1..87ebe8ecaf 100644 --- a/testsuite/tests/deSugar/should_run/all.T +++ b/testsuite/tests/deSugar/should_run/all.T @@ -40,5 +40,7 @@ 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, ['']) test('T9844', normal, compile_and_run, ['']) diff --git a/testsuite/tests/driver/T4437.hs b/testsuite/tests/driver/T4437.hs index 320238d865..250eae1d41 100644 --- a/testsuite/tests/driver/T4437.hs +++ b/testsuite/tests/driver/T4437.hs @@ -37,7 +37,8 @@ expectedGhcOnlyExtensions = ["RelaxedLayout", "JavaScriptFFI", "PatternSynonyms", "PartialTypeSignatures", - "NamedWildcards"] + "NamedWildcards", + "StaticPointers"] 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..1a9baa3fd6 --- /dev/null +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE StaticPointers #-} + +module RnStaticPointersFail03 where + +f x = static (x . id) diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr new file mode 100644 index 0000000000..d5a7270853 --- /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 . id) + 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 d81b743afc..2798fe96ec 100644 --- a/testsuite/tests/rename/should_fail/all.T +++ b/testsuite/tests/rename/should_fail/all.T @@ -112,6 +112,12 @@ test('T7937', normal, compile_fail, ['']) test('T7943', normal, compile_fail, ['']) test('T8448', normal, compile_fail, ['']) test('T8149', normal, compile, ['']) +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..7c2fc2b354 --- /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 :: StaticKey +nats_fp = staticKey (static nats :: StaticPtr [Integer]) + +main = do + let z = nats !! 400 + print z + performGC + addFinalizer z (putStrLn "finalizer z") + print z + performGC + threadDelay 1000000 + let Just p = unsafeLookupStaticPtr nats_fp + 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/ListStaticPointers.hs b/testsuite/tests/rts/ListStaticPointers.hs new file mode 100644 index 0000000000..5ddb63613f --- /dev/null +++ b/testsuite/tests/rts/ListStaticPointers.hs @@ -0,0 +1,26 @@ +-- A test to show that Static Pointers can be listed. +{-# LANGUAGE StaticPointers #-} +module Main where + +import Control.Monad (when) +import Data.List ((\\)) +import GHC.StaticPtr +import System.Exit + +main = when (not $ eqBags staticPtrKeys expected) $ do + print ("expected", expected) + print ("found", staticPtrKeys) + exitFailure + where + + expected = + [ staticKey $ static (\x -> x :: Int) + , staticKey (static return :: StaticPtr (Int -> IO Int)) + , staticKey $ static g + ] + + eqBags :: Eq a => [a] -> [a] -> Bool + eqBags xs ys = null (xs \\ ys) && null (ys \\ xs) + +g :: Int -> Int +g = (+1) diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T index 7162f4c667..b997a574fc 100644 --- a/testsuite/tests/rts/all.T +++ b/testsuite/tests/rts/all.T @@ -243,6 +243,13 @@ 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, ['']) +test('ListStaticPointers', + [ 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..119fb8d421 --- /dev/null +++ b/testsuite/tests/th/TH_StaticPointers.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StaticPointers #-} + +-- | A test of static forms in TH quotations. +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/TH_StaticPointers02.hs b/testsuite/tests/th/TH_StaticPointers02.hs new file mode 100644 index 0000000000..1f619a7569 --- /dev/null +++ b/testsuite/tests/th/TH_StaticPointers02.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE StaticPointers #-} + +-- | A test to try the static form in splices. +-- +-- A static form is defined in a splice and then it is used in the program. +-- +module Main(main) where + +import GHC.Fingerprint +import GHC.StaticPtr + +main = print $ $(case staticKey (static 'a') of + Fingerprint w0 w1 -> + let w0i = fromIntegral w0 :: Integer + w1i = fromIntegral w1 :: Integer + in + [| fmap (\p -> deRefStaticPtr p :: Char) $ unsafeLookupStaticPtr $ + Fingerprint (fromIntegral w0i) (fromIntegral w1i) + |] + ) diff --git a/testsuite/tests/th/TH_StaticPointers02.stderr b/testsuite/tests/th/TH_StaticPointers02.stderr new file mode 100644 index 0000000000..cc6fa82e40 --- /dev/null +++ b/testsuite/tests/th/TH_StaticPointers02.stderr @@ -0,0 +1,10 @@ + +TH_StaticPointers02.hs:13:34: + static forms cannot be used in splices: static 'a' + In the splice: + $(case staticKey (static 'a') of { + Fingerprint w0 w1 + -> let ... + in + [| fmap (\ p -> ...) $ unsafeLookupStaticPtr + $ Fingerprint (fromIntegral w0i) (fromIntegral w1i) |] }) diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T index 8656fcb87e..4c8023e94e 100644 --- a/testsuite/tests/th/all.T +++ b/testsuite/tests/th/all.T @@ -322,6 +322,12 @@ 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('TH_StaticPointers02', + [ when(compiler_lt('ghc', '7.9'), skip) ], + compile_fail, ['']) 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..a48568eb7b --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/TcStaticPointers01.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE StaticPointers #-} + +module StaticPointers01 where + +import GHC.StaticPtr + +f0 :: StaticPtr (Int -> Int) +f0 = static g + +f1 :: StaticPtr (Bool -> Bool -> Bool) +f1 = static (&&) + +f2 :: StaticPtr (Bool -> Bool -> Bool) +f2 = static ((&&) . id) + +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..9b51aeedfe --- /dev/null +++ b/testsuite/tests/typecheck/should_compile/TcStaticPointers02.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StaticPointers #-} + +module StaticPointers02 where + +import GHC.StaticPtr +import Data.Typeable + +f2 :: Typeable a => StaticPtr (a -> a) +f2 = static id + +f3 :: StaticPtr (Char -> Int) +f3 = static method + +f4 :: Typeable a => StaticPtr (T a -> a) +f4 = static t_field + +g :: Int -> Int +g = id + +f5 :: Typeable a => StaticPtr (a -> a) +f5 = static (id . id) + +f6 :: Typeable a => StaticPtr (a -> IO a) +f6 = static return + +f7 :: Typeable a => StaticPtr (a -> IO a) +f7 = static (\x -> getLine >> return x) + +data T a = T { t_field :: a } + deriving Typeable + +class C a where + method :: a -> Int + +instance C Char where + method = const 0 diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T index e1f4c3f5d6..4a28032523 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..f11ec28f18 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail02.stderr @@ -0,0 +1,14 @@ + +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) + (maybe you haven't applied enough arguments to a function?) + 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..03a01df842 --- /dev/null +++ b/testsuite/tests/typecheck/should_fail/TcStaticPointersFail03.stderr @@ -0,0 +1,6 @@ + +TcStaticPointersFail03.hs:9:29: + No instance for (Monad m) arising from a use of ‘return’ + 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 d3c8941c65..1546b3ae8c 100644 --- a/testsuite/tests/typecheck/should_fail/all.T +++ b/testsuite/tests/typecheck/should_fail/all.T @@ -328,6 +328,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, ['']) |