diff options
25 files changed, 232 insertions, 53 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 diff --git a/docs/users_guide/8.2.1-notes.rst b/docs/users_guide/8.2.1-notes.rst index f81c3995e0..d29914a100 100644 --- a/docs/users_guide/8.2.1-notes.rst +++ b/docs/users_guide/8.2.1-notes.rst @@ -145,6 +145,9 @@ GHCi - Added :ghc-flag:`-flocal-ghci-history` which uses current directory for `.ghci-history`. +- Added support for :ghc-flag:`-XStaticPointers` in interpreted modules. Note, however, + that ``static`` expressions are still not allowed in expressions evaluated in the REPL. + Template Haskell ~~~~~~~~~~~~~~~~ diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst index 0bbf6588cc..c2d8437303 100644 --- a/docs/users_guide/glasgow_exts.rst +++ b/docs/users_guide/glasgow_exts.rst @@ -11984,6 +11984,13 @@ While the following definitions are rejected: :: ref8 (y :: a) = let x = undefined :: a in static x -- x has a non-closed type +.. note:: + + While modules loaded in GHCi with the :ghci-cmd:`:load` command may use + :ghc-flag:`-XStaticPointers` and ``static`` expressions, statements + entered on the REPL may not. This is a limitation of GHCi; see + :ghc-ticket:`12356` for details. + .. _typechecking-static-pointers: Static semantics of static pointers diff --git a/includes/rts/StaticPtrTable.h b/includes/rts/StaticPtrTable.h index 9c03d05ed3..e536f4b496 100644 --- a/includes/rts/StaticPtrTable.h +++ b/includes/rts/StaticPtrTable.h @@ -28,6 +28,14 @@ * */ void hs_spt_insert (StgWord64 key[2],void* spe_closure); +/** Inserts an entry for a StgTablePtr in the Static Pointer Table. + * + * This function is called from the GHCi interpreter to insert + * SPT entries for bytecode objects. + * + * */ +void hs_spt_insert_stableptr(StgWord64 key[2], StgStablePtr *entry); + /** Removes an entry from the Static Pointer Table. * * This function is called from the code generated by diff --git a/libraries/ghci/GHCi/Message.hs b/libraries/ghci/GHCi/Message.hs index fe4e95eb9e..c336349daf 100644 --- a/libraries/ghci/GHCi/Message.hs +++ b/libraries/ghci/GHCi/Message.hs @@ -30,6 +30,7 @@ import GHCi.TH.Binary () import GHCi.BreakArray import GHC.LanguageExtensions +import GHC.Fingerprint import Control.Concurrent import Control.Exception import Data.Binary @@ -85,6 +86,9 @@ data Message a where -- | Release 'HValueRef's FreeHValueRefs :: [HValueRef] -> Message () + -- | Add entries to the Static Pointer Table + AddSptEntry :: Fingerprint -> HValueRef -> Message () + -- | Malloc some data and return a 'RemotePtr' to it MallocData :: ByteString -> Message (RemotePtr ()) MallocStrings :: [ByteString] -> Message [RemotePtr ()] @@ -446,6 +450,7 @@ getMessage = do 30 -> Msg <$> (GetBreakpointVar <$> get <*> get) 31 -> Msg <$> return StartTH 32 -> Msg <$> (RunModFinalizers <$> get <*> get) + 33 -> Msg <$> (AddSptEntry <$> get <*> get) _ -> Msg <$> (RunTH <$> get <*> get <*> get <*> get) putMessage :: Message a -> Put @@ -483,7 +488,8 @@ putMessage m = case m of GetBreakpointVar a b -> putWord8 30 >> put a >> put b StartTH -> putWord8 31 RunModFinalizers a b -> putWord8 32 >> put a >> put b - RunTH st q loc ty -> putWord8 33 >> put st >> put q >> put loc >> put ty + AddSptEntry a b -> putWord8 33 >> put a >> put b + RunTH st q loc ty -> putWord8 34 >> put st >> put q >> put loc >> put ty -- ----------------------------------------------------------------------------- -- Reading/writing messages diff --git a/libraries/ghci/GHCi/Run.hs b/libraries/ghci/GHCi/Run.hs index 858b247f65..eecafa1f75 100644 --- a/libraries/ghci/GHCi/Run.hs +++ b/libraries/ghci/GHCi/Run.hs @@ -20,6 +20,7 @@ import GHCi.ObjLink import GHCi.RemoteTypes import GHCi.TH import GHCi.BreakArray +import GHCi.StaticPtrTable import Control.Concurrent import Control.DeepSeq @@ -56,6 +57,7 @@ run m = case m of FindSystemLibrary str -> findSystemLibrary str CreateBCOs bcos -> createBCOs (concatMap (runGet get) bcos) FreeHValueRefs rs -> mapM_ freeRemoteRef rs + AddSptEntry fpr r -> localRef r >>= sptAddEntry fpr EvalStmt opts r -> evalStmt opts r ResumeStmt opts r -> resumeStmt opts r AbandonStmt r -> abandonStmt r diff --git a/libraries/ghci/GHCi/StaticPtrTable.hs b/libraries/ghci/GHCi/StaticPtrTable.hs new file mode 100644 index 0000000000..d23e810f8a --- /dev/null +++ b/libraries/ghci/GHCi/StaticPtrTable.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module GHCi.StaticPtrTable ( sptAddEntry ) where + +import Data.Word +import Foreign +import GHC.Fingerprint +import GHCi.RemoteTypes + +-- | Used by GHCi to add an SPT entry for a set of interactive bindings. +sptAddEntry :: Fingerprint -> HValue -> IO () +sptAddEntry (Fingerprint a b) (HValue x) = do + -- We own the memory holding the key (fingerprint) which gets inserted into + -- the static pointer table and can't free it until the SPT entry is removed + -- (which is currently never). + fpr_ptr <- newArray [a,b] + sptr <- newStablePtr x + ent_ptr <- malloc + poke ent_ptr (castStablePtrToPtr sptr) + spt_insert_stableptr fpr_ptr ent_ptr + +foreign import ccall "hs_spt_insert_stableptr" + spt_insert_stableptr :: Ptr Word64 -> Ptr (Ptr ()) -> IO () diff --git a/libraries/ghci/ghci.cabal.in b/libraries/ghci/ghci.cabal.in index 87b2c4e2fd..631eed7190 100644 --- a/libraries/ghci/ghci.cabal.in +++ b/libraries/ghci/ghci.cabal.in @@ -62,6 +62,7 @@ library GHCi.RemoteTypes GHCi.FFI GHCi.InfoTable + GHCi.StaticPtrTable GHCi.TH.Binary SizedSeq diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c index be61388501..b5e4f8e8bf 100644 --- a/rts/RtsSymbols.c +++ b/rts/RtsSymbols.c @@ -904,6 +904,7 @@ SymI_HasProto(atomic_dec) \ SymI_HasProto(hs_spt_lookup) \ SymI_HasProto(hs_spt_insert) \ + SymI_HasProto(hs_spt_insert_stableptr) \ SymI_HasProto(hs_spt_remove) \ SymI_HasProto(hs_spt_keys) \ SymI_HasProto(hs_spt_key_count) \ diff --git a/rts/StaticPtrTable.c b/rts/StaticPtrTable.c index 57ade5bafb..b793b9c56c 100644 --- a/rts/StaticPtrTable.c +++ b/rts/StaticPtrTable.c @@ -31,7 +31,7 @@ static int compareFingerprint(StgWord64 ptra[2], StgWord64 ptrb[2]) { return ptra[0] == ptrb[0] && ptra[1] == ptrb[1]; } -void hs_spt_insert(StgWord64 key[2],void *spe_closure) { +void hs_spt_insert_stableptr(StgWord64 key[2], StgStablePtr *entry) { // hs_spt_insert is called from constructor functions, so // the SPT needs to be initialized here. if (spt == NULL) { @@ -43,6 +43,12 @@ void hs_spt_insert(StgWord64 key[2],void *spe_closure) { #endif } + ACQUIRE_LOCK(&spt_lock); + insertHashTable(spt, (StgWord)key, entry); + RELEASE_LOCK(&spt_lock); +} + +void hs_spt_insert(StgWord64 key[2], void *spe_closure) { // Cannot remove this indirection yet because getStablePtr() // might return NULL, in which case hs_spt_lookup() returns NULL // instead of the actual closure pointer. @@ -50,9 +56,7 @@ void hs_spt_insert(StgWord64 key[2],void *spe_closure) { , "hs_spt_insert: entry" ); *entry = getStablePtr(spe_closure); - ACQUIRE_LOCK(&spt_lock); - insertHashTable(spt, (StgWord)key, entry); - RELEASE_LOCK(&spt_lock); + hs_spt_insert_stableptr(key, entry); } static void freeSptEntry(void* entry) { diff --git a/testsuite/tests/ghci/scripts/StaticPtr.hs b/testsuite/tests/ghci/scripts/StaticPtr.hs new file mode 100644 index 0000000000..41bf6231cc --- /dev/null +++ b/testsuite/tests/ghci/scripts/StaticPtr.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE StaticPointers #-} + +module StaticPtr where + +import GHC.StaticPtr + +topLevelStatic :: StaticPtr String +topLevelStatic = static "this is a top-level" + +nestedStatic :: (StaticPtr String, Int) +nestedStatic = (s, 42) + where + s = static "nested static" + {-# NOINLINE s #-} + +s1 :: StaticPtr Int +s1 = static 3 + +s2 :: StaticPtr String +s2 = static "hello world" diff --git a/testsuite/tests/ghci/scripts/StaticPtr.script b/testsuite/tests/ghci/scripts/StaticPtr.script new file mode 100644 index 0000000000..925a21ef39 --- /dev/null +++ b/testsuite/tests/ghci/scripts/StaticPtr.script @@ -0,0 +1,27 @@ +-- This should throw a warning +:set -XStaticPointers + +:set -XScopedTypeVariables +:load StaticPtr.hs +import GHC.StaticPtr +import Prelude + +:{ +let checkKey :: forall a. (Show a, Eq a) => StaticPtr a -> IO () + checkKey x = do + allKeys <- staticPtrKeys + Just x' <- unsafeLookupStaticPtr (staticKey x) :: IO (Maybe (StaticPtr a)) + putStrLn $ + show (deRefStaticPtr x) + ++ " " ++ + (if deRefStaticPtr x == deRefStaticPtr x' + then "good" + else "bad") +:} + +checkKey s1 +checkKey s2 + +-- :m + StaticPtr +--checkKey topLevelStatic +--checkKey (fst nestedStatic) diff --git a/testsuite/tests/ghci/scripts/StaticPtr.stderr b/testsuite/tests/ghci/scripts/StaticPtr.stderr new file mode 100644 index 0000000000..b45f64e64d --- /dev/null +++ b/testsuite/tests/ghci/scripts/StaticPtr.stderr @@ -0,0 +1,3 @@ + +<interactive>: warning: + StaticPointers is not supported in GHCi interactive expressions. diff --git a/testsuite/tests/ghci/scripts/StaticPtr.stdout b/testsuite/tests/ghci/scripts/StaticPtr.stdout new file mode 100644 index 0000000000..992ca432e2 --- /dev/null +++ b/testsuite/tests/ghci/scripts/StaticPtr.stdout @@ -0,0 +1,2 @@ +3 good +"hello world" good diff --git a/testsuite/tests/ghci/scripts/T9878.stderr b/testsuite/tests/ghci/scripts/T9878.stderr index 98a8edfe25..e69de29bb2 100644 --- a/testsuite/tests/ghci/scripts/T9878.stderr +++ b/testsuite/tests/ghci/scripts/T9878.stderr @@ -1,4 +0,0 @@ - -T9878.hs:6:21: - The static form is not supported in interpreted mode. - Please use -fobject-code. diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index fd82c6fc8b..5621addb26 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -242,3 +242,4 @@ test('T12024', normal, ghci_script, ['T12024.script']) test('T12447', expect_broken(12447), ghci_script, ['T12447.script']) test('T10249', normal, ghci_script, ['T10249.script']) test('T12550', normal, ghci_script, ['T12550.script']) +test('StaticPtr', normal, ghci_script, ['StaticPtr.script']) |