summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
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
View Lorry Controller Status