diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/ghci/GHCi.hsc | 7 | ||||
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 5 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 17 | ||||
| -rw-r--r-- | compiler/main/GhcMake.hs | 12 | ||||
| -rw-r--r-- | compiler/main/HscMain.hs | 24 | ||||
| -rw-r--r-- | compiler/main/HscTypes.hs | 30 | ||||
| -rw-r--r-- | compiler/main/InteractiveEval.hs | 2 | ||||
| -rw-r--r-- | compiler/main/StaticPtrTable.hs | 38 | ||||
| -rw-r--r-- | compiler/main/TidyPgm.hs | 18 | ||||
| -rw-r--r-- | compiler/rename/RnExpr.hs | 9 |
10 files changed, 118 insertions, 44 deletions
diff --git a/compiler/ghci/GHCi.hsc b/compiler/ghci/GHCi.hsc index 2c6860f126..849c8db7fa 100644 --- a/compiler/ghci/GHCi.hsc +++ b/compiler/ghci/GHCi.hsc @@ -14,6 +14,7 @@ module GHCi , evalStringToIOString , mallocData , createBCOs + , addSptEntry , mkCostCentres , costCentreStackInfo , newBreakArray @@ -52,6 +53,7 @@ import GHCi.Run import GHCi.RemoteTypes import GHCi.ResolvedBCO import GHCi.BreakArray (BreakArray) +import Fingerprint import HscTypes import UniqFM import Panic @@ -326,6 +328,11 @@ createBCOs hsc_env rbcos = do parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs)) where fx = f x; fxs = parMap f xs +addSptEntry :: HscEnv -> Fingerprint -> ForeignHValue -> IO () +addSptEntry hsc_env fpr ref = + withForeignRef ref $ \val -> + iservCmd hsc_env (AddSptEntry fpr val) + costCentreStackInfo :: HscEnv -> RemotePtr CostCentreStack -> IO [String] costCentreStackInfo hsc_env ccs = iservCmd hsc_env (CostCentreStackInfo ccs) diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index 08af37cdda..463b715807 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -182,7 +182,8 @@ compileOne' m_tc_result mHscMessage let linkable = LM o_time this_mod [DotO object_filename] return hmi0 { hm_linkable = Just linkable } (HscRecomp cgguts summary, HscInterpreted) -> do - (hasStub, comp_bc) <- hscInteractive hsc_env cgguts summary + (hasStub, comp_bc, spt_entries) <- + hscInteractive hsc_env cgguts summary stub_o <- case hasStub of Nothing -> return [] @@ -190,7 +191,7 @@ compileOne' m_tc_result mHscMessage stub_o <- compileStub hsc_env stub_c return [DotO stub_o] - let hs_unlinked = [BCOs comp_bc] + let hs_unlinked = [BCOs comp_bc spt_entries] unlinked_time = ms_hs_date summary -- Why do we use the timestamp of the source file here, -- rather than the current time? This works better in diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 25c1484770..bc406d5c59 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -323,7 +323,7 @@ import Annotations import Module import Panic import Platform -import Bag ( unitBag ) +import Bag ( listToBag, unitBag ) import ErrUtils import MonadUtils import Util @@ -615,7 +615,8 @@ getProgramDynFlags = getSessionDynFlags setInteractiveDynFlags :: GhcMonad m => DynFlags -> m () setInteractiveDynFlags dflags = do dflags' <- checkNewDynFlags dflags - modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags' }} + dflags'' <- checkNewInteractiveDynFlags dflags' + modifySession $ \h -> h{ hsc_IC = (hsc_IC h) { ic_dflags = dflags'' }} -- | Get the 'DynFlags' used to evaluate interactive expressions. getInteractiveDynFlags :: GhcMonad m => m DynFlags @@ -637,6 +638,18 @@ checkNewDynFlags dflags = do liftIO $ handleFlagWarnings dflags warnings return dflags' +checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags +checkNewInteractiveDynFlags dflags0 = do + dflags1 <- + if xopt LangExt.StaticPointers dflags0 + then do liftIO $ printOrThrowWarnings dflags0 $ listToBag + [mkPlainWarnMsg dflags0 interactiveSrcSpan + $ text "StaticPointers is not supported in GHCi interactive expressions."] + return $ xopt_unset dflags0 LangExt.StaticPointers + else return dflags0 + return dflags1 + + -- %************************************************************************ -- %* * -- Setting, getting, and modifying the targets diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 94c02d5017..77b9581a2e 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1286,6 +1286,18 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done' setSession hsc_env4 + -- Add any necessary entries to the static pointer + -- table. See Note [Grand plan for static forms] in + -- StaticPtrTable. + when (hscTarget (hsc_dflags hsc_env4) == HscInterpreted) $ + liftIO $ hscAddSptEntries hsc_env4 + [ spt + | Just linkable <- pure $ hm_linkable mod_info + , unlinked <- linkableUnlinked linkable + , BCOs _ spts <- pure unlinked + , spt <- spts + ] + upsweep' old_hpt1 done' mods (mod_index+1) nmods uids_to_check' done_holes' unitIdsToCheck :: DynFlags -> [UnitId] diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 092f04c1aa..c8aa0ab390 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -79,10 +79,12 @@ module HscMain , hscFileFrontEnd, genericHscFrontend, dumpIfaceStats , ioMsgMaybe , showModuleIndex + , hscAddSptEntries ) where import Data.Data hiding (Fixity, TyCon) import Id +import GHCi ( addSptEntry ) import GHCi.RemoteTypes ( ForeignHValue ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker @@ -1308,7 +1310,7 @@ hscGenHardCode hsc_env cgguts mod_summary output_filename = do hscInteractive :: HscEnv -> CgGuts -> ModSummary - -> IO (Maybe FilePath, CompiledByteCode) + -> IO (Maybe FilePath, CompiledByteCode, [SptEntry]) hscInteractive hsc_env cgguts mod_summary = do let dflags = hsc_dflags hsc_env let CgGuts{ -- This is the last use of the ModGuts in a compilation. @@ -1317,7 +1319,8 @@ hscInteractive hsc_env cgguts mod_summary = do cg_binds = core_binds, cg_tycons = tycons, cg_foreign = foreign_stubs, - cg_modBreaks = mod_breaks } = cgguts + cg_modBreaks = mod_breaks, + cg_spt_entries = spt_entries } = cgguts location = ms_location mod_summary data_tycons = filter isDataTyCon tycons @@ -1331,10 +1334,10 @@ hscInteractive hsc_env cgguts mod_summary = do corePrepPgm hsc_env this_mod location core_binds data_tycons ----------------- Generate byte code ------------------ comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks - ------------------ Create f-x-dynamic C-side stuff --- + ------------------ Create f-x-dynamic C-side stuff ----- (_istub_h_exists, istub_c_exists) <- outputForeignStubs dflags this_mod location foreign_stubs - return (istub_c_exists, comp_bc) + return (istub_c_exists, comp_bc, spt_entries) ------------------------------ @@ -1572,6 +1575,9 @@ hscDeclsWithLocation hsc_env0 str source linenumber = let src_span = srcLocSpan interactiveSrcLoc liftIO $ linkDecls hsc_env src_span cbc + {- Load static pointer table entries -} + liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg) + let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) patsyns = mg_patsyns simpl_mg @@ -1593,6 +1599,16 @@ hscDeclsWithLocation hsc_env0 str source linenumber = fam_insts defaults fix_env return (new_tythings, new_ictxt) +-- | Load the given static-pointer table entries into the interpreter. +-- See Note [Grand plan for static forms] in StaticPtrTable. +hscAddSptEntries :: HscEnv -> [SptEntry] -> IO () +hscAddSptEntries hsc_env entries = do + let add_spt_entry :: SptEntry -> IO () + add_spt_entry (SptEntry i fpr) = do + val <- getHValue hsc_env (idName i) + pprTrace "add_spt_entry" (ppr fpr <+> ppr i) $ + addSptEntry hsc_env fpr val + mapM_ add_spt_entry entries {- Note [Fixity declarations in GHCi] diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index 0fcf58229b..f44a261e76 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -22,7 +22,7 @@ module HscTypes ( -- * Information about modules ModDetails(..), emptyModDetails, ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, - ImportedMods, ImportedModsVal(..), + ImportedMods, ImportedModsVal(..), SptEntry(..), ModSummary(..), ms_imps, ms_installed_mod, ms_mod_name, showModMsg, isBootSummary, msHsFilePath, msHiFilePath, msObjFilePath, @@ -1281,8 +1281,12 @@ data CgGuts cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs cg_dep_pkgs :: ![InstalledUnitId], -- ^ Dependent packages, used to -- generate #includes for C code gen - cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information - cg_modBreaks :: !(Maybe ModBreaks) -- ^ Module breakpoints + cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information + cg_modBreaks :: !(Maybe ModBreaks), -- ^ Module breakpoints + cg_spt_entries :: [SptEntry] + -- ^ Static pointer table entries for static forms defined in + -- the module. + -- See Note [Grand plan for static forms] in StaticPtrTable } ----------------------------------- @@ -1303,6 +1307,13 @@ appendStubC :: ForeignStubs -> SDoc -> ForeignStubs appendStubC NoStubs c_code = ForeignStubs empty c_code appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) +-- | An entry to be inserted into a module's static pointer table. +-- See Note [Grand plan for static forms] in StaticPtrTable. +data SptEntry = SptEntry Id Fingerprint + +instance Outputable SptEntry where + ppr (SptEntry id fpr) = ppr id <> colon <+> ppr fpr + {- ************************************************************************ * * @@ -2951,13 +2962,18 @@ data Unlinked = DotO FilePath -- ^ An object file (.o) | DotA FilePath -- ^ Static archive file (.a) | DotDLL FilePath -- ^ Dynamically linked library file (.so, .dll, .dylib) - | BCOs CompiledByteCode -- ^ A byte-code object, lives only in memory + | BCOs CompiledByteCode + [SptEntry] -- ^ A byte-code object, lives only in memory. Also + -- carries some static pointer table entries which + -- should be loaded along with the BCOs. + -- See Note [Grant plan for static forms] in + -- StaticPtrTable. instance Outputable Unlinked where ppr (DotO path) = text "DotO" <+> text path ppr (DotA path) = text "DotA" <+> text path ppr (DotDLL path) = text "DotDLL" <+> text path - ppr (BCOs bcos) = text "BCOs" <+> ppr bcos + ppr (BCOs bcos spt) = text "BCOs" <+> ppr bcos <+> ppr spt -- | Is this an actual file on disk we can link in somehow? isObject :: Unlinked -> Bool @@ -2979,8 +2995,8 @@ nameOfObject other = pprPanic "nameOfObject" (ppr other) -- | Retrieve the compiled byte-code if possible. Panic if it is a file-based linkable byteCodeOfObject :: Unlinked -> CompiledByteCode -byteCodeOfObject (BCOs bc) = bc -byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) +byteCodeOfObject (BCOs bc _) = bc +byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other) ------------------------------------------- diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs index 93abb07ec0..1fa269825d 100644 --- a/compiler/main/InteractiveEval.hs +++ b/compiler/main/InteractiveEval.hs @@ -116,7 +116,7 @@ getHistorySpan hsc_env History{..} = getModBreaks :: HomeModInfo -> ModBreaks getModBreaks hmi | Just linkable <- hm_linkable hmi, - [BCOs cbc] <- linkableUnlinked linkable + [BCOs cbc _] <- linkableUnlinked linkable = fromMaybe emptyModBreaks (bc_breaks cbc) | otherwise = emptyModBreaks -- probably object code diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs index 7a836e6068..f61714db61 100644 --- a/compiler/main/StaticPtrTable.hs +++ b/compiler/main/StaticPtrTable.hs @@ -45,8 +45,11 @@ -- > } -- -{-# LANGUAGE ViewPatterns #-} -module StaticPtrTable (sptCreateStaticBinds) where +{-# LANGUAGE ViewPatterns, TupleSections #-} +module StaticPtrTable + ( sptCreateStaticBinds + , sptModuleInitCode + ) where {- Note [Grand plan for static forms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -114,10 +117,15 @@ Here is a running example: where a distinct key is generated for each binding. - We produce also a C function which inserts all these bindings in the static - pointer table (see the call to StaticPtrTable.sptCreateStaticBinds in - TidyPgm). As the Ids of floated static pointers are exported, they can be - linked with the C function. +* If we are compiling to object code we insert a C stub (generated by + sptModuleInitCode) into the final object which runs when the module is loaded, + inserting the static forms defined by the module into the RTS's static pointer + table. + +* If we are compiling for the byte-code interpreter, we instead explicitly add + the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter + process' SPT table using the addSptEntry interpreter message. This happens + in upsweep after we have compiled the module (see GhcMake.upsweep'). -} import CLabel @@ -157,15 +165,15 @@ import qualified GHC.LanguageExtensions as LangExt -- It also yields the C stub that inserts these bindings into the static -- pointer table. sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram - -> IO (SDoc, CoreProgram) + -> IO ([SptEntry], CoreProgram) sptCreateStaticBinds hsc_env this_mod binds | not (xopt LangExt.StaticPointers dflags) = - return (Outputable.empty, binds) + return ([], binds) | otherwise = do -- Make sure the required interface files are loaded. _ <- lookupGlobal hsc_env unpackCStringName (fps, binds') <- evalStateT (go [] [] binds) 0 - return (sptModuleInitCode this_mod fps, binds') + return (fps, binds') where go fps bs xs = case xs of [] -> return (reverse fps, reverse bs) @@ -179,7 +187,7 @@ sptCreateStaticBinds hsc_env this_mod binds -- -- The 'Int' state is used to produce a different key for each binding. replaceStaticBind :: CoreBind - -> StateT Int IO ([(Id, Fingerprint)], CoreBind) + -> StateT Int IO ([SptEntry], CoreBind) replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e return (maybeToList mfp, NonRec b' e') replaceStaticBind (Rec rbs) = do @@ -187,13 +195,13 @@ sptCreateStaticBinds hsc_env this_mod binds return (catMaybes mfps, Rec rbs') replaceStatic :: Id -> CoreExpr - -> StateT Int IO (Maybe (Id, Fingerprint), (Id, CoreExpr)) + -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr)) replaceStatic b e@(collectTyBinders -> (tvs, e0)) = case collectMakeStaticArgs e0 of Nothing -> return (Nothing, (b, e)) Just (_, t, info, arg) -> do (fp, e') <- mkStaticBind t info arg - return (Just (b, fp), (b, foldr Lam e' tvs)) + return (Just (SptEntry b fp), (b, foldr Lam e' tvs)) mkStaticBind :: Type -> CoreExpr -> CoreExpr -> StateT Int IO (Fingerprint, CoreExpr) @@ -249,7 +257,7 @@ sptCreateStaticBinds hsc_env this_mod binds -- -- @fps@ is a list associating each binding corresponding to a static entry with -- its fingerprint. -sptModuleInitCode :: Module -> [(Id, Fingerprint)] -> SDoc +sptModuleInitCode :: Module -> [SptEntry] -> SDoc sptModuleInitCode _ [] = Outputable.empty sptModuleInitCode this_mod entries = vcat [ text "static void hs_spt_init_" <> ppr this_mod @@ -267,7 +275,7 @@ sptModuleInitCode this_mod entries = vcat ] ) <> semi - | (i, (n, fp)) <- zip [0..] entries + | (i, SptEntry n fp) <- zip [0..] entries ] , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void) __attribute__((destructor));" @@ -276,7 +284,7 @@ sptModuleInitCode this_mod entries = 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 + | (i, (SptEntry _ fp)) <- zip [0..] entries ] ] where diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index c546e5c257..0fc153ad4c 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -377,8 +377,18 @@ tidyProgram hsc_env (ModGuts { mg_module = mod ; tidy_type_env = tidyTypeEnv omit_prags type_env2 } -- See Note [Grand plan for static forms] in StaticPtrTable. - ; (spt_init_code, tidy_binds') <- + ; (spt_entries, tidy_binds') <- sptCreateStaticBinds hsc_env mod tidy_binds + ; let { spt_init_code = sptModuleInitCode mod spt_entries + ; add_spt_init_code = + case hscTarget dflags of + -- If we are compiling for the interpreter we will insert + -- any necessary SPT entries dynamically + HscInterpreted -> id + -- otherwise add a C stub to do so + _ -> (`appendStubC` spt_init_code) + } + ; let { -- See Note [Injecting implicit bindings] all_tidy_binds = implicit_binds ++ tidy_binds' @@ -415,11 +425,11 @@ 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 `appendStubC` - spt_init_code, + cg_foreign = add_spt_init_code foreign_stubs, cg_dep_pkgs = map fst $ dep_pkgs deps, cg_hpc_info = hpc_info, - cg_modBreaks = modBreaks }, + cg_modBreaks = modBreaks, + cg_spt_entries = spt_entries }, ModDetails { md_types = tidy_type_env, md_rules = tidy_rules, diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs index 17c9042f22..769dff0fb6 100644 --- a/compiler/rename/RnExpr.hs +++ b/compiler/rename/RnExpr.hs @@ -360,15 +360,6 @@ wired-in. See the Notes about the NameSorts in Name.hs. -} 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 - -- not the case in interpreted mode. See bug #9878. - HscInterpreted -> addErr $ sep - [ text "The static form is not supported in interpreted mode." - , text "Please use -fobject-code." - ] - _ -> return () (expr',fvExpr) <- rnLExpr expr stage <- getStage case stage of |