[Git][ghc/ghc][wip/bytecode-serialize-clean] compiler: remove FFIInfo bookkeeping in BCO
Cheng Shao (@TerrorJack)
gitlab at gitlab.haskell.org
Fri Feb 14 21:09:02 UTC 2025
Cheng Shao pushed to branch wip/bytecode-serialize-clean at Glasgow Haskell Compiler / GHC
Commits:
ed49da55 by Cheng Shao at 2025-02-14T21:08:52+00:00
compiler: remove FFIInfo bookkeeping in BCO
- - - - -
4 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/StgToByteCode.hs
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -103,7 +103,6 @@ assembleBCOs profile proto_bcos tycons top_strs modbreaks spt_entries = do
return CompiledByteCode
{ bc_bcos = bcos
, bc_itbls = itbls
- , bc_ffis = concatMap protoBCOFFIs proto_bcos
, bc_strs = top_strs
, bc_breaks = modbreaks
, bc_spt_entries = spt_entries
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -49,9 +49,7 @@ data ProtoBCO a
protoBCOBitmapSize :: Word,
protoBCOArity :: Int,
-- what the BCO came from, for debugging only
- protoBCOExpr :: Either [CgStgAlt] CgStgRhs,
- -- malloc'd pointers
- protoBCOFFIs :: [FFIInfo]
+ protoBCOExpr :: Either [CgStgAlt] CgStgRhs
}
-- | A local block label (e.g. identifying a case alternative).
@@ -258,10 +256,9 @@ instance Outputable a => Outputable (ProtoBCO a) where
, protoBCOBitmap = bitmap
, protoBCOBitmapSize = bsize
, protoBCOArity = arity
- , protoBCOExpr = origin
- , protoBCOFFIs = ffis })
+ , protoBCOExpr = origin })
= (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
- <+> text (show ffis) <> colon)
+ <> colon)
$$ nest 3 (case origin of
Left alts ->
vcat (zipWith (<+>) (char '{' : repeat (char ';'))
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -62,9 +62,6 @@ data CompiledByteCode = CompiledByteCode
, bc_itbls :: ![(Name, Message (RemotePtr Heap.StgInfoTable))]
-- ^ Mapping from DataCons to their info tables
- , bc_ffis :: [FFIInfo]
- -- ^ ffi blocks we allocated
-
, bc_strs :: ![(Name, ByteString)]
-- ^ top-level strings (heap allocated)
@@ -89,7 +86,6 @@ seqCompiledByteCode :: CompiledByteCode -> ()
seqCompiledByteCode CompiledByteCode{..} =
rnf bc_bcos `seq`
seq bc_itbls `seq`
- rnf bc_ffis `seq`
rnf bc_strs `seq`
rnf (fmap seqModBreaks bc_breaks)
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -124,9 +124,6 @@ byteCodeGen hsc_env this_mod binds tycs mb_modBreaks spt_entries
let flattened_binds = concatMap flattenBind (reverse lifted_binds)
FlatBag.fromList (fromIntegral $ length flattened_binds) <$> mapM schemeTopBind flattened_binds
- when (notNull ffis)
- (panic "GHC.StgToByteCode.byteCodeGen: missing final emitBc?")
-
putDumpFileMaybe logger Opt_D_dump_BCOs
"Proto-BCOs" FormatByteCode
(vcat (intersperse (char ' ') (map ppr $ elemsFlatBag proto_bcos)))
@@ -236,17 +233,15 @@ mkProtoBCO
-> WordOff -- ^ bitmap size
-> [StgWord] -- ^ bitmap
-> Bool -- ^ True <=> is a return point, rather than a function
- -> [FFIInfo]
-> ProtoBCO Name
-mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis
+mkProtoBCO platform _add_bco_name nm instrs_ordlist origin arity bitmap_size bitmap is_ret
= ProtoBCO {
protoBCOName = nm,
protoBCOInstrs = maybe_add_bco_name $ maybe_add_stack_check peep_d,
protoBCOBitmap = bitmap,
protoBCOBitmapSize = fromIntegral bitmap_size,
protoBCOArity = arity,
- protoBCOExpr = origin,
- protoBCOFFIs = ffis
+ protoBCOExpr = origin
}
where
#if MIN_VERSION_rts(1,0,3)
@@ -316,7 +311,7 @@ schemeTopBind (id, rhs)
-- by just re-using the single top-level definition. So
-- for the worker itself, we must allocate it directly.
-- ioToBc (putStrLn $ "top level BCO")
- emitBc (mkProtoBCO platform add_bco_name
+ pure (mkProtoBCO platform add_bco_name
(getName id) (toOL [PACK data_con 0, RETURN P])
(Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
@@ -381,7 +376,7 @@ schemeR_wrk fvs nm original_body (args, body)
bitmap = mkBitmap platform bits
body_code <- schemeER_wrk sum_szsb_args p_init body
- emitBc (mkProtoBCO platform add_bco_name nm body_code (Right original_body)
+ pure (mkProtoBCO platform add_bco_name nm body_code (Right original_body)
arity bitmap_size bitmap False{-not alts-})
-- | Introduce break instructions for ticked expressions.
@@ -527,7 +522,7 @@ returnUnliftedReps d s szb reps = do
-- otherwise use RETURN_TUPLE with a tuple descriptor
nv_reps -> do
let (call_info, args_offsets) = layoutNativeCall profile NativeTupleReturn 0 id nv_reps
- tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)
+ tuple_bco = tupleBCO platform call_info args_offsets
return $ PUSH_UBX (mkNativeCallInfoLit platform call_info) 1 `consOL`
PUSH_BCO tuple_bco `consOL`
unitOL RETURN_TUPLE
@@ -1079,16 +1074,15 @@ doCase d s p scrut bndr alts
scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)
(d + ret_frame_size_b + save_ccs_size_b)
p scrut
- alt_bco' <- emitBc alt_bco
if ubx_tuple_frame
- then do tuple_bco <- emitBc (tupleBCO platform call_info args_offsets)
- return (PUSH_ALTS_TUPLE alt_bco' call_info tuple_bco
+ then do let tuple_bco = tupleBCO platform call_info args_offsets
+ return (PUSH_ALTS_TUPLE alt_bco call_info tuple_bco
`consOL` scrut_code)
else let scrut_rep = case non_void_arg_reps of
[] -> V
[rep] -> rep
_ -> panic "schemeE(StgCase).push_alts"
- in return (PUSH_ALTS alt_bco' scrut_rep `consOL` scrut_code)
+ in return (PUSH_ALTS alt_bco scrut_rep `consOL` scrut_code)
-- -----------------------------------------------------------------------------
@@ -1380,7 +1374,7 @@ Note [unboxed tuple bytecodes and tuple_BCO]
-}
-tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
+tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> ProtoBCO Name
tupleBCO platform args_info args =
mkProtoBCO platform Nothing invented_name body_code (Left [])
0{-no arity-} bitmap_size bitmap False{-is alts-}
@@ -1401,7 +1395,7 @@ tupleBCO platform args_info args =
body_code = mkSlideW 0 1 -- pop frame header
`snocOL` RETURN_TUPLE -- and add it again
-primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
+primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> ProtoBCO Name
primCallBCO platform args_info args =
mkProtoBCO platform Nothing invented_name body_code (Left [])
0{-no arity-} bitmap_size bitmap False{-is alts-}
@@ -1510,7 +1504,7 @@ generatePrimCall d s p target _mb_unit _result_ty args
massert (off == dd + szb)
go (dd + szb) (push:pushes) cs
push_args <- go d [] shifted_args_offsets
- args_bco <- emitBc (primCallBCO platform args_info prim_args_offsets)
+ let args_bco = primCallBCO platform args_info prim_args_offsets
return $ mconcat push_args `appOL`
(push_target `consOL`
push_info `consOL`
@@ -1690,7 +1684,6 @@ generateCCall d0 s p (CCallSpec target _ safety) result_ty args
ffiargs = map (primRepToFFIType platform) a_reps
interp <- hscInterp <$> getHscEnv
token <- ioToBc $ interpCmd interp (PrepFFI ffiargs ffires)
- recordFFIBc token
let
-- do the call
@@ -2285,8 +2278,6 @@ data BcM_State
{ bcm_hsc_env :: HscEnv
, thisModule :: Module -- current module (for breakpoints)
, nextlabel :: Word32 -- for generating local labels
- , ffis :: [FFIInfo] -- ffi info blocks, to free later
- -- Should be free()d when it is GCd
, modBreaks :: Maybe ModBreaks -- info about breakpoints
, breakInfo :: IntMap CgBreakInfo -- ^ Info at breakpoint occurrence.
@@ -2307,7 +2298,7 @@ runBc :: HscEnv -> Module -> Maybe ModBreaks
-> BcM r
-> IO (BcM_State, r)
runBc hsc_env this_mod modBreaks (BcM m)
- = m (BcM_State hsc_env this_mod 0 [] modBreaks IntMap.empty 0)
+ = m (BcM_State hsc_env this_mod 0 modBreaks IntMap.empty 0)
thenBc :: BcM a -> (a -> BcM b) -> BcM b
thenBc (BcM expr) cont = BcM $ \st0 -> do
@@ -2350,14 +2341,6 @@ shouldAddBcoName = do
then Just <$> getCurrentModule
else return Nothing
-emitBc :: ([FFIInfo] -> ProtoBCO Name) -> BcM (ProtoBCO Name)
-emitBc bco
- = BcM $ \st -> return (st{ffis=[]}, bco (ffis st))
-
-recordFFIBc :: RemotePtr C_ffi_cif -> BcM ()
-recordFFIBc a
- = BcM $ \st -> return (st{ffis = FFIInfo a : ffis st}, ())
-
getLabelBc :: BcM LocalLabel
getLabelBc
= BcM $ \st -> do let nl = nextlabel st
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ed49da559e1fcf1f4e0bb4db4ff20f5801f4cba6
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ed49da559e1fcf1f4e0bb4db4ff20f5801f4cba6
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/20250214/b876ff3d/attachment-0001.html>
More information about the ghc-commits
mailing list