Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC

Commits:

10 changed files:

Changes:

  • compiler/GHC/Driver/Plugins.hs
    ... ... @@ -421,7 +421,7 @@ loadExternalPlugins ps = do
    421 421
     loadExternalPluginLib :: FilePath -> IO ()
    
    422 422
     loadExternalPluginLib path = do
    
    423 423
       -- load library
    
    424
    -  loadDLL path >>= \case
    
    424
    +  loadDLLs [path] >>= \case
    
    425 425
         Left errmsg -> pprPanic "loadExternalPluginLib"
    
    426 426
                          (vcat [ text "Can't load plugin library"
    
    427 427
                                , text "  Library path: " <> text path
    

  • compiler/GHC/Linker/Loader.hs
    1 1
     {-# LANGUAGE CPP #-}
    
    2 2
     {-# LANGUAGE RecordWildCards #-}
    
    3 3
     {-# LANGUAGE LambdaCase #-}
    
    4
    +{-# LANGUAGE ViewPatterns #-}
    
    4 5
     
    
    5 6
     --
    
    6 7
     --  (c) The University of Glasgow 2002-2006
    
    ... ... @@ -535,7 +536,7 @@ preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do
    535 536
           return pls
    
    536 537
     
    
    537 538
         DLL dll_unadorned -> do
    
    538
    -      maybe_errstr <- loadDLL interp (platformSOName platform dll_unadorned)
    
    539
    +      maybe_errstr <- loadDLLs interp [platformSOName platform dll_unadorned]
    
    539 540
           case maybe_errstr of
    
    540 541
              Right _ -> maybePutStrLn logger "done"
    
    541 542
              Left mm | platformOS platform /= OSDarwin ->
    
    ... ... @@ -545,14 +546,14 @@ preloadLib interp hsc_env lib_paths framework_paths pls lib_spec = do
    545 546
                -- since (apparently) some things install that way - see
    
    546 547
                -- ticket #8770.
    
    547 548
                let libfile = ("lib" ++ dll_unadorned) <.> "so"
    
    548
    -           err2 <- loadDLL interp libfile
    
    549
    +           err2 <- loadDLLs interp [libfile]
    
    549 550
                case err2 of
    
    550 551
                  Right _ -> maybePutStrLn logger "done"
    
    551 552
                  Left _  -> preloadFailed mm lib_paths lib_spec
    
    552 553
           return pls
    
    553 554
     
    
    554 555
         DLLPath dll_path -> do
    
    555
    -      do maybe_errstr <- loadDLL interp dll_path
    
    556
    +      do maybe_errstr <- loadDLLs interp [dll_path]
    
    556 557
              case maybe_errstr of
    
    557 558
                 Right _ -> maybePutStrLn logger "done"
    
    558 559
                 Left mm -> preloadFailed mm lib_paths lib_spec
    
    ... ... @@ -892,7 +893,7 @@ dynLoadObjs interp hsc_env pls@LoaderState{..} objs = do
    892 893
     
    
    893 894
         -- if we got this far, extend the lifetime of the library file
    
    894 895
         changeTempFilesLifetime tmpfs TFL_GhcSession [soFile]
    
    895
    -    m <- loadDLL interp soFile
    
    896
    +    m <- loadDLLs interp [soFile]
    
    896 897
         case m of
    
    897 898
           Right _ -> return $! pls { temp_sos = (libPath, libName) : temp_sos }
    
    898 899
           Left err -> linkFail msg (text err)
    
    ... ... @@ -1129,51 +1130,91 @@ loadPackages interp hsc_env new_pkgs = do
    1129 1130
     
    
    1130 1131
     loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState
    
    1131 1132
     loadPackages' interp hsc_env new_pks pls = do
    
    1132
    -    pkgs' <- link (pkgs_loaded pls) new_pks
    
    1133
    -    return $! pls { pkgs_loaded = pkgs'
    
    1134
    -                  }
    
    1133
    +  (reverse -> pkgs_info_list, pkgs_almost_loaded) <-
    
    1134
    +    downsweep
    
    1135
    +      ([], pkgs_loaded pls)
    
    1136
    +      new_pks
    
    1137
    +  loaded_pkgs_info_list <- loadPackage interp hsc_env pkgs_info_list
    
    1138
    +  evaluate $
    
    1139
    +    pls
    
    1140
    +      { pkgs_loaded =
    
    1141
    +          foldl'
    
    1142
    +            ( \pkgs (new_pkg_info, (hs_cls, extra_cls, loaded_dlls)) ->
    
    1143
    +                adjustUDFM
    
    1144
    +                  ( \old_pkg_info ->
    
    1145
    +                      old_pkg_info
    
    1146
    +                        { loaded_pkg_hs_objs = hs_cls,
    
    1147
    +                          loaded_pkg_non_hs_objs = extra_cls,
    
    1148
    +                          loaded_pkg_hs_dlls = loaded_dlls
    
    1149
    +                        }
    
    1150
    +                  )
    
    1151
    +                  pkgs
    
    1152
    +                  (Packages.unitId new_pkg_info)
    
    1153
    +            )
    
    1154
    +            pkgs_almost_loaded
    
    1155
    +            (zip pkgs_info_list loaded_pkgs_info_list)
    
    1156
    +      }
    
    1135 1157
       where
    
    1136
    -     link :: PkgsLoaded -> [UnitId] -> IO PkgsLoaded
    
    1137
    -     link pkgs new_pkgs =
    
    1138
    -         foldM link_one pkgs new_pkgs
    
    1139
    -
    
    1140
    -     link_one pkgs new_pkg
    
    1141
    -        | new_pkg `elemUDFM` pkgs   -- Already linked
    
    1142
    -        = return pkgs
    
    1143
    -
    
    1144
    -        | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg
    
    1145
    -        = do { let deps = unitDepends pkg_cfg
    
    1146
    -               -- Link dependents first
    
    1147
    -             ; pkgs' <- link pkgs deps
    
    1148
    -                -- Now link the package itself
    
    1149
    -             ; (hs_cls, extra_cls, loaded_dlls) <- loadPackage interp hsc_env pkg_cfg
    
    1150
    -             ; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg
    
    1151
    -                                                   | dep_pkg <- deps
    
    1152
    -                                                   , Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg)
    
    1153
    -                                                   ]
    
    1154
    -             ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls loaded_dlls trans_deps)) }
    
    1155
    -
    
    1156
    -        | otherwise
    
    1157
    -        = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))
    
    1158
    -
    
    1159
    -
    
    1160
    -loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL])
    
    1161
    -loadPackage interp hsc_env pkg
    
    1158
    +    -- The downsweep process takes an initial 'PkgsLoaded' and uses it
    
    1159
    +    -- to memoize new packages to load when recursively downsweeping
    
    1160
    +    -- the dependencies. The returned 'PkgsLoaded' is popularized with
    
    1161
    +    -- placeholder 'LoadedPkgInfo' for new packages yet to be loaded,
    
    1162
    +    -- which need to be modified later to fill in the missing fields.
    
    1163
    +    --
    
    1164
    +    -- The [UnitInfo] list is an accumulated *reverse* topologically
    
    1165
    +    -- sorted list of new packages to load: 'downsweep_one' appends a
    
    1166
    +    -- package to its head after that package's transitive
    
    1167
    +    -- dependencies go into that list. There are no duplicate items in
    
    1168
    +    -- this list due to memoization.
    
    1169
    +    downsweep ::
    
    1170
    +      ([UnitInfo], PkgsLoaded) -> [UnitId] -> IO ([UnitInfo], PkgsLoaded)
    
    1171
    +    downsweep = foldlM downsweep_one
    
    1172
    +
    
    1173
    +    downsweep_one ::
    
    1174
    +      ([UnitInfo], PkgsLoaded) -> UnitId -> IO ([UnitInfo], PkgsLoaded)
    
    1175
    +    downsweep_one (pkgs_info_list, pkgs) new_pkg
    
    1176
    +      | new_pkg `elemUDFM` pkgs = pure (pkgs_info_list, pkgs)
    
    1177
    +      | Just new_pkg_info <- lookupUnitId (hsc_units hsc_env) new_pkg = do
    
    1178
    +          let new_pkg_deps = unitDepends new_pkg_info
    
    1179
    +          (pkgs_info_list', pkgs') <- downsweep (pkgs_info_list, pkgs) new_pkg_deps
    
    1180
    +          let new_pkg_trans_deps =
    
    1181
    +                unionManyUniqDSets
    
    1182
    +                  [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg
    
    1183
    +                  | dep_pkg <- new_pkg_deps,
    
    1184
    +                    loaded_pkg_info <- maybeToList $ pkgs' `lookupUDFM` dep_pkg
    
    1185
    +                  ]
    
    1186
    +          pure
    
    1187
    +            ( new_pkg_info : pkgs_info_list',
    
    1188
    +              addToUDFM pkgs' new_pkg $
    
    1189
    +                LoadedPkgInfo
    
    1190
    +                  { loaded_pkg_uid = new_pkg,
    
    1191
    +                    loaded_pkg_hs_objs = [],
    
    1192
    +                    loaded_pkg_non_hs_objs = [],
    
    1193
    +                    loaded_pkg_hs_dlls = [],
    
    1194
    +                    loaded_pkg_trans_deps = new_pkg_trans_deps
    
    1195
    +                  }
    
    1196
    +            )
    
    1197
    +      | otherwise =
    
    1198
    +          throwGhcExceptionIO
    
    1199
    +            (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))
    
    1200
    +
    
    1201
    +loadPackage :: Interp -> HscEnv -> [UnitInfo] -> IO [([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL])]
    
    1202
    +loadPackage interp hsc_env pkgs
    
    1162 1203
        = do
    
    1163 1204
             let dflags    = hsc_dflags hsc_env
    
    1164 1205
             let logger    = hsc_logger hsc_env
    
    1165 1206
                 platform  = targetPlatform dflags
    
    1166 1207
                 is_dyn    = interpreterDynamic interp
    
    1167
    -            dirs | is_dyn    = map ST.unpack $ Packages.unitLibraryDynDirs pkg
    
    1168
    -                 | otherwise = map ST.unpack $ Packages.unitLibraryDirs pkg
    
    1208
    +            dirs | is_dyn    = [map ST.unpack $ Packages.unitLibraryDynDirs pkg | pkg <- pkgs]
    
    1209
    +                 | otherwise = [map ST.unpack $ Packages.unitLibraryDirs pkg | pkg <- pkgs]
    
    1169 1210
     
    
    1170
    -        let hs_libs   = map ST.unpack $ Packages.unitLibraries pkg
    
    1211
    +        let hs_libs   = [map ST.unpack $ Packages.unitLibraries pkg | pkg <- pkgs]
    
    1171 1212
                 -- The FFI GHCi import lib isn't needed as
    
    1172 1213
                 -- GHC.Linker.Loader + rts/Linker.c link the
    
    1173 1214
                 -- interpreted references to FFI to the compiled FFI.
    
    1174 1215
                 -- We therefore filter it out so that we don't get
    
    1175 1216
                 -- duplicate symbol errors.
    
    1176
    -            hs_libs'  =  filter ("HSffi" /=) hs_libs
    
    1217
    +            hs_libs'  =  filter ("HSffi" /=) <$> hs_libs
    
    1177 1218
     
    
    1178 1219
             -- Because of slight differences between the GHC dynamic linker and
    
    1179 1220
             -- the native system linker some packages have to link with a
    
    ... ... @@ -1182,53 +1223,62 @@ loadPackage interp hsc_env pkg
    1182 1223
             -- libs do not exactly match the .so/.dll equivalents. So if the
    
    1183 1224
             -- package file provides an "extra-ghci-libraries" field then we use
    
    1184 1225
             -- that instead of the "extra-libraries" field.
    
    1185
    -            extdeplibs = map ST.unpack (if null (Packages.unitExtDepLibsGhc pkg)
    
    1226
    +            extdeplibs = [map ST.unpack (if null (Packages.unitExtDepLibsGhc pkg)
    
    1186 1227
                                           then Packages.unitExtDepLibsSys pkg
    
    1187
    -                                      else Packages.unitExtDepLibsGhc pkg)
    
    1188
    -            linkerlibs = [ lib | '-':'l':lib <- (map ST.unpack $ Packages.unitLinkerOptions pkg) ]
    
    1189
    -            extra_libs = extdeplibs ++ linkerlibs
    
    1228
    +                                      else Packages.unitExtDepLibsGhc pkg) | pkg <- pkgs]
    
    1229
    +            linkerlibs = [[ lib | '-':'l':lib <- (map ST.unpack $ Packages.unitLinkerOptions pkg) ] | pkg <- pkgs]
    
    1230
    +            extra_libs = zipWith (++) extdeplibs linkerlibs
    
    1190 1231
     
    
    1191 1232
             -- See Note [Fork/Exec Windows]
    
    1192 1233
             gcc_paths <- getGCCPaths logger dflags (platformOS platform)
    
    1193
    -        dirs_env <- addEnvPaths "LIBRARY_PATH" dirs
    
    1234
    +        dirs_env <- traverse (addEnvPaths "LIBRARY_PATH") dirs
    
    1194 1235
     
    
    1195 1236
             hs_classifieds
    
    1196
    -           <- mapM (locateLib interp hsc_env True  dirs_env gcc_paths) hs_libs'
    
    1237
    +           <- sequenceA [mapM (locateLib interp hsc_env True  dirs_env_ gcc_paths) hs_libs'_ | (dirs_env_, hs_libs'_) <- zip dirs_env hs_libs' ]
    
    1197 1238
             extra_classifieds
    
    1198
    -           <- mapM (locateLib interp hsc_env False dirs_env gcc_paths) extra_libs
    
    1199
    -        let classifieds = hs_classifieds ++ extra_classifieds
    
    1239
    +           <- sequenceA [mapM (locateLib interp hsc_env False dirs_env_ gcc_paths) extra_libs_ | (dirs_env_, extra_libs_) <- zip dirs_env extra_libs]
    
    1240
    +        let classifieds = zipWith (++) hs_classifieds extra_classifieds
    
    1200 1241
     
    
    1201 1242
             -- Complication: all the .so's must be loaded before any of the .o's.
    
    1202
    -        let known_hs_dlls    = [ dll | DLLPath dll <- hs_classifieds ]
    
    1203
    -            known_extra_dlls = [ dll | DLLPath dll <- extra_classifieds ]
    
    1204
    -            known_dlls       = known_hs_dlls ++ known_extra_dlls
    
    1243
    +        let known_hs_dlls    = [[ dll | DLLPath dll <- hs_classifieds_ ] | hs_classifieds_ <- hs_classifieds]
    
    1244
    +            known_extra_dlls = [ dll | extra_classifieds_ <- extra_classifieds, DLLPath dll <- extra_classifieds_ ]
    
    1245
    +            known_dlls       = concat known_hs_dlls ++ known_extra_dlls
    
    1205 1246
     #if defined(CAN_LOAD_DLL)
    
    1206
    -            dlls       = [ dll  | DLL dll        <- classifieds ]
    
    1247
    +            dlls       = [ dll  | classifieds_ <- classifieds, DLL dll      <- classifieds_ ]
    
    1207 1248
     #endif
    
    1208
    -            objs       = [ obj  | Objects objs    <- classifieds
    
    1209
    -                                , obj <- objs ]
    
    1210
    -            archs      = [ arch | Archive arch   <- classifieds ]
    
    1249
    +            objs       = [ obj  | classifieds_ <- classifieds, Objects objs <- classifieds_
    
    1250
    +                                , obj <- objs]
    
    1251
    +            archs      = [ arch | classifieds_ <- classifieds, Archive arch <- classifieds_ ]
    
    1211 1252
     
    
    1212 1253
             -- Add directories to library search paths
    
    1213 1254
             let dll_paths  = map takeDirectory known_dlls
    
    1214
    -            all_paths  = nub $ map normalise $ dll_paths ++ dirs
    
    1255
    +            all_paths  = nub $ map normalise $ dll_paths ++ concat dirs
    
    1215 1256
             all_paths_env <- addEnvPaths "LD_LIBRARY_PATH" all_paths
    
    1216 1257
             pathCache <- mapM (addLibrarySearchPath interp) all_paths_env
    
    1217 1258
     
    
    1218 1259
             maybePutSDoc logger
    
    1219
    -            (text "Loading unit " <> pprUnitInfoForUser pkg <> text " ... ")
    
    1260
    +            (text "Loading units " <> vcat (map pprUnitInfoForUser pkgs) <> text " ... ")
    
    1220 1261
     
    
    1221 1262
     #if defined(CAN_LOAD_DLL)
    
    1222
    -        loadFrameworks interp platform pkg
    
    1263
    +        forM_ pkgs $ loadFrameworks interp platform
    
    1223 1264
             -- See Note [Crash early load_dyn and locateLib]
    
    1224 1265
             -- Crash early if can't load any of `known_dlls`
    
    1225
    -        mapM_ (load_dyn interp hsc_env True) known_extra_dlls
    
    1226
    -        loaded_dlls <- mapMaybeM (load_dyn interp hsc_env True) known_hs_dlls
    
    1266
    +        _ <- load_dyn interp hsc_env True known_extra_dlls
    
    1267
    +
    
    1268
    +        -- We pass [[FilePath]] of dlls to load and flattens the list
    
    1269
    +        -- before doing a LoadDLLs. The returned list of RemotePtrs
    
    1270
    +        -- would need to be regrouped to the same shape of the input
    
    1271
    +        -- [[FilePath]], each group's [RemotePtr LoadedDLL]
    
    1272
    +        -- corresponds to the DLL handles of a Haskell unit.
    
    1273
    +        let regroup :: [[a]] -> [b] -> [[b]]
    
    1274
    +            regroup [] _ = []
    
    1275
    +            regroup (l:ls) xs = xs0: regroup ls xs1 where (xs0, xs1) = splitAt (length l) xs
    
    1276
    +        loaded_dlls <- regroup known_hs_dlls <$> load_dyn interp hsc_env True (concat known_hs_dlls)
    
    1227 1277
             -- For remaining `dlls` crash early only when there is surely
    
    1228 1278
             -- no package's DLL around ... (not is_dyn)
    
    1229
    -        mapM_ (load_dyn interp hsc_env (not is_dyn) . platformSOName platform) dlls
    
    1279
    +        _ <- load_dyn interp hsc_env (not is_dyn) $ map (platformSOName platform) dlls
    
    1230 1280
     #else
    
    1231
    -        let loaded_dlls = []
    
    1281
    +        let loaded_dlls = replicate (length pkgs) []
    
    1232 1282
     #endif
    
    1233 1283
             -- After loading all the DLLs, we can load the static objects.
    
    1234 1284
             -- Ordering isn't important here, because we do one final link
    
    ... ... @@ -1248,9 +1298,9 @@ loadPackage interp hsc_env pkg
    1248 1298
             if succeeded ok
    
    1249 1299
                then do
    
    1250 1300
                  maybePutStrLn logger "done."
    
    1251
    -             return (hs_classifieds, extra_classifieds, loaded_dlls)
    
    1252
    -           else let errmsg = text "unable to load unit `"
    
    1253
    -                             <> pprUnitInfoForUser pkg <> text "'"
    
    1301
    +             pure $ zip3 hs_classifieds extra_classifieds loaded_dlls
    
    1302
    +           else let errmsg = text "unable to load units `"
    
    1303
    +                             <> vcat (map pprUnitInfoForUser pkgs) <> text "'"
    
    1254 1304
                      in throwGhcExceptionIO (InstallationError (showSDoc dflags errmsg))
    
    1255 1305
     
    
    1256 1306
     {-
    
    ... ... @@ -1300,12 +1350,12 @@ restriction very easily.
    1300 1350
     -- we have already searched the filesystem; the strings passed to load_dyn
    
    1301 1351
     -- can be passed directly to loadDLL.  They are either fully-qualified
    
    1302 1352
     -- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so").  In the latter case,
    
    1303
    --- loadDLL is going to search the system paths to find the library.
    
    1304
    -load_dyn :: Interp -> HscEnv -> Bool -> FilePath -> IO (Maybe (RemotePtr LoadedDLL))
    
    1305
    -load_dyn interp hsc_env crash_early dll = do
    
    1306
    -  r <- loadDLL interp dll
    
    1353
    +-- loadDLLs is going to search the system paths to find the library.
    
    1354
    +load_dyn :: Interp -> HscEnv -> Bool -> [FilePath] -> IO [RemotePtr LoadedDLL]
    
    1355
    +load_dyn interp hsc_env crash_early dlls = do
    
    1356
    +  r <- loadDLLs interp dlls
    
    1307 1357
       case r of
    
    1308
    -    Right loaded_dll -> pure (Just loaded_dll)
    
    1358
    +    Right loaded_dlls -> pure loaded_dlls
    
    1309 1359
         Left err ->
    
    1310 1360
           if crash_early
    
    1311 1361
             then cmdLineErrorIO err
    
    ... ... @@ -1314,7 +1364,7 @@ load_dyn interp hsc_env crash_early dll = do
    1314 1364
                 $ reportDiagnostic logger
    
    1315 1365
                     neverQualify diag_opts
    
    1316 1366
                       noSrcSpan (WarningWithFlag Opt_WarnMissedExtraSharedLib) $ withPprStyle defaultUserStyle (note err)
    
    1317
    -          pure Nothing
    
    1367
    +          pure []
    
    1318 1368
       where
    
    1319 1369
         diag_opts = initDiagOpts (hsc_dflags hsc_env)
    
    1320 1370
         logger = hsc_logger hsc_env
    
    ... ... @@ -1370,7 +1420,7 @@ locateLib interp hsc_env is_hs lib_dirs gcc_dirs lib0
    1370 1420
         --   then  look in library-dirs and inplace GCC for a static library (libfoo.a)
    
    1371 1421
         --   then  try "gcc --print-file-name" to search gcc's search path
    
    1372 1422
         --       for a dynamic library (#5289)
    
    1373
    -    --   otherwise, assume loadDLL can find it
    
    1423
    +    --   otherwise, assume loadDLLs can find it
    
    1374 1424
         --
    
    1375 1425
         --   The logic is a bit complicated, but the rationale behind it is that
    
    1376 1426
         --   loading a shared library for us is O(1) while loading an archive is
    

  • compiler/GHC/Linker/MacOS.hs
    ... ... @@ -162,7 +162,7 @@ loadFramework interp extraPaths rootname
    162 162
          -- sorry for the hardcoded paths, I hope they won't change anytime soon:
    
    163 163
          defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"]
    
    164 164
     
    
    165
    -     -- Try to call loadDLL for each candidate path.
    
    165
    +     -- Try to call loadDLLs for each candidate path.
    
    166 166
          --
    
    167 167
          -- See Note [macOS Big Sur dynamic libraries]
    
    168 168
          findLoadDLL [] errs =
    
    ... ... @@ -170,7 +170,7 @@ loadFramework interp extraPaths rootname
    170 170
            -- has no built-in paths for frameworks: give up
    
    171 171
            return $ Just errs
    
    172 172
          findLoadDLL (p:ps) errs =
    
    173
    -       do { dll <- loadDLL interp (p </> fwk_file)
    
    173
    +       do { dll <- loadDLLs interp [p </> fwk_file]
    
    174 174
               ; case dll of
    
    175 175
                   Right _  -> return Nothing
    
    176 176
                   Left err -> findLoadDLL ps ((p ++ ": " ++ err):errs)
    

  • compiler/GHC/Linker/Types.hs
    ... ... @@ -494,7 +494,7 @@ data LibrarySpec
    494 494
        | DLL String         -- "Unadorned" name of a .DLL/.so
    
    495 495
                             --  e.g.    On unix     "qt"  denotes "libqt.so"
    
    496 496
                             --          On Windows  "burble"  denotes "burble.DLL" or "libburble.dll"
    
    497
    -                        --  loadDLL is platform-specific and adds the lib/.so/.DLL
    
    497
    +                        --  loadDLLs is platform-specific and adds the lib/.so/.DLL
    
    498 498
                             --  suffixes platform-dependently
    
    499 499
     
    
    500 500
        | DLLPath FilePath   -- Absolute or relative pathname to a dynamic library
    

  • compiler/GHC/Runtime/Interpreter.hs
    ... ... @@ -38,7 +38,7 @@ module GHC.Runtime.Interpreter
    38 38
       , lookupSymbol
    
    39 39
       , lookupSymbolInDLL
    
    40 40
       , lookupClosure
    
    41
    -  , loadDLL
    
    41
    +  , loadDLLs
    
    42 42
       , loadArchive
    
    43 43
       , loadObj
    
    44 44
       , unloadObj
    
    ... ... @@ -559,13 +559,13 @@ withSymbolCache interp str determine_addr = do
    559 559
     purgeLookupSymbolCache :: Interp -> IO ()
    
    560 560
     purgeLookupSymbolCache interp = purgeInterpSymbolCache (interpSymbolCache interp)
    
    561 561
     
    
    562
    --- | loadDLL loads a dynamic library using the OS's native linker
    
    562
    +-- | 'loadDLLs' loads dynamic libraries using the OS's native linker
    
    563 563
     -- (i.e. dlopen() on Unix, LoadLibrary() on Windows).  It takes either
    
    564
    --- an absolute pathname to the file, or a relative filename
    
    565
    --- (e.g. "libfoo.so" or "foo.dll").  In the latter case, loadDLL
    
    566
    --- searches the standard locations for the appropriate library.
    
    567
    -loadDLL :: Interp -> String -> IO (Either String (RemotePtr LoadedDLL))
    
    564
    +-- absolute pathnames to the files, or relative filenames
    
    565
    +-- (e.g. "libfoo.so" or "foo.dll").  In the latter case, 'loadDLLs'
    
    566
    +-- searches the standard locations for the appropriate libraries.
    
    567
    +loadDLLs :: Interp -> [String] -> IO (Either String [RemotePtr LoadedDLL])
    
    568
    +loadDLLs interp strs = interpCmd interp (LoadDLLs strs)
    
    568 569
     
    
    569 570
     loadArchive :: Interp -> String -> IO ()
    
    570 571
     loadArchive interp path = do
    
    ... ... @@ -761,4 +761,3 @@ readIModModBreaks hug mod = imodBreaks_modBreaks . expectJust <$> readIModBreaks
    761 761
     fromEvalResult :: EvalResult a -> IO a
    
    762 762
     fromEvalResult (EvalException e) = throwIO (fromSerializableException e)
    
    763 763
     fromEvalResult (EvalSuccess a) = return a
    764
    -

  • libraries/ghci/GHCi/Message.hs
    ... ... @@ -89,7 +89,7 @@ data Message a where
    89 89
       LookupSymbol :: String -> Message (Maybe (RemotePtr ()))
    
    90 90
       LookupSymbolInDLL :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ()))
    
    91 91
       LookupClosure :: String -> Message (Maybe HValueRef)
    
    92
    -  LoadDLL :: String -> Message (Either String (RemotePtr LoadedDLL))
    
    92
    +  LoadDLLs :: [String] -> Message (Either String [RemotePtr LoadedDLL])
    
    93 93
       LoadArchive :: String -> Message () -- error?
    
    94 94
       LoadObj :: String -> Message () -- error?
    
    95 95
       UnloadObj :: String -> Message () -- error?
    
    ... ... @@ -448,7 +448,7 @@ data BreakModule
    448 448
     -- that type isn't available here.
    
    449 449
     data BreakUnitId
    
    450 450
     
    
    451
    --- | A dummy type that tags pointers returned by 'LoadDLL'.
    
    451
    +-- | A dummy type that tags pointers returned by 'LoadDLLs'.
    
    452 452
     data LoadedDLL
    
    453 453
     
    
    454 454
     -- SomeException can't be serialized because it contains dynamic
    
    ... ... @@ -564,7 +564,7 @@ getMessage = do
    564 564
           1  -> Msg <$> return InitLinker
    
    565 565
           2  -> Msg <$> LookupSymbol <$> get
    
    566 566
           3  -> Msg <$> LookupClosure <$> get
    
    567
    -      4  -> Msg <$> LoadDLL <$> get
    
    567
    +      4  -> Msg <$> LoadDLLs <$> get
    
    568 568
           5  -> Msg <$> LoadArchive <$> get
    
    569 569
           6  -> Msg <$> LoadObj <$> get
    
    570 570
           7  -> Msg <$> UnloadObj <$> get
    
    ... ... @@ -610,7 +610,7 @@ putMessage m = case m of
    610 610
       InitLinker                  -> putWord8 1
    
    611 611
       LookupSymbol str            -> putWord8 2  >> put str
    
    612 612
       LookupClosure str           -> putWord8 3  >> put str
    
    613
    -  LoadDLL str                 -> putWord8 4  >> put str
    
    613
    +  LoadDLLs strs               -> putWord8 4  >> put strs
    
    614 614
       LoadArchive str             -> putWord8 5  >> put str
    
    615 615
       LoadObj str                 -> putWord8 6  >> put str
    
    616 616
       UnloadObj str               -> putWord8 7  >> put str
    

  • libraries/ghci/GHCi/ObjLink.hs
    ... ... @@ -12,7 +12,7 @@
    12 12
     -- dynamic linker.
    
    13 13
     module GHCi.ObjLink
    
    14 14
       ( initObjLinker, ShouldRetainCAFs(..)
    
    15
    -  , loadDLL
    
    15
    +  , loadDLLs
    
    16 16
       , loadArchive
    
    17 17
       , loadObj
    
    18 18
       , unloadObj
    
    ... ... @@ -31,6 +31,7 @@ import GHCi.RemoteTypes
    31 31
     import GHCi.Message (LoadedDLL)
    
    32 32
     import Control.Exception (throwIO, ErrorCall(..))
    
    33 33
     import Control.Monad    ( when )
    
    34
    +import Data.Foldable
    
    34 35
     import Foreign.C
    
    35 36
     import Foreign.Marshal.Alloc ( alloca, free )
    
    36 37
     import Foreign          ( nullPtr, peek )
    
    ... ... @@ -43,6 +44,10 @@ import Control.Exception (catch, evaluate)
    43 44
     import GHC.Wasm.Prim
    
    44 45
     #endif
    
    45 46
     
    
    47
    +#if defined(wasm32_HOST_ARCH)
    
    48
    +import Data.List (intercalate)
    
    49
    +#endif
    
    50
    +
    
    46 51
     -- ---------------------------------------------------------------------------
    
    47 52
     -- RTS Linker Interface
    
    48 53
     -- ---------------------------------------------------------------------------
    
    ... ... @@ -67,20 +72,25 @@ data ShouldRetainCAFs
    67 72
     initObjLinker :: ShouldRetainCAFs -> IO ()
    
    68 73
     initObjLinker _ = pure ()
    
    69 74
     
    
    70
    -loadDLL :: String -> IO (Either String (Ptr LoadedDLL))
    
    71
    -loadDLL f =
    
    75
    +-- Batch load multiple DLLs at once via dyld to enable a single
    
    76
    +-- dependency resolution and more parallel compilation. We pass a
    
    77
    +-- NUL-delimited JSString to avoid array marshalling on wasm.
    
    78
    +loadDLLs :: [String] -> IO (Either String [Ptr LoadedDLL])
    
    79
    +loadDLLs fs =
    
    72 80
       m `catch` \(err :: JSException) ->
    
    73
    -    pure $ Left $ "loadDLL failed for " <> f <> ": " <> show err
    
    81
    +    pure $ Left $ "loadDLLs failed: " <> show err
    
    74 82
       where
    
    83
    +    packed :: JSString
    
    84
    +    packed = toJSString (intercalate ['\0'] fs)
    
    75 85
         m = do
    
    76
    -      evaluate =<< js_loadDLL (toJSString f)
    
    77
    -      pure $ Right nullPtr
    
    86
    +      evaluate =<< js_loadDLLs packed
    
    87
    +      pure $ Right (replicate (length fs) nullPtr)
    
    78 88
     
    
    79 89
     -- See Note [Variable passing in JSFFI] for where
    
    80 90
     -- __ghc_wasm_jsffi_dyld comes from
    
    81 91
     
    
    82
    -foreign import javascript safe "__ghc_wasm_jsffi_dyld.loadDLL($1)"
    
    83
    -  js_loadDLL :: JSString -> IO ()
    
    92
    +foreign import javascript safe "__ghc_wasm_jsffi_dyld.loadDLLs($1)"
    
    93
    +  js_loadDLLs :: JSString -> IO ()
    
    84 94
     
    
    85 95
     loadArchive :: String -> IO ()
    
    86 96
     loadArchive f = throwIO $ ErrorCall $ "loadArchive: unsupported on wasm for " <> f
    
    ... ... @@ -241,6 +251,16 @@ resolveObjs = do
    241 251
        r <- c_resolveObjs
    
    242 252
        return (r /= 0)
    
    243 253
     
    
    254
    +loadDLLs :: [String] -> IO (Either String [Ptr LoadedDLL])
    
    255
    +loadDLLs = foldrM load_one $ Right []
    
    256
    +  where
    
    257
    +    load_one _ err@(Left _) = pure err
    
    258
    +    load_one p (Right dlls) = do
    
    259
    +      r <- loadDLL p
    
    260
    +      pure $ case r of
    
    261
    +        Left err -> Left err
    
    262
    +        Right dll -> Right $ dll : dlls
    
    263
    +
    
    244 264
     -- ---------------------------------------------------------------------------
    
    245 265
     -- Foreign declarations to RTS entry points which does the real work;
    
    246 266
     -- ---------------------------------------------------------------------------
    

  • libraries/ghci/GHCi/Run.hs
    ... ... @@ -57,7 +57,7 @@ run m = case m of
    57 57
     #if defined(javascript_HOST_ARCH)
    
    58 58
       LoadObj p                   -> withCString p loadJS
    
    59 59
       InitLinker                  -> notSupportedJS m
    
    60
    -  LoadDLL {}                  -> notSupportedJS m
    
    60
    +  LoadDLLs {}                 -> notSupportedJS m
    
    61 61
       LoadArchive {}              -> notSupportedJS m
    
    62 62
       UnloadObj {}                -> notSupportedJS m
    
    63 63
       AddLibrarySearchPath {}     -> notSupportedJS m
    
    ... ... @@ -69,7 +69,7 @@ run m = case m of
    69 69
       LookupClosure str           -> lookupJSClosure str
    
    70 70
     #else
    
    71 71
       InitLinker -> initObjLinker RetainCAFs
    
    72
    -  LoadDLL str -> fmap toRemotePtr <$> loadDLL str
    
    72
    +  LoadDLLs strs -> fmap (map toRemotePtr) <$> loadDLLs strs
    
    73 73
       LoadArchive str -> loadArchive str
    
    74 74
       LoadObj str -> loadObj str
    
    75 75
       UnloadObj str -> unloadObj str
    

  • testsuite/tests/rts/linker/T2615.hs
    ... ... @@ -4,7 +4,7 @@ library_name = "libfoo_script_T2615.so" -- this is really a linker script
    4 4
     
    
    5 5
     main = do
    
    6 6
       initObjLinker RetainCAFs
    
    7
    -  result <- loadDLL library_name
    
    7
    +  result <- loadDLLs [library_name]
    
    8 8
       case result of
    
    9 9
         Right _ -> putStrLn (library_name ++ " loaded successfully")
    
    10 10
         Left x  -> putStrLn ("error: " ++ x)

  • utils/jsffi/dyld.mjs
    ... ... @@ -9,7 +9,7 @@
    9 9
     //    iserv (GHCi.Server.defaultServer). This part only runs in
    
    10 10
     //    nodejs.
    
    11 11
     // 2. Dynamic linker: provide RTS linker interfaces like
    
    12
    -//    loadDLL/lookupSymbol etc which are imported by wasm iserv. This
    
    12
    +//    loadDLLs/lookupSymbol etc which are imported by wasm iserv. This
    
    13 13
     //    part can run in browsers as well.
    
    14 14
     //
    
    15 15
     // When GHC starts external interpreter for the wasm target, it starts
    
    ... ... @@ -50,7 +50,7 @@
    50 50
     //
    
    51 51
     // *** What works right now and what doesn't work yet?
    
    52 52
     //
    
    53
    -// loadDLL & bytecode interpreter work. Template Haskell & ghci work.
    
    53
    +// loadDLLs & bytecode interpreter work. Template Haskell & ghci work.
    
    54 54
     // Profiled dynamic code works. Compiled code and bytecode can all be
    
    55 55
     // loaded, though the side effects are constrained to what's supported
    
    56 56
     // by wasi preview1: we map the full host filesystem into wasm cause
    
    ... ... @@ -777,17 +777,17 @@ class DyLD {
    777 777
         return this.#rpc.findSystemLibrary(f);
    
    778 778
       }
    
    779 779
     
    
    780
    -  // When we do loadDLL, we first perform "downsweep" which return a
    
    780
    +  // When we do loadDLLs, we first perform "downsweep" which return a
    
    781 781
       // toposorted array of dependencies up to itself, then sequentially
    
    782 782
       // load the downsweep result.
    
    783 783
       //
    
    784 784
       // The rationale of a separate downsweep phase, instead of a simple
    
    785
    -  // recursive loadDLL function is: V8 delegates async
    
    785
    +  // recursive loadDLLs function is: V8 delegates async
    
    786 786
       // WebAssembly.compile to a background worker thread pool. To
    
    787 787
       // maintain consistent internal linker state, we *must* load each so
    
    788 788
       // file sequentially, but it's okay to kick off compilation asap,
    
    789 789
       // store the Promise in downsweep result and await for the actual
    
    790
    -  // WebAssembly.Module in loadDLL logic. This way we can harness some
    
    790
    +  // WebAssembly.Module in loadDLLs logic. This way we can harness some
    
    791 791
       // background parallelism.
    
    792 792
       async #downsweep(p) {
    
    793 793
         const toks = p.split("/");
    
    ... ... @@ -828,8 +828,26 @@ class DyLD {
    828 828
         return acc;
    
    829 829
       }
    
    830 830
     
    
    831
    -  // The real stuff
    
    832
    -  async loadDLL(p) {
    
    831
    +  // Batch load multiple DLLs in one go.
    
    832
    +  // Accepts a NUL-delimited string of paths to avoid array marshalling.
    
    833
    +  // Each path can be absolute or a soname; dependency resolution is
    
    834
    +  // performed across the full set to enable maximal parallel compile
    
    835
    +  // while maintaining sequential instantiation order.
    
    836
    +  async loadDLLs(packed) {
    
    837
    +    // Normalize input to an array of strings. When called from Haskell
    
    838
    +    // we pass a single JSString containing NUL-separated paths.
    
    839
    +    const paths = (typeof packed === "string"
    
    840
    +      ? (packed.length === 0 ? [] : packed.split("\0"))
    
    841
    +      : [packed] // tolerate an accidental single path object
    
    842
    +    ).filter((s) => s.length > 0).reverse();
    
    843
    +
    
    844
    +    // Compute a single downsweep plan for the whole batch.
    
    845
    +    // Note: #downsweep mutates #loadedSos to break cycles and dedup.
    
    846
    +    const plan = [];
    
    847
    +    for (const p of paths) {
    
    848
    +      plan.push(...(await this.#downsweep(p)));
    
    849
    +    }
    
    850
    +
    
    833 851
         for (const {
    
    834 852
           memSize,
    
    835 853
           memP2Align,
    
    ... ... @@ -837,7 +855,7 @@ class DyLD {
    837 855
           tableP2Align,
    
    838 856
           modp,
    
    839 857
           soname,
    
    840
    -    } of await this.#downsweep(p)) {
    
    858
    +    } of plan) {
    
    841 859
           const import_obj = {
    
    842 860
             wasi_snapshot_preview1: this.#wasi.wasiImport,
    
    843 861
             env: {
    
    ... ... @@ -1131,7 +1149,7 @@ export async function main({ rpc, libdir, ghciSoPath, args }) {
    1131 1149
           rpc,
    
    1132 1150
         });
    
    1133 1151
         await dyld.addLibrarySearchPath(libdir);
    
    1134
    -    await dyld.loadDLL(ghciSoPath);
    
    1152
    +    await dyld.loadDLLs(ghciSoPath);
    
    1135 1153
     
    
    1136 1154
         const reader = rpc.readStream.getReader();
    
    1137 1155
         const writer = rpc.writeStream.getWriter();