diff options
Diffstat (limited to 'compiler/deSugar')
| -rw-r--r-- | compiler/deSugar/Coverage.lhs | 3 | ||||
| -rw-r--r-- | compiler/deSugar/Desugar.lhs | 31 | ||||
| -rw-r--r-- | compiler/deSugar/DsExpr.lhs | 78 | ||||
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 9 | ||||
| -rw-r--r-- | compiler/deSugar/DsMonad.lhs | 22 | ||||
| -rw-r--r-- | compiler/deSugar/SPT.lhs | 88 |
6 files changed, 215 insertions, 16 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} + |