From 98ed207472febdc3b2a144267f8af9b29b44934c Mon Sep 17 00:00:00 2001 From: Ben Gamari Date: Wed, 31 Aug 2016 19:39:54 -0400 Subject: Add support for StaticPointers in GHCi Here we add support to GHCi for StaticPointers. This process begins by adding remote GHCi messages for adding entries to the static pointer table. We then collect binders needing SPT entries after linking and send the interpreter a message adding entries with the appropriate fingerprints. --- compiler/ghci/GHCi.hsc | 7 ++++ compiler/main/HscMain.hs | 11 +++++++ compiler/main/StaticPtrTable.hs | 46 ++++++++++++++++----------- compiler/main/TidyPgm.hs | 10 ++++-- compiler/rename/RnExpr.hs | 9 ------ includes/rts/StaticPtrTable.h | 8 +++++ libraries/ghci/GHCi/Message.hs | 8 ++++- libraries/ghci/GHCi/RemoteTypes.hs | 3 +- libraries/ghci/GHCi/Run.hs | 2 ++ libraries/ghci/GHCi/StaticPtrTable.hs | 21 ++++++++++++ libraries/ghci/ghci.cabal.in | 1 + rts/RtsSymbols.c | 1 + rts/StaticPtrTable.c | 12 ++++--- testsuite/tests/ghci/scripts/StaticPtr.hs | 20 ++++++++++++ testsuite/tests/ghci/scripts/StaticPtr.script | 23 ++++++++++++++ testsuite/tests/ghci/scripts/StaticPtr.stdout | 3 ++ testsuite/tests/ghci/scripts/all.T | 1 + 17 files changed, 151 insertions(+), 35 deletions(-) create mode 100644 libraries/ghci/GHCi/StaticPtrTable.hs create mode 100644 testsuite/tests/ghci/scripts/StaticPtr.hs create mode 100644 testsuite/tests/ghci/scripts/StaticPtr.script create mode 100644 testsuite/tests/ghci/scripts/StaticPtr.stdout diff --git a/compiler/ghci/GHCi.hsc b/compiler/ghci/GHCi.hsc index 4503034971..c1bcc67331 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/HscMain.hs b/compiler/main/HscMain.hs index 7d809126bf..fce61649fa 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -82,8 +82,10 @@ module HscMain ) where import Id +import GHCi ( addSptEntry ) import GHCi.RemoteTypes ( ForeignHValue ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) +import StaticPtrTable ( collectStaticThings ) import Linker import CoreTidy ( tidyExpr ) import Type ( Type ) @@ -1566,6 +1568,15 @@ hscDeclsWithLocation hsc_env0 str source linenumber = let src_span = srcLocSpan interactiveSrcLoc liftIO $ linkDecls hsc_env src_span cbc +#ifdef GHCI + {- Extract static pointer table entries -} + let add_spt_entry :: (Id, Fingerprint) -> Hsc () + add_spt_entry (i, fpr) = do + val <- liftIO $ getHValue hsc_env (idName i) + liftIO $ addSptEntry hsc_env fpr val + mapM_ add_spt_entry (collectStaticThings prepd_binds) +#endif + let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg) patsyns = mg_patsyns simpl_mg diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs index 9ec970f453..a64479724e 100644 --- a/compiler/main/StaticPtrTable.hs +++ b/compiler/main/StaticPtrTable.hs @@ -46,7 +46,12 @@ -- {-# LANGUAGE ViewPatterns #-} -module StaticPtrTable (sptModuleInitCode) where +{-# LANGUAGE TupleSections #-} + +module StaticPtrTable + ( sptModuleInitCode + , collectStaticThings + ) where -- See SimplCore Note [Grand plan for static forms] @@ -70,24 +75,8 @@ import GHC.Fingerprint -- sptModuleInitCode :: Module -> CoreProgram -> SDoc sptModuleInitCode this_mod binds = - sptInitCode $ catMaybes - $ map (\(b, e) -> ((,) b) <$> staticPtrFp e) - $ flattenBinds binds + sptInitCode $ collectStaticThings 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 @@ -125,3 +114,24 @@ sptModuleInitCode this_mod binds = [ integer (fromIntegral w1) <> text "ULL" , integer (fromIntegral w2) <> text "ULL" ] + +-- | Collect all of the bindings that should have static pointer table entries, +-- along with their fingerprints. +collectStaticThings :: CoreProgram -> [(Id, Fingerprint)] +collectStaticThings binds = + mapMaybe (\(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 diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index 52137a4cd7..55e790b887 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -379,6 +379,13 @@ tidyProgram hsc_env (ModGuts { mg_module = mod -- See SimplCore Note [Grand plan for static forms] ; spt_init_code = sptModuleInitCode mod all_tidy_binds + ; 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) -- Get the TyCons to generate code for. Careful! We must use -- the untidied TypeEnv here, because we need @@ -413,8 +420,7 @@ 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 }, 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/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/RemoteTypes.hs b/libraries/ghci/GHCi/RemoteTypes.hs index 3b4dee75c5..e0126bddb9 100644 --- a/libraries/ghci/GHCi/RemoteTypes.hs +++ b/libraries/ghci/GHCi/RemoteTypes.hs @@ -18,13 +18,14 @@ module GHCi.RemoteTypes ) where import Control.DeepSeq -import Data.Word import Foreign hiding (newForeignPtr) import Foreign.Concurrent import Data.Binary import Unsafe.Coerce import GHC.Exts import GHC.ForeignPtr +import Foreign.Ptr (Ptr) +import Data.Word (Word64) -- ----------------------------------------------------------------------------- -- RemotePtr 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..e0dab66102 --- /dev/null +++ b/libraries/ghci/GHCi/StaticPtrTable.hs @@ -0,0 +1,21 @@ +{-# 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 + sptr <- newStablePtr x + withArray [a,b] $ \fpr_ptr -> do + 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 28479fb508..bccf8fb7a1 100644 --- a/rts/RtsSymbols.c +++ b/rts/RtsSymbols.c @@ -901,6 +901,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..95b72b305f --- /dev/null +++ b/testsuite/tests/ghci/scripts/StaticPtr.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE StaticPointers #-} + +module StaticPtr2 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..6070c15943 --- /dev/null +++ b/testsuite/tests/ghci/scripts/StaticPtr.script @@ -0,0 +1,23 @@ +:set -XStaticPointers +:load StaticPtr.hs +import GHC.StaticPtr +import Prelude + +:{ +let checkKey :: Show a => StaticPtr a -> IO () + checkKey x = do + allKeys <- staticPtrKeys + putStrLn $ + show (deRefStaticPtr x) + ++ " " ++ + (if staticKey x `elem` allKeys + then "good" + else "bad") +:} + +checkKey s1 +checkKey s2 + +-- :m + StaticPtr +--checkKey topLevelStatic +--checkKey (fst nestedStatic) diff --git a/testsuite/tests/ghci/scripts/StaticPtr.stdout b/testsuite/tests/ghci/scripts/StaticPtr.stdout new file mode 100644 index 0000000000..427dc0f15a --- /dev/null +++ b/testsuite/tests/ghci/scripts/StaticPtr.stdout @@ -0,0 +1,3 @@ +3 good +"hello world" good +42 good diff --git a/testsuite/tests/ghci/scripts/all.T b/testsuite/tests/ghci/scripts/all.T index d448a12d9f..c0e6e153f6 100755 --- a/testsuite/tests/ghci/scripts/all.T +++ b/testsuite/tests/ghci/scripts/all.T @@ -270,3 +270,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', [extra_files(['StaticPtr.hs'])], ghci_script, ['StaticPtr.script']) -- cgit v1.2.1