[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 17 commits: Hadrian: always generate the libffi dynlibs manifest with globbing
Marge Bot
gitlab at gitlab.haskell.org
Thu May 30 11:33:31 UTC 2019
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
3aa71a22 by Alp Mestanogullari at 2019-05-30T11:28:32Z
Hadrian: always generate the libffi dynlibs manifest with globbing
Instead of trying to deduce which dynlibs are expected to be found (and then
copied to the RTS's build dir) in libffi's build directory, with some OS
specific logic, we now always just use `getDirectoryFilesIO` to look for
those dynlibs and record their names in the manifest. The previous logic
ended up causing problems on Windows, where we don't build dynlibs at all
for now but the manifest file's logic didn't take that into account because
it was only partially reproducing the criterions that determine whether or not
we will be building shared libraries.
This patch also re-enables the Hadrian/Windows CI job, which was failing to
build GHC precisely because of libffi shared libraries and the aforementionned
duplicated logic.
- - - - -
ade53ce2 by Ben Gamari at 2019-05-30T11:29:10Z
CODEOWNERS: Use correct username for Richard Eisenberg
In !980 Richard noted that he could not approve the MR.
This mis-spelling was the reason.
[skip ci]
- - - - -
4ad37a32 by Ben Gamari at 2019-05-30T11:29:47Z
rts: Handle zero-sized mappings in MachO linker
As noted in #16701, it is possible that we will find that an object has
no segments needing to be mapped. Previously this would result in mmap
being called for a zero-length mapping, which would fail. We now simply
skip the mmap call in this case; the rest of the logic just works.
- - - - -
c1d1c1a2 by Phuong Trinh at 2019-05-30T11:33:17Z
Use binary search to speedup checkUnload
We are iterating through all object code for each heap objects when
checking whether object code can be unloaded. For large projects in
GHCi, this can be very expensive due to the large number of object code
that needs to be loaded/unloaded. To speed it up, this arrangess all
mapped sections of unloaded object code in a sorted array and use binary
search to check if an address location fall on them.
- - - - -
8b14a284 by Trịnh Tuấn Phương at 2019-05-30T11:33:17Z
Apply suggestion to rts/CheckUnload.c
- - - - -
77baa578 by Trịnh Tuấn Phương at 2019-05-30T11:33:17Z
Apply suggestion to rts/CheckUnload.c
- - - - -
894ac429 by Daniel Gröber at 2019-05-30T11:33:18Z
Export GhcMake.downsweep
This is to enable #10887 as well as to make it possible to test downsweep
on its own in the testsuite.
- - - - -
64e95ca8 by Daniel Gröber at 2019-05-30T11:33:18Z
Add failing test for #10887
- - - - -
8164edc5 by Daniel Gröber at 2019-05-30T11:33:18Z
Refactor downsweep to allow returning multiple errors per module
- - - - -
20b7cdca by Daniel Gröber at 2019-05-30T11:33:18Z
Refactor summarise{File,Module} to reduce code duplication
- - - - -
e0079565 by Daniel Gröber at 2019-05-30T11:33:18Z
Refactor summarise{File,Module} to extract checkSummaryTimestamp
This introduces a slight change of behaviour in the interrest of keeping
the code simple: Previously summariseModule would not call
addHomeModuleToFinder for summaries that are being re-used but now we do.
We're forced to to do this in summariseFile because the file being
summarised might not even be on the regular search path! So if GHC is to
find it at all we have to pre-populate the cache with its location. For
modules however the finder cache is really just a cache so we don't have to
pre-populate it with the module's location.
As straightforward as that seems I did almost manage to introduce a bug (or
so I thought) because the call to addHomeModuleToFinder I copied from
summariseFile used to use `ms_location old_summary` instead of the
`location` argument to checkSummaryTimestamp. If this call were to
overwrite the existing entry in the cache that would have resulted in us
using the old location of any module even if it was, say, moved to a
different directory between calls to 'depanal'.
However it turns out the cache just ignores the location if the module is
already in the cache. Since summariseModule has to search for the module,
which has the side effect of populating the cache, everything would have
been fine either way.
Well I'm adding a test for this anyways: tests/depanal/OldModLocation.hs.
- - - - -
e2bde788 by Daniel Gröber at 2019-05-30T11:33:18Z
Make downsweep return all errors per-module instead of throwing some
This enables API clients to handle such errors instead of immideately
crashing in the face of some kinds of user errors, which is arguably quite
bad UX.
Fixes #10887
- - - - -
56edfb9e by Daniel Gröber at 2019-05-30T11:33:18Z
Catch preprocessor errors in downsweep
This changes the way preprocessor failures are presented to the
user. Previously the user would simply get an unlocated message on stderr
such as:
`gcc' failed in phase `C pre-processor'. (Exit code: 1)
Now at the problematic source file is mentioned:
A.hs:1:1: error:
`gcc' failed in phase `C pre-processor'. (Exit code: 1)
This also makes live easier for GHC API clients as the preprocessor error
is now thrown as a SourceError exception.
- - - - -
f67c0198 by Daniel Gröber at 2019-05-30T11:33:18Z
PartialDownsweep: Add test for import errors
- - - - -
76666294 by Daniel Gröber at 2019-05-30T11:33:18Z
Add depanalPartial to make getting a partial modgraph easier
As per @mpickering's suggestion on IRC this is to make the partial
module-graph more easily accessible for API clients which don't intend to
re-implementing depanal.
- - - - -
9404e2a2 by Daniel Gröber at 2019-05-30T11:33:18Z
Improve targetContents code docs
- - - - -
fc9e2b21 by Ben Gamari at 2019-05-30T11:33:18Z
testsuite: Compile T9630 with +RTS -G1
For the reasons described in Note [residency] we run programs with -G1
when we care about the max_bytes_used metric.
- - - - -
26 changed files:
- .gitlab-ci.yml
- CODEOWNERS
- compiler/backpack/DriverBkp.hs
- compiler/main/DriverPipeline.hs
- compiler/main/GhcMake.hs
- compiler/main/HeaderInfo.hs
- compiler/main/HscTypes.hs
- hadrian/src/Rules/Libffi.hs
- rts/CheckUnload.c
- rts/linker/MachO.c
- testsuite/tests/driver/T8602/T8602.stderr
- + testsuite/tests/ghc-api/downsweep/OldModLocation.hs
- + testsuite/tests/ghc-api/downsweep/OldModLocation.stderr
- + testsuite/tests/ghc-api/downsweep/PartialDownsweep.darwin.stderr
- + testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs
- + testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr
- + testsuite/tests/ghc-api/downsweep/all.T
- testsuite/tests/perf/compiler/all.T
- + testsuite/tests/rts/linker/unload_multiple_objs/A.hs
- + testsuite/tests/rts/linker/unload_multiple_objs/B.hs
- + testsuite/tests/rts/linker/unload_multiple_objs/C.hs
- + testsuite/tests/rts/linker/unload_multiple_objs/D.hs
- + testsuite/tests/rts/linker/unload_multiple_objs/Makefile
- + testsuite/tests/rts/linker/unload_multiple_objs/all.T
- + testsuite/tests/rts/linker/unload_multiple_objs/linker_unload_multiple_objs.c
- + testsuite/tests/rts/linker/unload_multiple_objs/linker_unload_multiple_objs.stdout
Changes:
=====================================
.gitlab-ci.yml
=====================================
@@ -577,7 +577,7 @@ validate-x86_64-linux-fedora27:
paths:
- ghc.tar.xz
-.validate-x86_64-windows-hadrian:
+validate-x86_64-windows-hadrian:
extends: .build-windows-hadrian
variables:
MSYSTEM: MINGW64
=====================================
CODEOWNERS
=====================================
@@ -17,10 +17,10 @@
# The compiler
/compiler/parser/ @int-index
-/compiler/typecheck/ @simonpj @goldfire
-/compiler/rename/ @simonpj @goldfire
-/compiler/types/ @simonpj @goldfire
-/compiler/deSugar/ @simonpj @goldfire
+/compiler/typecheck/ @simonpj @rae
+/compiler/rename/ @simonpj @rae
+/compiler/types/ @simonpj @rae
+/compiler/deSugar/ @simonpj @rae
/compiler/typecheck/TcDeriv* @RyanGlScott
/compiler/nativeGen/ @simonmar @bgamari @AndreasK
/compiler/llvmGen/ @angerman
@@ -34,12 +34,12 @@
/compiler/simplStg/StgLiftLams.hs @sgraf
/compiler/cmm/CmmSwitch.hs @nomeata
/compiler/stranal/DmdAnal.hs @simonpj @sgraf
-/compiler/hsSyn/Convert.hs @goldfire
+/compiler/hsSyn/Convert.hs @rae
# Core libraries
/libraries/base/ @hvr
/libraries/ghci/ @simonmar
-/libraries/template-haskell/ @goldfire
+/libraries/template-haskell/ @rae
# Internal utilities and libraries
/libraries/libiserv/ @angerman @simonmar
=====================================
compiler/backpack/DriverBkp.hs
=====================================
@@ -729,7 +729,7 @@ summariseDecl _pn hsc_src lmodname@(L loc modname) Nothing
[] -- No exclusions
case r of
Nothing -> throwOneError (mkPlainErrMsg dflags loc (text "module" <+> ppr modname <+> text "was not found"))
- Just (Left err) -> throwOneError err
+ Just (Left err) -> throwErrors err
Just (Right summary) -> return summary
-- | Up until now, GHC has assumed a single compilation target per source file.
=====================================
compiler/main/DriverPipeline.hs
=====================================
@@ -51,7 +51,7 @@ import ErrUtils
import DynFlags
import Panic
import Util
-import StringBuffer ( StringBuffer, hGetStringBuffer, hPutStringBuffer )
+import StringBuffer ( hGetStringBuffer, hPutStringBuffer )
import BasicTypes ( SuccessFlag(..) )
import Maybes ( expectJust )
import SrcLoc
@@ -64,6 +64,8 @@ import Hooks
import qualified GHC.LanguageExtensions as LangExt
import FileCleanup
import Ar
+import Bag ( unitBag )
+import FastString ( mkFastString )
import Exception
import System.Directory
@@ -88,11 +90,14 @@ import Data.Time ( UTCTime )
preprocess :: HscEnv
-> FilePath -- ^ input filename
- -> Maybe StringBuffer
- -- ^ optional buffer to use instead of reading input file
+ -> Maybe InputFileBuffer
+ -- ^ optional buffer to use instead of reading the input file
-> Maybe Phase -- ^ starting phase
- -> IO (DynFlags, FilePath)
+ -> IO (Either ErrorMessages (DynFlags, FilePath))
preprocess hsc_env input_fn mb_input_buf mb_phase =
+ handleSourceError (\err -> return (Left (srcErrorMessages err))) $
+ ghandle handler $
+ fmap Right $
ASSERT2(isJust mb_phase || isHaskellSrcFilename input_fn, text input_fn)
runPipeline anyHsc hsc_env (input_fn, mb_input_buf, fmap RealPhase mb_phase)
Nothing
@@ -101,6 +106,11 @@ preprocess hsc_env input_fn mb_input_buf mb_phase =
(Temporary TFL_GhcSession)
Nothing{-no ModLocation-}
[]{-no foreign objects-}
+ where
+ srcspan = srcLocSpan $ mkSrcLoc (mkFastString input_fn) 1 1
+ handler (ProgramError msg) = return $ Left $ unitBag $
+ mkPlainErrMsg (hsc_dflags hsc_env) srcspan $ text msg
+ handler ex = throwGhcExceptionIO ex
-- ---------------------------------------------------------------------------
@@ -569,7 +579,7 @@ doLink dflags stop_phase o_files
runPipeline
:: Phase -- ^ When to stop
-> HscEnv -- ^ Compilation environment
- -> (FilePath, Maybe StringBuffer, Maybe PhasePlus)
+ -> (FilePath, Maybe InputFileBuffer, Maybe PhasePlus)
-- ^ Pipeline input file name, optional
-- buffer and maybe -x suffix
-> Maybe FilePath -- ^ original basename (if different from ^^^)
@@ -1032,8 +1042,11 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
(hspp_buf,mod_name,imps,src_imps) <- liftIO $ do
do
buf <- hGetStringBuffer input_fn
- (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
- return (Just buf, mod_name, imps, src_imps)
+ eimps <- getImports dflags buf input_fn (basename <.> suff)
+ case eimps of
+ Left errs -> throwErrors errs
+ Right (src_imps,imps,L _ mod_name) -> return
+ (Just buf, mod_name, imps, src_imps)
-- Take -o into account if present
-- Very like -ohi, but we must *only* do this if we aren't linking
=====================================
compiler/main/GhcMake.hs
=====================================
@@ -1,5 +1,5 @@
{-# LANGUAGE BangPatterns, CPP, NondecreasingIndentation, ScopedTypeVariables #-}
-{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards, NamedFieldPuns #-}
-- -----------------------------------------------------------------------------
--
@@ -10,9 +10,11 @@
--
-- -----------------------------------------------------------------------------
module GhcMake(
- depanal,
+ depanal, depanalPartial,
load, load', LoadHowMuch(..),
+ downsweep,
+
topSortModuleGraph,
ms_home_srcimps, ms_home_imps,
@@ -46,7 +48,7 @@ import TcIface ( typecheckIface )
import TcRnMonad ( initIfaceCheck )
import HscMain
-import Bag ( listToBag )
+import Bag ( unitBag, listToBag, unionManyBags, isEmptyBag )
import BasicTypes
import Digraph
import Exception ( tryIO, gbracket, gfinally )
@@ -80,6 +82,7 @@ import Control.Concurrent.MVar
import Control.Concurrent.QSem
import Control.Exception
import Control.Monad
+import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
import Data.IORef
import Data.List
import qualified Data.List as List
@@ -119,6 +122,32 @@ depanal :: GhcMonad m =>
-> Bool -- ^ allow duplicate roots
-> m ModuleGraph
depanal excluded_mods allow_dup_roots = do
+ hsc_env <- getSession
+ (errs, mod_graph) <- depanalPartial excluded_mods allow_dup_roots
+ if isEmptyBag errs
+ then do
+ warnMissingHomeModules hsc_env mod_graph
+ setSession hsc_env { hsc_mod_graph = mod_graph }
+ return mod_graph
+ else throwErrors errs
+
+
+-- | Perform dependency analysis like 'depanal' but return a partial module
+-- graph even in the face of problems with some modules.
+--
+-- Modules which have parse errors in the module header, failing
+-- preprocessors or other issues preventing them from being summarised will
+-- simply be absent from the returned module graph.
+--
+-- Unlike 'depanal' this function will not update 'hsc_mod_graph' with the
+-- new module graph.
+depanalPartial
+ :: GhcMonad m
+ => [ModuleName] -- ^ excluded modules
+ -> Bool -- ^ allow duplicate roots
+ -> m (ErrorMessages, ModuleGraph)
+ -- ^ possibly empty 'Bag' of errors and a module graph.
+depanalPartial excluded_mods allow_dup_roots = do
hsc_env <- getSession
let
dflags = hsc_dflags hsc_env
@@ -138,14 +167,10 @@ depanal excluded_mods allow_dup_roots = do
mod_summariesE <- liftIO $ downsweep hsc_env (mgModSummaries old_graph)
excluded_mods allow_dup_roots
- mod_summaries <- reportImportErrors mod_summariesE
-
- let mod_graph = mkModuleGraph mod_summaries
-
- warnMissingHomeModules hsc_env mod_graph
-
- setSession hsc_env { hsc_mod_graph = mod_graph }
- return mod_graph
+ let
+ (errs, mod_summaries) = partitionEithers mod_summariesE
+ mod_graph = mkModuleGraph mod_summaries
+ return (unionManyBags errs, mod_graph)
-- Note [Missing home modules]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1910,14 +1935,11 @@ warnUnnecessarySourceImports sccs = do
<+> quotes (ppr mod))
-reportImportErrors :: MonadIO m => [Either ErrMsg b] -> m [b]
+reportImportErrors :: MonadIO m => [Either ErrorMessages b] -> m [b]
reportImportErrors xs | null errs = return oks
- | otherwise = throwManyErrors errs
+ | otherwise = throwErrors $ unionManyBags errs
where (errs, oks) = partitionEithers xs
-throwManyErrors :: MonadIO m => [ErrMsg] -> m ab
-throwManyErrors errs = liftIO $ throwIO $ mkSrcErr $ listToBag errs
-
-----------------------------------------------------------------------------
--
@@ -1941,7 +1963,7 @@ downsweep :: HscEnv
-> Bool -- True <=> allow multiple targets to have
-- the same module name; this is
-- very useful for ghc -M
- -> IO [Either ErrMsg ModSummary]
+ -> IO [Either ErrorMessages ModSummary]
-- The elts of [ModSummary] all have distinct
-- (Modules, IsBoot) identifiers, unless the Bool is true
-- in which case there can be repeats
@@ -1975,13 +1997,13 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
old_summary_map :: NodeMap ModSummary
old_summary_map = mkNodeMap old_summaries
- getRootSummary :: Target -> IO (Either ErrMsg ModSummary)
+ getRootSummary :: Target -> IO (Either ErrorMessages ModSummary)
getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
= do exists <- liftIO $ doesFileExist file
if exists || isJust maybe_buf
- then Right `fmap` summariseFile hsc_env old_summaries file mb_phase
+ then summariseFile hsc_env old_summaries file mb_phase
obj_allowed maybe_buf
- else return $ Left $ mkPlainErrMsg dflags noSrcSpan $
+ else return $ Left $ unitBag $ mkPlainErrMsg dflags noSrcSpan $
text "can't find file:" <+> text file
getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
= do maybe_summary <- summariseModule hsc_env old_summary_map NotBoot
@@ -1997,7 +2019,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
-- name, so we have to check that there aren't multiple root files
-- defining the same module (otherwise the duplicates will be silently
-- ignored, leading to confusing behaviour).
- checkDuplicates :: NodeMap [Either ErrMsg ModSummary] -> IO ()
+ checkDuplicates :: NodeMap [Either ErrorMessages ModSummary] -> IO ()
checkDuplicates root_map
| allow_dup_roots = return ()
| null dup_roots = return ()
@@ -2008,11 +2030,11 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
loop :: [(Located ModuleName,IsBoot)]
-- Work list: process these modules
- -> NodeMap [Either ErrMsg ModSummary]
+ -> NodeMap [Either ErrorMessages ModSummary]
-- Visited set; the range is a list because
-- the roots can have the same module names
-- if allow_dup_roots is True
- -> IO (NodeMap [Either ErrMsg ModSummary])
+ -> IO (NodeMap [Either ErrorMessages ModSummary])
-- The result is the completed NodeMap
loop [] done = return done
loop ((wanted_mod, is_boot) : ss) done
@@ -2041,8 +2063,8 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
-- and .o file locations to be temporary files.
-- See Note [-fno-code mode]
enableCodeGenForTH :: HscTarget
- -> NodeMap [Either ErrMsg ModSummary]
- -> IO (NodeMap [Either ErrMsg ModSummary])
+ -> NodeMap [Either ErrorMessages ModSummary]
+ -> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForTH =
enableCodeGenWhen condition should_modify TFL_CurrentModule TFL_GhcSession
where
@@ -2061,8 +2083,8 @@ enableCodeGenForTH =
-- This is used used in order to load code that uses unboxed tuples
-- into GHCi while still allowing some code to be interpreted.
enableCodeGenForUnboxedTuples :: HscTarget
- -> NodeMap [Either ErrMsg ModSummary]
- -> IO (NodeMap [Either ErrMsg ModSummary])
+ -> NodeMap [Either ErrorMessages ModSummary]
+ -> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenForUnboxedTuples =
enableCodeGenWhen condition should_modify TFL_GhcSession TFL_CurrentModule
where
@@ -2084,8 +2106,8 @@ enableCodeGenWhen
-> TempFileLifetime
-> TempFileLifetime
-> HscTarget
- -> NodeMap [Either ErrMsg ModSummary]
- -> IO (NodeMap [Either ErrMsg ModSummary])
+ -> NodeMap [Either ErrorMessages ModSummary]
+ -> IO (NodeMap [Either ErrorMessages ModSummary])
enableCodeGenWhen condition should_modify staticLife dynLife target nodemap =
traverse (traverse (traverse enable_code_gen)) nodemap
where
@@ -2147,7 +2169,7 @@ enableCodeGenWhen condition should_modify staticLife dynLife target nodemap =
new_marked_mods = Set.insert ms_mod marked_mods
in foldl' go new_marked_mods deps
-mkRootMap :: [ModSummary] -> NodeMap [Either ErrMsg ModSummary]
+mkRootMap :: [ModSummary] -> NodeMap [Either ErrorMessages ModSummary]
mkRootMap summaries = Map.insertListWith (flip (++))
[ (msKey s, [Right s]) | s <- summaries ]
Map.empty
@@ -2207,13 +2229,13 @@ summariseFile
-> Maybe Phase -- start phase
-> Bool -- object code allowed?
-> Maybe (StringBuffer,UTCTime)
- -> IO ModSummary
+ -> IO (Either ErrorMessages ModSummary)
-summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
+summariseFile hsc_env old_summaries src_fn mb_phase obj_allowed maybe_buf
-- we can use a cached summary if one is available and the
-- source file hasn't changed, But we have to look up the summary
-- by source file, rather than module name as we do in summarise.
- | Just old_summary <- findSummaryBySourceFile old_summaries file
+ | Just old_summary <- findSummaryBySourceFile old_summaries src_fn
= do
let location = ms_location old_summary
dflags = hsc_dflags hsc_env
@@ -2225,82 +2247,44 @@ summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf
-- behaviour.
-- return the cached summary if the source didn't change
- if ms_hs_date old_summary == src_timestamp &&
- not (gopt Opt_ForceRecomp (hsc_dflags hsc_env))
- then do -- update the object-file timestamp
- obj_timestamp <-
- if isObjectTarget (hscTarget (hsc_dflags hsc_env))
- || obj_allowed -- bug #1205
- then liftIO $ getObjTimestamp location NotBoot
- else return Nothing
- hi_timestamp <- maybeGetIfaceDate dflags location
- let hie_location = ml_hie_file location
- hie_timestamp <- modificationTimeIfExists hie_location
-
- -- We have to repopulate the Finder's cache because it
- -- was flushed before the downsweep.
- _ <- liftIO $ addHomeModuleToFinder hsc_env
- (moduleName (ms_mod old_summary)) (ms_location old_summary)
-
- return old_summary{ ms_obj_date = obj_timestamp
- , ms_iface_date = hi_timestamp
- , ms_hie_date = hie_timestamp }
- else
- new_summary src_timestamp
+ checkSummaryTimestamp
+ hsc_env dflags obj_allowed NotBoot (new_summary src_fn)
+ old_summary location src_timestamp
| otherwise
= do src_timestamp <- get_src_timestamp
- new_summary src_timestamp
+ new_summary src_fn src_timestamp
where
get_src_timestamp = case maybe_buf of
Just (_,t) -> return t
- Nothing -> liftIO $ getModificationUTCTime file
+ Nothing -> liftIO $ getModificationUTCTime src_fn
-- getModificationUTCTime may fail
- new_summary src_timestamp = do
- let dflags = hsc_dflags hsc_env
-
- let hsc_src = if isHaskellSigFilename file then HsigFile else HsSrcFile
+ new_summary src_fn src_timestamp = runExceptT $ do
+ preimps at PreprocessedImports {..}
+ <- getPreprocessedImports hsc_env src_fn mb_phase maybe_buf
- (dflags', hspp_fn, buf)
- <- preprocessFile hsc_env file mb_phase maybe_buf
-
- (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file
-- Make a ModLocation for this file
- location <- liftIO $ mkHomeModLocation dflags mod_name file
+ location <- liftIO $ mkHomeModLocation (hsc_dflags hsc_env) pi_mod_name src_fn
-- Tell the Finder cache where it is, so that subsequent calls
-- to findModule will find it, even if it's not on any search path
- mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location
-
- -- when the user asks to load a source file by name, we only
- -- use an object file if -fobject-code is on. See #1205.
- obj_timestamp <-
- if isObjectTarget (hscTarget (hsc_dflags hsc_env))
- || obj_allowed -- bug #1205
- then liftIO $ modificationTimeIfExists (ml_obj_file location)
- else return Nothing
-
- hi_timestamp <- maybeGetIfaceDate dflags location
- hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
-
- extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name
- required_by_imports <- implicitRequirements hsc_env the_imps
-
- return (ModSummary { ms_mod = mod,
- ms_hsc_src = hsc_src,
- ms_location = location,
- ms_hspp_file = hspp_fn,
- ms_hspp_opts = dflags',
- ms_hspp_buf = Just buf,
- ms_parsed_mod = Nothing,
- ms_srcimps = srcimps,
- ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,
- ms_hs_date = src_timestamp,
- ms_iface_date = hi_timestamp,
- ms_hie_date = hie_timestamp,
- ms_obj_date = obj_timestamp })
+ mod <- liftIO $ addHomeModuleToFinder hsc_env pi_mod_name location
+
+ liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
+ { nms_src_fn = src_fn
+ , nms_src_timestamp = src_timestamp
+ , nms_is_boot = NotBoot
+ , nms_hsc_src =
+ if isHaskellSigFilename src_fn
+ then HsigFile
+ else HsSrcFile
+ , nms_location = location
+ , nms_mod = mod
+ , nms_obj_allowed = obj_allowed
+ , nms_preimps = preimps
+ }
findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
findSummaryBySourceFile summaries file
@@ -2309,6 +2293,44 @@ findSummaryBySourceFile summaries file
[] -> Nothing
(x:_) -> Just x
+checkSummaryTimestamp
+ :: HscEnv -> DynFlags -> Bool -> IsBoot
+ -> (UTCTime -> IO (Either e ModSummary))
+ -> ModSummary -> ModLocation -> UTCTime
+ -> IO (Either e ModSummary)
+checkSummaryTimestamp
+ hsc_env dflags obj_allowed is_boot new_summary
+ old_summary location src_timestamp
+ | ms_hs_date old_summary == src_timestamp &&
+ not (gopt Opt_ForceRecomp (hsc_dflags hsc_env)) = do
+ -- update the object-file timestamp
+ obj_timestamp <-
+ if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+ || obj_allowed -- bug #1205
+ then liftIO $ getObjTimestamp location is_boot
+ else return Nothing
+
+ -- We have to repopulate the Finder's cache for file targets
+ -- because the file might not even be on the regular serach path
+ -- and it was likely flushed in depanal. This is not technically
+ -- needed when we're called from sumariseModule but it shouldn't
+ -- hurt.
+ _ <- addHomeModuleToFinder hsc_env
+ (moduleName (ms_mod old_summary)) location
+
+ hi_timestamp <- maybeGetIfaceDate dflags location
+ hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
+
+ return $ Right old_summary
+ { ms_obj_date = obj_timestamp
+ , ms_iface_date = hi_timestamp
+ , ms_hie_date = hie_timestamp
+ }
+
+ | otherwise =
+ -- source changed: re-summarise.
+ new_summary src_timestamp
+
-- Summarise a module, and pick up source and timestamp.
summariseModule
:: HscEnv
@@ -2318,7 +2340,7 @@ summariseModule
-> Bool -- object code allowed?
-> Maybe (StringBuffer, UTCTime)
-> [ModuleName] -- Modules to exclude
- -> IO (Maybe (Either ErrMsg ModSummary)) -- Its new summary
+ -> IO (Maybe (Either ErrorMessages ModSummary)) -- Its new summary
summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
obj_allowed maybe_buf excl_mods
@@ -2335,11 +2357,13 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
-- return the cached summary if it hasn't changed. If the
-- file has disappeared, we need to call the Finder again.
case maybe_buf of
- Just (_,t) -> check_timestamp old_summary location src_fn t
+ Just (_,t) ->
+ Just <$> check_timestamp old_summary location src_fn t
Nothing -> do
m <- tryIO (getModificationUTCTime src_fn)
case m of
- Right t -> check_timestamp old_summary location src_fn t
+ Right t ->
+ Just <$> check_timestamp old_summary location src_fn t
Left e | isDoesNotExistError e -> find_it
| otherwise -> ioError e
@@ -2347,23 +2371,11 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
where
dflags = hsc_dflags hsc_env
- check_timestamp old_summary location src_fn src_timestamp
- | ms_hs_date old_summary == src_timestamp &&
- not (gopt Opt_ForceRecomp dflags) = do
- -- update the object-file timestamp
- obj_timestamp <-
- if isObjectTarget (hscTarget (hsc_dflags hsc_env))
- || obj_allowed -- bug #1205
- then getObjTimestamp location is_boot
- else return Nothing
- hi_timestamp <- maybeGetIfaceDate dflags location
- hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
- return (Just (Right old_summary{ ms_obj_date = obj_timestamp
- , ms_iface_date = hi_timestamp
- , ms_hie_date = hie_timestamp }))
- | otherwise =
- -- source changed: re-summarise.
- new_summary location (ms_mod old_summary) src_fn src_timestamp
+ check_timestamp old_summary location src_fn =
+ checkSummaryTimestamp
+ hsc_env dflags obj_allowed is_boot
+ (new_summary location (ms_mod old_summary) src_fn)
+ old_summary location
find_it = do
found <- findImportedModule hsc_env wanted_mod Nothing
@@ -2371,7 +2383,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
Found location mod
| isJust (ml_hs_file location) ->
-- Home package
- just_found location mod
+ Just <$> just_found location mod
_ -> return Nothing
-- Not found
@@ -2389,16 +2401,13 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
-- It might have been deleted since the Finder last found it
maybe_t <- modificationTimeIfExists src_fn
case maybe_t of
- Nothing -> return $ Just $ Left $ noHsFileErr dflags loc src_fn
+ Nothing -> return $ Left $ noHsFileErr dflags loc src_fn
Just t -> new_summary location' mod src_fn t
-
new_summary location mod src_fn src_timestamp
- = do
- -- Preprocess the source file and get its imports
- -- The dflags' contains the OPTIONS pragmas
- (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf
- (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
+ = runExceptT $ do
+ preimps at PreprocessedImports {..}
+ <- getPreprocessedImports hsc_env src_fn Nothing maybe_buf
-- NB: Despite the fact that is_boot is a top-level parameter, we
-- don't actually know coming into this function what the HscSource
@@ -2412,75 +2421,123 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
_ | isHaskellSigFilename src_fn -> HsigFile
| otherwise -> HsSrcFile
- when (mod_name /= wanted_mod) $
- throwOneError $ mkPlainErrMsg dflags' mod_loc $
+ when (pi_mod_name /= wanted_mod) $
+ throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $
text "File name does not match module name:"
- $$ text "Saw:" <+> quotes (ppr mod_name)
+ $$ text "Saw:" <+> quotes (ppr pi_mod_name)
$$ text "Expected:" <+> quotes (ppr wanted_mod)
- when (hsc_src == HsigFile && isNothing (lookup mod_name (thisUnitIdInsts dflags))) $
+ when (hsc_src == HsigFile && isNothing (lookup pi_mod_name (thisUnitIdInsts dflags))) $
let suggested_instantiated_with =
hcat (punctuate comma $
[ ppr k <> text "=" <> ppr v
- | (k,v) <- ((mod_name, mkHoleModule mod_name)
+ | (k,v) <- ((pi_mod_name, mkHoleModule pi_mod_name)
: thisUnitIdInsts dflags)
])
- in throwOneError $ mkPlainErrMsg dflags' mod_loc $
- text "Unexpected signature:" <+> quotes (ppr mod_name)
+ in throwE $ unitBag $ mkPlainErrMsg pi_local_dflags pi_mod_name_loc $
+ text "Unexpected signature:" <+> quotes (ppr pi_mod_name)
$$ if gopt Opt_BuildingCabalPackage dflags
- then parens (text "Try adding" <+> quotes (ppr mod_name)
+ then parens (text "Try adding" <+> quotes (ppr pi_mod_name)
<+> text "to the"
<+> quotes (text "signatures")
<+> text "field in your Cabal file.")
else parens (text "Try passing -instantiated-with=\"" <>
suggested_instantiated_with <> text "\"" $$
- text "replacing <" <> ppr mod_name <> text "> as necessary.")
-
- -- Find the object timestamp, and return the summary
- obj_timestamp <-
- if isObjectTarget (hscTarget (hsc_dflags hsc_env))
- || obj_allowed -- bug #1205
- then getObjTimestamp location is_boot
- else return Nothing
-
- hi_timestamp <- maybeGetIfaceDate dflags location
- hie_timestamp <- modificationTimeIfExists (ml_hie_file location)
-
- extra_sig_imports <- findExtraSigImports hsc_env hsc_src mod_name
- required_by_imports <- implicitRequirements hsc_env the_imps
-
- return (Just (Right (ModSummary { ms_mod = mod,
- ms_hsc_src = hsc_src,
- ms_location = location,
- ms_hspp_file = hspp_fn,
- ms_hspp_opts = dflags',
- ms_hspp_buf = Just buf,
- ms_parsed_mod = Nothing,
- ms_srcimps = srcimps,
- ms_textual_imps = the_imps ++ extra_sig_imports ++ required_by_imports,
- ms_hs_date = src_timestamp,
- ms_iface_date = hi_timestamp,
- ms_hie_date = hie_timestamp,
- ms_obj_date = obj_timestamp })))
-
+ text "replacing <" <> ppr pi_mod_name <> text "> as necessary.")
+
+ liftIO $ makeNewModSummary hsc_env $ MakeNewModSummary
+ { nms_src_fn = src_fn
+ , nms_src_timestamp = src_timestamp
+ , nms_is_boot = is_boot
+ , nms_hsc_src = hsc_src
+ , nms_location = location
+ , nms_mod = mod
+ , nms_obj_allowed = obj_allowed
+ , nms_preimps = preimps
+ }
+
+-- | Convenience named arguments for 'makeNewModSummary' only used to make
+-- code more readable, not exported.
+data MakeNewModSummary
+ = MakeNewModSummary
+ { nms_src_fn :: FilePath
+ , nms_src_timestamp :: UTCTime
+ , nms_is_boot :: IsBoot
+ , nms_hsc_src :: HscSource
+ , nms_location :: ModLocation
+ , nms_mod :: Module
+ , nms_obj_allowed :: Bool
+ , nms_preimps :: PreprocessedImports
+ }
+
+makeNewModSummary :: HscEnv -> MakeNewModSummary -> IO ModSummary
+makeNewModSummary hsc_env MakeNewModSummary{..} = do
+ let PreprocessedImports{..} = nms_preimps
+ let dflags = hsc_dflags hsc_env
+
+ -- when the user asks to load a source file by name, we only
+ -- use an object file if -fobject-code is on. See #1205.
+ obj_timestamp <- liftIO $
+ if isObjectTarget (hscTarget dflags)
+ || nms_obj_allowed -- bug #1205
+ then getObjTimestamp nms_location nms_is_boot
+ else return Nothing
+
+ hi_timestamp <- maybeGetIfaceDate dflags nms_location
+ hie_timestamp <- modificationTimeIfExists (ml_hie_file nms_location)
+
+ extra_sig_imports <- findExtraSigImports hsc_env nms_hsc_src pi_mod_name
+ required_by_imports <- implicitRequirements hsc_env pi_theimps
+
+ return $ ModSummary
+ { ms_mod = nms_mod
+ , ms_hsc_src = nms_hsc_src
+ , ms_location = nms_location
+ , ms_hspp_file = pi_hspp_fn
+ , ms_hspp_opts = pi_local_dflags
+ , ms_hspp_buf = Just pi_hspp_buf
+ , ms_parsed_mod = Nothing
+ , ms_srcimps = pi_srcimps
+ , ms_textual_imps =
+ pi_theimps ++ extra_sig_imports ++ required_by_imports
+ , ms_hs_date = nms_src_timestamp
+ , ms_iface_date = hi_timestamp
+ , ms_hie_date = hie_timestamp
+ , ms_obj_date = obj_timestamp
+ }
getObjTimestamp :: ModLocation -> IsBoot -> IO (Maybe UTCTime)
getObjTimestamp location is_boot
= if is_boot == IsBoot then return Nothing
else modificationTimeIfExists (ml_obj_file location)
-
-preprocessFile :: HscEnv
- -> FilePath
- -> Maybe Phase -- ^ Starting phase
- -> Maybe (StringBuffer,UTCTime)
- -> IO (DynFlags, FilePath, StringBuffer)
-preprocessFile hsc_env src_fn mb_phase maybe_buf
- = do
- (dflags', hspp_fn)
- <- preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
- buf <- hGetStringBuffer hspp_fn
- return (dflags', hspp_fn, buf)
+data PreprocessedImports
+ = PreprocessedImports
+ { pi_local_dflags :: DynFlags
+ , pi_srcimps :: [(Maybe FastString, Located ModuleName)]
+ , pi_theimps :: [(Maybe FastString, Located ModuleName)]
+ , pi_hspp_fn :: FilePath
+ , pi_hspp_buf :: StringBuffer
+ , pi_mod_name_loc :: SrcSpan
+ , pi_mod_name :: ModuleName
+ }
+
+-- Preprocess the source file and get its imports
+-- The pi_local_dflags contains the OPTIONS pragmas
+getPreprocessedImports
+ :: HscEnv
+ -> FilePath
+ -> Maybe Phase
+ -> Maybe (StringBuffer, UTCTime)
+ -- ^ optional source code buffer and modification time
+ -> ExceptT ErrorMessages IO PreprocessedImports
+getPreprocessedImports hsc_env src_fn mb_phase maybe_buf = do
+ (pi_local_dflags, pi_hspp_fn)
+ <- ExceptT $ preprocess hsc_env src_fn (fst <$> maybe_buf) mb_phase
+ pi_hspp_buf <- liftIO $ hGetStringBuffer pi_hspp_fn
+ (pi_srcimps, pi_theimps, L pi_mod_name_loc pi_mod_name)
+ <- ExceptT $ getImports pi_local_dflags pi_hspp_buf pi_hspp_fn src_fn
+ return PreprocessedImports {..}
-----------------------------------------------------------------------------
@@ -2527,13 +2584,13 @@ noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> ErrMsg
noModError dflags loc wanted_mod err
= mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err
-noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrMsg
+noHsFileErr :: DynFlags -> SrcSpan -> String -> ErrorMessages
noHsFileErr dflags loc path
- = mkPlainErrMsg dflags loc $ text "Can't find" <+> text path
+ = unitBag $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path
-moduleNotFoundErr :: DynFlags -> ModuleName -> ErrMsg
+moduleNotFoundErr :: DynFlags -> ModuleName -> ErrorMessages
moduleNotFoundErr dflags mod
- = mkPlainErrMsg dflags noSrcSpan $
+ = unitBag $ mkPlainErrMsg dflags noSrcSpan $
text "module" <+> quotes (ppr mod) <+> text "cannot be found locally"
multiRootsErr :: DynFlags -> [ModSummary] -> IO ()
=====================================
compiler/main/HeaderInfo.hs
=====================================
@@ -59,17 +59,19 @@ getImports :: DynFlags
-- reporting parse error locations.
-> FilePath -- ^ The original source filename (used for locations
-- in the function result)
- -> IO ([(Maybe FastString, Located ModuleName)],
- [(Maybe FastString, Located ModuleName)],
- Located ModuleName)
+ -> IO (Either
+ ErrorMessages
+ ([(Maybe FastString, Located ModuleName)],
+ [(Maybe FastString, Located ModuleName)],
+ Located ModuleName))
-- ^ The source imports, normal imports, and the module name.
getImports dflags buf filename source_filename = do
let loc = mkRealSrcLoc (mkFastString filename) 1 1
case unP parseHeader (mkPState dflags buf loc) of
- PFailed pst -> do
+ PFailed pst ->
-- assuming we're not logging warnings here as per below
- throwErrors (getErrorMessages pst dflags)
- POk pst rdr_module -> do
+ return $ Left $ getErrorMessages pst dflags
+ POk pst rdr_module -> fmap Right $ do
let _ms@(_warns, errs) = getMessages pst dflags
-- don't log warnings: they'll be reported when we parse the file
-- for real. See #2500.
=====================================
compiler/main/HscTypes.hs
=====================================
@@ -13,7 +13,7 @@ module HscTypes (
-- * compilation state
HscEnv(..), hscEPS,
FinderCache, FindResult(..), InstalledFindResult(..),
- Target(..), TargetId(..), pprTarget, pprTargetId,
+ Target(..), TargetId(..), InputFileBuffer, pprTarget, pprTargetId,
HscStatus(..),
IServ(..),
@@ -511,7 +511,7 @@ data Target
= Target {
targetId :: TargetId, -- ^ module or filename
targetAllowObjCode :: Bool, -- ^ object code allowed?
- targetContents :: Maybe (StringBuffer,UTCTime)
+ targetContents :: Maybe (InputFileBuffer, UTCTime)
-- ^ Optional in-memory buffer containing the source code GHC should
-- use for this target instead of reading it from disk.
--
@@ -534,6 +534,8 @@ data TargetId
-- should be determined from the suffix of the filename.
deriving Eq
+type InputFileBuffer = StringBuffer
+
pprTarget :: Target -> SDoc
pprTarget (Target id obj _) =
(if obj then char '*' else empty) <> pprTargetId id
=====================================
hadrian/src/Rules/Libffi.hs
=====================================
@@ -171,19 +171,15 @@ libffiRules = do
dynLibFiles <- do
windows <- windowsHost
osx <- osxHost
- let libffiName'' = libffiName' windows True
- if windows
- then
- let libffiDll = "lib" ++ libffiName'' ++ ".dll"
- in return [libffiPath -/- "inst/bin" -/- libffiDll]
- else do
- let libffiLibPath = libffiPath -/- "inst/lib"
- dynLibsRelative <- liftIO $ getDirectoryFilesIO
- libffiLibPath
- (if osx
- then ["lib" ++ libffiName'' ++ ".dylib*"]
- else ["lib" ++ libffiName'' ++ ".so*"])
- return (fmap (libffiLibPath -/-) dynLibsRelative)
+ let libfilesDir = libffiPath -/-
+ (if windows then "inst" -/- "bin" else "inst" -/- "lib")
+ libffiName'' = libffiName' windows True
+ dynlibext
+ | windows = "dll"
+ | osx = "dylib"
+ | otherwise = "so"
+ filepat = "lib" ++ libffiName'' ++ "*." ++ dynlibext ++ "*"
+ liftIO $ getDirectoryFilesIO "." [libfilesDir -/- filepat]
writeFileLines dynLibMan dynLibFiles
putSuccess "| Successfully build libffi."
=====================================
rts/CheckUnload.c
=====================================
@@ -38,30 +38,130 @@
// object as referenced so that it won't get unloaded in this round.
//
-static void checkAddress (HashTable *addrs, const void *addr)
+// Note [Speeding up checkUnload]
+// ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+// In certain circumstances, there may be a lot of unloaded ObjectCode structs
+// chained in `unloaded_objects` (such as when users `:load` a module in a very
+// big repo in GHCi). To speed up checking whether an address lies within any of
+// these objects, we populate the addresses of their mapped sections in
+// an array sorted by their `start` address and do binary search for our address
+// on that array. Note that this works because the sections are mapped to mutual
+// exclusive memory regions, so we can simply find the largest lower bound among
+// the `start` addresses of the sections and then check if our address is inside
+// that section. In particular, we store the start address and end address of
+// each mapped section in a OCSectionIndex, arrange them all on a contiguous
+// memory range and then sort by start address. We then put this array in an
+// OCSectionIndices struct to be passed into `checkAddress` to do binary search
+// on.
+//
+
+typedef struct {
+ W_ start;
+ W_ end;
+ ObjectCode *oc;
+} OCSectionIndex;
+
+typedef struct {
+ int n_sections;
+ OCSectionIndex *indices;
+} OCSectionIndices;
+
+static OCSectionIndices *createOCSectionIndices(int n_sections)
+{
+ OCSectionIndices *s_indices;
+ s_indices = stgMallocBytes(sizeof(OCSectionIndices), "OCSectionIndices");
+ s_indices->n_sections = n_sections;
+ s_indices->indices = stgMallocBytes(n_sections*sizeof(OCSectionIndex),
+ "OCSectionIndices::indices");
+ return s_indices;
+}
+
+static int cmpSectionIndex(const void* indexa, const void *indexb)
+{
+ W_ s1 = ((OCSectionIndex*)indexa)->start;
+ W_ s2 = ((OCSectionIndex*)indexb)->start;
+ if (s1 < s2) {
+ return -1;
+ } else if (s1 > s2) {
+ return 1;
+ }
+ return 0;
+}
+
+static OCSectionIndices* buildOCSectionIndices(ObjectCode *ocs)
+{
+ int cnt_sections = 0;
+ ObjectCode *oc;
+ for (oc = ocs; oc; oc = oc->next) {
+ cnt_sections += oc->n_sections;
+ }
+ OCSectionIndices* s_indices = createOCSectionIndices(cnt_sections);
+ int s_i = 0, i;
+ for (oc = ocs; oc; oc = oc->next) {
+ for (i = 0; i < oc->n_sections; i++) {
+ if (oc->sections[i].kind != SECTIONKIND_OTHER) {
+ s_indices->indices[s_i].start = (W_)oc->sections[i].start;
+ s_indices->indices[s_i].end = (W_)oc->sections[i].start
+ + oc->sections[i].size;
+ s_indices->indices[s_i].oc = oc;
+ s_i++;
+ }
+ }
+ }
+ s_indices->n_sections = s_i;
+ qsort(s_indices->indices,
+ s_indices->n_sections,
+ sizeof(OCSectionIndex),
+ cmpSectionIndex);
+ return s_indices;
+}
+
+static void freeOCSectionIndices(OCSectionIndices *section_indices)
+{
+ free(section_indices->indices);
+ free(section_indices);
+}
+
+static ObjectCode *findOC(OCSectionIndices *s_indices, const void *addr) {
+ W_ w_addr = (W_)addr;
+ if (s_indices->n_sections <= 0) return NULL;
+ if (w_addr < s_indices->indices[0].start) return NULL;
+
+ int left = 0, right = s_indices->n_sections;
+ while (left + 1 < right) {
+ int mid = (left + right)/2;
+ W_ w_mid = s_indices->indices[mid].start;
+ if (w_mid <= w_addr) {
+ left = mid;
+ } else {
+ right = mid;
+ }
+ }
+ ASSERT(w_addr >= s_indices->indices[left].start);
+ if (w_addr < s_indices->indices[left].end) {
+ return s_indices->indices[left].oc;
+ }
+ return NULL;
+}
+
+static void checkAddress (HashTable *addrs, const void *addr,
+ OCSectionIndices *s_indices)
{
ObjectCode *oc;
- int i;
if (!lookupHashTable(addrs, (W_)addr)) {
insertHashTable(addrs, (W_)addr, addr);
- for (oc = unloaded_objects; oc; oc = oc->next) {
- for (i = 0; i < oc->n_sections; i++) {
- if (oc->sections[i].kind != SECTIONKIND_OTHER) {
- if ((W_)addr >= (W_)oc->sections[i].start &&
- (W_)addr < (W_)oc->sections[i].start
- + oc->sections[i].size) {
- oc->referenced = 1;
- return;
- }
- }
- }
+ oc = findOC(s_indices, addr);
+ if (oc != NULL) {
+ oc->referenced = 1;
+ return;
}
}
}
-static void searchStackChunk (HashTable *addrs, StgPtr sp, StgPtr stack_end)
+static void searchStackChunk (HashTable *addrs, StgPtr sp, StgPtr stack_end,
+ OCSectionIndices *s_indices)
{
StgPtr p;
const StgRetInfoTable *info;
@@ -73,7 +173,7 @@ static void searchStackChunk (HashTable *addrs, StgPtr sp, StgPtr stack_end)
switch (info->i.type) {
case RET_SMALL:
case RET_BIG:
- checkAddress(addrs, (const void*)info);
+ checkAddress(addrs, (const void*)info, s_indices);
break;
default:
@@ -85,7 +185,8 @@ static void searchStackChunk (HashTable *addrs, StgPtr sp, StgPtr stack_end)
}
-static void searchHeapBlocks (HashTable *addrs, bdescr *bd)
+static void searchHeapBlocks (HashTable *addrs, bdescr *bd,
+ OCSectionIndices *s_indices)
{
StgPtr p;
const StgInfoTable *info;
@@ -189,7 +290,7 @@ static void searchHeapBlocks (HashTable *addrs, bdescr *bd)
prim = true;
size = ap_stack_sizeW(ap);
searchStackChunk(addrs, (StgPtr)ap->payload,
- (StgPtr)ap->payload + ap->size);
+ (StgPtr)ap->payload + ap->size, s_indices);
break;
}
@@ -223,7 +324,7 @@ static void searchHeapBlocks (HashTable *addrs, bdescr *bd)
StgStack *stack = (StgStack*)p;
prim = true;
searchStackChunk(addrs, stack->sp,
- stack->stack + stack->stack_size);
+ stack->stack + stack->stack_size, s_indices);
size = stack_sizeW(stack);
break;
}
@@ -238,7 +339,7 @@ static void searchHeapBlocks (HashTable *addrs, bdescr *bd)
}
if (!prim) {
- checkAddress(addrs,info);
+ checkAddress(addrs,info, s_indices);
}
p += size;
@@ -251,15 +352,16 @@ static void searchHeapBlocks (HashTable *addrs, bdescr *bd)
// Do not unload the object if the CCS tree refers to a CCS or CC which
// originates in the object.
//
-static void searchCostCentres (HashTable *addrs, CostCentreStack *ccs)
+static void searchCostCentres (HashTable *addrs, CostCentreStack *ccs,
+ OCSectionIndices* s_indices)
{
IndexTable *i;
- checkAddress(addrs, ccs);
- checkAddress(addrs, ccs->cc);
+ checkAddress(addrs, ccs, s_indices);
+ checkAddress(addrs, ccs->cc, s_indices);
for (i = ccs->indexTable; i != NULL; i = i->next) {
if (!i->back_edge) {
- searchCostCentres(addrs, i->ccs);
+ searchCostCentres(addrs, i->ccs, s_indices);
}
}
}
@@ -288,6 +390,7 @@ void checkUnload (StgClosure *static_objects)
ACQUIRE_LOCK(&linker_unloaded_mutex);
+ OCSectionIndices *s_indices = buildOCSectionIndices(unloaded_objects);
// Mark every unloadable object as unreferenced initially
for (oc = unloaded_objects; oc; oc = oc->next) {
IF_DEBUG(linker, debugBelch("Checking whether to unload %" PATH_FMT "\n",
@@ -299,7 +402,7 @@ void checkUnload (StgClosure *static_objects)
for (p = static_objects; p != END_OF_STATIC_OBJECT_LIST; p = link) {
p = UNTAG_STATIC_LIST_PTR(p);
- checkAddress(addrs, p);
+ checkAddress(addrs, p, s_indices);
info = get_itbl(p);
link = *STATIC_LINK(info, p);
}
@@ -309,32 +412,33 @@ void checkUnload (StgClosure *static_objects)
p != END_OF_CAF_LIST;
p = ((StgIndStatic *)p)->static_link) {
p = UNTAG_STATIC_LIST_PTR(p);
- checkAddress(addrs, p);
+ checkAddress(addrs, p, s_indices);
}
for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
- searchHeapBlocks (addrs, generations[g].blocks);
- searchHeapBlocks (addrs, generations[g].large_objects);
+ searchHeapBlocks (addrs, generations[g].blocks, s_indices);
+ searchHeapBlocks (addrs, generations[g].large_objects, s_indices);
for (n = 0; n < n_capabilities; n++) {
ws = &gc_threads[n]->gens[g];
- searchHeapBlocks(addrs, ws->todo_bd);
- searchHeapBlocks(addrs, ws->part_list);
- searchHeapBlocks(addrs, ws->scavd_list);
+ searchHeapBlocks(addrs, ws->todo_bd, s_indices);
+ searchHeapBlocks(addrs, ws->part_list, s_indices);
+ searchHeapBlocks(addrs, ws->scavd_list, s_indices);
}
}
#if defined(PROFILING)
/* Traverse the cost centre tree, calling checkAddress on each CCS/CC */
- searchCostCentres(addrs, CCS_MAIN);
+ searchCostCentres(addrs, CCS_MAIN, s_indices);
/* Also check each cost centre in the CC_LIST */
CostCentre *cc;
for (cc = CC_LIST; cc != NULL; cc = cc->link) {
- checkAddress(addrs, cc);
+ checkAddress(addrs, cc, s_indices);
}
#endif /* PROFILING */
+ freeOCSectionIndices(s_indices);
// Look through the unloadable objects, and any object that is still
// marked as unreferenced can be physically unloaded, because we
// have no references to it.
=====================================
rts/linker/MachO.c
=====================================
@@ -1122,8 +1122,12 @@ ocBuildSegments_MachO(ObjectCode *oc)
n_activeSegments++;
}
- mem = mmapForLinker(size_compound, MAP_ANON, -1, 0);
- if (NULL == mem) return 0;
+ // N.B. it's possible that there is nothing mappable in an object. In this
+ // case we avoid the mmap call since it would fail. See #16701.
+ if (size_compound > 0) {
+ mem = mmapForLinker(size_compound, MAP_ANON, -1, 0);
+ if (NULL == mem) return 0;
+ }
IF_DEBUG(linker, debugBelch("ocBuildSegments: allocating %d segments\n", n_activeSegments));
segments = (Segment*)stgCallocBytes(n_activeSegments, sizeof(Segment),
=====================================
testsuite/tests/driver/T8602/T8602.stderr
=====================================
@@ -1,2 +1,4 @@
A B C
-`t8602.sh' failed in phase `Haskell pre-processor'. (Exit code: 1)
+
+A.hs:1:1: error:
+ `t8602.sh' failed in phase `Haskell pre-processor'. (Exit code: 1)
=====================================
testsuite/tests/ghc-api/downsweep/OldModLocation.hs
=====================================
@@ -0,0 +1,61 @@
+{-# LANGUAGE ViewPatterns #-}
+
+import GHC
+import GhcMake
+import DynFlags
+import Finder
+
+import Control.Monad.IO.Class (liftIO)
+import Data.List
+import Data.Either
+
+import System.Environment
+import System.Directory
+import System.IO
+
+main :: IO ()
+main = do
+ libdir:args <- getArgs
+
+ runGhc (Just libdir) $
+ defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
+
+ dflags0 <- getSessionDynFlags
+ (dflags1, _, _) <- parseDynamicFlags dflags0 $ map noLoc $
+ [ "-i", "-i.", "-imydir"
+ -- , "-v3"
+ ] ++ args
+ _ <- setSessionDynFlags dflags1
+
+ liftIO $ mapM_ writeMod
+ [ [ "module A where"
+ , "import B"
+ ]
+ , [ "module B where"
+ ]
+ ]
+
+ tgt <- guessTarget "A" Nothing
+ setTargets [tgt]
+ hsc_env <- getSession
+
+ liftIO $ do
+
+ _emss <- downsweep hsc_env [] [] False
+
+ flushFinderCaches hsc_env
+ createDirectoryIfMissing False "mydir"
+ renameFile "B.hs" "mydir/B.hs"
+
+ emss <- downsweep hsc_env [] [] False
+
+ -- If 'checkSummaryTimestamp' were to call 'addHomeModuleToFinder' with
+ -- (ms_location old_summary) like summariseFile used to instead of
+ -- using the 'location' parameter we'd end up using the old location of
+ -- the "B" module in this test. Make sure that doesn't happen.
+
+ hPrint stderr $ sort (map (ml_hs_file . ms_location) (rights emss))
+
+writeMod :: [String] -> IO ()
+writeMod src@(head -> stripPrefix "module " -> Just (takeWhile (/=' ') -> mod))
+ = writeFile (mod++".hs") $ unlines src
=====================================
testsuite/tests/ghc-api/downsweep/OldModLocation.stderr
=====================================
@@ -0,0 +1 @@
+[Just "A.hs",Just "mydir/B.hs"]
=====================================
testsuite/tests/ghc-api/downsweep/PartialDownsweep.darwin.stderr
=====================================
@@ -0,0 +1,16 @@
+== Parse error in export list
+== Parse error in export list with bypass module
+== Parse error in import list
+== CPP preprocessor error
+
+B.hs:2:2: #elif without #if
+ #elif <- cpp error here
+ ^
+1 error generated.
+== CPP preprocessor error with bypass
+
+B.hs:2:2: #elif without #if
+ #elif <- cpp error here
+ ^
+1 error generated.
+== Import error
=====================================
testsuite/tests/ghc-api/downsweep/PartialDownsweep.hs
=====================================
@@ -0,0 +1,179 @@
+{-# LANGUAGE ScopedTypeVariables, ViewPatterns #-}
+
+-- | This test checks if 'downsweep can return partial results when vaious
+-- kinds of parse errors occur in modules.
+
+import GHC
+import GhcMake
+import DynFlags
+import Outputable
+import Exception (ExceptionMonad, ghandle)
+import Bag
+
+import Control.Monad
+import Control.Monad.IO.Class (liftIO)
+import Control.Exception
+import Data.IORef
+import Data.List
+import Data.Either
+
+import System.Environment
+import System.Exit
+import System.IO
+import System.IO.Unsafe (unsafePerformIO)
+
+any_failed :: IORef Bool
+any_failed = unsafePerformIO $ newIORef False
+{-# NOINLINE any_failed #-}
+
+it :: ExceptionMonad m => [Char] -> m Bool -> m ()
+it msg act =
+ ghandle (\(_ex :: AssertionFailed) -> dofail) $
+ ghandle (\(_ex :: ExitCode) -> dofail) $ do
+ res <- act
+ case res of
+ False -> dofail
+ True -> return ()
+ where
+ dofail = do
+ liftIO $ hPutStrLn stderr $ "FAILED: " ++ msg
+ liftIO $ writeIORef any_failed True
+
+main :: IO ()
+main = do
+ libdir:args <- getArgs
+
+ runGhc (Just libdir) $ do
+ dflags0 <- getSessionDynFlags
+ (dflags1, _, _) <- parseDynamicFlags dflags0 $ map noLoc $
+ [ "-fno-diagnostics-show-caret"
+ -- , "-v3"
+ ] ++ args
+ _ <- setSessionDynFlags dflags1
+
+ go "Parse error in export list"
+ [ [ "module A where"
+ , "import B"
+ ]
+ , [ "module B !parse_error where"
+ -- ^ this used to cause getImports to throw an exception instead
+ -- of having downsweep return an error for just this module
+ , "import C"
+ ]
+ , [ "module C where"
+ ]
+ ]
+ (\mss -> return $
+ sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A"]
+ )
+
+ go "Parse error in export list with bypass module"
+ [ [ "module A where"
+ , "import B"
+ , "import C"
+ ]
+ , [ "module B !parse_error where"
+ , "import D"
+ ]
+ , [ "module C where"
+ , "import D"
+ ]
+ , [ "module D where"
+ ]
+ ]
+ (\mss -> return $
+ sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A", "C", "D"]
+ )
+ go "Parse error in import list"
+ [ [ "module A where"
+ , "import B"
+ ]
+ , [ "module B where"
+ , "!parse_error"
+ -- ^ this is silently ignored, getImports assumes the import
+ -- list is just empty. This smells like a parser bug to me but
+ -- I'm still documenting this behaviour here.
+ , "import C"
+ ]
+ , [ "module C where"
+ ]
+ ]
+ (\mss -> return $
+ sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A", "B"]
+ )
+
+ go "CPP preprocessor error"
+ [ [ "module A where"
+ , "import B"
+ ]
+ , [ "{-# LANGUAGE CPP #-}"
+ , "#elif <- cpp error here"
+ , "module B where"
+ , "import C"
+ ]
+ , [ "module C where"
+ ]
+ ]
+ (\mss -> return $
+ sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A"]
+ )
+
+ go "CPP preprocessor error with bypass"
+ [ [ "module A where"
+ , "import B"
+ , "import C"
+ ]
+ , [ "{-# LANGUAGE CPP #-}"
+ , "#elif <- cpp error here"
+ , "module B where"
+ , "import C"
+ ]
+ , [ "module C where"
+ ]
+ ]
+ (\mss -> return $
+ sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A", "C"]
+ )
+
+ go "Import error"
+ [ [ "module A where"
+ , "import B"
+ , "import DoesNotExist_FooBarBaz"
+ ]
+ , [ "module B where"
+ ]
+ ]
+ (\mss -> return $
+ sort (map (moduleNameString . moduleName . ms_mod) mss) == ["A", "B"]
+ )
+
+ errored <- readIORef any_failed
+ when errored $ exitFailure
+ return ()
+
+
+go :: String -> [[String]] -> ([ModSummary] -> Ghc Bool) -> Ghc ()
+go label mods cnd =
+ defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
+ liftIO $ hPutStrLn stderr $ "== " ++ label
+
+ liftIO $ mapM_ writeMod mods
+
+ tgt <- guessTarget "A" Nothing
+
+ setTargets [tgt]
+
+ hsc_env <- getSession
+ emss <- liftIO $ downsweep hsc_env [] [] False
+ -- liftIO $ hPutStrLn stderr $ showSDocUnsafe $ ppr $ rights emss
+ -- liftIO $ hPrint stderr $ bagToList $ unionManyBags $ lefts emss
+
+ it label $ cnd (rights emss)
+
+
+writeMod :: [String] -> IO ()
+writeMod src =
+ writeFile (mod++".hs") $ unlines src
+ where
+ Just modline = find ("module" `isPrefixOf`) src
+ Just (takeWhile (/=' ') -> mod) = stripPrefix "module " modline
=====================================
testsuite/tests/ghc-api/downsweep/PartialDownsweep.stderr
=====================================
@@ -0,0 +1,16 @@
+== Parse error in export list
+== Parse error in export list with bypass module
+== Parse error in import list
+== CPP preprocessor error
+
+B.hs:2:0: error:
+ error: #elif without #if
+ #elif <- cpp error here
+
+== CPP preprocessor error with bypass
+
+B.hs:2:0: error:
+ error: #elif without #if
+ #elif <- cpp error here
+
+== Import error
=====================================
testsuite/tests/ghc-api/downsweep/all.T
=====================================
@@ -0,0 +1,14 @@
+test('PartialDownsweep',
+ [ extra_run_opts('"' + config.libdir + '"')
+ , when(opsys('darwin'),
+ use_specs({'stderr' : 'PartialDownsweep.darwin.stderr'})
+ )
+ ],
+ compile_and_run,
+ ['-package ghc'])
+
+test('OldModLocation',
+ [ extra_run_opts('"' + config.libdir + '"')
+ ],
+ compile_and_run,
+ ['-package ghc'])
=====================================
testsuite/tests/perf/compiler/all.T
=====================================
@@ -382,7 +382,10 @@ test('Naperian',
test ('T9630',
[ collect_compiler_stats('max_bytes_used',15), # Note [residency]
- extra_clean(['T9630a.hi', 'T9630a.o'])
+ extra_clean(['T9630a.hi', 'T9630a.o']),
+
+ # Use `+RTS -G1` for more stable residency measurements. Note [residency].
+ extra_hc_opts('+RTS -G1 -RTS')
],
multimod_compile,
['T9630', '-v0 -O'])
=====================================
testsuite/tests/rts/linker/unload_multiple_objs/A.hs
=====================================
@@ -0,0 +1,16 @@
+module A where
+
+import Foreign.StablePtr
+
+id1 :: Int
+id1 = 1
+
+createHeapObjectA :: IO (StablePtr [Int])
+createHeapObjectA = do
+ newStablePtr [2+id1]
+
+freeHeapObjectA :: StablePtr [Int] -> IO ()
+freeHeapObjectA obj = freeStablePtr obj
+
+foreign export ccall createHeapObjectA :: IO (StablePtr [Int])
+foreign export ccall freeHeapObjectA :: StablePtr [Int] -> IO ()
=====================================
testsuite/tests/rts/linker/unload_multiple_objs/B.hs
=====================================
@@ -0,0 +1,16 @@
+module B where
+
+import Foreign.StablePtr
+
+id2 :: Int
+id2 = 2
+
+createHeapObjectB :: IO (StablePtr [Int])
+createHeapObjectB = do
+ newStablePtr [2+id2]
+
+freeHeapObjectB :: StablePtr [Int] -> IO ()
+freeHeapObjectB obj = freeStablePtr obj
+
+foreign export ccall createHeapObjectB :: IO (StablePtr [Int])
+foreign export ccall freeHeapObjectB :: StablePtr [Int] -> IO ()
=====================================
testsuite/tests/rts/linker/unload_multiple_objs/C.hs
=====================================
@@ -0,0 +1,16 @@
+module C where
+
+import Foreign.StablePtr
+
+id3 :: Int
+id3 = 3
+
+createHeapObjectC :: IO (StablePtr [Int])
+createHeapObjectC = do
+ newStablePtr [2+id3]
+
+freeHeapObjectC :: StablePtr [Int] -> IO ()
+freeHeapObjectC obj = freeStablePtr obj
+
+foreign export ccall createHeapObjectC :: IO (StablePtr [Int])
+foreign export ccall freeHeapObjectC :: StablePtr [Int] -> IO ()
=====================================
testsuite/tests/rts/linker/unload_multiple_objs/D.hs
=====================================
@@ -0,0 +1,16 @@
+module D where
+
+import Foreign.StablePtr
+
+id4 :: Int
+id4 = 4
+
+createHeapObjectD :: IO (StablePtr [Int])
+createHeapObjectD = do
+ newStablePtr [2+id4]
+
+freeHeapObjectD :: StablePtr [Int] -> IO ()
+freeHeapObjectD obj = freeStablePtr obj
+
+foreign export ccall createHeapObjectD :: IO (StablePtr [Int])
+foreign export ccall freeHeapObjectD :: StablePtr [Int] -> IO ()
=====================================
testsuite/tests/rts/linker/unload_multiple_objs/Makefile
=====================================
@@ -0,0 +1,17 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+.PHONY: linker_unload_multiple_objs
+linker_unload_multiple_objs:
+ $(RM) A.o B.o C.o D.o
+ $(RM) A.hi B.hi C.hi D.hi
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c A.hs -v0
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c B.hs -v0
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c C.hs -v0
+ "$(TEST_HC)" $(TEST_HC_OPTS) -c D.hs -v0
+ # -rtsopts causes a warning
+ "$(TEST_HC)" LinkerUnload.hs -package ghc $(filter-out -rtsopts, $(TEST_HC_OPTS)) linker_unload_multiple_objs.c -o linker_unload_multiple_objs -no-hs-main -optc-Werror
+ ./linker_unload_multiple_objs "`'$(TEST_HC)' $(TEST_HC_OPTS) --print-libdir | tr -d '\r'`"
+
+
=====================================
testsuite/tests/rts/linker/unload_multiple_objs/all.T
=====================================
@@ -0,0 +1,4 @@
+test('linker_unload_multiple_objs',
+ [extra_files(['../LinkerUnload.hs', 'A.hs', 'B.hs', 'C.hs', 'D.hs',]),
+ when(arch('powerpc64') or arch('powerpc64le'), expect_broken(11259))],
+ run_command, ['$MAKE -s --no-print-directory linker_unload_multiple_objs'])
=====================================
testsuite/tests/rts/linker/unload_multiple_objs/linker_unload_multiple_objs.c
=====================================
@@ -0,0 +1,147 @@
+#include "ghcconfig.h"
+#include <stdio.h>
+#include <stdlib.h>
+#include "Rts.h"
+#include <string.h>
+#include "HsFFI.h"
+
+extern void loadPackages(void);
+
+#define NUM_OBJS 4
+
+static char *objs[NUM_OBJS] = {"A.o", "B.o", "C.o", "D.o"};
+
+pathchar* toPathchar(char* path)
+{
+#if defined(mingw32_HOST_OS)
+ size_t required = strlen(path);
+ pathchar *ret = (pathchar*)malloc(sizeof(pathchar) * (required + 1));
+ if (mbstowcs(ret, path, required) == (size_t)-1)
+ {
+ errorBelch("toPathchar failed converting char* to wchar_t*: %s", path);
+ exit(1);
+ }
+ ret[required] = '\0';
+ return ret;
+#else
+ return path;
+#endif
+}
+
+void load_and_resolve_all_objects() {
+ int i, r;
+ for (i = 0; i < NUM_OBJS; i++) {
+ r = loadObj(toPathchar(objs[i]));
+ if (!r) {
+ errorBelch("loadObj(%s) failed", objs[i]);
+ exit(1);
+ }
+ }
+
+ r = resolveObjs();
+ if (!r) {
+ errorBelch("resolveObjs failed");
+ exit(1);
+ }
+
+ for (i = 0; i < NUM_OBJS; i++) {
+ char sym_name[138] = {0};
+#if LEADING_UNDERSCORE
+ sprintf(sym_name, "_createHeapObject%c", 'A'+i);
+#else
+ sprintf(sym_name, "createHeapObject%c", 'A'+i);
+#endif
+ void *sym_addr = lookupSymbol(sym_name);
+ if (!sym_addr) {
+ errorBelch("lookupSymbol(%s) failed", sym_name);
+ exit(1);
+ }
+ }
+}
+
+void check_object_freed(char *obj_path) {
+ OStatus st;
+ st = getObjectLoadStatus(toPathchar(obj_path));
+ if (st != OBJECT_NOT_LOADED) {
+ errorBelch("object %s status != OBJECT_NOT_LOADED", obj_path);
+ exit(1);
+ }
+}
+
+void check_object_unloaded_but_not_freed(char *obj_path) {
+ OStatus st;
+ st = getObjectLoadStatus(toPathchar(obj_path));
+ if (st != OBJECT_UNLOADED) {
+ errorBelch("object %s status != OBJECT_UNLOADED, is %d instead", obj_path, st);
+ exit(1);
+ }
+}
+
+void test_no_dangling_references_to_unloaded_objects()
+{
+ load_and_resolve_all_objects();
+
+ unloadObj(toPathchar("A.o"));
+ unloadObj(toPathchar("B.o"));
+ unloadObj(toPathchar("C.o"));
+ unloadObj(toPathchar("D.o"));
+ performMajorGC();
+
+ check_object_freed("A.o");
+ check_object_freed("B.o");
+ check_object_freed("C.o");
+ check_object_freed("D.o");
+
+}
+
+typedef HsStablePtr stableptrfun_t(void);
+typedef void freeptrfun_t(HsStablePtr);
+
+void test_still_has_references_to_unloaded_objects()
+{
+ load_and_resolve_all_objects();
+#if LEADING_UNDERSCORE
+ stableptrfun_t *createHeapObject = lookupSymbol("_createHeapObjectD");
+ freeptrfun_t *freeHeapObject = lookupSymbol("_freeHeapObjectD");
+#else
+ stableptrfun_t *createHeapObject = lookupSymbol("createHeapObjectD");
+ freeptrfun_t *freeHeapObject = lookupSymbol("freeHeapObjectD");
+#endif
+ HsStablePtr ptr = createHeapObject();
+
+ unloadObj(toPathchar("A.o"));
+ unloadObj(toPathchar("B.o"));
+ unloadObj(toPathchar("C.o"));
+ unloadObj(toPathchar("D.o"));
+ performMajorGC();
+
+ check_object_freed("A.o");
+ check_object_freed("B.o");
+ check_object_freed("C.o");
+ check_object_unloaded_but_not_freed("D.o");
+
+
+ freeHeapObject(ptr);
+ performMajorGC();
+
+ check_object_freed("A.o");
+ check_object_freed("B.o");
+ check_object_freed("C.o");
+ check_object_freed("D.o");
+}
+
+int main (int argc, char *argv[])
+{
+ RtsConfig conf = defaultRtsConfig;
+ conf.rts_opts_enabled = RtsOptsAll;
+ hs_init_ghc(&argc, &argv, conf);
+
+ initLinker_(0);
+ loadPackages();
+
+ test_still_has_references_to_unloaded_objects();
+ test_no_dangling_references_to_unloaded_objects();
+
+ hs_exit();
+ exit(0);
+}
=====================================
testsuite/tests/rts/linker/unload_multiple_objs/linker_unload_multiple_objs.stdout
=====================================
@@ -0,0 +1,2 @@
+[1 of 1] Compiling LinkerUnload ( LinkerUnload.hs, LinkerUnload.o )
+Linking linker_unload_multiple_objs ...
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/c511fd4e09318ff106a996e9d4bb2d613e2aae33...fc9e2b21ce19f8a7d5f00b468c9f39a24acaa324
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/c511fd4e09318ff106a996e9d4bb2d613e2aae33...fc9e2b21ce19f8a7d5f00b468c9f39a24acaa324
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190530/2d421af1/attachment-0001.html>
More information about the ghc-commits
mailing list