diff options
Diffstat (limited to 'compiler/main')
| -rw-r--r-- | compiler/main/HscMain.hs | 11 | ||||
| -rw-r--r-- | compiler/main/StaticPtrTable.hs | 46 | ||||
| -rw-r--r-- | compiler/main/TidyPgm.hs | 10 |
3 files changed, 47 insertions, 20 deletions
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 }, |