[Git][ghc/ghc][wip/T17521] 2 commits: Rename and remove temporary debug tracing
Jaro Reinders (@Noughtmare)
gitlab at gitlab.haskell.org
Mon Aug 28 20:49:14 UTC 2023
Jaro Reinders pushed to branch wip/T17521 at Glasgow Haskell Compiler / GHC
Commits:
fdb9939a by Jaro Reinders at 2023-08-25T12:29:15+02:00
Rename and remove temporary debug tracing
- - - - -
90c0ce3d by Jaro Reinders at 2023-08-28T22:49:06+02:00
Almost fix static BCO initialisation
- - - - -
5 changed files:
- compiler/GHC/Linker/Loader.hs
- compiler/GHC/Runtime/Interpreter.hs
- libraries/ghci/GHCi/Message.hs
- libraries/ghci/GHCi/Run.hs
- rts/Interpreter.c
Changes:
=====================================
compiler/GHC/Linker/Loader.hs
=====================================
@@ -66,6 +66,7 @@ import GHC.SysTools
import GHC.Types.Basic
import GHC.Types.Name
import GHC.Types.Name.Env
+import GHC.Types.Name.Set
import GHC.Types.SrcLoc
import GHC.Types.Unique.DSet
import GHC.Types.Unique.DFM
@@ -650,10 +651,8 @@ 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 (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 } }
+ (nms_fhvs, le3) <- linkSomeBCOs interp (hsc_unit_env hsc_env) le2 [cbc]
+ let !pls2 = pls { linker_env = le3 }
return (pls2, (nms_fhvs, links_needed, units_needed))
where
free_names = uniqDSetToList $
@@ -872,44 +871,83 @@ dynLinkBCOs interp ue 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 ue le2 cbcs
+ (names_and_refs, le3) <- 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
+ let to_drop = filter (not.isExternalName.fst) names_and_refs
- -- Immediately release any HValueRefs we're not going to add
- freeHValueRefs interp (map snd to_drop)
- -- Wrap finalizers on the ones we want to keep
- new_binds <- makeForeignNamedHValueRefs interp to_add
+ -- Finalize any ForeignHValues we want to drop
+ mapM_ finalizeForeignRef (map snd to_drop)
- let ce2 = extendClosureEnv (closure_env le2) new_binds
- return $! pls1 { linker_env = le2 { closure_env = ce2 } }
+ let ce = delListFromNameEnv (closure_env le3) (map fst to_drop)
+ return $! pls1 { linker_env = le3 { closure_env = ce } }
-- Link a bunch of BCOs and return references to their values
linkSomeBCOs :: Interp
-> UnitEnv
-> LinkerEnv
-> [CompiledByteCode]
- -> IO [(Name,HValueRef)]
+ -> IO ([(Name,ForeignHValue)], LinkerEnv)
-- The returned HValueRefs are associated 1-1 with
-- the incoming unlinked BCOs. Each gives the
-- value of the corresponding unlinked BCO
-linkSomeBCOs interp ue le mods = foldr fun do_link mods []
+linkSomeBCOs interp ue le mods = do
+ let flat = concatMap bc_bcos mods
+ (static_bcos, bcos) = partition unlinkedBCOIsStatic flat
+ names = map unlinkedBCOName bcos
+ bco_ix = mkNameEnv (zip names [0..])
+ (static_nms_fhvs, le') <- do_link_static bco_ix static_bcos
+ hvs <- do_link le' bco_ix bcos
+ nms_fhvs <- makeForeignNamedHValueRefs interp (zip names hvs)
+ let ce = extendClosureEnv (closure_env le') nms_fhvs
+ pure (static_nms_fhvs ++ nms_fhvs, le' { closure_env = ce })
where
- fun CompiledByteCode{..} inner accum = inner (bc_bcos : accum)
-
- do_link [] = return []
- do_link mods = do
- let flat = [ bco | bcos <- mods, bco <- bcos ]
- names = map unlinkedBCOName flat
- bco_ix = mkNameEnv (zip names [0..])
- (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)
+ do_link_static :: NameEnv Int -> [UnlinkedBCO] -> IO ([(Name, ForeignHValue)], LinkerEnv)
+ do_link_static bco_ix bcos = do
+ let names = map unlinkedBCOName bcos
+ bco_deps = mkNameEnv
+ [ ( unlinkedBCOName bco
+ , mapMaybe (\case BCOPtrName n | n `elem` names -> Just n; _ -> Nothing) (ssElts (unlinkedBCOPtrs bco))
+ )
+ | bco <- bcos
+ ]
+ name_bco = mkNameEnv [(unlinkedBCOName bco, bco) | bco <- bcos]
+
+ -- topological sort
+ go :: LinkerEnv -> NameSet -> [Name] -> IO ([(Name, ForeignHValue)], LinkerEnv)
+ go le _ [] = pure ([], le)
+ go le done (n:ns)
+ | elemNameSet n done = go le done ns
+ | otherwise =
+ case filter (not . flip elemNameSet done) <$> lookupNameEnv bco_deps n of
+ -- not in our bco set
+ Nothing -> go le done ns
+ -- all dependencies have been processed
+ Just [] -> do
+ resolved <- linkBCO interp le bco_ix (lookupNameEnv_NF name_bco n)
+ hvrefs <- createBCOs interp [resolved]
+ case hvrefs of
+ [hvref] -> do
+ fref <- mkFinalizedHValue interp hvref
+ result <- seqHValue interp ue fref
+ case result of
+ EvalException e -> pprPanic "linkSomeBCOs" (text (show e))
+ EvalSuccess hv' -> do
+ fhv' <- mkFinalizedHValue interp hv'
+ let le' = le { closure_env = extendClosureEnv (closure_env le) [(n, fhv')] }
+ (nms_fhvs, le'') <- go le' (extendNameSet done n) ns
+ pure ((n, fhv') : nms_fhvs, le'')
+ _ -> pprPanic "linkSomeBCOs" (text "Failed to create BCOs")
+ -- still need to process some depeendencies first
+ Just ns' -> go le done (ns' ++ n : ns)
+
+ go le emptyNameSet names
+
+ do_link _ _ [] = return []
+ do_link le bco_ix bcos = do
+ resolved <- traverse (linkBCO interp le bco_ix) bcos
+ createBCOs interp resolved
-- | Useful to apply to the result of 'linkSomeBCOs'
makeForeignNamedHValueRefs
=====================================
compiler/GHC/Runtime/Interpreter.hs
=====================================
@@ -408,7 +408,7 @@ getClosure interp ref =
mapM (mkFinalizedHValue interp) mb
-- | Send a Seq message to the iserv process to force a value #2950
-seqHValue :: Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult ())
+seqHValue :: Interp -> UnitEnv -> ForeignHValue -> IO (EvalResult HValueRef)
seqHValue interp unit_env ref =
withForeignRef ref $ \hval -> do
status <- interpCmd interp (Seq hval)
@@ -424,7 +424,7 @@ evalBreakInfo hpt (EvalBreakpoint ix mod_name) =
lookupHpt hpt (mkModuleName mod_name)
-- | Process the result of a Seq or ResumeSeq message. #2950
-handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus () -> IO (EvalResult ())
+handleSeqHValueStatus :: Interp -> UnitEnv -> EvalStatus HValueRef -> IO (EvalResult HValueRef)
handleSeqHValueStatus interp unit_env eval_status =
case eval_status of
(EvalBreak _ maybe_break resume_ctxt _) -> do
=====================================
libraries/ghci/GHCi/Message.hs
=====================================
@@ -221,12 +221,12 @@ data Message a where
-- | Evaluate something. This is used to support :force in GHCi.
Seq
:: HValueRef
- -> Message (EvalStatus ())
+ -> Message (EvalStatus HValueRef)
-- | Resume forcing a free variable in a breakpoint (#2950)
ResumeSeq
- :: RemoteRef (ResumeContext ())
- -> Message (EvalStatus ())
+ :: RemoteRef (ResumeContext (HValueRef))
+ -> Message (EvalStatus HValueRef)
-- | Allocate a string for a breakpoint module name.
-- This uses an empty dummy type because @ModuleName@ isn't available here.
=====================================
libraries/ghci/GHCi/Run.hs
=====================================
@@ -183,15 +183,14 @@ evalStringToString r str = do
-- The UI process has more and therefore also can show more
-- information about the breakpoint than the current iserv
-- process.
-doSeq :: RemoteRef a -> IO (EvalStatus ())
+doSeq :: RemoteRef a -> IO (EvalStatus (RemoteRef a))
doSeq ref = do
sandboxIO evalOptsSeq $ do
- _ <- (void $ evaluate =<< localRef ref)
- return ()
+ mkRemoteRef =<< evaluate =<< localRef ref
-- | Process a ResumeSeq message. Continue the :force processing #2950
-- after a breakpoint.
-resumeSeq :: RemoteRef (ResumeContext ()) -> IO (EvalStatus ())
+resumeSeq :: RemoteRef (ResumeContext a) -> IO (EvalStatus a)
resumeSeq hvref = do
ResumeContext{..} <- localRef hvref
withBreakAction evalOptsSeq resumeBreakMVar resumeStatusMVar $
=====================================
rts/Interpreter.c
=====================================
@@ -1299,9 +1299,6 @@ run_BCO:
case bci_PUSH_G: {
W_ o1 = BCO_GET_LARGE_ARG;
- IF_DEBUG(interpreter,
- debugBelch("PUSH_G %ld\n", o1);
- );
SpW(-1) = BCO_PTR(o1);
Sp_subW(1);
goto nextInsn;
@@ -1310,9 +1307,6 @@ run_BCO:
case bci_PUSH_TAGGED: {
W_ o1 = BCO_GET_LARGE_ARG;
W_ o_itbl = BCO_GET_LARGE_ARG;
- IF_DEBUG(interpreter,
- debugBelch("PUSH_TAGGED %ld %ld\n", o1, o_itbl);
- );
StgInfoTable* itbl = INFO_PTR_TO_STRUCT((StgInfoTable *)BCO_LIT(o_itbl));
SpW(-1) = (W_)tagPtr((StgClosure *)BCO_PTR(o1), itbl);
Sp_subW(1);
@@ -1695,9 +1689,6 @@ run_BCO:
W_ i;
W_ o_itbl = BCO_GET_LARGE_ARG;
W_ n_words = BCO_GET_LARGE_ARG;
- IF_DEBUG(interpreter,
- debugBelch("PACK %ld %ld\n", o_itbl, n_words);
- );
StgInfoTable* itbl = INFO_PTR_TO_STRUCT((StgInfoTable *)BCO_LIT(o_itbl));
int request = CONSTR_sizeW( itbl->layout.payload.ptrs,
itbl->layout.payload.nptrs );
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/653706650afc168b009dcd072e5b701f2b4773c2...90c0ce3dacf6053c40639fb9d34682a97decfa37
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/653706650afc168b009dcd072e5b701f2b4773c2...90c0ce3dacf6053c40639fb9d34682a97decfa37
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/20230828/0b2c24eb/attachment-0001.html>
More information about the ghc-commits
mailing list