summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
authorBen Gamari <ben@smart-cactus.org>2016-08-31 19:39:54 -0400
committerBen Gamari <ben@smart-cactus.org>2017-01-08 22:19:45 -0500
commit98ed207472febdc3b2a144267f8af9b29b44934c (patch)
treef6f2dea660fb6f391d3a7e89edddb8e0daf55227 /compiler
parent326931db9cdc26f2d47657c1f084b9903fd46246 (diff)
downloadhaskell-wip/ghci-staticptrs.tar.gz
Add support for StaticPointers in GHCiwip/ghci-staticptrs
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.
Diffstat (limited to 'compiler')
-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
5 files changed, 54 insertions, 29 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