Matthew Pickering pushed to branch wip/bytecode-lib-shared-object at Glasgow Haskell Compiler / GHC

Commits:

9 changed files:

Changes:

  • compiler/GHC/ByteCode/Linker.hs
    ... ... @@ -28,7 +28,6 @@ import GHCi.ResolvedBCO
    28 28 
     import GHC.Builtin.PrimOps
    29 29 
     import GHC.Builtin.PrimOps.Ids
    30 30
    31 
    -import GHC.Unit.Module.Env
    32 31 
     import GHC.Unit.Types
    33 32
    34 33 
     import GHC.Data.FastString
    ... ... @@ -57,17 +56,16 @@ import GHC.Exts
    57 56 
     linkBCO
    58 57 
       :: Interp
    59 58 
       -> PkgsLoaded
    60 
    -  -> LinkerEnv
    61 
    -  -> LinkedBreaks
    59 
    +  -> BytecodeLoaderState
    62 60 
       -> NameEnv Int
    63 61 
       -> UnlinkedBCO
    64 62 
       -> IO ResolvedBCO
    65 
    -linkBCO interp pkgs_loaded le lb bco_ix
    63 
    +linkBCO interp pkgs_loaded bytecode_state bco_ix
    66 64 
                (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
    67 65 
       -- fromIntegral Word -> Word64 should be a no op if Word is Word64
    68 66 
       -- otherwise it will result in a cast to longlong on 32bit systems.
    69 
    -  (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le lb) (elemsFlatBag lits0)
    70 
    -  ptrs <- mapM (resolvePtr interp pkgs_loaded le lb bco_ix) (elemsFlatBag ptrs0)
    67 
    +  (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded bytecode_state) (elemsFlatBag lits0)
    68 
    +  ptrs <- mapM (resolvePtr interp pkgs_loaded bytecode_state bco_ix) (elemsFlatBag ptrs0)
    71 69 
       let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits
    72 70 
       return $ ResolvedBCO { resolvedBCOIsLE   = isLittleEndian
    73 71 
                            , resolvedBCOArity  = arity
    ... ... @@ -77,17 +75,17 @@ linkBCO interp pkgs_loaded le lb bco_ix
    77 75 
                            , resolvedBCOPtrs   = addListToSS emptySS ptrs
    78 76 
                            }
    79 77
    80 
    -lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> LinkedBreaks -> BCONPtr -> IO Word
    81 
    -lookupLiteral interp pkgs_loaded le lb ptr = case ptr of
    78 
    +lookupLiteral :: Interp -> PkgsLoaded -> BytecodeLoaderState -> BCONPtr -> IO Word
    79 
    +lookupLiteral interp pkgs_loaded bytecode_state ptr = case ptr of
    82 80 
       BCONPtrWord lit -> return lit
    83 81 
       BCONPtrLbl  sym -> do
    84 82 
         Ptr a# <- lookupStaticPtr interp sym
    85 83 
         return (W# (int2Word# (addr2Int# a#)))
    86 84 
       BCONPtrItbl nm -> do
    87 
    -    Ptr a# <- lookupIE interp pkgs_loaded (itbl_env le) nm
    85 
    +    Ptr a# <- lookupIE interp pkgs_loaded bytecode_state nm
    88 86 
         return (W# (int2Word# (addr2Int# a#)))
    89 87 
       BCONPtrAddr nm -> do
    90 
    -    Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm
    88 
    +    Ptr a# <- lookupAddr interp pkgs_loaded bytecode_state nm
    91 89 
         return (W# (int2Word# (addr2Int# a#)))
    92 90 
       BCONPtrStr bs -> do
    93 91 
         RemotePtr p <- fmap head $ interpCmd interp $ MallocStrings [bs]
    ... ... @@ -100,7 +98,7 @@ lookupLiteral interp pkgs_loaded le lb ptr = case ptr of
    100 98 
         pure $ fromIntegral p
    101 99 
       BCONPtrCostCentre InternalBreakpointId{..}
    102 100 
         | interpreterProfiled interp -> do
    103 
    -        case expectJust (lookupModuleEnv (ccs_env lb) ibi_info_mod) ! ibi_info_index of
    101 
    +        case expectJust (lookupCCSBytecodeState bytecode_state ibi_info_mod) ! ibi_info_index of
    104 102 
               RemotePtr p -> pure $ fromIntegral p
    105 103 
         | otherwise ->
    106 104 
             case toRemotePtr nullPtr of
    ... ... @@ -114,9 +112,9 @@ lookupStaticPtr interp addr_of_label_string = do
    114 112 
         Nothing  -> linkFail "GHC.ByteCode.Linker: can't find label"
    115 113 
                       (ppr addr_of_label_string)
    116 114
    117 
    -lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ())
    118 
    -lookupIE interp pkgs_loaded ie con_nm =
    119 
    -  case lookupNameEnv ie con_nm of
    115 
    +lookupIE :: Interp -> PkgsLoaded -> BytecodeLoaderState -> Name -> IO (Ptr ())
    116 
    +lookupIE interp pkgs_loaded bytecode_state con_nm =
    117 
    +  case lookupInfoTableBytecodeState bytecode_state con_nm of
    120 118 
         Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))
    121 119 
         Nothing -> do -- try looking up in the object files.
    122 120 
            let sym_to_find1 = IConInfoSymbol con_nm
    ... ... @@ -134,9 +132,9 @@ lookupIE interp pkgs_loaded ie con_nm =
    134 132 
                                            ppr sym_to_find2)
    135 133
    136 134 
     -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
    137 
    -lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ())
    138 
    -lookupAddr interp pkgs_loaded ae addr_nm = do
    139 
    -  case lookupNameEnv ae addr_nm of
    135 
    +lookupAddr :: Interp -> PkgsLoaded -> BytecodeLoaderState -> Name -> IO (Ptr ())
    136 
    +lookupAddr interp pkgs_loaded bytecode_state addr_nm = do
    137 
    +  case lookupAddressBytecodeState bytecode_state addr_nm of
    140 138 
         Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr)
    141 139 
         Nothing -> do -- try looking up in the object files.
    142 140 
           let sym_to_find = IBytesSymbol addr_nm
    ... ... @@ -158,17 +156,16 @@ lookupPrimOp interp pkgs_loaded primop = do
    158 156 
     resolvePtr
    159 157 
       :: Interp
    160 158 
       -> PkgsLoaded
    161 
    -  -> LinkerEnv
    162 
    -  -> LinkedBreaks
    159 
    +  -> BytecodeLoaderState
    163 160 
       -> NameEnv Int
    164 161 
       -> BCOPtr
    165 162 
       -> IO ResolvedBCOPtr
    166 
    -resolvePtr interp pkgs_loaded le lb bco_ix ptr = case ptr of
    163 
    +resolvePtr interp pkgs_loaded bco_loader_state bco_ix ptr = case ptr of
    167 164 
       BCOPtrName nm
    168 165 
         | Just ix <- lookupNameEnv bco_ix nm
    169 166 
         -> return (ResolvedBCORef ix) -- ref to another BCO in this group
    170 167
    171 
    -    | Just (_, rhv) <- lookupNameEnv (closure_env le) nm
    168 
    +    | Just (_, rhv) <- lookupNameBytecodeState bco_loader_state nm
    172 169 
         -> return (ResolvedBCOPtr (unsafeForeignRefToRemoteRef rhv))
    173 170
    174 171 
         | otherwise
    ... ... @@ -184,10 +181,10 @@ resolvePtr interp pkgs_loaded le lb bco_ix ptr = case ptr of
    184 181 
         -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op
    185 182
    186 183 
       BCOPtrBCO bco
    187 
    -    -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le lb bco_ix bco
    184 
    +    -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded bco_loader_state bco_ix bco
    188 185
    189 186 
       BCOPtrBreakArray tick_mod ->
    190 
    -    withForeignRef (expectJust (lookupModuleEnv (breakarray_env lb) tick_mod)) $
    187 
    +    withForeignRef (expectJust (lookupBreakArrayBytecodeState bco_loader_state tick_mod)) $
    191 188 
           \ba -> pure $ ResolvedBCOPtrBreakArray ba
    192 189
    193 190 
     -- | Look up the address of a Haskell symbol in the currently

  • compiler/GHC/Driver/Make.hs
    ... ... @@ -822,7 +822,7 @@ pruneCache hpt summ
    822 822 
     unload :: Interp -> HscEnv -> IO ()
    823 823 
     unload interp hsc_env
    824 824 
       = case ghcLink (hsc_dflags hsc_env) of
    825 
    -        LinkInMemory -> Linker.unload interp hsc_env []
    825 
    +        LinkInMemory -> Linker.unload interp hsc_env
    826 826 
             _other -> return ()
    827 827
    828 828

  • compiler/GHC/Driver/Phases.hs
    ... ... @@ -32,6 +32,7 @@ module GHC.Driver.Phases (
    32 32 
        isHaskellSrcFilename,
    33 33 
        isHaskellSigFilename,
    34 34 
        isObjectFilename,
    35 
    +   isBytecodeFilename,
    35 36 
        isCishFilename,
    36 37 
        isDynLibFilename,
    37 38 
        isHaskellUserSrcFilename,
    ... ... @@ -235,7 +236,9 @@ phaseInputExt Js = "js"
    235 236 
     phaseInputExt StopLn              = "o"
    236 237
    237 238 
     haskellish_src_suffixes, backpackish_suffixes, haskellish_suffixes, cish_suffixes,
    238 
    -    js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes, haskellish_boot_suffixes
    239 
    +    js_suffixes, haskellish_user_src_suffixes, haskellish_sig_suffixes, haskellish_boot_suffixes,
    240 
    +    bytecode_suffixes
    241 
    +
    239 242 
      :: [String]
    240 243 
     -- When a file with an extension in the haskellish_src_suffixes group is
    241 244 
     -- loaded in --make mode, its imports will be loaded too.
    ... ... @@ -252,6 +255,7 @@ haskellish_user_src_suffixes =
    252 255 
     haskellish_boot_suffixes     = [ "hs-boot", "lhs-boot" ]
    253 256 
     haskellish_sig_suffixes      = [ "hsig", "lhsig" ]
    254 257 
     backpackish_suffixes         = [ "bkp" ]
    258 
    +bytecode_suffixes            = [ "gbc" ]
    255 259
    256 260 
     objish_suffixes :: Platform -> [String]
    257 261 
     -- Use the appropriate suffix for the system on which
    ... ... @@ -267,7 +271,8 @@ dynlib_suffixes platform = case platformOS platform of
    267 271 
       _         -> ["so"]
    268 272
    269 273 
     isHaskellishSuffix, isBackpackishSuffix, isHaskellSrcSuffix, isCishSuffix,
    270 
    -    isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix, isHaskellBootSuffix
    274 
    +    isHaskellUserSrcSuffix, isJsSuffix, isHaskellSigSuffix, isHaskellBootSuffix,
    275 
    +    isBytecodeSuffix
    271 276 
      :: String -> Bool
    272 277 
     isHaskellishSuffix     s = s `elem` haskellish_suffixes
    273 278 
     isBackpackishSuffix    s = s `elem` backpackish_suffixes
    ... ... @@ -277,6 +282,7 @@ isHaskellSrcSuffix s = s `elem` haskellish_src_suffixes
    277 282 
     isCishSuffix           s = s `elem` cish_suffixes
    278 283 
     isJsSuffix             s = s `elem` js_suffixes
    279 284 
     isHaskellUserSrcSuffix s = s `elem` haskellish_user_src_suffixes
    285 
    +isBytecodeSuffix       s = s `elem` bytecode_suffixes
    280 286
    281 287 
     isObjectSuffix, isDynLibSuffix :: Platform -> String -> Bool
    282 288 
     isObjectSuffix platform s = s `elem` objish_suffixes platform
    ... ... @@ -306,7 +312,8 @@ isHaskellishTarget (_,Just phase) =
    306 312 
                       , StopLn]
    307 313
    308 314 
     isHaskellishFilename, isHaskellSrcFilename, isCishFilename,
    309 
    -    isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename
    315 
    +    isHaskellUserSrcFilename, isSourceFilename, isHaskellSigFilename,
    316 
    +    isBytecodeFilename
    310 317 
      :: FilePath -> Bool
    311 318 
     -- takeExtension return .foo, so we drop 1 to get rid of the .
    312 319 
     isHaskellishFilename     f = isHaskellishSuffix     (drop 1 $ takeExtension f)
    ... ... @@ -315,6 +322,7 @@ isCishFilename f = isCishSuffix (drop 1 $ takeExtension f)
    315 322 
     isHaskellUserSrcFilename f = isHaskellUserSrcSuffix (drop 1 $ takeExtension f)
    316 323 
     isSourceFilename         f = isSourceSuffix         (drop 1 $ takeExtension f)
    317 324 
     isHaskellSigFilename     f = isHaskellSigSuffix     (drop 1 $ takeExtension f)
    325 
    +isBytecodeFilename       f = isBytecodeSuffix       (drop 1 $ takeExtension f)
    318 326
    319 327 
     isObjectFilename, isDynLibFilename :: Platform -> FilePath -> Bool
    320 328 
     isObjectFilename platform f = isObjectSuffix platform (drop 1 $ takeExtension f)

  • compiler/GHC/Linker/Loader.hs
    ... ... @@ -27,7 +27,7 @@ module GHC.Linker.Loader
    27 27 
        -- * LoadedEnv
    28 28 
        , withExtendedLoadedEnv
    29 29 
        , extendLoadedEnv
    30 
    -   , deleteFromLoadedEnv
    30 
    +   , deleteFromLoadedHomeEnv
    31 31 
        , lookupFromLoadedEnv
    32 32 
        -- * Internals
    33 33 
        , allocateBreakArrays
    ... ... @@ -183,19 +183,11 @@ getLoaderState interp = readMVar (loader_state (interpLoader interp))
    183 183
    184 184 
     emptyLoaderState :: LoaderState
    185 185 
     emptyLoaderState = LoaderState
    186 
    -   { linker_env = LinkerEnv
    187 
    -     { closure_env = emptyNameEnv
    188 
    -     , itbl_env    = emptyNameEnv
    189 
    -     , addr_env    = emptyNameEnv
    190 
    -     }
    186 
    +   { bco_loader_state = emptyBytecodeLoaderState
    191 187 
        , pkgs_loaded = init_pkgs
    192 188 
        , bcos_loaded = emptyModuleEnv
    193 189 
        , objs_loaded = emptyModuleEnv
    194 190 
        , temp_sos = []
    195 
    -   , linked_breaks = LinkedBreaks
    196 
    -     { breakarray_env = emptyModuleEnv
    197 
    -     , ccs_env        = emptyModuleEnv
    198 
    -     }
    199 191 
        }
    200 192 
       -- Packages that don't need loading, because the compiler
    201 193 
       -- shares them with the interpreted program.
    ... ... @@ -204,18 +196,18 @@ emptyLoaderState = LoaderState
    204 196 
       -- explicit list.  See rts/Linker.c for details.
    205 197 
       where init_pkgs = unitUDFM rtsUnitId (LoadedPkgInfo rtsUnitId [] [] [] emptyUniqDSet)
    206 198
    207 
    -extendLoadedEnv :: Interp -> [(Name,ForeignHValue)] -> IO ()
    208 
    -extendLoadedEnv interp new_bindings =
    199 
    +extendLoadedEnv :: Interp -> BytecodeLoaderStateModifier -> [(Name,ForeignHValue)] -> IO ()
    200 
    +extendLoadedEnv interp modify_bytecode_loader_state new_bindings =
    209 201 
       modifyLoaderState_ interp $ \pls -> do
    210 
    -    return $! modifyClosureEnv pls $ \ce ->
    211 
    -      extendClosureEnv ce new_bindings
    202 
    +    return $! modifyBytecodeLoaderState modify_bytecode_loader_state pls $ \bco_loader_state ->
    203 
    +      modifyClosureEnv bco_loader_state $ \ce -> extendClosureEnv ce new_bindings
    212 204 
         -- strictness is important for not retaining old copies of the pls
    213 205
    214 
    -deleteFromLoadedEnv :: Interp -> [Name] -> IO ()
    215 
    -deleteFromLoadedEnv interp to_remove =
    206 
    +deleteFromLoadedHomeEnv :: Interp -> [Name] -> IO ()
    207 
    +deleteFromLoadedHomeEnv interp to_remove =
    216 208 
       modifyLoaderState_ interp $ \pls -> do
    217 
    -    return $ modifyClosureEnv pls $ \ce ->
    218 
    -      delListFromNameEnv ce to_remove
    209 
    +    return $ modifyBytecodeLoaderState modifyHomePackageBytecodeState pls $ \bco_state ->
    210 
    +      modifyClosureEnv bco_state $ \ce -> delListFromNameEnv ce to_remove
    219 211
    220 212 
     -- | Have we already loaded a name into the interpreter?
    221 213 
     lookupFromLoadedEnv :: Interp -> Name -> IO (Maybe ForeignHValue)
    ... ... @@ -223,7 +215,7 @@ lookupFromLoadedEnv interp name = do
    223 215 
       mstate <- getLoaderState interp
    224 216 
       return $ do
    225 217 
         pls <- mstate
    226 
    -    res <- lookupNameEnv (closure_env (linker_env pls)) name
    218 
    +    res <- lookupNameBytecodeState (bco_loader_state pls) name
    227 219 
         return (snd res)
    228 220
    229 221 
     -- | Load the module containing the given Name and get its associated 'HValue'.
    ... ... @@ -242,7 +234,7 @@ loadName interp hsc_env name = do
    242 234 
                then throwGhcExceptionIO (ProgramError "")
    243 235 
                else return (pls', links, pkgs)
    244 236
    245 
    -    case lookupNameEnv (closure_env (linker_env pls)) name of
    237 
    +    case lookupNameBytecodeState (bco_loader_state pls) name of
    246 238 
           Just (_,aa) -> return (pls,(aa, links, pkgs))
    247 239 
           Nothing     -> assertPpr (isExternalName name) (ppr name) $
    248 240 
                          do let sym_to_find = IClosureSymbol name
    ... ... @@ -289,7 +281,7 @@ withExtendedLoadedEnv
    289 281 
       -> m a
    290 282 
       -> m a
    291 283 
     withExtendedLoadedEnv interp new_env action
    292 
    -    = MC.bracket (liftIO $ extendLoadedEnv interp new_env)
    284 
    +    = MC.bracket (liftIO $ extendLoadedEnv interp modifyHomePackageBytecodeState new_env)
    293 285 
                    (\_ -> reset_old_env)
    294 286 
                    (\_ -> action)
    295 287 
         where
    ... ... @@ -299,7 +291,7 @@ withExtendedLoadedEnv interp new_env action
    299 291 
             -- package), so the reset action only removes the names we
    300 292 
             -- added earlier.
    301 293 
               reset_old_env = liftIO $
    302 
    -            deleteFromLoadedEnv interp (map fst new_env)
    294 
    +            deleteFromLoadedHomeEnv interp (map fst new_env)
    303 295
    304 296
    305 297 
     -- | Display the loader state.
    ... ... @@ -862,7 +854,7 @@ loadObjects interp hsc_env pls objs = do
    862 854 
                         if succeeded ok then
    863 855 
                                 return (pls1, Succeeded)
    864 856 
                           else do
    865 
    -                            pls2 <- unload_wkr interp [] pls1
    857 
    +                            pls2 <- unload_wkr interp pls1
    866 858 
                                 return (pls2, Failed)
    867 859
    868 860
    ... ... @@ -981,21 +973,33 @@ dynLinkBCOs interp pls keep_spec bcos =
    981 973
    982 974 
                 cbcs :: [CompiledByteCode]
    983 975 
                 cbcs = concatMap linkableBCOs new_bcos
    984 
    -        in dynLinkCompiledByteCode interp pls1 keep_spec cbcs
    985 
    -
    986 
    -dynLinkCompiledByteCode :: Interp -> LoaderState -> KeepModuleLinkableDefinitions -> [CompiledByteCode] -> IO LoaderState
    987 
    -dynLinkCompiledByteCode interp pls keep_spec cbcs = do
    988 
    -        let
    989 
    -            le1 = linker_env pls
    990 
    -            lb1 = linked_breaks pls
    991 
    -        ie2 <- linkITbls interp (itbl_env le1) (concatMap bc_itbls cbcs)
    992 
    -        ae2 <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le1) cbcs
    993 
    -        be2 <- allocateBreakArrays interp (breakarray_env lb1) (catMaybes $ map bc_breaks cbcs)
    994 
    -        ce2 <- allocateCCS         interp (ccs_env lb1)        (catMaybes $ map bc_breaks cbcs)
    995 
    -        let le2 = le1 { itbl_env = ie2, addr_env = ae2 }
    996 
    -        let lb2 = lb1 { breakarray_env = be2, ccs_env = ce2 }
    997 
    -
    998 
    -        names_and_refs <- linkSomeBCOs interp (pkgs_loaded pls) le2 lb2 cbcs
    976 
    +        in do
    977 
    +          bco_state <- dynLinkCompiledByteCode interp (pkgs_loaded pls) (bco_loader_state pls) traverseHomePackageBytecodeState keep_spec cbcs
    978 
    +          return $! pls1 { bco_loader_state = bco_state }
    979 
    +
    980 
    +dynLinkCompiledByteCode :: Interp
    981 
    +                        -> PkgsLoaded
    982 
    +                        -> BytecodeLoaderState
    983 
    +                        -> BytecodeLoaderStateTraverser IO  -- ^ The traverser tells us to update home package bytecode state or external package bytecode state
    984 
    +                        -> KeepModuleLinkableDefinitions
    985 
    +                        -> [CompiledByteCode]
    986 
    +                        -> IO BytecodeLoaderState
    987 
    +dynLinkCompiledByteCode interp pkgs_loaded whole_bytecode_state traverse_bytecode_state keep_spec cbcs = do
    988 
    +        st1 <- traverse_bytecode_state whole_bytecode_state $ \bytecode_state -> do
    989 
    +          let
    990 
    +              le1 = bco_linker_env bytecode_state
    991 
    +              lb1 = bco_linked_breaks bytecode_state
    992 
    +          ie2 <- linkITbls interp (itbl_env le1) (concatMap bc_itbls cbcs)
    993 
    +          ae2 <- foldlM (\env cbc -> allocateTopStrings interp (bc_strs cbc) env) (addr_env le1) cbcs
    994 
    +          be2 <- allocateBreakArrays interp (breakarray_env lb1) (catMaybes $ map bc_breaks cbcs)
    995 
    +          ce2 <- allocateCCS         interp (ccs_env lb1)        (catMaybes $ map bc_breaks cbcs)
    996 
    +          let le2 = le1 { itbl_env = ie2, addr_env = ae2 }
    997 
    +          let lb2 = lb1 { breakarray_env = be2, ccs_env = ce2 }
    998 
    +          return $! bytecode_state { bco_linker_env = le2, bco_linked_breaks = lb2 }
    999 
    +
    1000 
    +        -- NB: Important to pass the whole bytecode loader state to linkSomeBCOs so that you can find Names in local
    1001 
    +        -- and external packages.
    1002 
    +        names_and_refs <- linkSomeBCOs interp pkgs_loaded st1 cbcs
    999 1003
    1000 1004 
             -- We only want to add the external ones to the ClosureEnv
    1001 1005 
             let (to_add, to_drop) = partition (keepDefinitions keep_spec . fst) names_and_refs
    ... ... @@ -1005,14 +1009,11 @@ dynLinkCompiledByteCode interp pls keep_spec cbcs = do
    1005 1009 
             -- Wrap finalizers on the ones we want to keep
    1006 1010 
             new_binds <- makeForeignNamedHValueRefs interp to_add
    1007 1011
    1008 
    -
    1009 
    -        let ce2 = extendClosureEnv (closure_env le2) new_binds
    1010 
    -
    1011 
    -        -- Add SPT entries
    1012 
    -        mapM_ (linkSptEntry interp ce2) (concatMap bc_spt_entries cbcs)
    1013 
    -
    1014 
    -        return $! pls { linker_env = le2 { closure_env = ce2 }
    1015 
    -                      , linked_breaks = lb2 }
    1012 
    +        traverse_bytecode_state st1 $ \bytecode_state -> do
    1013 
    +          let ce2 = extendClosureEnv (closure_env (bco_linker_env bytecode_state)) new_binds
    1014 
    +          -- Add SPT entries
    1015 
    +          mapM_ (linkSptEntry interp ce2) (concatMap bc_spt_entries cbcs)
    1016 
    +          return $! bytecode_state { bco_linker_env = (bco_linker_env bytecode_state) { closure_env = ce2 } }
    1016 1017
    1017 1018 
     -- | Register SPT entries for this module in the interpreter
    1018 1019 
     -- 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
    1030 1031 
     -- Link a bunch of BCOs and return references to their values
    1031 1032 
     linkSomeBCOs :: Interp
    1032 1033 
                  -> PkgsLoaded
    1033 
    -             -> LinkerEnv
    1034 
    -             -> LinkedBreaks
    1034 
    +             -> BytecodeLoaderState
    1035 1035 
                  -> [CompiledByteCode]
    1036 1036 
                  -> IO [(Name,HValueRef)]
    1037 1037 
                             -- The returned HValueRefs are associated 1-1 with
    1038 1038 
                             -- the incoming unlinked BCOs.  Each gives the
    1039 1039 
                             -- value of the corresponding unlinked BCO
    1040 1040
    1041 
    -linkSomeBCOs interp pkgs_loaded le lb mods = foldr fun do_link mods []
    1041 
    +linkSomeBCOs interp pkgs_loaded bytecode_state mods = foldr fun do_link mods []
    1042 1042 
      where
    1043 1043 
       fun CompiledByteCode{..} inner accum =
    1044 1044 
         inner (Foldable.toList bc_bcos : accum)
    ... ... @@ -1048,7 +1048,7 @@ linkSomeBCOs interp pkgs_loaded le lb mods = foldr fun do_link mods []
    1048 1048 
         let flat = [ bco | bcos <- mods, bco <- bcos ]
    1049 1049 
             names = map unlinkedBCOName flat
    1050 1050 
             bco_ix = mkNameEnv (zip names [0..])
    1051 
    -    resolved <- sequence [ linkBCO interp pkgs_loaded le lb bco_ix bco | bco <- flat ]
    1051 
    +    resolved <- sequence [ linkBCO interp pkgs_loaded bytecode_state bco_ix bco | bco <- flat ]
    1052 1052 
         hvrefs <- createBCOs interp resolved
    1053 1053 
         return (zip names hvrefs)
    1054 1054
    ... ... @@ -1071,66 +1071,39 @@ linkITbls interp = foldlM $ \env (nm, itbl) -> do
    1071 1071
    1072 1072 
     -- ---------------------------------------------------------------------------
    1073 1073 
     -- | Unloading old objects ready for a new compilation sweep.
    1074 
    ---
    1075 
    --- The compilation manager provides us with a list of linkables that it
    1076 
    --- considers \"stable\", i.e. won't be recompiled this time around.  For
    1077 
    --- each of the modules current linked in memory,
    1078 
    ---
    1079 
    ---   * if the linkable is stable (and it's the same one -- the user may have
    1080 
    ---     recompiled the module on the side), we keep it,
    1081 
    ---
    1082 
    ---   * otherwise, we unload it.
    1083 
    ---
    1074 
    +--   * compilation artifacts for home modules that we might be about to recompile
    1075 
    +--     are unloaded from the interpreter.
    1084 1076 
     --   * we also implicitly unload all temporary bindings at this point.
    1085 1077 
     --
    1086 1078 
     unload
    1087 1079 
       :: Interp
    1088 1080 
       -> HscEnv
    1089 
    -  -> [Linkable] -- ^ The linkables to *keep*.
    1090 1081 
       -> IO ()
    1091 
    -unload interp hsc_env linkables
    1082 
    +unload interp hsc_env
    1092 1083 
       = mask_ $ do -- mask, so we're safe from Ctrl-C in here
    1093 1084
    1094 1085 
             -- Initialise the linker (if it's not been done already)
    1095 1086 
             initLoaderState interp hsc_env
    1096 1087
    1097 
    -        new_pls
    1098 
    -            <- modifyLoaderState interp $ \pls -> do
    1099 
    -                 pls1 <- unload_wkr interp linkables pls
    1088 
    +        _new_pls <- modifyLoaderState interp $ \pls -> do
    1089 
    +                 pls1 <- unload_wkr interp pls
    1100 1090 
                      return (pls1, pls1)
    1101 1091
    1102 
    -        let logger = hsc_logger hsc_env
    1103 
    -        debugTraceMsg logger 3 $
    1104 
    -          text "unload: retaining objs" <+> ppr (moduleEnvElts $ objs_loaded new_pls)
    1105 
    -        debugTraceMsg logger 3 $
    1106 
    -          text "unload: retaining bcos" <+> ppr (moduleEnvElts $ bcos_loaded new_pls)
    1107 1092 
             return ()
    1108 1093
    1109 1094 
     unload_wkr
    1110 1095 
       :: Interp
    1111 
    -  -> [Linkable]                -- stable linkables
    1112 1096 
       -> LoaderState
    1113 1097 
       -> IO LoaderState
    1114 1098 
     -- Does the core unload business
    1115 1099 
     -- (the wrapper blocks exceptions and deals with the LS get and put)
    1116 1100
    1117 
    -unload_wkr interp keep_linkables pls@LoaderState{..}  = do
    1101 
    +unload_wkr interp pls@LoaderState{..}  = do
    1118 1102 
       -- NB. careful strictness here to avoid keeping the old LS when
    1119 1103 
       -- we're unloading some code.  -fghci-leak-check with the tests in
    1120 1104 
       -- testsuite/ghci can detect space leaks here.
    1121 1105
    1122 
    -  let (objs_to_keep', bcos_to_keep') = partition linkableIsNativeCodeOnly keep_linkables
    1123 
    -      objs_to_keep = mkLinkableSet objs_to_keep'
    1124 
    -      bcos_to_keep = mkLinkableSet bcos_to_keep'
    1125 
    -
    1126 
    -      discard keep l = not (linkableInSet l keep)
    1127 
    -
    1128 
    -      (objs_to_unload, remaining_objs_loaded) =
    1129 
    -         partitionModuleEnv (discard objs_to_keep) objs_loaded
    1130 
    -      (bcos_to_unload, remaining_bcos_loaded) =
    1131 
    -         partitionModuleEnv (discard bcos_to_keep) bcos_loaded
    1132 
    -
    1133 
    -      linkables_to_unload = moduleEnvElts objs_to_unload ++ moduleEnvElts bcos_to_unload
    1106 
    +  let linkables_to_unload = moduleEnvElts objs_loaded ++ moduleEnvElts bcos_loaded
    1134 1107
    1135 1108 
       mapM_ unloadObjs linkables_to_unload
    1136 1109
    ... ... @@ -1139,20 +1112,10 @@ unload_wkr interp keep_linkables pls@LoaderState{..} = do
    1139 1112 
       when (not (null (filter (not . null . linkableObjs) linkables_to_unload))) $
    1140 1113 
         purgeLookupSymbolCache interp
    1141 1114
    1142 
    -  let -- Note that we want to remove all *local*
    1143 
    -      -- (i.e. non-isExternal) names too (these are the
    1144 
    -      -- temporary bindings from the command line).
    1145 
    -      keep_name :: Name -> Bool
    1146 
    -      keep_name n = isExternalName n &&
    1147 
    -                    nameModule n `elemModuleEnv` remaining_bcos_loaded
    1148 
    -
    1149 
    -      keep_mod :: Module -> Bool
    1150 
    -      keep_mod m = m `elemModuleEnv` remaining_bcos_loaded
    1151 
    -
    1152 
    -      !new_pls = pls { linker_env    = filterLinkerEnv keep_name linker_env,
    1153 
    -                       linked_breaks = filterLinkedBreaks keep_mod linked_breaks,
    1154 
    -                       bcos_loaded   = remaining_bcos_loaded,
    1155 
    -                       objs_loaded   = remaining_objs_loaded }
    1115 
    +  let !new_pls = pls { bco_loader_state = modifyHomePackageBytecodeState bco_loader_state $ \_ -> emptyBytecodeState,
    1116 
    +                       -- NB: we don't unload the external package
    1117 
    +                       bcos_loaded   = emptyModuleEnv,
    1118 
    +                       objs_loaded   = emptyModuleEnv }
    1156 1119
    1157 1120 
       return new_pls
    1158 1121 
       where
    ... ... @@ -1296,6 +1259,8 @@ loadPackage interp hsc_env pkgs pls
    1296 1259 
                <- sequenceA [mapM (locateLib interp hsc_env False [] dirs_env_ gcc_paths) extra_libs_ | (dirs_env_, extra_libs_) <- zip dirs_env extra_libs]
    1297 1260 
             let classifieds = zipWith (++) hs_classifieds extra_classifieds
    1298 1261
    1262 
    +        maybePutSDoc logger (text "Using these library specs: " $$ (vcat (map ppr classifieds)))
    1263 
    +
    1299 1264 
             -- Complication: all the .so's must be loaded before any of the .o's.
    1300 1265 
             let known_hs_dlls    = [[ dll | DLLPath dll <- hs_classifieds_ ] | hs_classifieds_ <- hs_classifieds]
    1301 1266 
                 known_extra_dlls = [ dll | extra_classifieds_ <- extra_classifieds, DLLPath dll <- extra_classifieds_ ]
    ... ... @@ -1372,15 +1337,19 @@ loadBytecodeLibrary hsc_env interp pls path = do
    1372 1337 
       -- 0. Get the modification time of the module
    1373 1338 
       _mod_time <- expectJust <$> modificationTimeIfExists path'
    1374 1339 
       -- 1. Read the bytecode library
    1375 
    -  (BytecodeLib _uid cbcs stubs_so) <- decodeOnDiskBytecodeLib hsc_env =<< readBytecodeLib hsc_env path'
    1376 
    -  pls' <-case stubs_so of
    1340 
    +  (BytecodeLib uid cbcs stubs_so) <- decodeOnDiskBytecodeLib hsc_env =<< readBytecodeLib hsc_env path'
    1341 
    +  debugTraceMsg (hsc_logger hsc_env) 3 $ text "loadBytecodeLibrary: " $$ vcat [ text "uid: " <+> ppr uid
    1342 
    +                                                                             , text "cbcs: " <+> ppr (length cbcs)
    1343 
    +                                                                             , text "stubs_so: " <+> ppr stubs_so ]
    1344 
    +  pls' <- case stubs_so of
    1377 1345 
         Nothing -> return pls
    1378 1346 
         Just (SharedObject so_file libdir libname) -> do
    1379 1347 
           m <- loadDLLs interp [so_file]
    1380 1348 
           case m of
    1381 1349 
             Right _ -> return $! pls { temp_sos = (libdir, libname) : temp_sos pls }
    1382 1350 
             Left err -> linkFail err (text err)
    1383 
    -  dynLinkCompiledByteCode interp pls' KeepExternalDefinitions cbcs
    1351 
    +  bco_state <- dynLinkCompiledByteCode interp (pkgs_loaded pls') (bco_loader_state pls') traverseExternalPackageBytecodeState KeepExternalDefinitions cbcs
    1352 
    +  return $! pls' { bco_loader_state = bco_state }
    1384 1353
    1385 1354
    1386 1355 
     {-

  • compiler/GHC/Linker/Types.hs
    ... ... @@ -12,14 +12,32 @@ module GHC.Linker.Types
    12 12 
        ( Loader (..)
    13 13 
        , LoaderState (..)
    14 14 
        , uninitializedLoader
    15 
    +
    16 
    +   -- * Bytecode Loader State
    17 
    +   , BytecodeLoaderState(..)
    18 
    +   , BytecodeState(..)
    19 
    +   , emptyBytecodeLoaderState
    20 
    +   , emptyBytecodeState
    21 
    +   , modifyHomePackageBytecodeState
    22 
    +   , modifyExternalPackageBytecodeState
    23 
    +   , modifyBytecodeLoaderState
    24 
    +   , lookupNameBytecodeState
    25 
    +   , lookupBreakArrayBytecodeState
    26 
    +   , lookupInfoTableBytecodeState
    27 
    +   , lookupAddressBytecodeState
    28 
    +   , lookupCCSBytecodeState
    29 
    +   , BytecodeLoaderStateModifier
    30 
    +   , BytecodeLoaderStateTraverser
    31 
    +   , traverseHomePackageBytecodeState
    32 
    +   , traverseExternalPackageBytecodeState
    15 33 
        , modifyClosureEnv
    16 34 
        , LinkerEnv(..)
    17 
    -   , filterLinkerEnv
    35 
    +   , emptyLinkerEnv
    18 36 
        , ClosureEnv
    19 37 
        , emptyClosureEnv
    20 38 
        , extendClosureEnv
    21 39 
        , LinkedBreaks(..)
    22 
    -   , filterLinkedBreaks
    40 
    +   , emptyLinkedBreaks
    23 41 
        , LinkableSet
    24 42 
        , mkLinkableSet
    25 43 
        , unionLinkableSet
    ... ... @@ -62,7 +80,7 @@ import GHCi.RemoteTypes
    62 80 
     import GHCi.Message            ( LoadedDLL )
    63 81
    64 82 
     import GHC.Stack.CCS
    65 
    -import GHC.Types.Name.Env      ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv )
    83 
    +import GHC.Types.Name.Env      ( NameEnv, emptyNameEnv, extendNameEnvList, lookupNameEnv )
    66 84 
     import GHC.Types.Name          ( Name )
    67 85 
     import GHC.Types.SptEntry
    68 86
    ... ... @@ -78,6 +96,8 @@ import GHC.Unit.Module.WholeCoreBindings
    78 96 
     import Data.Maybe (mapMaybe)
    79 97 
     import Data.List.NonEmpty (NonEmpty, nonEmpty)
    80 98 
     import qualified Data.List.NonEmpty as NE
    99 
    +import Control.Applicative ((<|>))
    100 
    +import Data.Functor.Identity
    81 101
    82 102
    83 103 
     {- **********************************************************************
    ... ... @@ -149,8 +169,9 @@ and be able to lookup symbols specifically in them too (similarly to
    149 169 
     newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) }
    150 170
    151 171 
     data LoaderState = LoaderState
    152 
    -    { linker_env :: !LinkerEnv
    153 
    -        -- ^ Current global mapping from Names to their true values
    172 
    +    { bco_loader_state :: !BytecodeLoaderState
    173 
    +        -- ^ Information about bytecode objects we have loaded into the
    174 
    +        -- interpreter.
    154 175
    155 176 
         , bcos_loaded :: !LinkableSet
    156 177 
             -- ^ The currently loaded interpreted modules (home package)
    ... ... @@ -165,19 +186,110 @@ data LoaderState = LoaderState
    165 186 
         , temp_sos :: ![(FilePath, String)]
    166 187 
             -- ^ We need to remember the name of previous temporary DLL/.so
    167 188 
             -- libraries so we can link them (see #10322)
    189 
    +    }
    168 190
    169 
    -    , linked_breaks :: !LinkedBreaks
    191 
    +data BytecodeState = BytecodeState
    192 
    +        { bco_linker_env :: !LinkerEnv
    193 
    +        -- ^ Current global mapping from Names to their true values
    194 
    +        , bco_linked_breaks :: !LinkedBreaks
    170 195 
             -- ^ Mapping from loaded modules to their breakpoint arrays
    196 
    +        }
    197 
    +
    198 
    +-- | The 'BytecodeLoaderState' captures all the information about bytecode loaded
    199 
    +-- into the interpreter.
    200 
    +-- It is separated into two parts. One for bytecode objects loaded by the home package and
    201 
    +-- one for bytecode objects loaded from bytecode libraries for external packages.
    202 
    +-- Much like the HPT/EPS split, the home package state can be unloaded by calling 'unload'.
    203 
    +data BytecodeLoaderState = BytecodeLoaderState
    204 
    +       { homePackage_loaded :: BytecodeState
    205 
    +       -- ^ Information about bytecode objects from the home package we have loaded into the interpreter.
    206 
    +       , externalPackage_loaded :: BytecodeState
    207 
    +       -- ^ Information about bytecode objects from external packages we have loaded into the interpreter.
    208 
    +       }
    209 
    +
    210 
    +
    211 
    +-- | Find a name loaded from bytecode
    212 
    +lookupNameBytecodeState :: BytecodeLoaderState -> Name -> Maybe (Name, ForeignHValue)
    213 
    +lookupNameBytecodeState (BytecodeLoaderState home_package external_package) name = do
    214 
    +      lookupNameEnv (closure_env (bco_linker_env home_package)) name
    215 
    +  <|> lookupNameEnv (closure_env (bco_linker_env external_package)) name
    216 
    +
    217 
    +-- | Look up a break array in the bytecode loader state.
    218 
    +lookupBreakArrayBytecodeState :: BytecodeLoaderState -> Module -> Maybe (ForeignRef BreakArray)
    219 
    +lookupBreakArrayBytecodeState (BytecodeLoaderState home_package external_package) break_mod = do
    220 
    +  lookupModuleEnv (breakarray_env (bco_linked_breaks home_package)) break_mod
    221 
    +  <|> lookupModuleEnv (breakarray_env (bco_linked_breaks external_package)) break_mod
    222 
    +
    223 
    +-- | Look up an info table in the bytecode loader state.
    224 
    +lookupInfoTableBytecodeState :: BytecodeLoaderState -> Name -> Maybe (Name, ItblPtr)
    225 
    +lookupInfoTableBytecodeState (BytecodeLoaderState home_package external_package) info_mod = do
    226 
    +  lookupNameEnv (itbl_env (bco_linker_env home_package)) info_mod
    227 
    +  <|> lookupNameEnv (itbl_env (bco_linker_env external_package)) info_mod
    228 
    +
    229 
    +-- | Look up an address in the bytecode loader state.
    230 
    +lookupAddressBytecodeState :: BytecodeLoaderState -> Name -> Maybe (Name, AddrPtr)
    231 
    +lookupAddressBytecodeState (BytecodeLoaderState home_package external_package) addr_mod = do
    232 
    +  lookupNameEnv (addr_env (bco_linker_env home_package)) addr_mod
    233 
    +  <|> lookupNameEnv (addr_env (bco_linker_env external_package)) addr_mod
    234 
    +
    235 
    +-- | Look up a cost centre stack in the bytecode loader state.
    236 
    +lookupCCSBytecodeState :: BytecodeLoaderState -> Module -> Maybe (Array BreakTickIndex (RemotePtr CostCentre))
    237 
    +lookupCCSBytecodeState (BytecodeLoaderState home_package external_package) ccs_mod = do
    238 
    +  lookupModuleEnv (ccs_env (bco_linked_breaks home_package)) ccs_mod
    239 
    +  <|> lookupModuleEnv (ccs_env (bco_linked_breaks external_package)) ccs_mod
    240 
    +
    241 
    +emptyBytecodeLoaderState :: BytecodeLoaderState
    242 
    +emptyBytecodeLoaderState = BytecodeLoaderState
    243 
    +    { homePackage_loaded = emptyBytecodeState
    244 
    +    , externalPackage_loaded = emptyBytecodeState
    171 245 
         }
    172 246
    247 
    +emptyBytecodeState :: BytecodeState
    248 
    +emptyBytecodeState = BytecodeState
    249 
    +    { bco_linker_env = emptyLinkerEnv
    250 
    +    , bco_linked_breaks = emptyLinkedBreaks
    251 
    +    }
    252 
    +
    253 
    +
    254 
    +-- Some parts of the compiler can be used to load bytecode into either the home package or
    255 
    +-- external package state. They are parameterised by a 'BytecodeLoaderStateModifier' or
    256 
    +-- 'BytecodeLoaderStateTraverser' so they know which part of the state to update.
    257 
    +
    258 
    +type BytecodeLoaderStateModifier = BytecodeLoaderState -> (BytecodeState -> BytecodeState) -> BytecodeLoaderState
    259 
    +type BytecodeLoaderStateTraverser m = BytecodeLoaderState -> (BytecodeState -> m BytecodeState) -> m BytecodeLoaderState
    260 
    +
    261 
    +-- | Only update the home package bytecode state.
    262 
    +modifyHomePackageBytecodeState :: BytecodeLoaderState -> (BytecodeState -> BytecodeState) -> BytecodeLoaderState
    263 
    +modifyHomePackageBytecodeState bls f = runIdentity $ traverseHomePackageBytecodeState bls (return . f)
    264 
    +
    265 
    +-- | Only update the external package bytecode state.
    266 
    +modifyExternalPackageBytecodeState :: BytecodeLoaderState -> (BytecodeState -> BytecodeState) -> BytecodeLoaderState
    267 
    +modifyExternalPackageBytecodeState bls f = runIdentity $ traverseExternalPackageBytecodeState bls (return . f)
    268 
    +
    269 
    +-- | Effectfully update the home package bytecode state.
    270 
    +traverseHomePackageBytecodeState :: Monad m => BytecodeLoaderState -> (BytecodeState -> m BytecodeState) -> m BytecodeLoaderState
    271 
    +traverseHomePackageBytecodeState bls f = do
    272 
    +  home_package <- f (homePackage_loaded bls)
    273 
    +  return bls { homePackage_loaded = home_package }
    274 
    +
    275 
    +-- | Effectfully update the external package bytecode state.
    276 
    +traverseExternalPackageBytecodeState :: Monad m => BytecodeLoaderState -> (BytecodeState -> m BytecodeState) -> m BytecodeLoaderState
    277 
    +traverseExternalPackageBytecodeState bls f = do
    278 
    +  external_package <- f (externalPackage_loaded bls)
    279 
    +  return bls { externalPackage_loaded = external_package }
    280 
    +
    281 
    +
    282 
    +modifyBytecodeLoaderState :: BytecodeLoaderStateModifier -> LoaderState -> (BytecodeState -> BytecodeState) -> LoaderState
    283 
    +modifyBytecodeLoaderState modify_bytecode_loader_state pls f = pls { bco_loader_state = modify_bytecode_loader_state (bco_loader_state pls) f }
    284 
    +
    173 285 
     uninitializedLoader :: IO Loader
    174 286 
     uninitializedLoader = Loader <$> newMVar Nothing
    175 287
    176 
    -modifyClosureEnv :: LoaderState -> (ClosureEnv -> ClosureEnv) -> LoaderState
    288 
    +modifyClosureEnv :: BytecodeState -> (ClosureEnv -> ClosureEnv) -> BytecodeState
    177 289 
     modifyClosureEnv pls f =
    178 
    -    let le = linker_env pls
    290 
    +    let le = bco_linker_env pls
    179 291 
             ce = closure_env le
    180 
    -    in pls { linker_env = le { closure_env = f ce } }
    292 
    +    in pls { bco_linker_env = le { closure_env = f ce } }
    181 293
    182 294 
     data LinkerEnv = LinkerEnv
    183 295 
       { closure_env :: !ClosureEnv
    ... ... @@ -195,11 +307,11 @@ data LinkerEnv = LinkerEnv
    195 307 
           -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode.
    196 308 
       }
    197 309
    198 
    -filterLinkerEnv :: (Name -> Bool) -> LinkerEnv -> LinkerEnv
    199 
    -filterLinkerEnv f (LinkerEnv closure_e itbl_e addr_e) = LinkerEnv
    200 
    -  { closure_env = filterNameEnv (f . fst) closure_e
    201 
    -  , itbl_env    = filterNameEnv (f . fst) itbl_e
    202 
    -  , addr_env    = filterNameEnv (f . fst) addr_e
    310 
    +emptyLinkerEnv :: LinkerEnv
    311 
    +emptyLinkerEnv = LinkerEnv
    312 
    +  { closure_env = emptyNameEnv
    313 
    +  , itbl_env    = emptyNameEnv
    314 
    +  , addr_env    = emptyNameEnv
    203 315 
       }
    204 316
    205 317 
     type ClosureEnv = NameEnv (Name, ForeignHValue)
    ... ... @@ -228,10 +340,10 @@ data LinkedBreaks
    228 340 
           -- Untouched when not profiling.
    229 341 
       }
    230 342
    231 
    -filterLinkedBreaks :: (Module -> Bool) -> LinkedBreaks -> LinkedBreaks
    232 
    -filterLinkedBreaks f (LinkedBreaks ba_e ccs_e) = LinkedBreaks
    233 
    -  { breakarray_env = filterModuleEnv (\m _ -> f m) ba_e
    234 
    -  , ccs_env        = filterModuleEnv (\m _ -> f m) ccs_e
    343 
    +emptyLinkedBreaks :: LinkedBreaks
    344 
    +emptyLinkedBreaks = LinkedBreaks
    345 
    +  { breakarray_env = emptyModuleEnv
    346 
    +  , ccs_env        = emptyModuleEnv
    235 347 
       }
    236 348
    237 349 
     type PkgsLoaded = UniqDFM UnitId LoadedPkgInfo

  • compiler/GHC/Runtime/Debugger.hs
    ... ... @@ -56,6 +56,7 @@ import Data.List ( partition )
    56 56 
     import qualified Data.List.NonEmpty as NE
    57 57 
     import Data.Maybe
    58 58 
     import Data.IORef
    59 
    +import GHC.Linker.Types
    59 60
    60 61 
     -------------------------------------
    61 62 
     -- | The :print & friends commands
    ... ... @@ -161,7 +162,7 @@ bindSuspensions t = do
    161 162 
                     | (name,ty) <- zip names tys]
    162 163 
               new_ic = extendInteractiveContextWithIds ictxt ids
    163 164 
               interp = hscInterp hsc_env
    164 
    -      liftIO $ extendLoadedEnv interp (zip names fhvs)
    165 
    +      liftIO $ extendLoadedEnv interp modifyHomePackageBytecodeState (zip names fhvs)
    165 166 
           setSession hsc_env {hsc_IC = new_ic }
    166 167 
           return t'
    167 168 
          where

  • compiler/GHC/Runtime/Eval.hs
    ... ... @@ -64,7 +64,7 @@ import GHCi.RemoteTypes
    64 64 
     import GHC.ByteCode.Types
    65 65
    66 66 
     import GHC.Linker.Loader as Loader
    67 
    -import GHC.Linker.Types (LinkedBreaks (..))
    67 
    +import GHC.Linker.Types
    68 68
    69 69 
     import GHC.Hs
    70 70
    ... ... @@ -310,7 +310,7 @@ handleRunStatus step expr bindings final_ids status history0 = do
    310 310 
           let
    311 311 
             final_ic = extendInteractiveContextWithIds (hsc_IC hsc_env) final_ids
    312 312 
             final_names = map getName final_ids
    313 
    -      liftIO $ Loader.extendLoadedEnv interp (zip final_names hvals)
    313 
    +      liftIO $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip final_names hvals)
    314 314 
           hsc_env' <- liftIO $ rttiEnvironment hsc_env{hsc_IC=final_ic}
    315 315 
           setSession hsc_env'
    316 316 
           return (ExecComplete (Right final_names) allocs)
    ... ... @@ -433,7 +433,7 @@ resumeExec step mbCnt
    433 433 
                                 , not (n `elem` old_names) ]
    434 434 
                 interp    = hscInterp hsc_env
    435 435 
                 dflags    = hsc_dflags hsc_env
    436 
    -        liftIO $ Loader.deleteFromLoadedEnv interp new_names
    436 
    +        liftIO $ Loader.deleteFromLoadedHomeEnv interp new_names
    437 437
    438 438 
             case r of
    439 439 
               Resume { resumeStmt = expr
    ... ... @@ -474,18 +474,18 @@ setupBreakpoint interp ibi cnt = do
    474 474
    475 475 
     getBreakArray :: Interp -> InternalBreakpointId -> InternalModBreaks -> IO (ForeignRef BreakArray)
    476 476 
     getBreakArray interp InternalBreakpointId{ibi_info_mod} imbs = do
    477 
    -  breaks0 <- linked_breaks . fromMaybe (panic "Loader not initialised") <$> getLoaderState interp
    477 
    +  breaks0 <- bco_linked_breaks . homePackage_loaded . bco_loader_state . fromMaybe (panic "Loader not initialised") <$> getLoaderState interp
    478 478 
       case lookupModuleEnv (breakarray_env breaks0) ibi_info_mod of
    479 479 
         Just ba -> return ba
    480 480 
         Nothing -> do
    481 481 
           modifyLoaderState interp $ \ld_st -> do
    482 
    -        let lb = linked_breaks ld_st
    482 
    +        let lb = bco_linked_breaks . homePackage_loaded . bco_loader_state $ ld_st
    483 483
    484 484 
             -- Recall that BreakArrays are allocated only at BCO link time, so if we
    485 485 
             -- haven't linked the BCOs we intend to break at yet, we allocate the arrays here.
    486 486 
             ba_env <- allocateBreakArrays interp (breakarray_env lb) [imbs]
    487 487
    488 
    -        let ld_st' = ld_st { linked_breaks = lb{breakarray_env = ba_env} }
    488 
    +        let ld_st' = modifyBytecodeLoaderState modifyHomePackageBytecodeState ld_st $ \bco_state -> bco_state { bco_linked_breaks = (bco_linked_breaks bco_state) { breakarray_env = ba_env } }
    489 489 
             let ba = expectJust {- just computed -} $ lookupModuleEnv ba_env ibi_info_mod
    490 490
    491 491 
             return
    ... ... @@ -575,7 +575,7 @@ bindLocalsAtBreakpoint hsc_env apStack span Nothing = do
    575 575 
            ictxt1 = extendInteractiveContextWithIds ictxt0 [exn_id]
    576 576 
            interp = hscInterp hsc_env
    577 577 
        --
    578 
    -   Loader.extendLoadedEnv interp [(exn_name, apStack)]
    578 
    +   Loader.extendLoadedEnv interp modifyHomePackageBytecodeState [(exn_name, apStack)]
    579 579 
        return (hsc_env{ hsc_IC = ictxt1 }, [exn_name])
    580 580
    581 581 
     -- 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
    634 634 
            names  = map idName new_ids
    635 635
    636 636 
        let fhvs = catMaybes mb_hValues
    637 
    -   Loader.extendLoadedEnv interp (zip names fhvs)
    638 
    -   when result_ok $ Loader.extendLoadedEnv interp [(result_name, apStack_fhv)]
    637 
    +   Loader.extendLoadedEnv interp modifyHomePackageBytecodeState (zip names fhvs)
    638 
    +   when result_ok $ Loader.extendLoadedEnv interp modifyHomePackageBytecodeState [(result_name, apStack_fhv)]
    639 639 
        hsc_env1 <- rttiEnvironment hsc_env{ hsc_IC = ictxt1 }
    640 640 
        return (hsc_env1, if result_ok then result_name:names else names)
    641 641 
       where

  • compiler/GHC/Unit/State.hs
    ... ... @@ -851,7 +851,8 @@ distrustAllUnits pkgs = map distrust pkgs
    851 851 
     mungeUnitInfo :: FilePath -> FilePath
    852 852 
                        -> UnitInfo -> UnitInfo
    853 853 
     mungeUnitInfo top_dir pkgroot =
    854 
    -    mungeDynLibFields
    854 
    +   mungeBytecodeLibFields
    855 
    +  . mungeDynLibFields
    855 856 
       . mungeUnitInfoPaths (ST.pack top_dir) (ST.pack pkgroot)
    856 857
    857 858 
     mungeDynLibFields :: UnitInfo -> UnitInfo
    ... ... @@ -862,6 +863,15 @@ mungeDynLibFields pkg =
    862 863 
              ds -> ds
    863 864 
         }
    864 865
    866 
    +-- | Default to using library-dirs if bytecode library dirs is not explicitly set.
    867 
    +mungeBytecodeLibFields :: UnitInfo -> UnitInfo
    868 
    +mungeBytecodeLibFields pkg =
    869 
    +    pkg {
    870 
    +      unitLibraryBytecodeDirs = case unitLibraryBytecodeDirs pkg of
    871 
    +         [] -> unitLibraryDirs pkg
    872 
    +         ds -> ds
    873 
    +    }
    874 
    +
    865 875 
     -- -----------------------------------------------------------------------------
    866 876 
     -- Modify our copy of the unit database based on trust flags,
    867 877 
     -- -trust and -distrust.

  • utils/ghc-pkg/Main.hs
    ... ... @@ -2056,7 +2056,8 @@ checkHSLib _verbosity dirs lib = do
    2056 2056 
                        "lib" ++ lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib",
    2057 2057 
                        "lib" ++ lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dylib",
    2058 2058 
                        lib ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll",
    2059 
    -                   lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll"
    2059 
    +                   lib ++ "_p" ++ "-ghc" ++ GHC.Version.cProjectVersion ++ ".dll",
    2060 
    +                   lib ++ ".bytecode"
    2060 2061 
                       ]
    2061 2062 
       b <- liftIO $ doesFileExistOnPath filenames dirs
    2062 2063 
       when (not b) $

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help