|
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
|
| ... |
... |
@@ -1132,33 +1133,57 @@ loadPackages interp hsc_env new_pkgs = do |
|
1132
|
1133
|
|
|
1133
|
1134
|
loadPackages' :: Interp -> HscEnv -> [UnitId] -> LoaderState -> IO LoaderState
|
|
1134
|
1135
|
loadPackages' interp hsc_env new_pks pls = do
|
|
1135
|
|
- pkgs' <- link (pkgs_loaded pls) new_pks
|
|
1136
|
|
- return $! pls { pkgs_loaded = pkgs'
|
|
|
1136
|
+ (reverse -> pkgs_info_list, pkgs_almost_loaded) <-
|
|
|
1137
|
+ downsweep
|
|
|
1138
|
+ ([], pkgs_loaded pls)
|
|
|
1139
|
+ new_pks
|
|
|
1140
|
+ let link_one pkgs new_pkg_info = do
|
|
|
1141
|
+ (hs_cls, extra_cls, loaded_dlls) <-
|
|
|
1142
|
+ loadPackage
|
|
|
1143
|
+ interp
|
|
|
1144
|
+ hsc_env
|
|
|
1145
|
+ new_pkg_info
|
|
|
1146
|
+ evaluate $
|
|
|
1147
|
+ adjustUDFM
|
|
|
1148
|
+ ( \old_pkg_info ->
|
|
|
1149
|
+ old_pkg_info
|
|
|
1150
|
+ { loaded_pkg_hs_objs = hs_cls,
|
|
|
1151
|
+ loaded_pkg_non_hs_objs = extra_cls,
|
|
|
1152
|
+ loaded_pkg_hs_dlls = loaded_dlls
|
|
1137
|
1153
|
}
|
|
|
1154
|
+ )
|
|
|
1155
|
+ pkgs
|
|
|
1156
|
+ (Packages.unitId new_pkg_info)
|
|
|
1157
|
+ pkgs_loaded' <- foldlM link_one pkgs_almost_loaded pkgs_info_list
|
|
|
1158
|
+ evaluate $ pls {pkgs_loaded = pkgs_loaded'}
|
|
1138
|
1159
|
where
|
|
1139
|
|
- link :: PkgsLoaded -> [UnitId] -> IO PkgsLoaded
|
|
1140
|
|
- link pkgs new_pkgs =
|
|
1141
|
|
- foldM link_one pkgs new_pkgs
|
|
1142
|
|
-
|
|
1143
|
|
- link_one pkgs new_pkg
|
|
1144
|
|
- | new_pkg `elemUDFM` pkgs -- Already linked
|
|
1145
|
|
- = return pkgs
|
|
1146
|
|
-
|
|
1147
|
|
- | Just pkg_cfg <- lookupUnitId (hsc_units hsc_env) new_pkg
|
|
1148
|
|
- = do { let deps = unitDepends pkg_cfg
|
|
1149
|
|
- -- Link dependents first
|
|
1150
|
|
- ; pkgs' <- link pkgs deps
|
|
1151
|
|
- -- Now link the package itself
|
|
1152
|
|
- ; (hs_cls, extra_cls, loaded_dlls) <- loadPackage interp hsc_env pkg_cfg
|
|
1153
|
|
- ; let trans_deps = unionManyUniqDSets [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg
|
|
1154
|
|
- | dep_pkg <- deps
|
|
1155
|
|
- , Just loaded_pkg_info <- pure (lookupUDFM pkgs' dep_pkg)
|
|
1156
|
|
- ]
|
|
1157
|
|
- ; return (addToUDFM pkgs' new_pkg (LoadedPkgInfo new_pkg hs_cls extra_cls loaded_dlls trans_deps)) }
|
|
1158
|
|
-
|
|
1159
|
|
- | otherwise
|
|
1160
|
|
- = throwGhcExceptionIO (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))
|
|
1161
|
|
-
|
|
|
1160
|
+ downsweep = foldlM downsweep_one
|
|
|
1161
|
+
|
|
|
1162
|
+ downsweep_one (pkgs_info_list, pkgs) new_pkg
|
|
|
1163
|
+ | new_pkg `elemUDFM` pkgs = pure (pkgs_info_list, pkgs)
|
|
|
1164
|
+ | Just new_pkg_info <- lookupUnitId (hsc_units hsc_env) new_pkg = do
|
|
|
1165
|
+ let new_pkg_deps = unitDepends new_pkg_info
|
|
|
1166
|
+ (pkgs_info_list', pkgs') <- downsweep (pkgs_info_list, pkgs) new_pkg_deps
|
|
|
1167
|
+ let new_pkg_trans_deps =
|
|
|
1168
|
+ unionManyUniqDSets
|
|
|
1169
|
+ [ addOneToUniqDSet (loaded_pkg_trans_deps loaded_pkg_info) dep_pkg
|
|
|
1170
|
+ | dep_pkg <- new_pkg_deps,
|
|
|
1171
|
+ loaded_pkg_info <- maybeToList $ pkgs' `lookupUDFM` dep_pkg
|
|
|
1172
|
+ ]
|
|
|
1173
|
+ pure
|
|
|
1174
|
+ ( new_pkg_info : pkgs_info_list',
|
|
|
1175
|
+ addToUDFM pkgs' new_pkg $
|
|
|
1176
|
+ LoadedPkgInfo
|
|
|
1177
|
+ { loaded_pkg_uid = new_pkg,
|
|
|
1178
|
+ loaded_pkg_hs_objs = [],
|
|
|
1179
|
+ loaded_pkg_non_hs_objs = [],
|
|
|
1180
|
+ loaded_pkg_hs_dlls = [],
|
|
|
1181
|
+ loaded_pkg_trans_deps = new_pkg_trans_deps
|
|
|
1182
|
+ }
|
|
|
1183
|
+ )
|
|
|
1184
|
+ | otherwise =
|
|
|
1185
|
+ throwGhcExceptionIO
|
|
|
1186
|
+ (CmdLineError ("unknown package: " ++ unpackFS (unitIdFS new_pkg)))
|
|
1162
|
1187
|
|
|
1163
|
1188
|
loadPackage :: Interp -> HscEnv -> UnitInfo -> IO ([LibrarySpec], [LibrarySpec], [RemotePtr LoadedDLL])
|
|
1164
|
1189
|
loadPackage interp hsc_env pkg
|