diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 26383afd7fdad999f20ee19e78a590d12b1027ad..5ce4ceeda4ce737c6643b8b812774f8cf1bb4093 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -66,8 +66,10 @@ import Control.Monad import qualified Control.Monad.Fail as MonadFail #endif import MonadUtils +import Data.Function (fix) import Data.Maybe import Pair +import qualified GHC.LanguageExtensions as LangExt {- Note [GHC Formalism] @@ -370,7 +372,8 @@ lintCoreBindings dflags pass local_in_scope binds ; mapM lint_bind binds } where flags = LF { lf_check_global_ids = check_globals - , lf_check_inline_loop_breakers = check_lbs } + , lf_check_inline_loop_breakers = check_lbs + , lf_check_static_ptrs = check_static_ptrs } -- See Note [Checking for global Ids] check_globals = case pass of @@ -384,6 +387,14 @@ lintCoreBindings dflags pass local_in_scope binds CoreDesugarOpt -> False _ -> True + -- See Note [Checking StaticPtrs] + check_static_ptrs = xopt LangExt.StaticPointers dflags && + case pass of + CoreDoFloatOutwards _ -> True + CoreTidy -> True + CorePrep -> True + _ -> False + binders = bindersOfBinds binds (_, dups) = removeDups compare binders @@ -460,7 +471,7 @@ lintSingleBinding :: TopLevelFlag -> RecFlag -> (Id, CoreExpr) -> LintM () lintSingleBinding top_lvl_flag rec_flag (binder,rhs) = addLoc (RhsOf binder) $ -- Check the rhs - do { ty <- lintCoreExpr rhs + do { ty <- lintRhs rhs ; lintBinder binder -- Check match to RHS type ; binder_ty <- applySubstTy (idType binder) ; ensureEqTys binder_ty ty (mkRhsMsg binder (text "RHS") ty) @@ -530,6 +541,32 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs) lintBinder var | isId var = lintIdBndr var $ \_ -> (return ()) | otherwise = return () +-- | Checks the RHS of top-level bindings. It only differs from 'lintCoreExpr' +-- in that it doesn't reject applications of the data constructor @StaticPtr@ +-- when they appear at the top level. +-- +-- See Note [Checking StaticPtrs]. +lintRhs :: CoreExpr -> LintM OutType +-- Allow applications of the data constructor @StaticPtr@ at the top +-- but produce errors otherwise. +lintRhs rhs + | (binders0, rhs') <- collectTyBinders rhs + , (fun@(Var b), args) <- collectArgs rhs' + , Just con <- isDataConId_maybe b + , dataConName con == staticPtrDataConName + , length args == 5 + = flip fix binders0 $ \loopBinders binders -> case binders of + -- imitate @lintCoreExpr (Lam ...)@ + var : vars -> addLoc (LambdaBodyOf var) $ lintBinder var $ \var' -> do + body_ty <- loopBinders vars + return $ mkPiType var' body_ty + -- imitate @lintCoreExpr (App ...)@ + [] -> do + fun_ty <- lintCoreExpr fun + addLoc (AnExpr rhs') $ foldM lintCoreArg fun_ty args +-- Rejects applications of the data constructor @StaticPtr@ if it finds any. +lintRhs rhs = lintCoreExpr rhs + lintIdUnfolding :: Id -> Type -> Unfolding -> LintM () lintIdUnfolding bndr bndr_ty (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) | isStableSource src @@ -644,9 +681,21 @@ lintCoreExpr (Let (Rec pairs) body) (_, dups) = removeDups compare bndrs lintCoreExpr e@(App _ _) - = do { fun_ty <- lintCoreExpr fun - ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args } + = do lf <- getLintFlags + -- Check for a nested occurrence of the StaticPtr constructor. + -- See Note [Checking StaticPtrs]. + case fun of + Var b | lf_check_static_ptrs lf + , Just con <- isDataConId_maybe b + , dataConName con == staticPtrDataConName + -> do + failWithL $ text "Found StaticPtr nested in an expression: " <+> + ppr e + _ -> go where + go = do { fun_ty <- lintCoreExpr fun + ; addLoc (AnExpr e) $ foldM lintCoreArg fun_ty args } + (fun, args) = collectArgs e lintCoreExpr (Lam var expr) @@ -1563,11 +1612,14 @@ data LintEnv data LintFlags = LF { lf_check_global_ids :: Bool -- See Note [Checking for global Ids] , lf_check_inline_loop_breakers :: Bool -- See Note [Checking for INLINE loop breakers] + , lf_check_static_ptrs :: Bool -- See Note [Checking StaticPtrs] } defaultLintFlags :: LintFlags defaultLintFlags = LF { lf_check_global_ids = False - , lf_check_inline_loop_breakers = True } + , lf_check_inline_loop_breakers = True + , lf_check_static_ptrs = False + } newtype LintM a = LintM { unLintM :: @@ -1582,6 +1634,13 @@ type WarnsAndErrs = (Bag MsgDoc, Bag MsgDoc) Before CoreTidy, all locally-bound Ids must be LocalIds, even top-level ones. See Note [Exported LocalIds] and Trac #9857. +Note [Checking StaticPtrs] +~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Every occurrence of the data constructor @StaticPtr@ should be moved to the top +level by the FloatOut pass. The linter is checking that no occurrence is left +nested within an expression. + Note [Type substitution] ~~~~~~~~~~~~~~~~~~~~~~~~ Why do we need a type substitution? Consider diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index 7479dcd15f7783e9fdf332bb1a8dc55cb2ceba23..432f242586f92b507184dfd64ac57a13aaf45de9 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -31,7 +31,7 @@ module CoreSyn ( -- ** Simple 'Expr' access functions and predicates bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, - collectBinders, collectTyAndValBinders, + collectBinders, collectTyBinders, collectTyAndValBinders, collectArgs, collectArgsTicks, flattenBinds, exprToType, exprToCoercion_maybe, diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 139aa0e38dd1f3cbe0ae0182ede845fd46312636..b082a02d6cd28d9c3d31bc9370784cbe4647b4b9 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -589,7 +589,7 @@ addTickHsExpr (ExplicitPArr ty es) = (return ty) (mapM (addTickLHsExpr) es) -addTickHsExpr (HsStatic e) = HsStatic <$> addTickLHsExpr e +addTickHsExpr (HsStatic fvs e) = HsStatic fvs <$> addTickLHsExpr e addTickHsExpr expr@(RecordCon { rcon_flds = rec_binds }) = do { rec_binds' <- addTickHsRecordBinds rec_binds diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index db4c86799f23aadcff5397c444c3a25456538750..34df42792326c2f3f5da29293c4c51280f049b18 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -60,7 +60,6 @@ import Coverage import Util import MonadUtils import OrdList -import StaticPtrTable import UniqFM import ListSetOps import Fingerprint @@ -312,20 +311,13 @@ 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 - `appendStubC` spt_init) } + , ds_fords `appendStubC` hpc_init) } ; case mb_res of { Nothing -> return (msgs, Nothing) ; diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index c037bb19ab0b97535fdd6deac91aad68fb05bf07..c33b867358861c6c1a57d1ab66ba5d07ca6d6a27 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -57,8 +57,7 @@ import Outputable import FastString import PatSyn -import IfaceEnv -import Data.IORef ( atomicModifyIORef', modifyIORef ) +import Data.IORef ( atomicModifyIORef' ) import Control.Monad import GHC.Fingerprint @@ -412,30 +411,27 @@ dsExpr (PArrSeq _ _) -- shouldn't have let it through {- -\noindent -\underline{\bf Static Pointers} - ~~~~~~~~~~~~~~~ -\begin{verbatim} +Static Pointers +~~~~~~~~~~~~~~~ + g = ... static f ... ==> - sptEntry:N = StaticPtr - (fingerprintString "pkgKey:module.sptEntry:N") - (StaticPtrInfo "current pkg key" "current module" "sptEntry:0") - f - g = ... sptEntry:N -\end{verbatim} + g = ... StaticPtr + w0 w1 + (StaticPtrInfo "current pkg key" "current module" "N") + f + ... + +Where we obtain w0 and w1 from + + Fingerprint w0 w1 = fingerprintString "pkgKey:module:N" -} -dsExpr (HsStatic expr@(L loc _)) = do +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 @@ -447,43 +443,51 @@ dsExpr (HsStatic expr@(L loc _)) = do [ Type intTy , Type intTy , mkIntExprInt dflags line, mkIntExprInt dflags col ] + this_mod <- getModule info <- mkConApp staticPtrInfoDataCon <$> (++[srcLoc]) <$> mapM mkStringExprFS - [ unitIdFS $ moduleUnitId $ nameModule n' - , moduleNameFS $ moduleName $ nameModule n' - , occNameFS $ nameOccName n' + [ unitIdFS $ moduleUnitId this_mod + , moduleNameFS $ moduleName this_mod ] - let tvars = tyCoVarsOfTypeWellScoped ty - speTy = ASSERT( all isTyVar tvars ) -- ty is top-level, so this is OK - mkInvForAllTys tvars $ mkTyConApp staticPtrTyCon [ty] - speId = mkExportedVanillaId 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) (mkTyVarTys tvars) + Fingerprint w0 w1 <- mkStaticPtrFingerprint this_mod + putSrcSpanDs loc $ return $ + mkConApp staticPtrDataCon [ Type ty + , mkWord64LitWordRep dflags w0 + , mkWord64LitWordRep dflags w1 + , info + , expr_ds + ] 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 - [ unitIdFS $ moduleUnitId $ nameModule n + mkStaticPtrFingerprint :: Module -> DsM Fingerprint + mkStaticPtrFingerprint this_mod = do + n <- mkGenPerModuleNum this_mod + return $ fingerprintString $ unpackFS $ concatFS + [ unitIdFS $ moduleUnitId this_mod + , fsLit ":" + , moduleNameFS $ moduleName this_mod , fsLit ":" - , moduleNameFS (moduleName $ nameModule n) - , fsLit "." - , occNameFS $ occName n + , mkFastString $ show n ] + mkGenPerModuleNum :: Module -> DsM Int + mkGenPerModuleNum this_mod = do + dflags <- getDynFlags + 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 this_mod + in (extendModuleEnv mod_env this_mod (num + 1), num) + return wrapperNum + {- \noindent \underline{\bf Record construction and update} @@ -1011,33 +1015,3 @@ badMonadBind rhs elt_ty , hang (text "Suppress this warning by saying") 2 (quotes $ text "_ <-" <+> ppr rhs) ] - -{- -************************************************************************ -* * -\subsection{Static pointers} -* * -************************************************************************ --} - --- | Creates an name for an entry in the Static Pointer Table. --- --- The name has the form @sptEntry:@ where @@ is generated from a --- per-module counter. --- -mkSptEntryName :: SrcSpan -> DsM Name -mkSptEntryName loc = do - mod <- getModule - occ <- mkWrapperName "sptEntry" - newGlobalBinder 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 3e224a306707b0270d6db23ac8db9ecaa37b2d45..b00717e53abc1b05dee1e5e61d2297ba1432afc1 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1182,7 +1182,7 @@ repE (ArithSeq _ _ aseq) = repFromThenTo ds1 ds2 ds3 repE (HsSpliceE splice) = repSplice splice -repE (HsStatic e) = repLE e >>= rep2 staticEName . (:[]) . unC +repE (HsStatic _ e) = repLE e >>= rep2 staticEName . (:[]) . unC repE (HsUnboundVar uv) = do occ <- occNameLit (unboundVarOcc uv) sname <- repNameS occ diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index 79ca265e4e1b4fa2b1cb23f10c8fdb00386fa522..de141073a2df2e0ed43e91a1e409c83cb342e1d7 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -22,7 +22,7 @@ module DsMonad ( mkPrintUnqualifiedDs, newUnique, UniqSupply, newUniqueSupply, - getGhcModeDs, dsGetFamInstEnvs, dsGetStaticBindsVar, + getGhcModeDs, dsGetFamInstEnvs, dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon, PArrBuiltin(..), @@ -74,7 +74,6 @@ import ErrUtils import FastString import Maybes import Var (EvVar) -import GHC.Fingerprint import qualified GHC.LanguageExtensions as LangExt import Data.IORef @@ -148,12 +147,10 @@ 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 [] ; pm_iter_var <- newIORef 0 ; let dflags = hsc_dflags hsc_env (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var - static_binds_var pm_iter_var ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $ @@ -229,13 +226,12 @@ initDsTc thing_inside ; tcg_env <- getGblEnv ; msg_var <- getErrsVar ; dflags <- getDynFlags - ; static_binds_var <- liftIO $ newIORef [] ; pm_iter_var <- liftIO $ newIORef 0 ; 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 pm_iter_var + msg_var pm_iter_var ; setEnvs ds_envs thing_inside } @@ -263,9 +259,8 @@ initTcDsForSolver thing_inside thing_inside } mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv - -> IORef Messages -> IORef [(Fingerprint, (Id, CoreExpr))] - -> IORef Int -> (DsGblEnv, DsLclEnv) -mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var pmvar + -> IORef Messages -> IORef Int -> (DsGblEnv, DsLclEnv) +mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) } if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod) real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1) @@ -276,7 +271,6 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var pmvar , 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 { dsl_meta = emptyNameEnv , dsl_loc = real_span @@ -517,10 +511,6 @@ dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a dsExtendMetaEnv menv thing_inside = updLclEnv (\env -> env { dsl_meta = dsl_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 deleted file mode 100644 index d1e8e051d3aca6dbdc3350bab16c44ab024ecf5f..0000000000000000000000000000000000000000 --- a/compiler/deSugar/StaticPtrTable.hs +++ /dev/null @@ -1,97 +0,0 @@ --- | 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_() 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 the constants are fingerprints produced from the static forms. --- --- There is also a finalization function for the time when the module is --- unloaded. --- --- > static void hs_hpc_fini_Main(void) __attribute__((destructor)); --- > static void hs_hpc_fini_Main(void) { --- > --- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; --- > hs_spt_remove(k0); --- > --- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; --- > hs_spt_remove(k1); --- > --- > } --- -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 - ] - , text "static void hs_spt_fini_" <> ppr this_mod - <> text "(void) __attribute__((destructor));" - , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)" - , braces $ vcat $ - [ text "StgWord64 k" <> int i <> text "[2] = " - <> pprFingerprint fp <> semi - $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi - | (i, (fp, _)) <- 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/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 520eb138d60e2753280b44b5cf8c8f94e8d6ddb5..9274725fe683fac9221f2c4ef5f0f070856617cf 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -797,7 +797,7 @@ cvtl e = wrapL (cvt e) <- mapM (cvtFld (mkAmbiguousFieldOcc . noLoc)) flds ; return $ mkRdrRecordUpd e' flds' } - cvt (StaticE e) = fmap HsStatic $ cvtl e + cvt (StaticE e) = fmap (HsStatic placeHolderNames) $ cvtl e cvt (UnboundVarE s) = do { s' <- vName s; return $ HsVar (noLoc s') } {- Note [Dropping constructors] diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index f83958978c31569bdfd3ffbfab4180f80cc6c30e..ffbd23c459563ca7e462eff62a469a6df6133cbb 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -385,7 +385,7 @@ variables. The action happens in TcBinds.mkExport. Note [Bind free vars] ~~~~~~~~~~~~~~~~~~~~~ The bind_fvs field of FunBind and PatBind records the free variables -of the definition. It is used for two purposes +of the definition. It is used for the following purposes a) Dependency analysis prior to type checking (see TcBinds.tc_group) @@ -393,6 +393,10 @@ a) Dependency analysis prior to type checking b) Deciding whether we can do generalisation of the binding (see TcBinds.decideGeneralisationPlan) +c) Deciding whether the binding can be used in static forms + (see TcExpr.checkClosedInStaticForm for the HsStatic case and + TcBinds.isClosedBndrGroup). + Specifically, * bind_fvs includes all free vars that are defined in this module diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index b6c5bdde92344f399a4c8005124f915a94e16c53..a6aaa6cecd000b1bca8d28f73bb8e2f8da63f7e6 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -30,6 +30,7 @@ import CoreSyn import Var import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) ) import Name +import NameSet import RdrName ( GlobalRdrEnv ) import BasicTypes import ConLike @@ -562,7 +563,8 @@ data HsExpr id -- | - 'ApiAnnotation.AnnKeywordId' : 'ApiAnnotation.AnnStatic', -- For details on above see note [Api annotations] in ApiAnnotation - | HsStatic (LHsExpr id) + | HsStatic (PostRn id NameSet) -- Free variables of the body + (LHsExpr id) -- Body --------------------------------------- -- The following are commands, not expressions proper @@ -920,7 +922,7 @@ ppr_expr (HsTcBracketOut e ps) = ppr e $$ text "pending(tc)" <+> ppr ps ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _))) = hsep [text "proc", ppr pat, ptext (sLit "->"), ppr cmd] -ppr_expr (HsStatic e) +ppr_expr (HsStatic _ e) = hsep [text "static", pprParendLExpr e] ppr_expr (HsTick tickish exp) diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs new file mode 100644 index 0000000000000000000000000000000000000000..c13bcd8d3ae0eb73f285f5cb1fcdd5a1631db239 --- /dev/null +++ b/compiler/main/StaticPtrTable.hs @@ -0,0 +1,125 @@ +-- | 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_() 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_r2wb_closure; +-- > hs_spt_insert(k0, &Main_r2wb_closure); +-- > +-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; +-- > extern StgPtr Main_r2wc_closure; +-- > hs_spt_insert(k1, &Main_r2wc_closure); +-- > +-- > } +-- +-- where the constants are fingerprints produced from the static forms. +-- +-- The linker must find the definitions matching the @extern StgPtr @ +-- declarations. For this to work, the identifiers of static pointers need to be +-- exported. This is done in TidyPgm.chooseExternalIds. +-- +-- There is also a finalization function for the time when the module is +-- unloaded. +-- +-- > static void hs_hpc_fini_Main(void) __attribute__((destructor)); +-- > static void hs_hpc_fini_Main(void) { +-- > +-- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; +-- > hs_spt_remove(k0); +-- > +-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; +-- > hs_spt_remove(k1); +-- > +-- > } +-- + +{-# LANGUAGE ViewPatterns #-} +module StaticPtrTable (sptModuleInitCode) where + +import CLabel +import CoreSyn +import DataCon +import Id +import Literal +import Module +import Outputable +import PrelNames + +import Data.Maybe +import GHC.Fingerprint + +-- | @sptModuleInitCode module binds@ is a C stub to insert the static entries +-- found in @binds@ of @module@ into the static pointer table. +-- +-- A bind is considered a static entry if it is an application of the +-- data constructor @StaticPtr@. +-- +sptModuleInitCode :: Module -> CoreProgram -> SDoc +sptModuleInitCode this_mod binds = + sptInitCode $ catMaybes + $ map (\(b, e) -> ((,) b) <$> staticPtrFp e) + $ flattenBinds binds + where + staticPtrFp :: CoreExpr -> Maybe Fingerprint + staticPtrFp (collectTyBinders -> (_, e)) + | (Var v, _ : Lit lit0 : Lit lit1 : _) <- collectArgs e + , Just con <- isDataConId_maybe v + , dataConName con == staticPtrDataConName + , Just w0 <- fromPlatformWord64Rep lit0 + , Just w1 <- fromPlatformWord64Rep lit1 + = Just $ Fingerprint (fromInteger w0) (fromInteger w1) + staticPtrFp _ = Nothing + + fromPlatformWord64Rep (MachWord w) = Just w + fromPlatformWord64Rep (MachWord64 w) = Just w + fromPlatformWord64Rep _ = Nothing + + sptInitCode :: [(Id, Fingerprint)] -> SDoc + sptInitCode [] = Outputable.empty + sptInitCode 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, (n, fp)) <- zip [0..] entries + ] + , text "static void hs_spt_fini_" <> ppr this_mod + <> text "(void) __attribute__((destructor));" + , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void)" + , braces $ vcat $ + [ text "StgWord64 k" <> int i <> text "[2] = " + <> pprFingerprint fp <> semi + $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi + | (i, (_, fp)) <- zip [0..] entries + ] + ] + + 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/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index 4ecd615d8cfcd2b892a6e1a6d96f869f3f525a4f..945e3f86e74919d8aa6a27a3024929d7401470c4 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -4,7 +4,7 @@ \section{Tidying up Core} -} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ViewPatterns #-} module TidyPgm ( mkBootModDetailsTc, tidyProgram, globaliseAndTidyId @@ -24,10 +24,12 @@ import CoreUtils (rhsIsStatic) import CoreStats (coreBindsStats, CoreStats(..)) import CoreLint import Literal +import PrelNames import Rules import PatSyn import ConLike import CoreArity ( exprArity, exprBotStrictness_maybe ) +import StaticPtrTable import VarEnv import VarSet import Var @@ -233,7 +235,8 @@ First we figure out which Ids are "external" Ids. An "external" Id is one that is visible from outside the compilation unit. These are a) the user exported ones - b) ones mentioned in the unfoldings, workers, + b) the ones bound to static forms + c) ones mentioned in the unfoldings, workers, rules of externally-visible ones , or vectorised versions of externally-visible ones @@ -405,7 +408,8 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; return (CgGuts { cg_module = mod, cg_tycons = alg_tycons, cg_binds = all_tidy_binds, - cg_foreign = foreign_stubs, + cg_foreign = foreign_stubs `appendStubC` + sptModuleInitCode mod all_tidy_binds, cg_dep_pkgs = map fst $ dep_pkgs deps, cg_hpc_info = hpc_info, cg_modBreaks = modBreaks }, @@ -635,17 +639,29 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_ -- bindings, which are ordered non-deterministically. init_work_list = zip init_ext_ids init_ext_ids init_ext_ids = sortBy (compare `on` getOccName) $ - filter is_external binders + map fst $ filter is_external flatten_binds -- An Id should be external if either (a) it is exported, -- (b) it appears in the RHS of a local rule for an imported Id, or - -- (c) it is the vectorised version of an imported Id + -- (c) it is the vectorised version of an imported Id, or + -- (d) it is a static pointer (see notes in StaticPtrTable.hs). -- See Note [Which rules to expose] - is_external id = isExportedId id || id `elemVarSet` rule_rhs_vars || id `elemVarSet` vect_var_vs + is_external (id, e) = isExportedId id || id `elemVarSet` rule_rhs_vars + || id `elemVarSet` vect_var_vs + || isStaticPtrApp e + + isStaticPtrApp :: CoreExpr -> Bool + isStaticPtrApp (collectTyBinders -> (_, e)) + | (Var v, _) <- collectArgs e + , Just con <- isDataConId_maybe v + = dataConName con == staticPtrDataConName + isStaticPtrApp _ = False + rule_rhs_vars = mapUnionVarSet ruleRhsFreeVars imp_id_rules vect_var_vs = mkVarSet [var_v | (var, var_v) <- nameEnvElts vect_vars, isGlobalId var] - binders = bindersOfBinds binds + flatten_binds = flattenBinds binds + binders = map fst flatten_binds implicit_binders = bindersOfBinds implicit_binds binder_set = mkVarSet binders diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index 497566154a0e3336c6cf327fdb7aa7b9cfd3b6a8..998ef6c4627bf8846ca7b8b20e60f20d597e028c 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -2244,7 +2244,7 @@ fexp :: { LHsExpr RdrName } : fexp aexp { sLL $1 $> $ HsApp $1 $2 } | fexp TYPEAPP atype {% ams (sLL $1 $> $ HsAppType $1 (mkHsWildCardBndrs $3)) [mj AnnAt $2] } - | 'static' aexp {% ams (sLL $1 $> $ HsStatic $2) + | 'static' aexp {% ams (sLL $1 $> $ HsStatic placeHolderNames $2) [mj AnnStatic $1] } | aexp { $1 } diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 2ee291160141c872f5dac619f0c50da3264b3b29..af58135bcd63e5963aa2ee5d76def521ff7eadbc 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -349,7 +349,7 @@ value bindings. This is done by checking that the name is external or wired-in. See the Notes about the NameSorts in Name.hs. -} -rnExpr e@(HsStatic expr) = do +rnExpr e@(HsStatic _ expr) = do target <- fmap hscTarget getDynFlags case target of -- SPT entries are expected to exist in object code so far, and this is @@ -362,28 +362,14 @@ 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 - (\n -> not (isTopLevelName n || isUnboundName n)) - 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) + _ -> return () + mod <- getModule + let fvExpr' = filterNameSet (nameIsLocalOrFrom mod) fvExpr + return (HsStatic fvExpr' expr', fvExpr) {- ************************************************************************ diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index de22e651323a3a60c16b106bb2cc09c16790be1f..fa4331291b7ddb71e664c44d64b66bbdcc9d3ba2 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -210,10 +210,12 @@ data FloatOutSwitches = FloatOutSwitches { floatOutConstants :: Bool, -- ^ True <=> float constants to top level, -- even if they do not escape a lambda - floatOutOverSatApps :: Bool -- ^ True <=> float out over-saturated applications - -- based on arity information. - -- See Note [Floating over-saturated applications] - -- in SetLevels + floatOutOverSatApps :: Bool, + -- ^ True <=> float out over-saturated applications + -- based on arity information. + -- See Note [Floating over-saturated applications] + -- in SetLevels + floatToTopLevelOnly :: Bool -- ^ Allow floating to the top level only. } instance Outputable FloatOutSwitches where ppr = pprFloatOutSwitches diff --git a/compiler/simplCore/SetLevels.hs b/compiler/simplCore/SetLevels.hs index f2d82ac7fad244409ba8cea7315b848b3bcadb71..86442ab54b643f0f6eef1098045ab4f9eccb919b 100644 --- a/compiler/simplCore/SetLevels.hs +++ b/compiler/simplCore/SetLevels.hs @@ -377,6 +377,7 @@ lvlCase env scrut_fvs scrut' case_bndr ty alts | [(con@(DataAlt {}), bs, body)] <- alts , exprOkForSpeculation scrut' -- See Note [Check the output scrutinee for okForSpec] , not (isTopLvl dest_lvl) -- Can't have top-level cases + , not (floatTopLvlOnly env) -- Can float anywhere = -- See Note [Floating cases] -- Always float the case if possible -- Unlike lets we don't insist that it escapes a value lambda @@ -475,7 +476,9 @@ lvlMFE True env e@(_, AnnCase {}) = lvlExpr env e -- Don't share cases lvlMFE strict_ctxt env ann_expr - | isUnliftedType (exprType expr) + | floatTopLvlOnly env && not (isTopLvl dest_lvl) + -- Only floating to the top level is allowed. + || isUnliftedType (exprType expr) -- Can't let-bind it; see Note [Unlifted MFEs] -- This includes coercions, which we don't want to float anyway -- NB: no need to substitute cos isUnliftedType doesn't change @@ -730,7 +733,9 @@ lvlBind env (AnnNonRec bndr rhs) is_bot = exprIsBottom (deAnnotate rhs) lvlBind env (AnnRec pairs) - | not (profitableFloat env dest_lvl) + | floatTopLvlOnly env && not (isTopLvl dest_lvl) + -- Only floating to the top level is allowed. + || not (profitableFloat env dest_lvl) = do { let bind_lvl = incMinorLvl (le_ctxt_lvl env) (env', bndrs') = substAndLvlBndrs Recursive env bind_lvl bndrs ; rhss' <- mapM (lvlExpr env') rhss @@ -979,6 +984,9 @@ floatConsts le = floatOutConstants (le_switches le) floatOverSat :: LevelEnv -> Bool floatOverSat le = floatOutOverSatApps (le_switches le) +floatTopLvlOnly :: LevelEnv -> Bool +floatTopLvlOnly le = floatToTopLevelOnly (le_switches le) + setCtxtLvl :: LevelEnv -> Level -> LevelEnv setCtxtLvl env lvl = env { le_ctxt_lvl = lvl } diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index 1ff0cee4f3f0b0e3bfdf1ee3bba7baf843ec8153..654fd521bd53608aa876f3b8bad010a4f19c26cc 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -53,6 +53,7 @@ import Maybes import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import Outputable import Control.Monad +import qualified GHC.LanguageExtensions as LangExt #ifdef GHCI import DynamicLoading ( loadPlugins ) @@ -128,6 +129,7 @@ getCoreToDo dflags rules_on = gopt Opt_EnableRewriteRules dflags eta_expand_on = gopt Opt_DoLambdaEtaExpansion dflags ww_on = gopt Opt_WorkerWrapper dflags + static_ptrs = xopt LangExt.StaticPointers dflags maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) @@ -201,8 +203,15 @@ getCoreToDo dflags core_todo = if opt_level == 0 then - [ vectorisation - , CoreDoSimplify max_iter + [ vectorisation, + -- Static forms are moved to the top level with the FloatOut pass. + -- See Note [Grand plan for static forms]. + runWhen static_ptrs $ CoreDoFloatOutwards FloatOutSwitches { + floatOutLambdas = Just 0, + floatOutConstants = True, + floatOutOverSatApps = False, + floatToTopLevelOnly = True }, + CoreDoSimplify max_iter (base_mode { sm_phase = Phase 0 , sm_names = ["Non-opt simplification"] }) ] @@ -230,7 +239,8 @@ getCoreToDo dflags CoreDoFloatOutwards FloatOutSwitches { floatOutLambdas = Just 0, floatOutConstants = True, - floatOutOverSatApps = False }, + floatOutOverSatApps = False, + floatToTopLevelOnly = False }, -- Was: gentleFloatOutSwitches -- -- I have no idea why, but not floating constants to @@ -281,7 +291,8 @@ getCoreToDo dflags CoreDoFloatOutwards FloatOutSwitches { floatOutLambdas = floatLamArgs dflags, floatOutConstants = True, - floatOutOverSatApps = True }, + floatOutOverSatApps = True, + floatToTopLevelOnly = False }, -- nofib/spectral/hartel/wang doubles in speed if you -- do full laziness late in the day. It only happens -- after fusion and other stuff, so the early pass doesn't @@ -977,3 +988,29 @@ transferIdInfo exported_id local_id (ruleInfo local_info) -- Remember to set the function-name field of the -- rules as we transfer them from one function to another + + +-- Note [Grand plan for static forms] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- +-- Static forms go through the compilation phases as follows: +-- +-- The renamer looks for out-of-scope names in the body of the static form. +-- If all names are in scope, the free variables of the body are stored in AST +-- at the location of the static form. +-- +-- The typechecker verifies that all free variables occurring in the static form +-- are closed (see Note [Bindings with closed types] in TcRnTypes). +-- +-- The desugarer replaces the static form with an application of the data +-- constructor 'StaticPtr' (defined in module GHC.StaticPtr of base). +-- +-- The simplifier runs the FloatOut pass which moves the applications of +-- 'StaticPtr' to the top level. Thus the FloatOut pass is always executed, +-- event when optimizations are disabled. +-- +-- The CoreTidy pass produces a C function which inserts all the floated +-- 'StaticPtr' in the static pointer table (See StaticPtrTable.hs). +-- This pass also exports the Ids of floated 'StaticPtr's so they can be linked +-- with the C function. +-- diff --git a/compiler/typecheck/TcExpr.hs b/compiler/typecheck/TcExpr.hs index 79fd25033d75e6fb6abf6c6a20e73ea0190b1640..11ec9ab96e42730825ddd8b7efdf82ba3d4686c9 100644 --- a/compiler/typecheck/TcExpr.hs +++ b/compiler/typecheck/TcExpr.hs @@ -566,7 +566,7 @@ tcExpr (HsProc pat cmd) res_ty ; return $ mkHsWrapCo coi (HsProc pat' cmd') } -- Typechecks the static form and wraps it with a call to 'fromStaticPtr'. -tcExpr (HsStatic expr) res_ty +tcExpr (HsStatic fvs expr) res_ty = do { res_ty <- expTypeToType res_ty ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty ; (expr', lie) <- captureConstraints $ @@ -574,6 +574,9 @@ tcExpr (HsStatic expr) res_ty 2 (ppr expr) ) $ tcPolyExprNC expr expr_ty + -- Check that the free variables of the static form are closed. + ; mapM_ checkClosedInStaticForm fvs + -- 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 @@ -591,7 +594,7 @@ tcExpr (HsStatic expr) res_ty ; let wrap = mkWpTyApps [expr_ty] ; loc <- getSrcSpanM ; return $ mkHsWrapCo co $ HsApp (L loc $ mkHsWrap wrap fromStaticPtr) - (L loc (HsStatic expr')) + (L loc (HsStatic fvs expr')) } {- @@ -2478,3 +2481,20 @@ badOverloadedUpdate = text "Record update is ambiguous, and requires a type sign fieldNotInType :: RecSelParent -> RdrName -> SDoc fieldNotInType p rdr = unknownSubordinateErr (text "field of type" <+> quotes (ppr p)) rdr + +{- +************************************************************************ +* * +\subsection{Static Pointers} +* * +************************************************************************ +-} + +checkClosedInStaticForm :: Name -> TcM () +checkClosedInStaticForm name = do + thing <- tcLookup name + case thing of + ATcId { tct_closed = NotTopLevel } -> + addErrTc $ quotes (ppr name) <+> + text "is used in a static form but it is not closed." + _ -> return () diff --git a/compiler/typecheck/TcHsSyn.hs b/compiler/typecheck/TcHsSyn.hs index c4c4b653a1b02eb05f149702d93ef1558beab8a5..36aeb5087ae6cae79fbcd72ae3370286f03fec64 100644 --- a/compiler/typecheck/TcHsSyn.hs +++ b/compiler/typecheck/TcHsSyn.hs @@ -793,8 +793,8 @@ zonkExpr env (HsProc pat body) ; return (HsProc new_pat new_body) } -- StaticPointers extension -zonkExpr env (HsStatic expr) - = HsStatic <$> zonkLExpr env expr +zonkExpr env (HsStatic fvs expr) + = HsStatic fvs <$> zonkLExpr env expr zonkExpr env (HsWrap co_fn expr) = do (env1, new_co_fn) <- zonkCoFn env co_fn diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index 2172cd8278d63da41b2a42fdca63a3597a9bdcfd..bce70020c8b868791b3177231209edd904a94202 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -170,7 +170,6 @@ import DynFlags import Outputable import ListSetOps import FastString -import GHC.Fingerprint import qualified GHC.LanguageExtensions as LangExt import Control.Monad (ap, liftM, msum) @@ -328,8 +327,6 @@ 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 diff --git a/docs/users_guide/8.0.2-notes.rst b/docs/users_guide/8.0.2-notes.rst new file mode 100644 index 0000000000000000000000000000000000000000..8466b499fc9e28f55f4d14a092f9f9ef70687e94 --- /dev/null +++ b/docs/users_guide/8.0.2-notes.rst @@ -0,0 +1,23 @@ +.. _release-8-0-2: + +Release notes for version 8.0.2 +=============================== + +TODO FIXME + +Highlights +---------- + +TODO FIXME. + +Full details +------------ + +Language +~~~~~~~~ + +- TODO FIXME. + +- :ghc-flag:`-XStaticPointers` now allows the body of the ``static`` form to + refer to closed local bindings. For instance, this is now permitted: + ``f = static x where x = 'a'``. diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index 863c0546114585c72d5ec90754397d3e1347c3c4..3f30dc57fc9b5290e97451fbb321d65e4c343044 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -11620,9 +11620,11 @@ 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 :base-ref:`deRefStaticPtr `. -The body ``e`` of a ``static e`` expression must be a closed expression. -That is, there can be no free variables occurring in ``e``, i.e. lambda- -or let-bound variables bound locally in the context of the expression. +The body ``e`` of a ``static e`` expression must be a closed expression. Where +we say an expression is *closed* when all of its free (type) variables are +closed. And a variable is *closed* if it is let-bound to a *closed* expression +and its type is *closed* as well. And a type is *closed* if it has no free +variables. All of the following are permissible: :: @@ -11634,11 +11636,14 @@ All of the following are permissible: :: ref3 = static (inc 1) ref4 = static ((\x -> x + 1) (1 :: Int)) ref5 y = static (let x = 1 in x) + ref6 y = let x = 1 in static x While the following definitions are rejected: :: - ref6 = let x = 1 in static x - ref7 y = static (let x = 1 in y) + ref7 y = let x = y in static x -- x is not closed + ref8 y = static (let x = 1 in y) -- y is not let-bound + ref8 (y :: a) = let x = undefined :: a + in static x -- x has a non-closed type .. _typechecking-static-pointers: diff --git a/libraries/base/GHC/StaticPtr.hs b/libraries/base/GHC/StaticPtr.hs index 3d5807a32f30b799e36776891616894c5a786254..1f145201eee5a5d0b4b92d8c43342cf991c30f3f 100644 --- a/libraries/base/GHC/StaticPtr.hs +++ b/libraries/base/GHC/StaticPtr.hs @@ -1,6 +1,7 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} -{-# LANGUAGE ExistentialQuantification #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.StaticPtr @@ -47,14 +48,24 @@ import Foreign.Ptr (castPtr) import GHC.Exts (addrToAny#) import GHC.Ptr (Ptr(..), nullPtr) import GHC.Fingerprint (Fingerprint(..)) +import GHC.Prim +import GHC.Word (Word64(..)) --- | A reference to a value of type 'a'. -data StaticPtr a = StaticPtr StaticKey StaticPtrInfo a +#include "MachDeps.h" +-- | A reference to a value of type 'a'. +#if WORD_SIZE_IN_BITS < 64 +data StaticPtr a = StaticPtr Word64# Word64# -- The flattened Fingerprint is + -- convenient in the compiler. + StaticPtrInfo a +#else +data StaticPtr a = StaticPtr Word# Word# + StaticPtrInfo a +#endif -- | Dereferences a static pointer. deRefStaticPtr :: StaticPtr a -> a -deRefStaticPtr (StaticPtr _ _ v) = v +deRefStaticPtr (StaticPtr _ _ _ v) = v -- | A key for `StaticPtrs` that can be serialized and used with -- 'unsafeLookupStaticPtr'. @@ -62,7 +73,7 @@ type StaticKey = Fingerprint -- | The 'StaticKey' that can be used to look up the given 'StaticPtr'. staticKey :: StaticPtr a -> StaticKey -staticKey (StaticPtr k _ _) = k +staticKey (StaticPtr w0 w1 _ _) = Fingerprint (W64# w0) (W64# w1) -- | Looks up a 'StaticPtr' by its 'StaticKey'. -- @@ -94,9 +105,6 @@ data StaticPtrInfo = StaticPtrInfo spInfoUnitId :: 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. , spInfoSrcLoc :: (Int, Int) @@ -105,7 +113,7 @@ data StaticPtrInfo = StaticPtrInfo -- | 'StaticPtrInfo' of the given 'StaticPtr'. staticPtrInfo :: StaticPtr a -> StaticPtrInfo -staticPtrInfo (StaticPtr _ n _) = n +staticPtrInfo (StaticPtr _ _ n _) = n -- | A list of all known keys. staticPtrKeys :: IO [StaticKey] diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md index dd386ed47713d49367c35d2bada856c364412217..4b40db798d1e01787c63e8b9330c94e1564d9b54 100644 --- a/libraries/base/changelog.md +++ b/libraries/base/changelog.md @@ -157,6 +157,9 @@ * `CallStack` now has an `IsList` instance + * The field `spInfoName` of `GHC.StaticPtr.StaticPtrInfo` has been removed. + The value is no longer available when constructing the `StaticPtr`. + ### Generalizations * Generalize `Debug.Trace.{traceM, traceShowM}` from `Monad` to `Applicative` diff --git a/testsuite/tests/codeGen/should_run/CgStaticPointers.hs b/testsuite/tests/codeGen/should_run/CgStaticPointers.hs index f7776b0c068e8d3f8a14f2ca80ba547a628b8448..66363ded6f30947218f10e9e471855e89ad93982 100644 --- a/testsuite/tests/codeGen/should_run/CgStaticPointers.hs +++ b/testsuite/tests/codeGen/should_run/CgStaticPointers.hs @@ -15,15 +15,15 @@ main = do print $ deRefStaticPtr (static g) print $ deRefStaticPtr p0 'a' print $ deRefStaticPtr (static t_field) $ T 'b' + where + g :: String + g = "found" lookupKey :: StaticPtr a -> IO a lookupKey p = unsafeLookupStaticPtr (staticKey p) >>= \case Just p -> return $ deRefStaticPtr p Nothing -> error $ "couldn't find " ++ show (staticPtrInfo p) -g :: String -g = "found" - p0 :: Typeable a => StaticPtr (a -> a) p0 = static (\x -> x) diff --git a/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout b/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout index 0a223db3e27cf5ffee093a2379a69f84028776d5..171ce47c3c1e6c51d57a28ea60b7736abc39516b 100644 --- a/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout +++ b/testsuite/tests/deSugar/should_run/DsStaticPointers.stdout @@ -1,5 +1,5 @@ -StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:1", spInfoSrcLoc = (10,32)} -StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:2", spInfoSrcLoc = (11,33)} -StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:0", spInfoSrcLoc = (21,13)} -StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:3", spInfoSrcLoc = (13,33)} -StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoName = "sptEntry:4", spInfoSrcLoc = (14,33)} +StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoSrcLoc = (10,32)} +StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoSrcLoc = (11,33)} +StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoSrcLoc = (21,13)} +StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoSrcLoc = (13,33)} +StaticPtrInfo {spInfoUnitId = "main", spInfoModuleName = "Main", spInfoSrcLoc = (14,33)} diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr b/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr index b7ff89c886c9e7975ba55fd11630c90465f60b7e..0590eaa5675ad56063bbe90fd2bce71c2c55170f 100644 --- a/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail01.stderr @@ -1,6 +1,5 @@ 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 + ‘x’ is used in a static form but it is not closed. + In the expression: static x + In an equation for ‘f’: f x = static x diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs index 1a9baa3fd67799241954d847c68d1d51a8de8334..141aa89e2a1d2bc887e40834829e56ca687b9dfc 100644 --- a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.hs @@ -3,3 +3,11 @@ module RnStaticPointersFail03 where f x = static (x . id) + +f0 x = static (k . id) + where + k = const (const () x) + +f1 x = static (k . id) + where + k = id diff --git a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr index d5a7270853ea5b24541c4a360ed10041d68ae683..8102662257535230ab0fe251a4d39656c240d49b 100644 --- a/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr +++ b/testsuite/tests/rename/should_fail/RnStaticPointersFail03.stderr @@ -1,6 +1,14 @@ 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 + ‘x’ is used in a static form but it is not closed. + In the expression: static (x . id) + In an equation for ‘f’: f x = static (x . id) + +RnStaticPointersFail03.hs:7:8: + ‘k’ is used in a static form but it is not closed. + In the expression: static (k . id) + In an equation for ‘f0’: + f0 x + = static (k . id) + where + k = const (const () x)