Matthew Pickering pushed to branch wip/bytecode-lib-shared-object at Glasgow Haskell Compiler / GHC Commits: 35968c75 by Matthew Pickering at 2025-10-30T10:11:34+00:00 WIP - - - - - 0655c75c by Matthew Pickering at 2025-10-30T10:47:28+00:00 Comments - - - - - 15c6d35a by Matthew Pickering at 2025-10-30T16:30:49+00:00 WIP - - - - - 9 changed files: - compiler/GHC/ByteCode/Linker.hs - compiler/GHC/Driver/Make.hs - compiler/GHC/Driver/Phases.hs - compiler/GHC/Linker/Loader.hs - compiler/GHC/Linker/Types.hs - compiler/GHC/Runtime/Debugger.hs - compiler/GHC/Runtime/Eval.hs - compiler/GHC/Unit/State.hs - utils/ghc-pkg/Main.hs Changes: ===================================== compiler/GHC/ByteCode/Linker.hs ===================================== @@ -28,7 +28,6 @@ import GHCi.ResolvedBCO import GHC.Builtin.PrimOps import GHC.Builtin.PrimOps.Ids -import GHC.Unit.Module.Env import GHC.Unit.Types import GHC.Data.FastString @@ -57,17 +56,16 @@ import GHC.Exts linkBCO :: Interp -> PkgsLoaded - -> LinkerEnv - -> LinkedBreaks + -> BytecodeLoaderState -> NameEnv Int -> UnlinkedBCO -> IO ResolvedBCO -linkBCO interp pkgs_loaded le lb bco_ix +linkBCO interp pkgs_loaded bytecode_state bco_ix (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 :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le lb) (elemsFlatBag lits0) - ptrs <- mapM (resolvePtr interp pkgs_loaded le lb bco_ix) (elemsFlatBag ptrs0) + (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded bytecode_state) (elemsFlatBag lits0) + ptrs <- mapM (resolvePtr interp pkgs_loaded bytecode_state bco_ix) (elemsFlatBag ptrs0) let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits return $ ResolvedBCO { resolvedBCOIsLE = isLittleEndian , resolvedBCOArity = arity @@ -77,17 +75,17 @@ linkBCO interp pkgs_loaded le lb bco_ix , resolvedBCOPtrs = addListToSS emptySS ptrs } -lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> LinkedBreaks -> BCONPtr -> IO Word -lookupLiteral interp pkgs_loaded le lb ptr = case ptr of +lookupLiteral :: Interp -> PkgsLoaded -> BytecodeLoaderState -> BCONPtr -> IO Word +lookupLiteral interp pkgs_loaded bytecode_state ptr = case ptr of BCONPtrWord lit -> return lit BCONPtrLbl sym -> do Ptr a# <- lookupStaticPtr interp sym return (W# (int2Word# (addr2Int# a#))) BCONPtrItbl nm -> do - Ptr a# <- lookupIE interp pkgs_loaded (itbl_env le) nm + Ptr a# <- lookupIE interp pkgs_loaded bytecode_state nm return (W# (int2Word# (addr2Int# a#))) BCONPtrAddr nm -> do - Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm + Ptr a# <- lookupAddr interp pkgs_loaded bytecode_state nm return (W# (int2Word# (addr2Int# a#))) BCONPtrStr bs -> do RemotePtr p <- fmap head $ interpCmd interp $ MallocStrings [bs] @@ -100,7 +98,7 @@ lookupLiteral interp pkgs_loaded le lb ptr = case ptr of pure $ fromIntegral p BCONPtrCostCentre InternalBreakpointId{..} | interpreterProfiled interp -> do - case expectJust (lookupModuleEnv (ccs_env lb) ibi_info_mod) ! ibi_info_index of + case expectJust (lookupCCSBytecodeState bytecode_state ibi_info_mod) ! ibi_info_index of RemotePtr p -> pure $ fromIntegral p | otherwise -> case toRemotePtr nullPtr of @@ -114,9 +112,9 @@ lookupStaticPtr interp addr_of_label_string = do Nothing -> linkFail "GHC.ByteCode.Linker: can't find label" (ppr addr_of_label_string) -lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ()) -lookupIE interp pkgs_loaded ie con_nm = - case lookupNameEnv ie con_nm of +lookupIE :: Interp -> PkgsLoaded -> BytecodeLoaderState -> Name -> IO (Ptr ()) +lookupIE interp pkgs_loaded bytecode_state con_nm = + case lookupInfoTableBytecodeState bytecode_state con_nm of Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a)) Nothing -> do -- try looking up in the object files. let sym_to_find1 = IConInfoSymbol con_nm @@ -134,9 +132,9 @@ lookupIE interp pkgs_loaded ie con_nm = ppr sym_to_find2) -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode -lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ()) -lookupAddr interp pkgs_loaded ae addr_nm = do - case lookupNameEnv ae addr_nm of +lookupAddr :: Interp -> PkgsLoaded -> BytecodeLoaderState -> Name -> IO (Ptr ()) +lookupAddr interp pkgs_loaded bytecode_state addr_nm = do + case lookupAddressBytecodeState bytecode_state addr_nm of Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr) Nothing -> do -- try looking up in the object files. let sym_to_find = IBytesSymbol addr_nm @@ -158,17 +156,16 @@ lookupPrimOp interp pkgs_loaded primop = do resolvePtr :: Interp -> PkgsLoaded - -> LinkerEnv - -> LinkedBreaks + -> BytecodeLoaderState -> NameEnv Int -> BCOPtr -> IO ResolvedBCOPtr -resolvePtr interp pkgs_loaded le lb bco_ix ptr = case ptr of +resolvePtr interp pkgs_loaded bco_loader_state bco_ix ptr = case ptr of BCOPtrName nm | Just ix <- lookupNameEnv bco_ix nm -> return (ResolvedBCORef ix) -- ref to another BCO in this group - | Just (_, rhv) <- lookupNameEnv (closure_env le) nm + | Just (_, rhv) <- lookupNameBytecodeState bco_loader_state nm -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv)) | otherwise @@ -184,10 +181,10 @@ resolvePtr interp pkgs_loaded le lb bco_ix ptr = case ptr of -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op BCOPtrBCO bco - -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le lb bco_ix bco + -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded bco_loader_state bco_ix bco BCOPtrBreakArray tick_mod -> - withForeignRef (expectJust (lookupModuleEnv (breakarray_env lb) tick_mod)) $ + withForeignRef (expectJust (lookupBreakArrayBytecodeState bco_loader_state tick_mod)) $ \ba -> pure $ ResolvedBCOPtrBreakArray ba -- | Look up the address of a Haskell symbol in the currently ===================================== compiler/GHC/Driver/Make.hs ===================================== @@ -822,7 +822,7 @@ pruneCache hpt summ unload :: Interp -> HscEnv -> IO () unload interp hsc_env = case ghcLink (hsc_dflags hsc_env) of - LinkInMemory -> Linker.unload interp hsc_env [] + LinkInMemory -> Linker.unload interp hsc_env _other -> return () ===================================== compiler/GHC/Driver/Phases.hs ===================================== @@ -32,6 +32,7 @@ module GHC.Driver.Phases ( isHaskellSrcFilename, isHaskellSigFilename, isObjectFilename, + isBytecodeFilename, isCishFilename, isDynLibFilename, isHaskellUserSrcFilename, @@ -235,7 +236,9 @@ phaseInputExt Js = "js" phaseInputExt StopLn = "o" haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes, - js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes, haskellish_boot_suffixes + js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes, haskellish_boot_suffixes, + bytecode_suffixes + :: [String] -- When a file with an extension in the haskellish_src_suffixes group is -- loaded in --make mode, its imports will be loaded too. @@ -252,6 +255,7 @@ haskellish_user_src_suffixes = haskellish_boot_suffixes = [ "hs-boot", "lhs-boot" ] haskellish_sig_suffixes = [ "hsig", "lhsig" ] backpackish_suffixes = [ "bkp" ] +bytecode_suffixes = [ "gbc" ] objish_suffixes :: Platform -> [String] -- Use the appropriate suffix for the system on which @@ -267,7 +271,8 @@ dynlib_suffixes platform = case platformOS platform of _ -> ["so"] isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix, - isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix, isHaskellBootSuffix + isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix, isHaskellBootSuffix, + isBytecodeSuffix :: String -> Bool isHaskellishSuffix s = s `elem` haskellish_suffixes isBackpackishSuffix s = s `elem` backpackish_suffixes @@ -277,6 +282,7 @@ isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes isCishSuffix s = s `elem` cish_suffixes isJsSuffix s = s `elem` js_suffixes isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes +isBytecodeSuffix s = s `elem` bytecode_suffixes isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool isObjectSuffix platform s = s `elem` objish_suffixes platform @@ -306,7 +312,8 @@ isHaskellishTarget (_,Just phase) = , StopLn] isHaskellishFilename, isHaskellSrcFilename, isCishFilename, - isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename + isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename, + isBytecodeFilename :: FilePath -> Bool -- takeExtension return .foo, so we drop 1 to get rid of the . isHaskellishFilename f = isHaskellishSuffix (drop 1 $ takeExtension f) @@ -315,6 +322,7 @@ isCishFilename f = isCishSuffix (drop 1 $ takeExtension f) isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f) isSourceFilename f = isSourceSuffix (drop 1 $ takeExtension f) isHaskellSigFilename f = isHaskellSigSuffix (drop 1 $ takeExtension f) +isBytecodeFilename f = isBytecodeSuffix (drop 1 $ takeExtension f) isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f) ===================================== compiler/GHC/Linker/Loader.hs ===================================== @@ -27,7 +27,7 @@ module GHC.Linker.Loader -- * LoadedEnv , withExtendedLoadedEnv , extendLoadedEnv - , deleteFromLoadedEnv + , deleteFromLoadedHomeEnv , lookupFromLoadedEnv -- * Internals , allocateBreakArrays @@ -183,19 +183,11 @@ getLoaderState interp = readMVar (loader_state (interpLoader interp)) emptyLoaderState :: LoaderState emptyLoaderState = LoaderState - { linker_env = LinkerEnv - { closure_env = emptyNameEnv - , itbl_env = emptyNameEnv - , addr_env = emptyNameEnv - } + { bco_loader_state = emptyBytecodeLoaderState , pkgs_loaded = init_pkgs , bcos_loaded = emptyModuleEnv , objs_loaded = emptyModuleEnv , temp_sos = [] - , linked_breaks = LinkedBreaks - { breakarray_env = emptyModuleEnv - , ccs_env = emptyModuleEnv - } } -- Packages that don't need loading, because the compiler -- shares them with the interpreted program. @@ -204,18 +196,18 @@ emptyLoaderState = LoaderState -- explicit list. See rts/Linker.c for details. where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] [] emptyUniqDSet) -extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO () -extendLoadedEnv interp new_bindings = +extendLoadedEnv :: Interp -> BytecodeLoaderStateModifier -> [(Name,ForeignHValue)] -> IO () +extendLoadedEnv interp modify_bytecode_loader_state new_bindings = modifyLoaderState_ interp $ \pls -> do - return $! modifyClosureEnv pls $ \ce -> - extendClosureEnv ce new_bindings + return $! modifyBytecodeLoaderState modify_bytecode_loader_state pls $ \bco_loader_state -> + modifyClosureEnv bco_loader_state $ \ce -> extendClosureEnv ce new_bindings -- strictness is important for not retaining old copies of the pls -deleteFromLoadedEnv :: Interp -> [Name] -> IO () -deleteFromLoadedEnv interp to_remove = +deleteFromLoadedHomeEnv :: Interp -> [Name] -> IO () +deleteFromLoadedHomeEnv interp to_remove = modifyLoaderState_ interp $ \pls -> do - return $ modifyClosureEnv pls $ \ce -> - delListFromNameEnv ce to_remove + return $ modifyBytecodeLoaderState modifyHomePackageBytecodeState pls $ \bco_state -> + modifyClosureEnv bco_state $ \ce -> delListFromNameEnv ce to_remove -- | Have we already loaded a name into the interpreter? lookupFromLoadedEnv :: Interp -> Name -> IO (Maybe ForeignHValue) @@ -223,7 +215,7 @@ lookupFromLoadedEnv interp name = do mstate <- getLoaderState interp return $ do pls <- mstate - res <- lookupNameEnv (closure_env (linker_env pls)) name + res <- lookupNameBytecodeState (bco_loader_state pls) name return (snd res) -- | Load the module containing the given Name and get its associated 'HValue'. @@ -242,7 +234,7 @@ loadName interp hsc_env name = do then throwGhcExceptionIO (ProgramError "") else return (pls', links, pkgs) - case lookupNameEnv (closure_env (linker_env pls)) name of + case lookupNameBytecodeState (bco_loader_state pls) name of Just (_,aa) -> return (pls,(aa, links, pkgs)) Nothing -> assertPpr (isExternalName name) (ppr name) $ do let sym_to_find = IClosureSymbol name @@ -289,7 +281,7 @@ withExtendedLoadedEnv -> m a -> m a withExtendedLoadedEnv interp new_env action - = MC.bracket (liftIO $ extendLoadedEnv interp new_env) + = MC.bracket (liftIO $ extendLoadedEnv interp modifyHomePackageBytecodeState new_env) (\_ -> reset_old_env) (\_ -> action) where @@ -299,7 +291,7 @@ withExtendedLoadedEnv interp new_env action -- package), so the reset action only removes the names we -- added earlier. reset_old_env = liftIO $ - deleteFromLoadedEnv interp (map fst new_env) + deleteFromLoadedHomeEnv interp (map fst new_env) -- | Display the loader state. @@ -862,7 +854,7 @@ loadObjects interp hsc_env pls objs = do if succeeded ok then return (pls1, Succeeded) else do - pls2 <- unload_wkr interp [] pls1 + pls2 <- unload_wkr interp pls1 return (pls2, Failed) @@ -981,21 +973,33 @@ dynLinkBCOs interp pls keep_spec bcos = cbcs :: [CompiledByteCode] cbcs = concatMap linkableBCOs new_bcos - in dynLinkCompiledByteCode interp pls1 keep_spec cbcs - -dynLinkCompiledByteCode :: Interp -> LoaderState -> KeepModuleLinkableDefinitions -> [CompiledByteCode] -> IO LoaderState -dynLinkCompiledByteCode interp pls keep_spec cbcs = do - let - le1 = linker_env pls - lb1 = linked_breaks pls - ie2 <- linkITbls interp (itbl_env le1) (concatMap bc_itbls cbcs) - ae2 <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le1) cbcs - be2 <- allocateBreakArrays interp (breakarray_env lb1) (catMaybes $ map bc_breaks cbcs) - ce2 <- allocateCCS interp (ccs_env lb1) (catMaybes $ map bc_breaks cbcs) - let le2 = le1 { itbl_env = ie2, addr_env = ae2 } - let lb2 = lb1 { breakarray_env = be2, ccs_env = ce2 } - - names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 lb2 cbcs + in do + bco_state <- dynLinkCompiledByteCode interp (pkgs_loaded pls) (bco_loader_state pls) traverseHomePackageBytecodeState keep_spec cbcs + return $! pls1 { bco_loader_state = bco_state } + +dynLinkCompiledByteCode :: Interp + -> PkgsLoaded + -> BytecodeLoaderState + -> BytecodeLoaderStateTraverser IO -- ^ The traverser tells us to update home package bytecode state or external package bytecode state + -> KeepModuleLinkableDefinitions + -> [CompiledByteCode] + -> IO BytecodeLoaderState +dynLinkCompiledByteCode interp pkgs_loaded whole_bytecode_state traverse_bytecode_state keep_spec cbcs = do + st1 <- traverse_bytecode_state whole_bytecode_state $ \bytecode_state -> do + let + le1 = bco_linker_env bytecode_state + lb1 = bco_linked_breaks bytecode_state + ie2 <- linkITbls interp (itbl_env le1) (concatMap bc_itbls cbcs) + ae2 <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le1) cbcs + be2 <- allocateBreakArrays interp (breakarray_env lb1) (catMaybes $ map bc_breaks cbcs) + ce2 <- allocateCCS interp (ccs_env lb1) (catMaybes $ map bc_breaks cbcs) + let le2 = le1 { itbl_env = ie2, addr_env = ae2 } + let lb2 = lb1 { breakarray_env = be2, ccs_env = ce2 } + return $! bytecode_state { bco_linker_env = le2, bco_linked_breaks = lb2 } + + -- NB: Important to pass the whole bytecode loader state to linkSomeBCOs so that you can find Names in local + -- and external packages. + names_and_refs <- linkSomeBCOs interp pkgs_loaded st1 cbcs -- We only want to add the external ones to the ClosureEnv let (to_add, to_drop) = partition (keepDefinitions keep_spec . fst) names_and_refs @@ -1005,14 +1009,11 @@ dynLinkCompiledByteCode interp pls keep_spec cbcs = do -- Wrap finalizers on the ones we want to keep new_binds <- makeForeignNamedHValueRefs interp to_add - - let ce2 = extendClosureEnv (closure_env le2) new_binds - - -- Add SPT entries - mapM_ (linkSptEntry interp ce2) (concatMap bc_spt_entries cbcs) - - return $! pls { linker_env = le2 { closure_env = ce2 } - , linked_breaks = lb2 } + traverse_bytecode_state st1 $ \bytecode_state -> do + let ce2 = extendClosureEnv (closure_env (bco_linker_env bytecode_state)) new_binds + -- Add SPT entries + mapM_ (linkSptEntry interp ce2) (concatMap bc_spt_entries cbcs) + return $! bytecode_state { bco_linker_env = (bco_linker_env bytecode_state) { closure_env = ce2 } } -- | Register SPT entries for this module in the interpreter -- Assumes that the name from the SPT has already been loaded into the interpreter. @@ -1030,15 +1031,14 @@ linkSptEntry interp ce (SptEntry name fpr) = do -- Link a bunch of BCOs and return references to their values linkSomeBCOs :: Interp -> PkgsLoaded - -> LinkerEnv - -> LinkedBreaks + -> BytecodeLoaderState -> [CompiledByteCode] -> IO [(Name,HValueRef)] -- The returned HValueRefs are associated 1-1 with -- the incoming unlinked BCOs. Each gives the -- value of the corresponding unlinked BCO -linkSomeBCOs interp pkgs_loaded le lb mods = foldr fun do_link mods [] +linkSomeBCOs interp pkgs_loaded bytecode_state mods = foldr fun do_link mods [] where fun CompiledByteCode{..} inner accum = inner (Foldable.toList bc_bcos : accum) @@ -1048,7 +1048,7 @@ linkSomeBCOs interp pkgs_loaded le lb 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 pkgs_loaded le lb bco_ix bco | bco <- flat ] + resolved <- sequence [ linkBCO interp pkgs_loaded bytecode_state bco_ix bco | bco <- flat ] hvrefs <- createBCOs interp resolved return (zip names hvrefs) @@ -1071,66 +1071,39 @@ linkITbls interp = foldlM $ \env (nm, itbl) -> do -- --------------------------------------------------------------------------- -- | Unloading old objects ready for a new compilation sweep. --- --- The compilation manager provides us with a list of linkables that it --- considers \"stable\", i.e. won't be recompiled this time around. For --- each of the modules current linked in memory, --- --- * if the linkable is stable (and it's the same one -- the user may have --- recompiled the module on the side), we keep it, --- --- * otherwise, we unload it. --- +-- * compilation artifacts for home modules that we might be about to recompile +-- are unloaded from the interpreter. -- * we also implicitly unload all temporary bindings at this point. -- unload :: Interp -> HscEnv - -> [Linkable] -- ^ The linkables to *keep*. -> IO () -unload interp hsc_env linkables +unload interp hsc_env = mask_ $ do -- mask, so we're safe from Ctrl-C in here -- Initialise the linker (if it's not been done already) initLoaderState interp hsc_env - new_pls - <- modifyLoaderState interp $ \pls -> do - pls1 <- unload_wkr interp linkables pls + _new_pls <- modifyLoaderState interp $ \pls -> do + pls1 <- unload_wkr interp pls return (pls1, pls1) - let logger = hsc_logger hsc_env - debugTraceMsg logger 3 $ - text "unload: retaining objs" <+> ppr (moduleEnvElts $ objs_loaded new_pls) - debugTraceMsg logger 3 $ - text "unload: retaining bcos" <+> ppr (moduleEnvElts $ bcos_loaded new_pls) return () unload_wkr :: Interp - -> [Linkable] -- stable linkables -> LoaderState -> IO LoaderState -- Does the core unload business -- (the wrapper blocks exceptions and deals with the LS get and put) -unload_wkr interp keep_linkables pls@LoaderState{..} = do +unload_wkr interp pls@LoaderState{..} = do -- NB. careful strictness here to avoid keeping the old LS when -- we're unloading some code. -fghci-leak-check with the tests in -- testsuite/ghci can detect space leaks here. - let (objs_to_keep', bcos_to_keep') = partition linkableIsNativeCodeOnly keep_linkables - objs_to_keep = mkLinkableSet objs_to_keep' - bcos_to_keep = mkLinkableSet bcos_to_keep' - - discard keep l = not (linkableInSet l keep) - - (objs_to_unload, remaining_objs_loaded) = - partitionModuleEnv (discard objs_to_keep) objs_loaded - (bcos_to_unload, remaining_bcos_loaded) = - partitionModuleEnv (discard bcos_to_keep) bcos_loaded - - linkables_to_unload = moduleEnvElts objs_to_unload ++ moduleEnvElts bcos_to_unload + let linkables_to_unload = moduleEnvElts objs_loaded ++ moduleEnvElts bcos_loaded mapM_ unloadObjs linkables_to_unload @@ -1139,20 +1112,10 @@ unload_wkr interp keep_linkables pls@LoaderState{..} = do when (not (null (filter (not . null . linkableObjs) linkables_to_unload))) $ purgeLookupSymbolCache interp - let -- Note that we want to remove all *local* - -- (i.e. non-isExternal) names too (these are the - -- temporary bindings from the command line). - keep_name :: Name -> Bool - keep_name n = isExternalName n && - nameModule n `elemModuleEnv` remaining_bcos_loaded - - keep_mod :: Module -> Bool - keep_mod m = m `elemModuleEnv` remaining_bcos_loaded - - !new_pls = pls { linker_env = filterLinkerEnv keep_name linker_env, - linked_breaks = filterLinkedBreaks keep_mod linked_breaks, - bcos_loaded = remaining_bcos_loaded, - objs_loaded = remaining_objs_loaded } + let !new_pls = pls { bco_loader_state = modifyHomePackageBytecodeState bco_loader_state $ \_ -> emptyBytecodeState, + -- NB: we don't unload the external package + bcos_loaded = emptyModuleEnv, + objs_loaded = emptyModuleEnv } return new_pls where @@ -1296,6 +1259,8 @@ loadPackage interp hsc_env pkgs pls <- sequenceA [mapM (locateLib interp hsc_env False [] dirs_env_ gcc_paths) extra_libs_ | (dirs_env_, extra_libs_) <- zip dirs_env extra_libs] let classifieds = zipWith (++) hs_classifieds extra_classifieds + maybePutSDoc logger (text "Using these library specs: " $$ (vcat (map ppr classifieds))) + -- Complication: all the .so's must be loaded before any of the .o's. let known_hs_dlls = [[ dll | DLLPath dll <- hs_classifieds_ ] | hs_classifieds_ <- hs_classifieds] known_extra_dlls = [ dll | extra_classifieds_ <- extra_classifieds, DLLPath dll <- extra_classifieds_ ] @@ -1372,15 +1337,19 @@ loadBytecodeLibrary hsc_env interp pls path = do -- 0. Get the modification time of the module _mod_time <- expectJust <$> modificationTimeIfExists path' -- 1. Read the bytecode library - (BytecodeLib _uid cbcs stubs_so) <- decodeOnDiskBytecodeLib hsc_env =<< readBytecodeLib hsc_env path' - pls' <-case stubs_so of + (BytecodeLib uid cbcs stubs_so) <- decodeOnDiskBytecodeLib hsc_env =<< readBytecodeLib hsc_env path' + debugTraceMsg (hsc_logger hsc_env) 3 $ text "loadBytecodeLibrary: " $$ vcat [ text "uid: " <+> ppr uid + , text "cbcs: " <+> ppr (length cbcs) + , text "stubs_so: " <+> ppr stubs_so ] + pls' <- case stubs_so of Nothing -> return pls Just (SharedObject so_file libdir libname) -> do m <- loadDLLs interp [so_file] case m of Right _ -> return $! pls { temp_sos = (libdir, libname) : temp_sos pls } Left err -> linkFail err (text err) - dynLinkCompiledByteCode interp pls' KeepExternalDefinitions cbcs + bco_state <- dynLinkCompiledByteCode interp (pkgs_loaded pls') (bco_loader_state pls') traverseExternalPackageBytecodeState KeepExternalDefinitions cbcs + return $! pls' { bco_loader_state = bco_state } {- ===================================== compiler/GHC/Linker/Types.hs ===================================== @@ -12,14 +12,32 @@ module GHC.Linker.Types ( Loader (..) , LoaderState (..) , uninitializedLoader + + -- * Bytecode Loader State + , BytecodeLoaderState(..) + , BytecodeState(..) + , emptyBytecodeLoaderState + , emptyBytecodeState + , modifyHomePackageBytecodeState + , modifyExternalPackageBytecodeState + , modifyBytecodeLoaderState + , lookupNameBytecodeState + , lookupBreakArrayBytecodeState + , lookupInfoTableBytecodeState + , lookupAddressBytecodeState + , lookupCCSBytecodeState + , BytecodeLoaderStateModifier + , BytecodeLoaderStateTraverser + , traverseHomePackageBytecodeState + , traverseExternalPackageBytecodeState , modifyClosureEnv , LinkerEnv(..) - , filterLinkerEnv + , emptyLinkerEnv , ClosureEnv , emptyClosureEnv , extendClosureEnv , LinkedBreaks(..) - , filterLinkedBreaks + , emptyLinkedBreaks , LinkableSet , mkLinkableSet , unionLinkableSet @@ -62,7 +80,7 @@ import GHCi.RemoteTypes import GHCi.Message ( LoadedDLL ) import GHC.Stack.CCS -import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv ) +import GHC.Types.Name.Env ( NameEnv, emptyNameEnv, extendNameEnvList, lookupNameEnv ) import GHC.Types.Name ( Name ) import GHC.Types.SptEntry @@ -78,6 +96,8 @@ import GHC.Unit.Module.WholeCoreBindings import Data.Maybe (mapMaybe) import Data.List.NonEmpty (NonEmpty, nonEmpty) import qualified Data.List.NonEmpty as NE +import Control.Applicative ((<|>)) +import Data.Functor.Identity {- ********************************************************************** @@ -149,8 +169,9 @@ and be able to lookup symbols specifically in them too (similarly to newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) } data LoaderState = LoaderState - { linker_env :: !LinkerEnv - -- ^ Current global mapping from Names to their true values + { bco_loader_state :: !BytecodeLoaderState + -- ^ Information about bytecode objects we have loaded into the + -- interpreter. , bcos_loaded :: !LinkableSet -- ^ The currently loaded interpreted modules (home package) @@ -165,19 +186,110 @@ data LoaderState = LoaderState , temp_sos :: ![(FilePath, String)] -- ^ We need to remember the name of previous temporary DLL/.so -- libraries so we can link them (see #10322) + } - , linked_breaks :: !LinkedBreaks +data BytecodeState = BytecodeState + { bco_linker_env :: !LinkerEnv + -- ^ Current global mapping from Names to their true values + , bco_linked_breaks :: !LinkedBreaks -- ^ Mapping from loaded modules to their breakpoint arrays + } + +-- | The 'BytecodeLoaderState' captures all the information about bytecode loaded +-- into the interpreter. +-- It is separated into two parts. One for bytecode objects loaded by the home package and +-- one for bytecode objects loaded from bytecode libraries for external packages. +-- Much like the HPT/EPS split, the home package state can be unloaded by calling 'unload'. +data BytecodeLoaderState = BytecodeLoaderState + { homePackage_loaded :: BytecodeState + -- ^ Information about bytecode objects from the home package we have loaded into the interpreter. + , externalPackage_loaded :: BytecodeState + -- ^ Information about bytecode objects from external packages we have loaded into the interpreter. + } + + +-- | Find a name loaded from bytecode +lookupNameBytecodeState :: BytecodeLoaderState -> Name -> Maybe (Name, ForeignHValue) +lookupNameBytecodeState (BytecodeLoaderState home_package external_package) name = do + lookupNameEnv (closure_env (bco_linker_env home_package)) name + <|> lookupNameEnv (closure_env (bco_linker_env external_package)) name + +-- | Look up a break array in the bytecode loader state. +lookupBreakArrayBytecodeState :: BytecodeLoaderState -> Module -> Maybe (ForeignRef BreakArray) +lookupBreakArrayBytecodeState (BytecodeLoaderState home_package external_package) break_mod = do + lookupModuleEnv (breakarray_env (bco_linked_breaks home_package)) break_mod + <|> lookupModuleEnv (breakarray_env (bco_linked_breaks external_package)) break_mod + +-- | Look up an info table in the bytecode loader state. +lookupInfoTableBytecodeState :: BytecodeLoaderState -> Name -> Maybe (Name, ItblPtr) +lookupInfoTableBytecodeState (BytecodeLoaderState home_package external_package) info_mod = do + lookupNameEnv (itbl_env (bco_linker_env home_package)) info_mod + <|> lookupNameEnv (itbl_env (bco_linker_env external_package)) info_mod + +-- | Look up an address in the bytecode loader state. +lookupAddressBytecodeState :: BytecodeLoaderState -> Name -> Maybe (Name, AddrPtr) +lookupAddressBytecodeState (BytecodeLoaderState home_package external_package) addr_mod = do + lookupNameEnv (addr_env (bco_linker_env home_package)) addr_mod + <|> lookupNameEnv (addr_env (bco_linker_env external_package)) addr_mod + +-- | Look up a cost centre stack in the bytecode loader state. +lookupCCSBytecodeState :: BytecodeLoaderState -> Module -> Maybe (Array BreakTickIndex (RemotePtr CostCentre)) +lookupCCSBytecodeState (BytecodeLoaderState home_package external_package) ccs_mod = do + lookupModuleEnv (ccs_env (bco_linked_breaks home_package)) ccs_mod + <|> lookupModuleEnv (ccs_env (bco_linked_breaks external_package)) ccs_mod + +emptyBytecodeLoaderState :: BytecodeLoaderState +emptyBytecodeLoaderState = BytecodeLoaderState + { homePackage_loaded = emptyBytecodeState + , externalPackage_loaded = emptyBytecodeState } +emptyBytecodeState :: BytecodeState +emptyBytecodeState = BytecodeState + { bco_linker_env = emptyLinkerEnv + , bco_linked_breaks = emptyLinkedBreaks + } + + +-- Some parts of the compiler can be used to load bytecode into either the home package or +-- external package state. They are parameterised by a 'BytecodeLoaderStateModifier' or +-- 'BytecodeLoaderStateTraverser' so they know which part of the state to update. + +type BytecodeLoaderStateModifier = BytecodeLoaderState -> (BytecodeState -> BytecodeState) -> BytecodeLoaderState +type BytecodeLoaderStateTraverser m = BytecodeLoaderState -> (BytecodeState -> m BytecodeState) -> m BytecodeLoaderState + +-- | Only update the home package bytecode state. +modifyHomePackageBytecodeState :: BytecodeLoaderState -> (BytecodeState -> BytecodeState) -> BytecodeLoaderState +modifyHomePackageBytecodeState bls f = runIdentity $ traverseHomePackageBytecodeState bls (return . f) + +-- | Only update the external package bytecode state. +modifyExternalPackageBytecodeState :: BytecodeLoaderState -> (BytecodeState -> BytecodeState) -> BytecodeLoaderState +modifyExternalPackageBytecodeState bls f = runIdentity $ traverseExternalPackageBytecodeState bls (return . f) + +-- | Effectfully update the home package bytecode state. +traverseHomePackageBytecodeState :: Monad m => BytecodeLoaderState -> (BytecodeState -> m BytecodeState) -> m BytecodeLoaderState +traverseHomePackageBytecodeState bls f = do + home_package <- f (homePackage_loaded bls) + return bls { homePackage_loaded = home_package } + +-- | Effectfully update the external package bytecode state. +traverseExternalPackageBytecodeState :: Monad m => BytecodeLoaderState -> (BytecodeState -> m BytecodeState) -> m BytecodeLoaderState +traverseExternalPackageBytecodeState bls f = do + external_package <- f (externalPackage_loaded bls) + return bls { externalPackage_loaded = external_package } + + +modifyBytecodeLoaderState :: BytecodeLoaderStateModifier -> LoaderState -> (BytecodeState -> BytecodeState) -> LoaderState +modifyBytecodeLoaderState modify_bytecode_loader_state pls f = pls { bco_loader_state = modify_bytecode_loader_state (bco_loader_state pls) f } + uninitializedLoader :: IO Loader uninitializedLoader = Loader <$> newMVar Nothing -modifyClosureEnv :: LoaderState -> (ClosureEnv -> ClosureEnv) -> LoaderState +modifyClosureEnv :: BytecodeState -> (ClosureEnv -> ClosureEnv) -> BytecodeState modifyClosureEnv pls f = - let le = linker_env pls + let le = bco_linker_env pls ce = closure_env le - in pls { linker_env = le { closure_env = f ce } } + in pls { bco_linker_env = le { closure_env = f ce } } data LinkerEnv = LinkerEnv { closure_env :: !ClosureEnv @@ -195,11 +307,11 @@ data LinkerEnv = LinkerEnv -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode. } -filterLinkerEnv :: (Name -> Bool) -> LinkerEnv -> LinkerEnv -filterLinkerEnv f (LinkerEnv closure_e itbl_e addr_e) = LinkerEnv - { closure_env = filterNameEnv (f . fst) closure_e - , itbl_env = filterNameEnv (f . fst) itbl_e - , addr_env = filterNameEnv (f . fst) addr_e +emptyLinkerEnv :: LinkerEnv +emptyLinkerEnv = LinkerEnv + { closure_env = emptyNameEnv + , itbl_env = emptyNameEnv + , addr_env = emptyNameEnv } type ClosureEnv = NameEnv (Name, ForeignHValue) @@ -228,10 +340,10 @@ data LinkedBreaks -- Untouched when not profiling. } -filterLinkedBreaks :: (Module -> Bool) -> LinkedBreaks -> LinkedBreaks -filterLinkedBreaks f (LinkedBreaks ba_e ccs_e) = LinkedBreaks - { breakarray_env = filterModuleEnv (\m _ -> f m) ba_e - , ccs_env = filterModuleEnv (\m _ -> f m) ccs_e +emptyLinkedBreaks :: LinkedBreaks +emptyLinkedBreaks = LinkedBreaks + { breakarray_env = emptyModuleEnv + , ccs_env = emptyModuleEnv } type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo ===================================== compiler/GHC/Runtime/Debugger.hs ===================================== @@ -56,6 +56,7 @@ import Data.List ( partition ) import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.IORef +import GHC.Linker.Types ------------------------------------- -- | The :print & friends commands @@ -161,7 +162,7 @@ bindSuspensions t = do | (name,ty) <- zip names tys] new_ic = extendInteractiveContextWithIds ictxt ids interp = hscInterp hsc_env - liftIO $ extendLoadedEnv interp (zip names fhvs) + liftIO $ extendLoadedEnv interp modifyHomePackageBytecodeState (zip names fhvs) setSession hsc_env {hsc_IC = new_ic } return t' where ===================================== compiler/GHC/Runtime/Eval.hs ===================================== @@ -64,7 +64,7 @@ import GHCi.RemoteTypes import GHC.ByteCode.Types import GHC.Linker.Loader as Loader -import GHC.Linker.Types (LinkedBreaks (..)) +import GHC.Linker.Types import GHC.Hs @@ -310,7 +310,7 @@ handleRunStatus step expr bindings final_ids status history0 = do let final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids final_names = map getName final_ids - liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals) + liftIO $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip final_names hvals) hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic} setSession hsc_env' return (ExecComplete (Right final_names) allocs) @@ -433,7 +433,7 @@ resumeExec step mbCnt , not (n `elem` old_names) ] interp = hscInterp hsc_env dflags = hsc_dflags hsc_env - liftIO $ Loader.deleteFromLoadedEnv interp new_names + liftIO $ Loader.deleteFromLoadedHomeEnv interp new_names case r of Resume { resumeStmt = expr @@ -474,18 +474,18 @@ setupBreakpoint interp ibi cnt = do getBreakArray :: Interp -> InternalBreakpointId -> InternalModBreaks -> IO (ForeignRef BreakArray) getBreakArray interp InternalBreakpointId{ibi_info_mod} imbs = do - breaks0 <- linked_breaks . fromMaybe (panic "Loader not initialised") <$> getLoaderState interp + breaks0 <- bco_linked_breaks . homePackage_loaded . bco_loader_state . fromMaybe (panic "Loader not initialised") <$> getLoaderState interp case lookupModuleEnv (breakarray_env breaks0) ibi_info_mod of Just ba -> return ba Nothing -> do modifyLoaderState interp $ \ld_st -> do - let lb = linked_breaks ld_st + let lb = bco_linked_breaks . homePackage_loaded . bco_loader_state $ ld_st -- Recall that BreakArrays are allocated only at BCO link time, so if we -- haven't linked the BCOs we intend to break at yet, we allocate the arrays here. ba_env <- allocateBreakArrays interp (breakarray_env lb) [imbs] - let ld_st' = ld_st { linked_breaks = lb{breakarray_env = ba_env} } + let ld_st' = modifyBytecodeLoaderState modifyHomePackageBytecodeState ld_st $ \bco_state -> bco_state { bco_linked_breaks = (bco_linked_breaks bco_state) { breakarray_env = ba_env } } let ba = expectJust {- just computed -} $ lookupModuleEnv ba_env ibi_info_mod return @@ -575,7 +575,7 @@ bindLocalsAtBreakpoint hsc_env apStack span Nothing = do ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id] interp = hscInterp hsc_env -- - Loader.extendLoadedEnv interp [(exn_name, apStack)] + Loader.extendLoadedEnv interp modifyHomePackageBytecodeState [(exn_name, apStack)] return (hsc_env{ hsc_IC = ictxt1 }, [exn_name]) -- Just case: we stopped at a breakpoint, we have information about the location @@ -634,8 +634,8 @@ bindLocalsAtBreakpoint hsc_env apStack_fhv span (Just ibi) = do names = map idName new_ids let fhvs = catMaybes mb_hValues - Loader.extendLoadedEnv interp (zip names fhvs) - when result_ok $ Loader.extendLoadedEnv interp [(result_name, apStack_fhv)] + Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip names fhvs) + when result_ok $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState [(result_name, apStack_fhv)] hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 } return (hsc_env1, if result_ok then result_name:names else names) where ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -851,7 +851,8 @@ distrustAllUnits pkgs = map distrust pkgs mungeUnitInfo :: FilePath -> FilePath -> UnitInfo -> UnitInfo mungeUnitInfo top_dir pkgroot = - mungeDynLibFields + mungeBytecodeLibFields + . mungeDynLibFields . mungeUnitInfoPaths (ST.pack top_dir) (ST.pack pkgroot) mungeDynLibFields :: UnitInfo -> UnitInfo @@ -862,6 +863,15 @@ mungeDynLibFields pkg = ds -> ds } +-- | Default to using library-dirs if bytecode library dirs is not explicitly set. +mungeBytecodeLibFields :: UnitInfo -> UnitInfo +mungeBytecodeLibFields pkg = + pkg { + unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of + [] -> unitLibraryDirs pkg + ds -> ds + } + -- ----------------------------------------------------------------------------- -- Modify our copy of the unit database based on trust flags, -- -trust and -distrust. ===================================== utils/ghc-pkg/Main.hs ===================================== @@ -2056,7 +2056,8 @@ checkHSLib _verbosity dirs lib = do "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib", "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib", lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll", - lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll" + lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll", + lib ++ ".bytecode" ] b <- liftIO $ doesFileExistOnPath filenames dirs when (not b) $ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/25af941ad306f08e115ab5f32f86260... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/25af941ad306f08e115ab5f32f86260... You're receiving this email because of your account on gitlab.haskell.org.