diff options
Diffstat (limited to 'compiler/deSugar')
| -rw-r--r-- | compiler/deSugar/Coverage.hs | 3 | ||||
| -rw-r--r-- | compiler/deSugar/Desugar.hs | 12 | ||||
| -rw-r--r-- | compiler/deSugar/DsExpr.hs | 109 | ||||
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 9 | ||||
| -rw-r--r-- | compiler/deSugar/DsMonad.hs | 25 | ||||
| -rw-r--r-- | compiler/deSugar/StaticPtrTable.hs | 75 |
6 files changed, 223 insertions, 10 deletions
diff --git a/compiler/deSugar/Coverage.hs b/compiler/deSugar/Coverage.hs index 8ae893314f..f57cc9e9f6 100644 --- a/compiler/deSugar/Coverage.hs +++ b/compiler/deSugar/Coverage.hs @@ -533,6 +533,9 @@ addTickHsExpr (ExplicitPArr ty es) = liftM2 ExplicitPArr (return ty) (mapM (addTickLHsExpr) es) + +addTickHsExpr (HsStatic e) = HsStatic <$> addTickLHsExpr e + addTickHsExpr (RecordCon id ty rec_binds) = liftM3 RecordCon (return id) diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index ac4bdb2b33..d6ccdaf359 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -49,6 +49,7 @@ import Coverage import Util import MonadUtils import OrdList +import StaticPtrTable import Data.List import Data.IORef import Control.Monad( when ) @@ -91,7 +92,7 @@ deSugar hsc_env tcg_tcs = tcs, tcg_insts = insts, tcg_fam_insts = fam_insts, - tcg_hpc = other_hpc_info }) + tcg_hpc = other_hpc_info}) = do { let dflags = hsc_dflags hsc_env print_unqual = mkPrintUnqualified dflags rdr_env @@ -121,13 +122,20 @@ deSugar hsc_env ; (ds_fords, foreign_prs) <- dsForeigns fords ; ds_rules <- mapMaybeM dsRule rules ; ds_vects <- mapM dsVect vects + ; stBinds <- dsGetStaticBindsVar >>= + liftIO . readIORef ; let hpc_init | gopt Opt_Hpc dflags = hpcInitCode mod ds_hpc_info | otherwise = empty + -- Stub to insert the static entries of the + -- module into the static pointer table + spt_init = sptInitCode mod stBinds ; return ( ds_ev_binds , foreign_prs `appOL` core_prs `appOL` spec_prs + `appOL` toOL (map snd stBinds) , spec_rules ++ ds_rules, ds_vects - , ds_fords `appendStubC` hpc_init) } + , ds_fords `appendStubC` hpc_init + `appendStubC` spt_init) } ; case mb_res of { Nothing -> return (msgs, Nothing) ; diff --git a/compiler/deSugar/DsExpr.hs b/compiler/deSugar/DsExpr.hs index e94936d48c..d252d91894 100644 --- a/compiler/deSugar/DsExpr.hs +++ b/compiler/deSugar/DsExpr.hs @@ -31,6 +31,7 @@ import DsMeta import HsSyn +import Platform -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types import TcType @@ -52,6 +53,7 @@ import VarEnv import ConLike import DataCon import TysWiredIn +import PrelNames import BasicTypes import Maybes import SrcLoc @@ -60,7 +62,11 @@ import Bag import Outputable import FastString +import IdInfo +import Data.IORef ( atomicModifyIORef, modifyIORef ) + import Control.Monad +import GHC.Fingerprint {- ************************************************************************ @@ -391,6 +397,78 @@ dsExpr (PArrSeq _ _) {- \noindent +\underline{\bf Static Pointers} + ~~~~~~~~~~~~~~~ +\begin{verbatim} + g = ... static f ... +==> + sptEntry:N = StaticPtr + (fingerprintString "pkgId:module.sptEntry:N") + (StaticPtrInfo "current pkg id" "current module" "sptEntry:0") + f + g = ... sptEntry:N +\end{verbatim} +-} + +dsExpr (HsStatic expr@(L loc _)) = do + expr_ds <- dsLExpr expr + let ty = exprType expr_ds + n' <- mkSptEntryName loc + static_binds_var <- dsGetStaticBindsVar + + staticPtrTyCon <- dsLookupTyCon staticPtrTyConName + staticPtrInfoDataCon <- dsLookupDataCon staticPtrInfoDataConName + staticPtrDataCon <- dsLookupDataCon staticPtrDataConName + fingerprintDataCon <- dsLookupDataCon fingerprintDataConName + + dflags <- getDynFlags + let (line, col) = case loc of + RealSrcSpan r -> ( srcLocLine $ realSrcSpanStart r + , srcLocCol $ realSrcSpanStart r + ) + _ -> (0, 0) + srcLoc = mkCoreConApps (tupleCon BoxedTuple 2) + [ Type intTy , Type intTy + , mkIntExprInt dflags line, mkIntExprInt dflags col + ] + info <- mkConApp staticPtrInfoDataCon <$> + (++[srcLoc]) <$> + mapM mkStringExprFS + [ packageKeyFS $ modulePackageKey $ nameModule n' + , moduleNameFS $ moduleName $ nameModule n' + , occNameFS $ nameOccName n' + ] + let tvars = varSetElems $ tyVarsOfType ty + speTy = mkForAllTys tvars $ mkTyConApp staticPtrTyCon [ty] + speId = mkExportedLocalId VanillaId n' speTy + fp@(Fingerprint w0 w1) = fingerprintName $ idName speId + fp_core = mkConApp fingerprintDataCon + [ mkWord64LitWordRep dflags w0 + , mkWord64LitWordRep dflags w1 + ] + sp = mkConApp staticPtrDataCon [Type ty, fp_core, info, expr_ds] + liftIO $ modifyIORef static_binds_var ((fp, (speId, mkLams tvars sp)) :) + putSrcSpanDs loc $ return $ mkTyApps (Var speId) (map mkTyVarTy tvars) + + where + + -- | Choose either 'Word64#' or 'Word#' to represent the arguments of the + -- 'Fingerprint' data constructor. + mkWord64LitWordRep dflags + | platformWordSize (targetPlatform dflags) < 8 = mkWord64LitWord64 + | otherwise = mkWordLit dflags . toInteger + + fingerprintName :: Name -> Fingerprint + fingerprintName n = fingerprintString $ unpackFS $ concatFS + [ packageKeyFS $ modulePackageKey $ nameModule n + , fsLit ":" + , moduleNameFS (moduleName $ nameModule n) + , fsLit "." + , occNameFS $ occName n + ] + +{- +\noindent \underline{\bf Record construction and update} ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For record construction we do this (assuming T has three arguments) @@ -857,3 +935,34 @@ badMonadBind rhs elt_ty flag_doc , hang (ptext (sLit "Suppress this warning by saying")) 2 (quotes $ ptext (sLit "_ <-") <+> ppr rhs) , ptext (sLit "or by using the flag") <+> flag_doc ] + +{- +************************************************************************ +* * +\subsection{Static pointers} +* * +************************************************************************ +-} + +-- | Creates an name for an entry in the Static Pointer Table. +-- +-- The name has the form @sptEntry:<N>@ where @<N>@ is generated from a +-- per-module counter. +-- +mkSptEntryName :: SrcSpan -> DsM Name +mkSptEntryName loc = do + uniq <- newUnique + mod <- getModule + occ <- mkWrapperName "sptEntry" + return $ mkExternalName uniq mod occ loc + where + mkWrapperName what + = do dflags <- getDynFlags + thisMod <- getModule + let -- Note [Generating fresh names for ccall wrapper] + -- in compiler/typecheck/TcEnv.hs + wrapperRef = nextWrapperNum dflags + wrapperNum <- liftIO $ atomicModifyIORef wrapperRef $ \mod_env -> + let num = lookupWithDefaultModuleEnv mod_env 0 thisMod + in (extendModuleEnv mod_env thisMod (num+1), num) + return $ mkVarOcc $ what ++ ":" ++ show wrapperNum diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 2addbdf554..b236f9cc7b 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -1092,6 +1092,7 @@ repE (ArithSeq _ _ aseq) = repFromThenTo ds1 ds2 ds3 repE (HsSpliceE _ splice) = repSplice splice +repE (HsStatic e) = repLE e >>= rep2 staticEName . (:[]) . unC repE e@(PArrSeq {}) = notHandled "Parallel arrays" (ppr e) repE e@(HsCoreAnn {}) = notHandled "Core annotations" (ppr e) repE e@(HsSCC {}) = notHandled "Cost centres" (ppr e) @@ -2125,7 +2126,7 @@ templateHaskellNames = [ tupEName, unboxedTupEName, condEName, multiIfEName, letEName, caseEName, doEName, compEName, fromEName, fromThenEName, fromToEName, fromThenToEName, - listEName, sigEName, recConEName, recUpdEName, + listEName, sigEName, recConEName, recUpdEName, staticEName, -- FieldExp fieldExpName, -- Body @@ -2307,7 +2308,7 @@ clauseName = libFun (fsLit "clause") clauseIdKey varEName, conEName, litEName, appEName, infixEName, infixAppName, sectionLName, sectionRName, lamEName, lamCaseEName, tupEName, unboxedTupEName, condEName, multiIfEName, letEName, caseEName, - doEName, compEName :: Name + doEName, compEName, staticEName :: Name varEName = libFun (fsLit "varE") varEIdKey conEName = libFun (fsLit "conE") conEIdKey litEName = libFun (fsLit "litE") litEIdKey @@ -2338,6 +2339,7 @@ listEName = libFun (fsLit "listE") listEIdKey sigEName = libFun (fsLit "sigE") sigEIdKey recConEName = libFun (fsLit "recConE") recConEIdKey recUpdEName = libFun (fsLit "recUpdE") recUpdEIdKey +staticEName = libFun (fsLit "staticE") staticEIdKey -- type FieldExp = ... fieldExpName :: Name @@ -2680,7 +2682,7 @@ varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey, unboxedTupEIdKey, condEIdKey, multiIfEIdKey, letEIdKey, caseEIdKey, doEIdKey, compEIdKey, fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, - listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique + listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey :: Unique varEIdKey = mkPreludeMiscIdUnique 270 conEIdKey = mkPreludeMiscIdUnique 271 litEIdKey = mkPreludeMiscIdUnique 272 @@ -2707,6 +2709,7 @@ listEIdKey = mkPreludeMiscIdUnique 292 sigEIdKey = mkPreludeMiscIdUnique 293 recConEIdKey = mkPreludeMiscIdUnique 294 recUpdEIdKey = mkPreludeMiscIdUnique 295 +staticEIdKey = mkPreludeMiscIdUnique 296 -- type FieldExp = ... fieldExpIdKey :: Unique diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs index 9c987a24b6..7c5619982e 100644 --- a/compiler/deSugar/DsMonad.hs +++ b/compiler/deSugar/DsMonad.hs @@ -21,7 +21,7 @@ module DsMonad ( mkPrintUnqualifiedDs, newUnique, UniqSupply, newUniqueSupply, - getGhcModeDs, dsGetFamInstEnvs, + getGhcModeDs, dsGetFamInstEnvs, dsGetStaticBindsVar, dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon, PArrBuiltin(..), @@ -67,6 +67,7 @@ import Maybes import Data.IORef import Control.Monad +import GHC.Fingerprint {- ************************************************************************ @@ -166,6 +167,8 @@ data DsGblEnv -- exported entities of 'Data.Array.Parallel' iff -- '-XParallelArrays' was given; otherwise, empty , ds_parr_bi :: PArrBuiltin -- desugarar names for '-XParallelArrays' + , ds_static_binds :: IORef [(Fingerprint, (Id,CoreExpr))] + -- ^ Bindings resulted from floating static forms } instance ContainsModule DsGblEnv where @@ -196,8 +199,11 @@ initDs :: HscEnv initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside = do { msg_var <- newIORef (emptyBag, emptyBag) + ; static_binds_var <- newIORef [] ; let dflags = hsc_dflags hsc_env - (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var + (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env + fam_inst_env msg_var + static_binds_var ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $ loadDAP $ @@ -272,15 +278,19 @@ initDsTc thing_inside ; tcg_env <- getGblEnv ; msg_var <- getErrsVar ; dflags <- getDynFlags + ; static_binds_var <- liftIO $ newIORef [] ; let type_env = tcg_type_env tcg_env rdr_env = tcg_rdr_env tcg_env fam_inst_env = tcg_fam_inst_env tcg_env - ds_envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env msg_var + ds_envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env + msg_var static_binds_var ; setEnvs ds_envs thing_inside } -mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv -> IORef Messages -> (DsGblEnv, DsLclEnv) -mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var +mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv + -> IORef Messages -> IORef [(Fingerprint, (Id, CoreExpr))] + -> (DsGblEnv, DsLclEnv) +mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) } if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod) gbl_env = DsGblEnv { ds_mod = mod @@ -290,6 +300,7 @@ mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var , ds_msgs = msg_var , ds_dph_env = emptyGlobalRdrEnv , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi" + , ds_static_binds = static_binds_var } lcl_env = DsLclEnv { ds_meta = emptyNameEnv , ds_loc = noSrcSpan @@ -487,6 +498,10 @@ dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a dsExtendMetaEnv menv thing_inside = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside +-- | Gets a reference to the SPT entries created so far. +dsGetStaticBindsVar :: DsM (IORef [(Fingerprint, (Id,CoreExpr))]) +dsGetStaticBindsVar = fmap ds_static_binds getGblEnv + discardWarningsDs :: DsM a -> DsM a -- Ignore warnings inside the thing inside; -- used to ignore inaccessable cases etc. inside generated code diff --git a/compiler/deSugar/StaticPtrTable.hs b/compiler/deSugar/StaticPtrTable.hs new file mode 100644 index 0000000000..d4cad0e03e --- /dev/null +++ b/compiler/deSugar/StaticPtrTable.hs @@ -0,0 +1,75 @@ +-- | Code generation for the Static Pointer Table +-- +-- (c) 2014 I/O Tweag +-- +-- Each module that uses 'static' keyword declares an initialization function of +-- the form hs_spt_init_<module>() which is emitted into the _stub.c file and +-- annotated with __attribute__((constructor)) so that it gets executed at +-- startup time. +-- +-- The function's purpose is to call hs_spt_insert to insert the static +-- pointers of this module in the hashtable of the RTS, and it looks something +-- like this: +-- +-- > static void hs_hpc_init_Main(void) __attribute__((constructor)); +-- > static void hs_hpc_init_Main(void) { +-- > +-- > static StgWord64 k0[2] = {16252233372134256ULL,7370534374096082ULL}; +-- > extern StgPtr Main_sptEntryZC0_closure; +-- > hs_spt_insert(k0, &Main_sptEntryZC0_closure); +-- > +-- > static StgWord64 k1[2] = {12545634534567898ULL,5409674567544151ULL}; +-- > extern StgPtr Main_sptEntryZC1_closure; +-- > hs_spt_insert(k1, &Main_sptEntryZC1_closure); +-- > +-- > } +-- +-- where constants are values of a fingerprint of the string +-- "<package_id>:<module_name>.sptEntry:<N>" +-- +module StaticPtrTable (sptInitCode) where + +import CoreSyn +import Module +import Outputable +import Id +import CLabel +import GHC.Fingerprint + + +-- | @sptInitCode module statics@ is a C stub to insert the static entries +-- @statics@ of @module@ into the static pointer table +-- +-- Each entry contains the fingerprint used to locate the entry and the +-- top-level binding for the entry. +-- +sptInitCode :: Module -> [(Fingerprint, (Id,CoreExpr))] -> SDoc +sptInitCode _ [] = Outputable.empty +sptInitCode this_mod entries = vcat + [ text "static void hs_spt_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void hs_spt_init_" <> ppr this_mod <> text "(void)" + , braces $ vcat $ + [ text "static StgWord64 k" <> int i <> text "[2] = " + <> pprFingerprint fp <> semi + $$ text "extern StgPtr " + <> (ppr $ mkClosureLabel (idName n) (idCafInfo n)) <> semi + $$ text "hs_spt_insert" <> parens + (hcat $ punctuate comma + [ char 'k' <> int i + , char '&' <> ppr (mkClosureLabel (idName n) (idCafInfo n)) + ] + ) + <> semi + | (i, (fp, (n, _))) <- zip [0..] entries + ] + ] + + where + + pprFingerprint :: Fingerprint -> SDoc + pprFingerprint (Fingerprint w1 w2) = + braces $ hcat $ punctuate comma + [ integer (fromIntegral w1) <> text "ULL" + , integer (fromIntegral w2) <> text "ULL" + ] |