diff options
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, ['']) |