diff options
Diffstat (limited to 'compiler/main/StaticPtrTable.hs')
| -rw-r--r-- | compiler/main/StaticPtrTable.hs | 38 |
1 files changed, 23 insertions, 15 deletions
diff --git a/compiler/main/StaticPtrTable.hs b/compiler/main/StaticPtrTable.hs index 7a836e6068..f61714db61 100644 --- a/compiler/main/StaticPtrTable.hs +++ b/compiler/main/StaticPtrTable.hs @@ -45,8 +45,11 @@ -- > } -- -{-# LANGUAGE ViewPatterns #-} -module StaticPtrTable (sptCreateStaticBinds) where +{-# LANGUAGE ViewPatterns, TupleSections #-} +module StaticPtrTable + ( sptCreateStaticBinds + , sptModuleInitCode + ) where {- Note [Grand plan for static forms] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -114,10 +117,15 @@ Here is a running example: where a distinct key is generated for each binding. - We produce also a C function which inserts all these bindings in the static - pointer table (see the call to StaticPtrTable.sptCreateStaticBinds in - TidyPgm). As the Ids of floated static pointers are exported, they can be - linked with the C function. +* If we are compiling to object code we insert a C stub (generated by + sptModuleInitCode) into the final object which runs when the module is loaded, + inserting the static forms defined by the module into the RTS's static pointer + table. + +* If we are compiling for the byte-code interpreter, we instead explicitly add + the SPT entries (recorded in CgGuts' cg_spt_entries field) to the interpreter + process' SPT table using the addSptEntry interpreter message. This happens + in upsweep after we have compiled the module (see GhcMake.upsweep'). -} import CLabel @@ -157,15 +165,15 @@ import qualified GHC.LanguageExtensions as LangExt -- It also yields the C stub that inserts these bindings into the static -- pointer table. sptCreateStaticBinds :: HscEnv -> Module -> CoreProgram - -> IO (SDoc, CoreProgram) + -> IO ([SptEntry], CoreProgram) sptCreateStaticBinds hsc_env this_mod binds | not (xopt LangExt.StaticPointers dflags) = - return (Outputable.empty, binds) + return ([], binds) | otherwise = do -- Make sure the required interface files are loaded. _ <- lookupGlobal hsc_env unpackCStringName (fps, binds') <- evalStateT (go [] [] binds) 0 - return (sptModuleInitCode this_mod fps, binds') + return (fps, binds') where go fps bs xs = case xs of [] -> return (reverse fps, reverse bs) @@ -179,7 +187,7 @@ sptCreateStaticBinds hsc_env this_mod binds -- -- The 'Int' state is used to produce a different key for each binding. replaceStaticBind :: CoreBind - -> StateT Int IO ([(Id, Fingerprint)], CoreBind) + -> StateT Int IO ([SptEntry], CoreBind) replaceStaticBind (NonRec b e) = do (mfp, (b', e')) <- replaceStatic b e return (maybeToList mfp, NonRec b' e') replaceStaticBind (Rec rbs) = do @@ -187,13 +195,13 @@ sptCreateStaticBinds hsc_env this_mod binds return (catMaybes mfps, Rec rbs') replaceStatic :: Id -> CoreExpr - -> StateT Int IO (Maybe (Id, Fingerprint), (Id, CoreExpr)) + -> StateT Int IO (Maybe SptEntry, (Id, CoreExpr)) replaceStatic b e@(collectTyBinders -> (tvs, e0)) = case collectMakeStaticArgs e0 of Nothing -> return (Nothing, (b, e)) Just (_, t, info, arg) -> do (fp, e') <- mkStaticBind t info arg - return (Just (b, fp), (b, foldr Lam e' tvs)) + return (Just (SptEntry b fp), (b, foldr Lam e' tvs)) mkStaticBind :: Type -> CoreExpr -> CoreExpr -> StateT Int IO (Fingerprint, CoreExpr) @@ -249,7 +257,7 @@ sptCreateStaticBinds hsc_env this_mod binds -- -- @fps@ is a list associating each binding corresponding to a static entry with -- its fingerprint. -sptModuleInitCode :: Module -> [(Id, Fingerprint)] -> SDoc +sptModuleInitCode :: Module -> [SptEntry] -> SDoc sptModuleInitCode _ [] = Outputable.empty sptModuleInitCode this_mod entries = vcat [ text "static void hs_spt_init_" <> ppr this_mod @@ -267,7 +275,7 @@ sptModuleInitCode this_mod entries = vcat ] ) <> semi - | (i, (n, fp)) <- zip [0..] entries + | (i, SptEntry n fp) <- zip [0..] entries ] , text "static void hs_spt_fini_" <> ppr this_mod <> text "(void) __attribute__((destructor));" @@ -276,7 +284,7 @@ sptModuleInitCode this_mod entries = vcat [ text "StgWord64 k" <> int i <> text "[2] = " <> pprFingerprint fp <> semi $$ text "hs_spt_remove" <> parens (char 'k' <> int i) <> semi - | (i, (_, fp)) <- zip [0..] entries + | (i, (SptEntry _ fp)) <- zip [0..] entries ] ] where |