diff --git a/asterius/src/Asterius/Ar.hs b/asterius/src/Asterius/Ar.hs index 1093dfd5a6..4a74942ee3 100644 --- a/asterius/src/Asterius/Ar.hs +++ b/asterius/src/Asterius/Ar.hs @@ -35,7 +35,6 @@ where import Asterius.Binary.ByteString import Asterius.Types -import qualified Asterius.Types.SymbolMap as SM import Control.Monad import Data.Binary.Get import Data.Binary.Put @@ -173,11 +172,7 @@ loadArchiveRep ncu path = do Left {} -> pure mempty -- Note [Malformed object files] in Asterius.Ld Right m -> pure m let combined = mconcat ms - pure - combined - { archiveSources = Set.singleton path, - symbolOrigin = SM.fromList [(k, path) | k <- SM.keys $ dependencyMap combined] - } + pure combined {archiveSources = Set.singleton path} loadArchiveFile :: GHC.NameCacheUpdater -> FilePath -> (AsteriusModule -> AsteriusModule) -> IO AsteriusModule loadArchiveFile ncu path fn = do diff --git a/asterius/src/Asterius/Passes/GCSections.hs b/asterius/src/Asterius/Passes/GCSections.hs index 3f3f87e28e..481bd1071d 100644 --- a/asterius/src/Asterius/Passes/GCSections.hs +++ b/asterius/src/Asterius/Passes/GCSections.hs @@ -103,12 +103,12 @@ gcModule mod_syms export_funcs m = -- approach thus depends on two important assumptions: (a) for each JSFFI -- import, @@ and @_wrapper@ are always in the same module, and (b) -- the keys of the @sptMap@ refer only to statics in the same module. -loadFilterEverything :: AsteriusRepModule -> Set.Set FilePath -> (AsteriusModule -> AsteriusModule) -> IO AsteriusModule -loadFilterEverything AsteriusRepModule {..} accessed_files fn = do +loadFilterEverything :: AsteriusRepModule -> (AsteriusModule -> AsteriusModule) -> IO AsteriusModule +loadFilterEverything AsteriusRepModule {..} fn = do ncu <- newNameCacheUpdater - objs <- for [p | p <- Set.toList objectSources, p `Set.member` accessed_files] $ \path -> + objs <- for (Set.toList objectSources) $ \path -> fn <$> loadObjectFile ncu path - arcs <- for [p | p <- Set.toList archiveSources, p `Set.member` accessed_files] $ \path -> + arcs <- for (Set.toList archiveSources) $ \path -> loadArchiveFile ncu path fn pure $ fn inMemoryModule <> mconcat objs <> mconcat arcs @@ -126,14 +126,9 @@ fromAsteriusRepModule AsteriusRepModule {..} = do buildGCModule :: SS.SymbolSet -> SS.SymbolSet -> AsteriusRepModule -> SS.SymbolSet -> IO AsteriusModule buildGCModule mod_syms err_syms module_rep export_funcs = do - everything <- loadFilterEverything module_rep accessed_files (gcModule mod_syms export_funcs) + everything <- loadFilterEverything module_rep (gcModule mod_syms export_funcs) pure everything {staticsMap = staticsMap everything <> err_statics} where - accessed_files = - Set.fromList - $ catMaybes - $ map (`SM.lookup` symbolOrigin module_rep) - $ SS.toList mod_syms err_statics = SM.fromList [ ( "__asterius_barf_" <> sym, diff --git a/asterius/src/Asterius/Types.hs b/asterius/src/Asterius/Types.hs index aaf0533b17..6e6f258989 100644 --- a/asterius/src/Asterius/Types.hs +++ b/asterius/src/Asterius/Types.hs @@ -189,10 +189,7 @@ mkModuleExports m = loadObjectRep :: GHC.NameCacheUpdater -> FilePath -> IO AsteriusRepModule loadObjectRep ncu path = tryGetFile ncu path >>= \case Left {} -> pure mempty -- Note [Malformed object files] in Asterius.Ld - Right m -> pure m - { objectSources = Set.singleton path, - symbolOrigin = SM.fromList [ (k, path) | k <- SM.keys $ dependencyMap m ] - } + Right m -> pure m {objectSources = Set.singleton path} -- | Load a module in its entirety from disk. loadObjectFile :: GHC.NameCacheUpdater -> FilePath -> IO AsteriusModule @@ -230,8 +227,6 @@ data AsteriusRepModule objectSources :: Set.Set FilePath, -- | (not on disk) Archive file dependencies. archiveSources :: Set.Set FilePath, - -- | (not on disk) Source-file origin for all symbols that come from disk. - symbolOrigin :: SymbolMap FilePath, -- | (not on disk) In-memory parts of the module that are not yet stored anywhere on disk yet. inMemoryModule :: AsteriusModule } @@ -252,24 +247,22 @@ instance GHC.Binary AsteriusRepModule where moduleExports = exports, objectSources = mempty, -- It is set later. archiveSources = mempty, -- It is set later. - symbolOrigin = mempty, -- It is set later. inMemoryModule = mempty } put_ _ _ = error "GHC.Binary.put_: AsteriusRepModule" instance Semigroup AsteriusRepModule where - AsteriusRepModule dm0 out0 osrc0 asrc0 or0 inmem0 <> AsteriusRepModule dm1 out1 osrc1 asrc1 or1 inmem1 = + AsteriusRepModule dm0 out0 osrc0 asrc0 inmem0 <> AsteriusRepModule dm1 out1 osrc1 asrc1 inmem1 = AsteriusRepModule (dm0 <> dm1) (out0 <> out1) (osrc0 <> osrc1) (asrc0 <> asrc1) - (or0 <> or1) (inmem0 <> inmem1) instance Monoid AsteriusRepModule where - mempty = AsteriusRepModule mempty mempty mempty mempty mempty mempty + mempty = AsteriusRepModule mempty mempty mempty mempty mempty -- | Convert an 'AsteriusModule' to an 'AsteriusRepModule' by laboriously -- computing the dependency graph for each 'EntitySymbol' and all the @@ -281,7 +274,6 @@ toAsteriusRepModule m = moduleExports = mkModuleExports m, objectSources = mempty, archiveSources = mempty, - symbolOrigin = mempty, inMemoryModule = m }