[Git][ghc/ghc][wip/bytecode-serialize-clean] compiler: make bc_strs serializable
Cheng Shao (@TerrorJack)
gitlab at gitlab.haskell.org
Fri Feb 14 00:52:19 UTC 2025
Cheng Shao pushed to branch wip/bytecode-serialize-clean at Glasgow Haskell Compiler / GHC
Commits:
6bb90c97 by Cheng Shao at 2025-02-14T00:52:06+00:00
compiler: make bc_strs serializable
- - - - -
4 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/StgToByteCode.hs
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -51,6 +51,7 @@ import qualified Data.Array.Unboxed as Array
import Data.Array.Base ( UArray(..) )
import Foreign hiding (shiftL, shiftR)
+import Data.ByteString ( ByteString )
import Data.Char ( ord )
import Data.Map.Strict (Map)
import Data.Maybe (fromMaybe)
@@ -92,7 +93,7 @@ assembleBCOs
-> Profile
-> FlatBag (ProtoBCO Name)
-> [TyCon]
- -> AddrEnv
+ -> [(Name, ByteString)]
-> Maybe ModBreaks
-> [SptEntry]
-> IO CompiledByteCode
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -64,7 +64,7 @@ data CompiledByteCode = CompiledByteCode
, bc_ffis :: [FFIInfo]
-- ^ ffi blocks we allocated
- , bc_strs :: AddrEnv
+ , bc_strs :: ![(Name, ByteString)]
-- ^ top-level strings (heap allocated)
, bc_breaks :: Maybe ModBreaks
@@ -89,7 +89,7 @@ seqCompiledByteCode CompiledByteCode{..} =
rnf bc_bcos `seq`
seqEltsNameEnv rnf bc_itbls `seq`
rnf bc_ffis `seq`
- seqEltsNameEnv rnf bc_strs `seq`
+ rnf bc_strs `seq`
rnf (fmap seqModBreaks bc_breaks)
newtype ByteOff = ByteOff Int
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -97,6 +97,7 @@ import GHC.Linker.Types
-- Standard libraries
import Control.Monad
+import Data.ByteString (ByteString)
import qualified Data.Set as Set
import Data.Char (isSpace)
import qualified Data.Foldable as Foldable
@@ -723,8 +724,9 @@ loadDecls interp hsc_env span linkable = do
else do
-- Link the expression itself
let le = linker_env pls
- le2 = le { itbl_env = foldl' (\acc cbc -> plusNameEnv acc (bc_itbls cbc)) (itbl_env le) cbcs
- , addr_env = foldl' (\acc cbc -> plusNameEnv acc (bc_strs cbc)) (addr_env le) cbcs }
+ le2_addr_env <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le) cbcs
+ let le2 = le { itbl_env = foldl' (\acc cbc -> plusNameEnv acc (bc_itbls cbc)) (itbl_env le) cbcs
+ , addr_env = le2_addr_env }
-- Link the necessary packages and linkables
new_bindings <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs
@@ -947,8 +949,8 @@ dynLinkBCOs interp pls bcos = do
le1 = linker_env pls
ie2 = foldr plusNameEnv (itbl_env le1) (map bc_itbls cbcs)
- ae2 = foldr plusNameEnv (addr_env le1) (map bc_strs cbcs)
- le2 = le1 { itbl_env = ie2, addr_env = ae2 }
+ ae2 <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le1) cbcs
+ let le2 = le1 { itbl_env = ie2, addr_env = ae2 }
names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 cbcs
@@ -1649,3 +1651,13 @@ maybePutStr logger s = maybePutSDoc logger (text s)
maybePutStrLn :: Logger -> String -> IO ()
maybePutStrLn logger s = maybePutSDoc logger (text s <> text "\n")
+
+-- | see Note [Generating code for top-level string literal bindings]
+allocateTopStrings ::
+ Interp -> [(Name, ByteString)] -> AddrEnv -> IO AddrEnv
+allocateTopStrings interp topStrings prev_env = do
+ let (bndrs, strings) = unzip topStrings
+ ptrs <- interpCmd interp $ MallocStrings strings
+ evaluate $ extendNameEnvList prev_env (zipWith mk_entry bndrs ptrs)
+ where
+ mk_entry nm ptr = (nm, (nm, AddrPtr ptr))
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -66,7 +66,6 @@ import GHC.Data.Bitmap
import GHC.Data.FlatBag as FlatBag
import GHC.Data.OrdList
import GHC.Data.Maybe
-import GHC.Types.Name.Env (mkNameEnv)
import GHC.Types.Tickish
import GHC.Types.SptEntry
@@ -81,7 +80,6 @@ import GHC.Unit.Home.PackageTable (lookupHpt)
import Data.Array
import Data.Coerce (coerce)
-import Data.ByteString (ByteString)
#if MIN_VERSION_rts(1,0,3)
import qualified Data.ByteString.Char8 as BS
#endif
@@ -117,10 +115,9 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries
bnd <- binds
case bnd of
StgTopLifted bnd -> [Right bnd]
- StgTopStringLit b str -> [Left (b, str)]
+ StgTopStringLit b str -> [Left (getName b, str)]
flattenBind (StgNonRec b e) = [(b,e)]
flattenBind (StgRec bs) = bs
- stringPtrs <- allocateTopStrings interp strings
(BcM_State{..}, proto_bcos) <-
runBc hsc_env this_mod mb_modBreaks $ do
@@ -137,7 +134,7 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries
let mod_breaks = case modBreaks of
Nothing -> Nothing
Just mb -> Just mb{ modBreaks_breakInfo = breakInfo }
- cbc <- assembleBCOs interp profile proto_bcos tycs stringPtrs mod_breaks spt_entries
+ cbc <- assembleBCOs interp profile proto_bcos tycs strings mod_breaks spt_entries
-- Squash space leaks in the CompiledByteCode. This is really
-- important, because when loading a set of modules into GHCi
@@ -154,19 +151,6 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries
interp = hscInterp hsc_env
profile = targetProfile dflags
--- | see Note [Generating code for top-level string literal bindings]
-allocateTopStrings
- :: Interp
- -> [(Id, ByteString)]
- -> IO AddrEnv
-allocateTopStrings interp topStrings = do
- let !(bndrs, strings) = unzip topStrings
- ptrs <- interpCmd interp $ MallocStrings strings
- return $ mkNameEnv (zipWith mk_entry bndrs ptrs)
- where
- mk_entry bndr ptr = let nm = getName bndr
- in (nm, (nm, AddrPtr ptr))
-
{- Note [Generating code for top-level string literal bindings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As described in Note [Compilation plan for top-level string literals]
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6bb90c97a28058e379eb023be236c9471e3cdb72
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6bb90c97a28058e379eb023be236c9471e3cdb72
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20250213/ef0705bf/attachment-0001.html>
More information about the ghc-commits
mailing list