summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/ghci/GHCi.hsc7
-rw-r--r--compiler/main/HscMain.hs11
-rw-r--r--compiler/main/StaticPtrTable.hs46
-rw-r--r--compiler/main/TidyPgm.hs10
-rw-r--r--compiler/rename/RnExpr.hs9
-rw-r--r--includes/rts/StaticPtrTable.h8
-rw-r--r--libraries/ghci/GHCi/Message.hs8
-rw-r--r--libraries/ghci/GHCi/RemoteTypes.hs3
-rw-r--r--libraries/ghci/GHCi/Run.hs2
-rw-r--r--libraries/ghci/GHCi/StaticPtrTable.hs21
-rw-r--r--libraries/ghci/ghci.cabal.in1
-rw-r--r--rts/RtsSymbols.c1
-rw-r--r--rts/StaticPtrTable.c12
-rw-r--r--testsuite/tests/ghci/scripts/StaticPtr.hs20
-rw-r--r--testsuite/tests/ghci/scripts/StaticPtr.script23
-rw-r--r--testsuite/tests/ghci/scripts/StaticPtr.stdout3
-rwxr-xr-xtestsuite/tests/ghci/scripts/all.T1
17 files changed, 151 insertions, 35 deletions
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'])
View Lorry Controller Status