[Git][ghc/ghc][wip/T17521] Force static BCOs at link-time
Jaro Reinders (@Noughtmare)
gitlab at gitlab.haskell.org
Thu Aug 24 10:09:41 UTC 2023
Jaro Reinders pushed to branch wip/T17521 at Glasgow Haskell Compiler / GHC
Commits:
65370665 by Jaro Reinders at 2023-08-24T12:09:32+02:00
Force static BCOs at link-time
- - - - -
6 changed files:
- compiler/GHC/ByteCode/Asm.hs
- compiler/GHC/ByteCode/Instr.hs
- compiler/GHC/ByteCode/Linker.hs
- compiler/GHC/ByteCode/Types.hs
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/StgToByteCode.hs
Changes:
=====================================
compiler/GHC/ByteCode/Asm.hs
=====================================
@@ -73,7 +73,7 @@ bcoFreeNames :: UnlinkedBCO -> UniqDSet Name
bcoFreeNames bco
= bco_refs bco `uniqDSetMinusUniqSet` mkNameSet [unlinkedBCOName bco]
where
- bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs)
+ bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs _)
= unionManyUniqDSets (
mkUniqDSet [ n | BCOPtrName n <- ssElts ptrs ] :
mkUniqDSet [ n | BCONPtrItbl n <- ssElts nonptrs ] :
@@ -182,7 +182,8 @@ assembleBCO platform (ProtoBCO { protoBCOName = nm
, protoBCOInstrs = instrs
, protoBCOBitmap = bitmap
, protoBCOBitmapSize = bsize
- , protoBCOArity = arity }) = do
+ , protoBCOArity = arity
+ , protoBCOIsStatic = static }) = do
-- pass 1: collect up the offsets of the local labels.
let asm = mapM_ (assembleI platform) instrs
@@ -219,7 +220,7 @@ assembleBCO platform (ProtoBCO { protoBCOName = nm
let asm_insns = ssElts final_insns
insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns
bitmap_arr = mkBitmapArray bsize bitmap
- ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs
+ ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs static
-- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
-- objects, since they might get run too early. Disable this until
=====================================
compiler/GHC/ByteCode/Instr.hs
=====================================
@@ -46,6 +46,7 @@ data ProtoBCO a
protoBCOArity :: Int,
-- what the BCO came from, for debugging only
protoBCOExpr :: Either [CgStgAlt] CgStgRhs,
+ protoBCOIsStatic :: Bool,
-- malloc'd pointers
protoBCOFFIs :: [FFIInfo]
}
@@ -222,9 +223,9 @@ instance Outputable a => Outputable (ProtoBCO a) where
, protoBCOBitmapSize = bsize
, protoBCOArity = arity
, protoBCOExpr = origin
- , protoBCOFFIs = ffis })
- = (text "ProtoBCO" <+> ppr name <> char '#' <> int arity
- <+> text (show ffis) <> colon)
+ , protoBCOFFIs = ffis
+ , protoBCOIsStatic = static })
+ = hsep ([text "ProtoBCO", ppr name <> char '#' <> int arity, text (show ffis)] ++ [text "static" | static]) <> colon
$$ nest 3 (case origin of
Left alts ->
vcat (zipWith (<+>) (char '{' : repeat (char ';'))
=====================================
compiler/GHC/ByteCode/Linker.hs
=====================================
@@ -58,7 +58,7 @@ linkBCO
-> UnlinkedBCO
-> IO ResolvedBCO
linkBCO interp le bco_ix
- (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
+ (UnlinkedBCO _ arity insns bitmap lits0 ptrs0 _) = do
-- fromIntegral Word -> Word64 should be a no op if Word is Word64
-- otherwise it will result in a cast to longlong on 32bit systems.
lits <- mapM (fmap fromIntegral . lookupLiteral interp le) (ssElts lits0)
=====================================
compiler/GHC/ByteCode/Types.hs
=====================================
@@ -155,7 +155,8 @@ data UnlinkedBCO
unlinkedBCOInstrs :: !(UArray Int Word16), -- insns
unlinkedBCOBitmap :: !(UArray Int Word64), -- bitmap
unlinkedBCOLits :: !(SizedSeq BCONPtr), -- non-ptrs
- unlinkedBCOPtrs :: !(SizedSeq BCOPtr) -- ptrs
+ unlinkedBCOPtrs :: !(SizedSeq BCOPtr), -- ptrs
+ unlinkedBCOIsStatic :: !Bool
}
instance NFData UnlinkedBCO where
@@ -208,10 +209,11 @@ seqCgBreakInfo CgBreakInfo{..} =
rnf cgb_resty
instance Outputable UnlinkedBCO where
- ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
- = sep [text "BCO", ppr nm, text "with",
- ppr (sizeSS lits), text "lits",
- ppr (sizeSS ptrs), text "ptrs" ]
+ ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs static)
+ = sep $ [text "BCO", ppr nm, text "with",
+ ppr (sizeSS lits), text "lits",
+ ppr (sizeSS ptrs), text "ptrs"]
+ ++ [text "static" | static]
instance Outputable CgBreakInfo where
ppr info = text "CgBreakInfo" <+>
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -650,7 +650,7 @@ loadDecls interp hsc_env span cbc at CompiledByteCode{..} = do
, addr_env = plusNameEnv (addr_env le) bc_strs }
-- Link the necessary packages and linkables
- new_bindings <- linkSomeBCOs interp le2 [cbc]
+ new_bindings <- linkSomeBCOs interp (hsc_unit_env hsc_env) le2 [cbc]
nms_fhvs <- makeForeignNamedHValueRefs interp new_bindings
let ce2 = extendClosureEnv (closure_env le2) nms_fhvs
!pls2 = pls { linker_env = le2 { closure_env = ce2 } }
@@ -705,7 +705,7 @@ loadModuleLinkables interp hsc_env pls linkables
if failed ok_flag then
return (pls1, Failed)
else do
- pls2 <- dynLinkBCOs interp pls1 bcos
+ pls2 <- dynLinkBCOs interp (hsc_unit_env hsc_env) pls1 bcos
return (pls2, Succeeded)
@@ -855,8 +855,8 @@ rmDupLinkables already ls
********************************************************************* -}
-dynLinkBCOs :: Interp -> LoaderState -> [Linkable] -> IO LoaderState
-dynLinkBCOs interp pls bcos = do
+dynLinkBCOs :: Interp -> UnitEnv -> LoaderState -> [Linkable] -> IO LoaderState
+dynLinkBCOs interp ue pls bcos = do
let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos
pls1 = pls { bcos_loaded = bcos_loaded' }
@@ -872,7 +872,7 @@ dynLinkBCOs interp pls bcos = do
ae2 = foldr plusNameEnv (addr_env le1) (map bc_strs cbcs)
le2 = le1 { itbl_env = ie2, addr_env = ae2 }
- names_and_refs <- linkSomeBCOs interp le2 cbcs
+ names_and_refs <- linkSomeBCOs interp ue le2 cbcs
-- We only want to add the external ones to the ClosureEnv
let (to_add, to_drop) = partition (isExternalName.fst) names_and_refs
@@ -887,6 +887,7 @@ dynLinkBCOs interp pls bcos = do
-- Link a bunch of BCOs and return references to their values
linkSomeBCOs :: Interp
+ -> UnitEnv
-> LinkerEnv
-> [CompiledByteCode]
-> IO [(Name,HValueRef)]
@@ -894,7 +895,7 @@ linkSomeBCOs :: Interp
-- the incoming unlinked BCOs. Each gives the
-- value of the corresponding unlinked BCO
-linkSomeBCOs interp le mods = foldr fun do_link mods []
+linkSomeBCOs interp ue le mods = foldr fun do_link mods []
where
fun CompiledByteCode{..} inner accum = inner (bc_bcos : accum)
@@ -903,8 +904,11 @@ linkSomeBCOs interp le mods = foldr fun do_link mods []
let flat = [ bco | bcos <- mods, bco <- bcos ]
names = map unlinkedBCOName flat
bco_ix = mkNameEnv (zip names [0..])
- resolved <- sequence [ linkBCO interp le bco_ix bco | bco <- flat ]
+ (resolved, isUnlifted) <- unzip <$> sequence
+ [ (\x -> (x, unlinkedBCOIsStatic bco)) <$> linkBCO interp le bco_ix bco | bco <- flat ]
hvrefs <- createBCOs interp resolved
+ zipWithM_ (\v isU -> when isU $ void . seqHValue interp ue =<< mkForeignRef v (pure ()))
+ hvrefs isUnlifted
return (zip names hvrefs)
-- | Useful to apply to the result of 'linkSomeBCOs'
=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -252,9 +252,10 @@ mkProtoBCO
-> WordOff -- ^ bitmap size
-> [StgWord] -- ^ bitmap
-> Bool -- ^ True <=> is a return point, rather than a function
+ -> Bool -- ^ Should this BCO be statically evaluated?
-> [FFIInfo]
-> ProtoBCO name
-mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffis
+mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret static ffis
= ProtoBCO {
protoBCOName = nm,
protoBCOInstrs = maybe_with_stack_check,
@@ -262,6 +263,7 @@ mkProtoBCO platform nm instrs_ordlist origin arity bitmap_size bitmap is_ret ffi
protoBCOBitmapSize = fromIntegral bitmap_size,
protoBCOArity = arity,
protoBCOExpr = origin,
+ protoBCOIsStatic = static,
protoBCOFFIs = ffis
}
where
@@ -329,10 +331,12 @@ schemeTopBind (id, rhs)
-- for the worker itself, we must allocate it directly.
-- ioToBc (putStrLn $ "top level BCO")
emitBc (mkProtoBCO platform (getName id) (toOL [PACK data_con 0, RETURN P])
- (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-})
+ (Right rhs) 0 0 [{-no bitmap-}] False{-no alts-} True{-static-})
| otherwise
- = schemeR [{- No free variables -}] (getName id, rhs)
+ = case rhs of
+ StgRhsCon{} -> schemeR_wrk [{- No free variables -}] id rhs (collect rhs) True{-static-}
+ _ -> schemeR [{- No free variables -}] (id, rhs)
-- -----------------------------------------------------------------------------
@@ -349,10 +353,10 @@ schemeTopBind (id, rhs)
schemeR :: [Id] -- Free vars of the RHS, ordered as they
-- will appear in the thunk. Empty for
-- top-level things, which have no free vars.
- -> (Name, CgStgRhs)
+ -> (Id, CgStgRhs)
-> BcM (ProtoBCO Name)
-schemeR fvs (nm, rhs)
- = schemeR_wrk fvs nm rhs (collect rhs)
+schemeR fvs (id, rhs)
+ = schemeR_wrk fvs id rhs (collect rhs) False
-- If an expression is a lambda, return the
-- list of arguments to the lambda (in R-to-L order) and the
@@ -364,11 +368,12 @@ collect (StgRhsCon _cc dc cnum _ticks args _typ) = ([], StgConApp dc cnum args [
schemeR_wrk
:: [Id]
- -> Name
+ -> Id
-> CgStgRhs -- expression e, for debugging only
-> ([Var], CgStgExpr) -- result of collect on e
+ -> Bool -- static?
-> BcM (ProtoBCO Name)
-schemeR_wrk fvs nm original_body (args, body)
+schemeR_wrk fvs id original_body (args, body) static
= do
profile <- getProfile
let
@@ -391,8 +396,8 @@ 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 nm body_code (Right original_body)
- arity bitmap_size bitmap False{-not alts-})
+ emitBc (mkProtoBCO platform (getName id) body_code (Right original_body)
+ arity bitmap_size bitmap False{-not alts-} static)
-- | Introduce break instructions for ticked expressions.
-- If no breakpoint information is available, the instruction is omitted.
@@ -644,7 +649,7 @@ schemeE d s p (StgLet _ext binds body) = do
_other -> False
compile_bind d' fvs x (rhs::CgStgRhs) size arity off = do
- bco <- schemeR fvs (getName x,rhs)
+ bco <- schemeR fvs (x,rhs)
build_thunk d' fvs size bco off arity
compile_binds =
@@ -1084,7 +1089,7 @@ doCase d s p scrut bndr alts
let
alt_bco_name = getName bndr
alt_bco = mkProtoBCO platform alt_bco_name alt_final (Left alts)
- 0{-no arity-} bitmap_size bitmap True{-is alts-}
+ 0{-no arity-} bitmap_size bitmap True{-is alts-} False
scrut_code <- schemeE (d + ret_frame_size_b + save_ccs_size_b)
(d + ret_frame_size_b + save_ccs_size_b)
p scrut
@@ -1294,7 +1299,7 @@ Note [unboxed tuple bytecodes and tuple_BCO]
tupleBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
tupleBCO platform args_info args =
mkProtoBCO platform invented_name body_code (Left [])
- 0{-no arity-} bitmap_size bitmap False{-is alts-}
+ 0{-no arity-} bitmap_size bitmap False{-is alts-} False
where
{-
The tuple BCO is never referred to by name, so we can get away
@@ -1315,7 +1320,7 @@ tupleBCO platform args_info args =
primCallBCO :: Platform -> NativeCallInfo -> [(PrimRep, ByteOff)] -> [FFIInfo] -> ProtoBCO Name
primCallBCO platform args_info args =
mkProtoBCO platform invented_name body_code (Left [])
- 0{-no arity-} bitmap_size bitmap False{-is alts-}
+ 0{-no arity-} bitmap_size bitmap False{-is alts-} False
where
{-
The primcall BCO is never referred to by name, so we can get away
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/653706650afc168b009dcd072e5b701f2b4773c2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/653706650afc168b009dcd072e5b701f2b4773c2
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/20230824/3f2e416a/attachment-0001.html>
More information about the ghc-commits
mailing list