*.o.cmd
*.depend*
log
+tags
autom4te.cache
config.log
Quick Start for developers
- http://hackage.haskell.org/trac/ghc/wiki/Building/Hacking
+ http://hackage.haskell.org/trac/ghc/wiki/Building/Hacking
This section on the wiki will get you up and running with a
serviceable build tree in no time:
which contains GHC itself and the "boot" libraries.
- 2. Check out the source code from darcs
- ---------------------------------------
+ 2. Check out the source code from git
+ -------------------------------------
- The recommended way to get a darcs checkout is to start off by
- downloading a snapshot with a name like:
+ First get the GHC git repository:
- ghc-HEAD-2009-09-09-ghc-corelibs-testsuite.tar.bz2
+ $ git clone http://darcs.haskell.org/ghc.git/
- from:
-
- http://darcs.haskell.org/
-
- and then untar it and bring it up-to-date with:
-
- $ cd ghc
- $ ./darcs-all get
-
-
- Alternatively you can use darcs to get the repos, but it will take a
- lot longer. First get the GHC darcs repository:
-
- $ darcs get http://darcs.haskell.org/ghc/
-
- Then run the darcs-all script in that repository
+ Then run the sync-all script in that repository
to get the other repositories:
$ cd ghc
- $ chmod +x darcs-all
- $ ./darcs-all get
+ $ ./sync-all get
This checks out the "boot" packages.
is itself written in Haskell. For instructions on how to port GHC to a
new platform, see the Building Guide.
-If you're building from darcs sources (as opposed to a source
+If you're building from git sources (as opposed to a source
distribution) then you also need to install Happy [4] and Alex [5].
For building library documentation, you'll need Haddock [6]. To build
$ make install
The "perl boot" step is only necessary if this is a tree checked out
-from darcs. For source distributions downloaded from GHC's web site,
+from git. For source distributions downloaded from GHC's web site,
this step has already been performed.
These steps give you the default build, which includes everything
optimised and built in various ways (eg. profiling libs are built).
-It can take a long time. To customise the build, see the file
-HACKING.
+It can take a long time. To customise the build, see the file HACKING.
# Determine which extra flags we need to pass gcc when we invoke it
# to compile .hc code.
#
-# Some OSs (Mandrake Linux, in particular) configure GCC with
-# -momit-leaf-frame-pointer on by default. If this is the case, we
-# need to turn it off for mangling to work. The test is currently a
-# bit crude, using only the version number of gcc.
-#
# -fwrapv is needed for gcc to emit well-behaved code in the presence of
# integer wrap around. (Trac #952)
#
-# -fno-unit-at-a-time or -fno-toplevel-reoder is necessary to avoid gcc
-# reordering things in the module and confusing the manger and/or splitter.
-# (eg. Trac #1427)
-#
AC_DEFUN([FP_GCC_EXTRA_FLAGS],
[AC_REQUIRE([FP_HAVE_GCC])
AC_CACHE_CHECK([for extra options to pass gcc when compiling via C], [fp_cv_gcc_extra_opts],
FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.4],
[fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fwrapv"],
[])
- case $TargetPlatform in
- i386-*|x86_64-*)
- FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.2],
- [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -mno-omit-leaf-frame-pointer"],
- [])
- FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.4],
- [FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [4.2],
- [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-toplevel-reorder"],
- [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-unit-at-a-time"]
- )],
- [])
- ;;
- sparc-*-solaris2)
- FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [4.2],
- [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-toplevel-reorder"],
- [])
- ;;
- esac
])
AC_SUBST([GccExtraViaCOpts],$fp_cv_gcc_extra_opts)
])
# If $tag is not "-" then it is an optional repository, so its
# absence isn't an error.
if (defined($required_tag{$tag})) {
- # We would like to just check for an _darcs directory here,
- # but in an lndir tree we avoid making _darcs directories,
+ # We would like to just check for a .git directory here,
+ # but in an lndir tree we avoid making .git directories,
# so it doesn't exist. We therefore require that every repo
# has a LICENSE file instead.
if (! -f "$dir/LICENSE") {
print STDERR "Error: $dir/LICENSE doesn't exist.\n";
- die "Maybe you haven't done './darcs-all get'?";
+ die "Maybe you haven't done './sync-all get'?";
}
}
}
}
}
-# Alas, darcs doesn't handle file permissions, so fix a few of them.
-for my $file ("boot", "darcs-all", "validate") {
- if (-f $file) {
- chmod 0755, $file
- or die "Can't chmod 0755 $file: $!";
- }
-}
if (-d "libraries/$package/_darcs") {
print "Ignoring libraries/$package as it looks like a darcs checkout\n"
}
+ elsif (-d "libraries/$package/.git") {
+ print "Ignoring libraries/$package as it looks like a git checkout\n"
+ }
else {
if (! -d "libraries/stamp") {
mkdir "libraries/stamp";
cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
do
-- Why bother doing it this early?
- -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
+ -- g <- dual_rewrite run Opt_D_dump_cmmz "spills and reloads"
-- (dualLivenessWithInsertion callPPs) g
-- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
- -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
+ -- g <- dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination"
-- (removeDeadAssignmentsAndReloads callPPs) g
dump Opt_D_dump_cmmz "Pre common block elimination" g
g <- return $ elimCommonBlocks g
----------- Spills and reloads -------------------
g <-
-- pprTrace "pre Spills" (ppr g) $
- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
+ dual_rewrite run Opt_D_dump_cmmz "spills and reloads"
(dualLivenessWithInsertion procPoints) g
-- Insert spills at defns; reloads at return points
g <-
-- pprTrace "pre insertLateReloads" (ppr g) $
- run $ insertLateReloads g -- Duplicate reloads just before uses
+ runOptimization $ insertLateReloads g -- Duplicate reloads just before uses
dump Opt_D_dump_cmmz "Post late reloads" g
g <-
-- pprTrace "post insertLateReloads" (ppr g) $
- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
+ dual_rewrite runOptimization Opt_D_dump_cmmz "Dead Assignment Elimination"
(removeDeadAssignmentsAndReloads procPoints) g
-- Remove redundant reloads (and any other redundant asst)
where dflags = hsc_dflags hsc_env
mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
-
- run = runFuelIO (hsc_OptFuel hsc_env)
-
- dual_rewrite flag txt pass g =
+ -- Runs a required transformation/analysis
+ run = runInfiniteFuelIO (hsc_OptFuel hsc_env)
+ -- Runs an optional transformation/analysis (and should
+ -- thus be subject to optimization fuel)
+ runOptimization = runFuelIO (hsc_OptFuel hsc_env)
+
+ -- pass 'run' or 'runOptimization' for 'r'
+ dual_rewrite r flag txt pass g =
do dump flag ("Pre " ++ txt) g
- g <- run $ pass g
+ g <- r $ pass g
dump flag ("Post " ++ txt) $ g
return g
cmmMiniInlineStmts uses (stmt:stmts)
= stmt : cmmMiniInlineStmts uses stmts
-lookForInline u expr (stmt : rest)
+lookForInline u expr stmts = lookForInline' u expr regset stmts
+ where regset = foldRegsUsed extendRegSet emptyRegSet expr
+
+lookForInline' u expr regset (stmt : rest)
| Just 1 <- lookupUFM (countUses stmt) u, ok_to_inline
= Just (inlineStmt u expr stmt : rest)
| ok_to_skip
- = case lookForInline u expr rest of
+ = case lookForInline' u expr regset rest of
Nothing -> Nothing
Just stmts -> Just (stmt:stmts)
CmmCall{} -> hasNoGlobalRegs expr
_ -> True
- -- We can skip over assignments to other tempoararies, because we
- -- know that expressions aren't side-effecting and temporaries are
- -- single-assignment.
+ -- Expressions aren't side-effecting. Temporaries may or may not
+ -- be single-assignment depending on the source (the old code
+ -- generator creates single-assignment code, but hand-written Cmm
+ -- and Cmm from the new code generator is not single-assignment.)
+ -- So we do an extra check to make sure that the register being
+ -- changed is not one we were relying on. I don't know how much of a
+ -- performance hit this is (we have to create a regset for every
+ -- instruction.) -- EZY
ok_to_skip = case stmt of
CmmNop -> True
CmmComment{} -> True
- CmmAssign (CmmLocal (LocalReg u' _)) rhs | u' /= u -> True
+ CmmAssign (CmmLocal r@(LocalReg u' _)) rhs | u' /= u && not (r `elemRegSet` regset) -> True
CmmAssign g@(CmmGlobal _) rhs -> not (g `regUsedIn` expr)
_other -> False
-- the optimiser with varying amount of fuel to find out the exact number of
-- steps where a bug is introduced in the output.
module OptimizationFuel
- ( OptimizationFuel, amountOfFuel, tankFilledTo, anyFuelLeft, oneLessFuel
+ ( OptimizationFuel, amountOfFuel, tankFilledTo, unlimitedFuel, anyFuelLeft, oneLessFuel
, OptFuelState, initOptFuelState
, FuelConsumer, FuelUsingMonad, FuelState
, fuelGet, fuelSet, lastFuelPass, setFuelPass
, fuelExhausted, fuelDec1, tryWithFuel
- , runFuelIO, fuelConsumingPass
+ , runFuelIO, runInfiniteFuelIO, fuelConsumingPass
, FuelUniqSM
, liftUniq
)
anyFuelLeft :: OptimizationFuel -> Bool
oneLessFuel :: OptimizationFuel -> OptimizationFuel
+unlimitedFuel :: OptimizationFuel
#ifdef DEBUG
newtype OptimizationFuel = OptimizationFuel Int
anyFuelLeft (OptimizationFuel f) = f > 0
oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1))
+unlimitedFuel = OptimizationFuel infiniteFuel
#else
-- type OptimizationFuel = State# () -- would like this, but it won't work
data OptimizationFuel = OptimizationFuel
anyFuelLeft _ = True
oneLessFuel _ = OptimizationFuel
+unlimitedFuel = OptimizationFuel
#endif
data FuelState = FuelState { fs_fuel :: OptimizationFuel, fs_lastpass :: String }
writeIORef (fuel_ref fs) fuel'
return a
+-- ToDo: Do we need the pass_ref when we are doing infinite fueld
+-- transformations?
+runInfiniteFuelIO :: OptFuelState -> FuelUniqSM a -> IO a
+runInfiniteFuelIO fs (FUSM f) =
+ do pass <- readIORef (pass_ref fs)
+ u <- mkSplitUniqSupply 'u'
+ let (a, FuelState _ pass') = initUs_ u $ f (FuelState unlimitedFuel pass)
+ writeIORef (pass_ref fs) pass'
+ return a
+
instance Monad FuelUniqSM where
FUSM f >>= k = FUSM (\s -> f s >>= \(a, s') -> unFUSM (k a) s')
return a = FUSM (\s -> return (a, s))
{- Note [Data constructor dynamic tags]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The family size of a data type (the number of constructors)
-can be either:
+The family size of a data type (the number of constructors
+or the arity of a function) can be either:
* small, if the family size < 2**tag_bits
* big, otherwise.
Small families can have the constructor tag in the tag bits.
-Big families only use the tag value 1 to represent evaluatedness. -}
+Big families only use the tag value 1 to represent evaluatedness.
+We don't have very many tag bits: for example, we have 2 bits on
+x86-32 and 3 bits on x86-64. -}
isSmallFamily :: Int -> Bool
isSmallFamily fam_size = fam_size <= mAX_PTR_TAG
@echo 'cGHC_UNLIT_PGM = "$(GHC_UNLIT_PGM)"' >> $@
@echo 'cGHC_UNLIT_DIR :: String' >> $@
@echo 'cGHC_UNLIT_DIR = "$(GHC_UNLIT_DIR)"' >> $@
- @echo 'cGHC_MANGLER_PGM :: String' >> $@
- @echo 'cGHC_MANGLER_PGM = "$(GHC_MANGLER_PGM)"' >> $@
- @echo 'cGHC_MANGLER_DIR :: String' >> $@
- @echo 'cGHC_MANGLER_DIR = "$(GHC_MANGLER_DIR)"' >> $@
@echo 'cGHC_SPLIT_PGM :: String' >> $@
@echo 'cGHC_SPLIT_PGM = "$(GHC_SPLIT_PGM)"' >> $@
@echo 'cGHC_SPLIT_DIR :: String' >> $@
where
(modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1))
parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8])
- parseModOcc acc str
+ -- We only look for dots if str could start with a module name,
+ -- i.e. if it starts with an upper case character.
+ -- Otherwise we might think that "X.:->" is the module name in
+ -- "X.:->.+", whereas actually "X" is the module name and
+ -- ":->.+" is a constructor name.
+ parseModOcc acc str@(c : _)
+ | isUpper $ chr $ fromIntegral c
= case break (== dot) str of
(top, []) -> (acc, top)
- (top, _:bot) -> parseModOcc (top : acc) bot
-
+ (top, _ : bot) -> parseModOcc (top : acc) bot
+ parseModOcc acc str = (acc, str)
+
-- | Get the 'HValue' associated with the given name.
--
-- May cause loading the module that contains the name.
import HscTypes
import DynFlags
import Config
+import SysTools
import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit )
import Outputable
-> ForeignStubs
-> [PackageId]
-> [RawCmm] -- Compiled C--
- -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
+ -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-})
codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
=
\begin{code}
outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs
-> IO (Bool, -- Header file created
- Bool) -- C file created
+ Maybe FilePath) -- C file created
outputForeignStubs dflags mod location stubs
- = case stubs of
- NoStubs -> do
+ = do
+ let stub_h = mkStubPaths dflags (moduleName mod) location
+ stub_c <- newTempName dflags "c"
+
+ case stubs of
+ NoStubs -> do
-- When compiling External Core files, may need to use stub
-- files from a previous compilation
- stub_c_exists <- doesFileExist stub_c
- stub_h_exists <- doesFileExist stub_h
- return (stub_h_exists, stub_c_exists)
+ stub_h_exists <- doesFileExist stub_h
+ return (stub_h_exists, Nothing)
- ForeignStubs h_code c_code -> do
- let
+ ForeignStubs h_code c_code -> do
+ let
stub_c_output_d = pprCode CStyle c_code
stub_c_output_w = showSDoc stub_c_output_d
-- isn't really HC code, so we need to define IN_STG_CODE==0 to
-- avoid the register variables etc. being enabled.
- return (stub_h_file_exists, stub_c_file_exists)
- where
- (stub_c, stub_h, _) = mkStubPaths dflags (moduleName mod) location
-
+ return (stub_h_file_exists, if stub_c_file_exists
+ then Just stub_c
+ else Nothing )
+ where
cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n"
cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n"
| Hsc HscSource
| Ccpp
| Cc
+ | Cobjc
| HCc -- Haskellised C (as opposed to vanilla C) compilation
- | Mangle -- assembly mangling, now done by a separate script.
| SplitMangle -- after mangler if splitting
| SplitAs
| As
| LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM
| CmmCpp -- pre-process Cmm source
| Cmm -- parse & compile Cmm code
+ | MergeStub -- merge in the stub object file
-- The final phase is a pseudo-phase that tells the pipeline to stop.
-- There is no runPhase case for it.
eqPhase (Hsc _) (Hsc _) = True
eqPhase Ccpp Ccpp = True
eqPhase Cc Cc = True
+eqPhase Cobjc Cobjc = True
eqPhase HCc HCc = True
-eqPhase Mangle Mangle = True
eqPhase SplitMangle SplitMangle = True
eqPhase SplitAs SplitAs = True
eqPhase As As = True
eqPhase LlvmMangle LlvmMangle = True
eqPhase CmmCpp CmmCpp = True
eqPhase Cmm Cmm = True
+eqPhase MergeStub MergeStub = True
eqPhase StopLn StopLn = True
eqPhase _ _ = False
after_x = nextPhase x
nextPhase :: Phase -> Phase
--- A conservative approximation the next phase, used in happensBefore
+-- A conservative approximation to the next phase, used in happensBefore
nextPhase (Unlit sf) = Cpp sf
nextPhase (Cpp sf) = HsPp sf
nextPhase (HsPp sf) = Hsc sf
nextPhase (Hsc _) = HCc
-nextPhase HCc = Mangle
-nextPhase Mangle = SplitMangle
nextPhase SplitMangle = As
nextPhase As = SplitAs
nextPhase LlvmOpt = LlvmLlc
nextPhase LlvmLlc = As
#endif
nextPhase LlvmMangle = As
-nextPhase SplitAs = StopLn
+nextPhase SplitAs = MergeStub
nextPhase Ccpp = As
nextPhase Cc = As
+nextPhase Cobjc = As
nextPhase CmmCpp = Cmm
nextPhase Cmm = HCc
+nextPhase HCc = As
+nextPhase MergeStub = StopLn
nextPhase StopLn = panic "nextPhase: nothing after StopLn"
-- the first compilation phase for a given file is determined
startPhase "c" = Cc
startPhase "cpp" = Ccpp
startPhase "C" = Cc
+startPhase "m" = Cobjc
startPhase "cc" = Ccpp
startPhase "cxx" = Ccpp
-startPhase "raw_s" = Mangle
startPhase "split_s" = SplitMangle
startPhase "s" = As
startPhase "S" = As
-- output filename. That could be fixed, but watch out.
phaseInputExt HCc = "hc"
phaseInputExt Ccpp = "cpp"
+phaseInputExt Cobjc = "m"
phaseInputExt Cc = "c"
-phaseInputExt Mangle = "raw_s"
phaseInputExt SplitMangle = "split_s" -- not really generated
phaseInputExt As = "s"
phaseInputExt LlvmOpt = "ll"
phaseInputExt SplitAs = "split_s" -- not really generated
phaseInputExt CmmCpp = "cmm"
phaseInputExt Cmm = "cmmcpp"
+phaseInputExt MergeStub = "o"
phaseInputExt StopLn = "o"
haskellish_src_suffixes, haskellish_suffixes, cish_suffixes,
haskellish_src_suffixes = haskellish_user_src_suffixes ++
[ "hspp", "hscpp", "hcr", "cmm", "cmmcpp" ]
haskellish_suffixes = haskellish_src_suffixes ++ ["hc", "raw_s"]
-cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc" ]
+cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "m" ]
extcoreish_suffixes = [ "hcr" ]
-- Will not be deleted as temp files:
haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ]
{-# OPTIONS -fno-cse #-}
+{-# LANGUAGE NamedFieldPuns #-}
-- -fno-cse is needed for GLOBAL_VAR's to behave properly
-----------------------------------------------------------------------------
preprocess hsc_env (filename, mb_phase) =
ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
runPipeline anyHsc hsc_env (filename, mb_phase)
- Nothing Temporary Nothing{-no ModLocation-}
+ Nothing Temporary Nothing{-no ModLocation-} Nothing{-no stub-}
-- ---------------------------------------------------------------------------
hsc_env = hsc_env0 {hsc_dflags = dflags}
-- Figure out what lang we're generating
- let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags)
+ let hsc_lang = hscTarget dflags
-- ... and what the next phase should be
let next_phase = hscNextPhase dflags src_flavour hsc_lang
-- ... and what file to generate the output into
source_unchanged = isJust maybe_old_linkable && not force_recomp
object_filename = ml_obj_file location
- let getStubLinkable False = return []
- getStubLinkable True
- = do stub_o <- compileStub hsc_env' this_mod location
- return [ DotO stub_o ]
-
- handleBatch HscNoRecomp
+ let handleBatch HscNoRecomp
= ASSERT (isJust maybe_old_linkable)
return maybe_old_linkable
return maybe_old_linkable
| otherwise
- = do stub_unlinked <- getStubLinkable hasStub
- (hs_unlinked, unlinked_time) <-
+ = do (hs_unlinked, unlinked_time) <-
case hsc_lang of
- HscNothing
- -> return ([], ms_hs_date summary)
+ HscNothing ->
+ return ([], ms_hs_date summary)
-- We're in --make mode: finish the compilation pipeline.
- _other
- -> do _ <- runPipeline StopLn hsc_env' (output_fn,Nothing)
+ _other -> do
+ maybe_stub_o <- case hasStub of
+ Nothing -> return Nothing
+ Just stub_c -> do
+ stub_o <- compileStub hsc_env' stub_c
+ return (Just stub_o)
+ _ <- runPipeline StopLn hsc_env' (output_fn,Nothing)
(Just basename)
Persistent
(Just location)
+ maybe_stub_o
-- The object filename comes from the ModLocation
- o_time <- getModificationTime object_filename
- return ([DotO object_filename], o_time)
- let linkable = LM unlinked_time this_mod
- (hs_unlinked ++ stub_unlinked)
+ o_time <- getModificationTime object_filename
+ return ([DotO object_filename], o_time)
+
+ let linkable = LM unlinked_time this_mod hs_unlinked
return (Just linkable)
handleInterpreted HscNoRecomp
= ASSERT (isHsBoot src_flavour)
return maybe_old_linkable
handleInterpreted (HscRecomp hasStub (Just (comp_bc, modBreaks)))
- = do stub_unlinked <- getStubLinkable hasStub
+ = do stub_o <- case hasStub of
+ Nothing -> return []
+ Just stub_c -> do
+ stub_o <- compileStub hsc_env' stub_c
+ return [DotO stub_o]
+
let hs_unlinked = [BCOs comp_bc modBreaks]
unlinked_time = ms_hs_date summary
-- Why do we use the timestamp of the source file here,
-- if the source is modified, then the linkable will
-- be out of date.
let linkable = LM unlinked_time this_mod
- (hs_unlinked ++ stub_unlinked)
+ (hs_unlinked ++ stub_o)
return (Just linkable)
let -- runCompiler :: Compiler result -> (result -> Maybe Linkable)
-- The _stub.c file is derived from the haskell source file, possibly taking
-- into account the -stubdir option.
--
--- Consequently, we derive the _stub.o filename from the haskell object
--- filename.
---
--- This isn't necessarily the same as the object filename we
--- would get if we just compiled the _stub.c file using the pipeline.
--- For example:
---
--- ghc src/A.hs -odir obj
---
--- results in obj/A.o, and src/A_stub.c. If we compile src/A_stub.c with
--- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want
--- obj/A_stub.o.
-
-compileStub :: HscEnv -> Module -> ModLocation -> IO FilePath
-compileStub hsc_env mod location = do
- -- compile the _stub.c file w/ gcc
- let (stub_c,_,stub_o) = mkStubPaths (hsc_dflags hsc_env)
- (moduleName mod) location
+-- The object file created by compiling the _stub.c file is put into a
+-- temporary file, which will be later combined with the main .o file
+-- (see the MergeStubs phase).
- _ <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing
- (SpecificFile stub_o) Nothing{-no ModLocation-}
+compileStub :: HscEnv -> FilePath -> IO FilePath
+compileStub hsc_env stub_c = do
+ (_, stub_o) <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing
+ Temporary Nothing{-no ModLocation-} Nothing
return stub_o
-
-- ---------------------------------------------------------------------------
-- Link
( _, out_file) <- runPipeline stop_phase' hsc_env
(src, mb_phase) Nothing output
- Nothing{-no ModLocation-}
+ Nothing{-no ModLocation-} Nothing
return out_file
-> Maybe FilePath -- ^ original basename (if different from ^^^)
-> PipelineOutput -- ^ Output filename
-> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
+ -> Maybe FilePath -- ^ stub object, if we have one
-> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
-runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc
+runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
+ mb_basename output maybe_loc maybe_stub_o
= do
let dflags0 = hsc_dflags hsc_env0
(input_basename, suffix) = splitExtension input_fn
let get_output_fn = getOutputFilename stop_phase output basename
-- Execute the pipeline...
- (dflags', output_fn, maybe_loc) <-
- pipeLoop hsc_env start_phase stop_phase input_fn
- basename suffix' get_output_fn maybe_loc
+ let env = PipeEnv{ stop_phase,
+ src_basename = basename,
+ src_suffix = suffix',
+ output_spec = output }
+
+ state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o }
+
+ (state', output_fn) <- unP (pipeLoop start_phase input_fn) env state
+
+ let PipeState{ hsc_env=hsc_env', maybe_loc } = state'
+ dflags' = hsc_dflags hsc_env'
-- Sometimes, a compilation phase doesn't actually generate any output
-- (eg. the CPP phase when -fcpp is not turned on). If we end on this
copyWithHeader dflags msg line_prag output_fn final_fn
return (dflags', final_fn)
+-- -----------------------------------------------------------------------------
+-- The pipeline uses a monad to carry around various bits of information
+
+-- PipeEnv: invariant information passed down
+data PipeEnv = PipeEnv {
+ stop_phase :: Phase, -- ^ Stop just before this phase
+ src_basename :: String, -- ^ basename of original input source
+ src_suffix :: String, -- ^ its extension
+ output_spec :: PipelineOutput -- ^ says where to put the pipeline output
+ }
+
+-- PipeState: information that might change during a pipeline run
+data PipeState = PipeState {
+ hsc_env :: HscEnv,
+ -- ^ only the DynFlags change in the HscEnv. The DynFlags change
+ -- at various points, for example when we read the OPTIONS_GHC
+ -- pragmas in the Cpp phase.
+ maybe_loc :: Maybe ModLocation,
+ -- ^ the ModLocation. This is discovered during compilation,
+ -- in the Hsc phase where we read the module header.
+ maybe_stub_o :: Maybe FilePath
+ -- ^ the stub object. This is set by the Hsc phase if a stub
+ -- object was created. The stub object will be joined with
+ -- the main compilation object using "ld -r" at the end.
+ }
+
+getPipeEnv :: CompPipeline PipeEnv
+getPipeEnv = P $ \env state -> return (state, env)
+
+getPipeState :: CompPipeline PipeState
+getPipeState = P $ \_env state -> return (state, state)
+
+getDynFlags :: CompPipeline DynFlags
+getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state))
+
+setDynFlags :: DynFlags -> CompPipeline ()
+setDynFlags dflags = P $ \_env state ->
+ return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ())
+
+setModLocation :: ModLocation -> CompPipeline ()
+setModLocation loc = P $ \_env state ->
+ return (state{ maybe_loc = Just loc }, ())
+
+setStubO :: FilePath -> CompPipeline ()
+setStubO stub_o = P $ \_env state ->
+ return (state{ maybe_stub_o = Just stub_o }, ())
+
+newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) }
+
+instance Monad CompPipeline where
+ return a = P $ \_env state -> return (state, a)
+ P m >>= k = P $ \env state -> do (state',a) <- m env state
+ unP (k a) env state'
+
+io :: IO a -> CompPipeline a
+io m = P $ \_env state -> do a <- m; return (state, a)
+
+phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath
+phaseOutputFilename next_phase = do
+ PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv
+ PipeState{maybe_loc, hsc_env} <- getPipeState
+ let dflags = hsc_dflags hsc_env
+ io $ getOutputFilename stop_phase output_spec
+ src_basename dflags next_phase maybe_loc
-
-pipeLoop :: HscEnv -> Phase -> Phase
- -> FilePath -> String -> Suffix
- -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
- -> Maybe ModLocation
- -> IO (DynFlags, FilePath, Maybe ModLocation)
-
-pipeLoop hsc_env phase stop_phase
- input_fn orig_basename orig_suff
- orig_get_output_fn maybe_loc
-
- | phase `eqPhase` stop_phase -- All done
- = return (hsc_dflags hsc_env, input_fn, maybe_loc)
-
- | not (phase `happensBefore` stop_phase)
+-- ---------------------------------------------------------------------------
+-- outer pipeline loop
+
+-- | pipeLoop runs phases until we reach the stop phase
+pipeLoop :: Phase -> FilePath -> CompPipeline FilePath
+pipeLoop phase input_fn = do
+ PipeEnv{stop_phase} <- getPipeEnv
+ PipeState{hsc_env} <- getPipeState
+ case () of
+ _ | phase `eqPhase` stop_phase -- All done
+ -> return input_fn
+
+ | not (phase `happensBefore` stop_phase)
-- Something has gone wrong. We'll try to cover all the cases when
-- this could happen, so if we reach here it is a panic.
-- eg. it might happen if the -C flag is used on a source file that
-- has {-# OPTIONS -fasm #-}.
- = panic ("pipeLoop: at phase " ++ show phase ++
+ -> panic ("pipeLoop: at phase " ++ show phase ++
" but I wanted to stop at phase " ++ show stop_phase)
- | otherwise
- = do debugTraceMsg (hsc_dflags hsc_env) 4
+ | otherwise
+ -> do io $ debugTraceMsg (hsc_dflags hsc_env) 4
(ptext (sLit "Running phase") <+> ppr phase)
- (next_phase, dflags', maybe_loc, output_fn)
- <- runPhase phase stop_phase hsc_env orig_basename
- orig_suff input_fn orig_get_output_fn maybe_loc
- let hsc_env' = hsc_env {hsc_dflags = dflags'}
- pipeLoop hsc_env' next_phase stop_phase output_fn
- orig_basename orig_suff orig_get_output_fn maybe_loc
+ dflags <- getDynFlags
+ (next_phase, output_fn) <- runPhase phase input_fn dflags
+ pipeLoop next_phase output_fn
+
+-- -----------------------------------------------------------------------------
+-- In each phase, we need to know into what filename to generate the
+-- output. All the logic about which filenames we generate output
+-- into is embodied in the following function.
getOutputFilename
:: Phase -> PipelineOutput -> String
odir = objectDir dflags
osuf = objectSuf dflags
keep_hc = dopt Opt_KeepHcFiles dflags
- keep_raw_s = dopt Opt_KeepRawSFiles dflags
keep_s = dopt Opt_KeepSFiles dflags
keep_bc = dopt Opt_KeepLlvmFiles dflags
- myPhaseInputExt HCc = hcsuf
- myPhaseInputExt StopLn = osuf
- myPhaseInputExt other = phaseInputExt other
+ myPhaseInputExt HCc = hcsuf
+ myPhaseInputExt MergeStub = osuf
+ myPhaseInputExt StopLn = osuf
+ myPhaseInputExt other = phaseInputExt other
is_last_phase = next_phase `eqPhase` stop_phase
-- sometimes, we keep output from intermediate stages
keep_this_output =
case next_phase of
- StopLn -> True
- Mangle | keep_raw_s -> True
As | keep_s -> True
LlvmOpt | keep_bc -> True
HCc | keep_hc -> True
-- of a source file can change the latter stages of the pipeline from
-- taking the via-C route to using the native code generator.
--
-runPhase :: Phase -- ^ Do this phase first
- -> Phase -- ^ Stop just before this phase
- -> HscEnv
- -> String -- ^ basename of original input source
- -> String -- ^ its extension
- -> FilePath -- ^ name of file which contains the input to this phase.
- -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
- -- ^ how to calculate the output filename
- -> Maybe ModLocation -- ^ the ModLocation, if we have one
- -> IO (Phase, -- next phase
- DynFlags, -- new dynamic flags
- Maybe ModLocation, -- the ModLocation, if we have one
- FilePath) -- output filename
+runPhase :: Phase -- ^ Run this phase
+ -> FilePath -- ^ name of the input file
+ -> DynFlags -- ^ for convenience, we pass the current dflags in
+ -> CompPipeline (Phase, -- next phase to run
+ FilePath) -- output filename
-- Invariant: the output filename always contains the output
-- Interesting case: Hsc when there is no recompilation to do
-- Then the output filename is still a .o file
+
-------------------------------------------------------------------------------
-- Unlit phase
-runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
+runPhase (Unlit sf) input_fn dflags
= do
- let dflags = hsc_dflags hsc_env
- output_fn <- get_output_fn dflags (Cpp sf) maybe_loc
+ output_fn <- phaseOutputFilename (Cpp sf)
let unlit_flags = getOpts dflags opt_L
flags = map SysTools.Option unlit_flags ++
, SysTools.FileOption "" output_fn
]
- SysTools.runUnlit dflags flags
+ io $ SysTools.runUnlit dflags flags
- return (Cpp sf, dflags, maybe_loc, output_fn)
+ return (Cpp sf, output_fn)
-------------------------------------------------------------------------------
-- Cpp phase : (a) gets OPTIONS out of file
-- (b) runs cpp if necessary
-runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
- = do let dflags0 = hsc_dflags hsc_env
- src_opts <- getOptionsFromFile dflags0 input_fn
+runPhase (Cpp sf) input_fn dflags0
+ = do
+ src_opts <- io $ getOptionsFromFile dflags0 input_fn
(dflags1, unhandled_flags, warns)
- <- parseDynamicNoPackageFlags dflags0 src_opts
- checkProcessArgsResult unhandled_flags
+ <- io $ parseDynamicNoPackageFlags dflags0 src_opts
+ setDynFlags dflags1
+ io $ checkProcessArgsResult unhandled_flags
if not (xopt Opt_Cpp dflags1) then do
-- we have to be careful to emit warnings only once.
- unless (dopt Opt_Pp dflags1) $ handleFlagWarnings dflags1 warns
+ unless (dopt Opt_Pp dflags1) $ io $ handleFlagWarnings dflags1 warns
-- no need to preprocess CPP, just pass input file along
-- to the next phase of the pipeline.
- return (HsPp sf, dflags1, maybe_loc, input_fn)
+ return (HsPp sf, input_fn)
else do
- output_fn <- get_output_fn dflags1 (HsPp sf) maybe_loc
- doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn
+ output_fn <- phaseOutputFilename (HsPp sf)
+ io $ doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn
-- re-read the pragmas now that we've preprocessed the file
-- See #2464,#3457
- src_opts <- getOptionsFromFile dflags0 output_fn
+ src_opts <- io $ getOptionsFromFile dflags0 output_fn
(dflags2, unhandled_flags, warns)
- <- parseDynamicNoPackageFlags dflags0 src_opts
- unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns
+ <- io $ parseDynamicNoPackageFlags dflags0 src_opts
+ unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns
-- the HsPp pass below will emit warnings
- checkProcessArgsResult unhandled_flags
+ io $ checkProcessArgsResult unhandled_flags
+
+ setDynFlags dflags2
- return (HsPp sf, dflags2, maybe_loc, output_fn)
+ return (HsPp sf, output_fn)
-------------------------------------------------------------------------------
-- HsPp phase
-runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
- = do let dflags = hsc_dflags hsc_env
+runPhase (HsPp sf) input_fn dflags
+ = do
if not (dopt Opt_Pp dflags) then
-- no need to preprocess, just pass input file along
-- to the next phase of the pipeline.
- return (Hsc sf, dflags, maybe_loc, input_fn)
+ return (Hsc sf, input_fn)
else do
let hspp_opts = getOpts dflags opt_F
- let orig_fn = basename <.> suff
- output_fn <- get_output_fn dflags (Hsc sf) maybe_loc
- SysTools.runPp dflags
+ PipeEnv{src_basename, src_suffix} <- getPipeEnv
+ let orig_fn = src_basename <.> src_suffix
+ output_fn <- phaseOutputFilename (Hsc sf)
+ io $ SysTools.runPp dflags
( [ SysTools.Option orig_fn
, SysTools.Option input_fn
, SysTools.FileOption "" output_fn
)
-- re-read pragmas now that we've parsed the file (see #3674)
- src_opts <- getOptionsFromFile dflags output_fn
+ src_opts <- io $ getOptionsFromFile dflags output_fn
(dflags1, unhandled_flags, warns)
- <- parseDynamicNoPackageFlags dflags src_opts
- handleFlagWarnings dflags1 warns
- checkProcessArgsResult unhandled_flags
+ <- io $ parseDynamicNoPackageFlags dflags src_opts
+ setDynFlags dflags1
+ io $ handleFlagWarnings dflags1 warns
+ io $ checkProcessArgsResult unhandled_flags
- return (Hsc sf, dflags1, maybe_loc, output_fn)
+ return (Hsc sf, output_fn)
-----------------------------------------------------------------------------
-- Hsc phase
-- Compilation of a single module, in "legacy" mode (_not_ under
-- the direction of the compilation manager).
-runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _maybe_loc
+runPhase (Hsc src_flavour) input_fn dflags0
= do -- normal Hsc mode, not mkdependHS
- let dflags0 = hsc_dflags hsc_env
+
+ PipeEnv{ stop_phase=stop,
+ src_basename=basename,
+ src_suffix=suff } <- getPipeEnv
-- we add the current directory (i.e. the directory in which
-- the .hs files resides) to the include path, since this is
paths = includePaths dflags0
dflags = dflags0 { includePaths = current_dir : paths }
+ setDynFlags dflags
+
-- gather the imports and module name
- (hspp_buf,mod_name,imps,src_imps) <-
+ (hspp_buf,mod_name,imps,src_imps) <- io $
case src_flavour of
ExtCoreFile -> do -- no explicit imports in ExtCore input.
m <- getCoreModuleName input_fn
-- the .hi and .o filenames, and this is as good a way
-- as any to generate them, and better than most. (e.g. takes
-- into accout the -osuf flags)
- location1 <- mkHomeModLocation2 dflags mod_name basename suff
+ location1 <- io $ mkHomeModLocation2 dflags mod_name basename suff
-- Boot-ify it if necessary
let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
o_file = ml_obj_file location4 -- The real object file
+ setModLocation location4
-- Figure out if the source has changed, for recompilation avoidance.
--
-- changed (which the compiler itself figures out).
-- Setting source_unchanged to False tells the compiler that M.o is out of
-- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
- src_timestamp <- getModificationTime (basename <.> suff)
+ src_timestamp <- io $ getModificationTime (basename <.> suff)
let force_recomp = dopt Opt_ForceRecomp dflags
- hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags)
- source_unchanged <-
+ hsc_lang = hscTarget dflags
+ source_unchanged <- io $
if force_recomp || not (isStopLn stop)
-- Set source_unchanged to False unconditionally if
-- (a) recompilation checker is off, or
-- get the DynFlags
let next_phase = hscNextPhase dflags src_flavour hsc_lang
- output_fn <- get_output_fn dflags next_phase (Just location4)
+ output_fn <- phaseOutputFilename next_phase
let dflags' = dflags { hscTarget = hsc_lang,
hscOutName = output_fn,
extCoreName = basename ++ ".hcr" }
- let hsc_env' = hsc_env {hsc_dflags = dflags'}
+ setDynFlags dflags'
+ PipeState{hsc_env=hsc_env'} <- getPipeState
-- Tell the finder cache about this module
- mod <- addHomeModuleToFinder hsc_env' mod_name location4
+ mod <- io $ addHomeModuleToFinder hsc_env' mod_name location4
-- Make the ModSummary to hand to hscMain
let
ms_srcimps = src_imps }
-- run the compiler!
- result <- hscCompileOneShot hsc_env'
+ result <- io $ hscCompileOneShot hsc_env'
mod_summary source_unchanged
Nothing -- No iface
Nothing -- No "module i of n" progress info
case result of
HscNoRecomp
- -> do SysTools.touch dflags' "Touching object file" o_file
+ -> do io $ SysTools.touch dflags' "Touching object file" o_file
-- The .o file must have a later modification date
-- than the source file (else we wouldn't be in HscNoRecomp)
-- but we touch it anyway, to keep 'make' happy (we think).
- return (StopLn, dflags', Just location4, o_file)
+ return (StopLn, o_file)
(HscRecomp hasStub _)
- -> do when hasStub $
- do stub_o <- compileStub hsc_env' mod location4
- liftIO $ consIORef v_Ld_inputs stub_o
+ -> do case hasStub of
+ Nothing -> return ()
+ Just stub_c ->
+ do stub_o <- io $ compileStub hsc_env' stub_c
+ setStubO stub_o
-- In the case of hs-boot files, generate a dummy .o-boot
-- stamp file for the benefit of Make
when (isHsBoot src_flavour) $
- SysTools.touch dflags' "Touching object file" o_file
- return (next_phase, dflags', Just location4, output_fn)
+ io $ SysTools.touch dflags' "Touching object file" o_file
+ return (next_phase, output_fn)
-----------------------------------------------------------------------------
-- Cmm phase
-runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
+runPhase CmmCpp input_fn dflags
= do
- let dflags = hsc_dflags hsc_env
- output_fn <- get_output_fn dflags Cmm maybe_loc
- doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn
- return (Cmm, dflags, maybe_loc, output_fn)
+ output_fn <- phaseOutputFilename Cmm
+ io $ doCpp dflags False{-not raw-} True{-include CC opts-}
+ input_fn output_fn
+ return (Cmm, output_fn)
-runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc
+runPhase Cmm input_fn dflags
= do
- let dflags = hsc_dflags hsc_env
- let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
+ PipeEnv{src_basename} <- getPipeEnv
+ let hsc_lang = hscTarget dflags
+
let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
- output_fn <- get_output_fn dflags next_phase maybe_loc
+
+ output_fn <- phaseOutputFilename next_phase
let dflags' = dflags { hscTarget = hsc_lang,
hscOutName = output_fn,
- extCoreName = basename ++ ".hcr" }
- let hsc_env' = hsc_env {hsc_dflags = dflags'}
+ extCoreName = src_basename ++ ".hcr" }
+
+ setDynFlags dflags'
+ PipeState{hsc_env} <- getPipeState
- hscCompileCmmFile hsc_env' input_fn
+ io $ hscCompileCmmFile hsc_env input_fn
-- XXX: catch errors above and convert them into ghcError? Original
-- code was:
--
--when (not ok) $ ghcError (PhaseFailed "cmm" (ExitFailure 1))
- return (next_phase, dflags, maybe_loc, output_fn)
+ return (next_phase, output_fn)
-----------------------------------------------------------------------------
-- Cc phase
-- we don't support preprocessing .c files (with -E) now. Doing so introduces
-- way too many hacks, and I can't say I've ever used it anyway.
-runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
- | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc
- = do let dflags = hsc_dflags hsc_env
+runPhase cc_phase input_fn dflags
+ | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc || cc_phase `eqPhase` Cobjc
+ = do
let cc_opts = getOpts dflags opt_c
hcc = cc_phase `eqPhase` HCc
let cmdline_include_paths = includePaths dflags
-- HC files have the dependent packages stamped into them
- pkgs <- if hcc then getHCFilePackages input_fn else return []
+ pkgs <- if hcc then io $ getHCFilePackages input_fn else return []
-- add package include paths even if we're just compiling .c
-- files; this is the Value Add(TM) that using ghc instead of
-- gcc gives you :)
- pkg_include_dirs <- getPackageIncludePath dflags pkgs
+ pkg_include_dirs <- io $ getPackageIncludePath dflags pkgs
let include_paths = foldr (\ x xs -> "-I" : x : xs) []
(cmdline_include_paths ++ pkg_include_dirs)
- let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags
- gcc_extra_viac_flags <- getExtraViaCOpts dflags
+ let md_c_flags = machdepCCOpts dflags
+ gcc_extra_viac_flags <- io $ getExtraViaCOpts dflags
let pic_c_flags = picCCOpts dflags
let verb = getVerbFlag dflags
-- cc-options are not passed when compiling .hc files. Our
-- hc code doesn't not #include any header files anyway, so these
-- options aren't necessary.
- pkg_extra_cc_opts <-
+ pkg_extra_cc_opts <- io $
if cc_phase `eqPhase` HCc
then return []
else getPackageExtraCcOpts dflags pkgs
#ifdef darwin_TARGET_OS
- pkg_framework_paths <- getPackageFrameworkPath dflags pkgs
+ pkg_framework_paths <- io $ getPackageFrameworkPath dflags pkgs
let cmdline_framework_paths = frameworkPaths dflags
let framework_paths = map ("-F"++)
(cmdline_framework_paths ++ pkg_framework_paths)
-- Decide next phase
- let mangle = dopt Opt_DoAsmMangling dflags
- next_phase
- | hcc && mangle = Mangle
- | otherwise = As
- output_fn <- get_output_fn dflags next_phase maybe_loc
+ let next_phase = As
+ output_fn <- phaseOutputFilename next_phase
let
more_hcc_opts =
-- very weakly typed, being derived from C--.
["-fno-strict-aliasing"]
- SysTools.runCc dflags (
+ let gcc_lang_opt | cc_phase `eqPhase` Ccpp = "c++"
+ | cc_phase `eqPhase` Cobjc = "objective-c"
+ | otherwise = "c"
+ io $ SysTools.runCc dflags (
-- force the C compiler to interpret this file as C when
-- compiling .hc files, by adding the -x c option.
-- Also useful for plain .c files, just in case GHC saw a
-- -x c option.
- [ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp
- then SysTools.Option "c++"
- else SysTools.Option "c"] ++
- [ SysTools.FileOption "" input_fn
+ [ SysTools.Option "-x", SysTools.Option gcc_lang_opt
+ , SysTools.FileOption "" input_fn
, SysTools.Option "-o"
, SysTools.FileOption "" output_fn
]
-- This is a temporary hack.
++ ["-mcpu=v9"]
#endif
- ++ (if hcc && mangle
- then md_regd_c_flags
- else [])
- ++ (if hcc
- then if mangle
- then gcc_extra_viac_flags
- else filter (=="-fwrapv")
- gcc_extra_viac_flags
- -- still want -fwrapv even for unreg'd
- else [])
++ (if hcc
- then more_hcc_opts
+ then gcc_extra_viac_flags ++ more_hcc_opts
else [])
++ [ verb, "-S", "-Wimplicit", cc_opt ]
++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
++ pkg_extra_cc_opts
))
- return (next_phase, dflags, maybe_loc, output_fn)
+ return (next_phase, output_fn)
-- ToDo: postprocess the output from gcc
-----------------------------------------------------------------------------
--- Mangle phase
-
-runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
- = do let dflags = hsc_dflags hsc_env
- let mangler_opts = getOpts dflags opt_m
-
-#if i386_TARGET_ARCH
- machdep_opts <- return [ show (stolen_x86_regs dflags) ]
-#else
- machdep_opts <- return []
-#endif
-
- let split = dopt Opt_SplitObjs dflags
- next_phase
- | split = SplitMangle
- | otherwise = As
- output_fn <- get_output_fn dflags next_phase maybe_loc
-
- SysTools.runMangle dflags (map SysTools.Option mangler_opts
- ++ [ SysTools.FileOption "" input_fn
- , SysTools.FileOption "" output_fn
- ]
- ++ map SysTools.Option machdep_opts)
-
- return (next_phase, dflags, maybe_loc, output_fn)
-
------------------------------------------------------------------------------
-- Splitting phase
-runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc
+runPhase SplitMangle input_fn dflags
= do -- tmp_pfx is the prefix used for the split .s files
- -- We also use it as the file to contain the no. of split .s files (sigh)
- let dflags = hsc_dflags hsc_env
- split_s_prefix <- SysTools.newTempName dflags "split"
+
+ split_s_prefix <- io $ SysTools.newTempName dflags "split"
let n_files_fn = split_s_prefix
- SysTools.runSplit dflags
+ io $ SysTools.runSplit dflags
[ SysTools.FileOption "" input_fn
, SysTools.FileOption "" split_s_prefix
, SysTools.FileOption "" n_files_fn
]
-- Save the number of split files for future references
- s <- readFile n_files_fn
+ s <- io $ readFile n_files_fn
let n_files = read s :: Int
dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }
+ setDynFlags dflags'
+
-- Remember to delete all these files
- addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s"
- | n <- [1..n_files]]
+ io $ addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s"
+ | n <- [1..n_files]]
- return (SplitAs, dflags', maybe_loc, "**splitmangle**")
+ return (SplitAs, "**splitmangle**")
-- we don't use the filename
-----------------------------------------------------------------------------
-- As phase
-runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
- = do let dflags = hsc_dflags hsc_env
+runPhase As input_fn dflags
+ = do
let as_opts = getOpts dflags opt_a
let cmdline_include_paths = includePaths dflags
- output_fn <- get_output_fn dflags StopLn maybe_loc
+ next_phase <- maybeMergeStub
+ output_fn <- phaseOutputFilename next_phase
-- we create directories for the object file, because it
-- might be a hierarchical module.
- createDirectoryHierarchy (takeDirectory output_fn)
+ io $ createDirectoryHierarchy (takeDirectory output_fn)
- let (md_c_flags, _) = machdepCCOpts dflags
- SysTools.runAs dflags
+ let md_c_flags = machdepCCOpts dflags
+ io $ SysTools.runAs dflags
(map SysTools.Option as_opts
++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
#ifdef sparc_TARGET_ARCH
]
++ map SysTools.Option md_c_flags)
- return (StopLn, dflags, maybe_loc, output_fn)
+ return (next_phase, output_fn)
-runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc
+runPhase SplitAs _input_fn dflags
= do
- let dflags = hsc_dflags hsc_env
- output_fn <- get_output_fn dflags StopLn maybe_loc
+ -- we'll handle the stub_o file in this phase, so don't MergeStub,
+ -- just jump straight to StopLn afterwards.
+ let next_phase = StopLn
+ output_fn <- phaseOutputFilename next_phase
let base_o = dropExtension output_fn
osuf = objectSuf dflags
split_odir = base_o ++ "_" ++ osuf ++ "_split"
- createDirectoryHierarchy split_odir
+ io $ createDirectoryHierarchy split_odir
-- remove M_split/ *.o, because we're going to archive M_split/ *.o
-- later and we don't want to pick up any old objects.
- fs <- getDirectoryContents split_odir
- mapM_ removeFile $ map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
+ fs <- io $ getDirectoryContents split_odir
+ io $ mapM_ removeFile $
+ map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
let as_opts = getOpts dflags opt_a
split_obj n = split_odir </>
takeFileName base_o ++ "__" ++ show n <.> osuf
- let (md_c_flags, _) = machdepCCOpts dflags
+ let md_c_flags = machdepCCOpts dflags
let assemble_file n
= SysTools.runAs dflags
(map SysTools.Option as_opts ++
]
++ map SysTools.Option md_c_flags)
- mapM_ assemble_file [1..n]
+ io $ mapM_ assemble_file [1..n]
+
+ -- If there's a stub_o file, then we make it the n+1th split object.
+ PipeState{maybe_stub_o} <- getPipeState
+ n' <- case maybe_stub_o of
+ Nothing -> return n
+ Just stub_o -> do io $ copyFile stub_o (split_obj (n+1))
+ return (n+1)
-- join them into a single .o file
- joinObjectFiles dflags (map split_obj [1..n]) output_fn
+ io $ joinObjectFiles dflags (map split_obj [1..n']) output_fn
- return (StopLn, dflags, maybe_loc, output_fn)
+ return (next_phase, output_fn)
-----------------------------------------------------------------------------
-- LlvmOpt phase
-runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
+runPhase LlvmOpt input_fn dflags
= do
- let dflags = hsc_dflags hsc_env
let lo_opts = getOpts dflags opt_lo
let opt_lvl = max 0 (min 2 $ optLevel dflags)
-- don't specify anything if user has specified commands. We do this for
then [SysTools.Option (llvmOpts !! opt_lvl)]
else []
- output_fn <- get_output_fn dflags LlvmLlc maybe_loc
+ output_fn <- phaseOutputFilename LlvmLlc
- SysTools.runLlvmOpt dflags
+ io $ SysTools.runLlvmOpt dflags
([ SysTools.FileOption "" input_fn,
SysTools.Option "-o",
SysTools.FileOption "" output_fn]
++ optFlag
++ map SysTools.Option lo_opts)
- return (LlvmLlc, dflags, maybe_loc, output_fn)
+ return (LlvmLlc, output_fn)
where
-- we always (unless -optlo specified) run Opt since we rely on it to
-- fix up some pretty big deficiencies in the code we generate
-----------------------------------------------------------------------------
-- LlvmLlc phase
-runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
+runPhase LlvmLlc input_fn dflags
= do
- let dflags = hsc_dflags hsc_env
let lc_opts = getOpts dflags opt_lc
let opt_lvl = max 0 (min 2 $ optLevel dflags)
#if darwin_TARGET_OS
| not opt_Static = "dynamic-no-pic"
| otherwise = "static"
- output_fn <- get_output_fn dflags nphase maybe_loc
+ output_fn <- phaseOutputFilename nphase
- SysTools.runLlvmLlc dflags
+ io $ SysTools.runLlvmLlc dflags
([ SysTools.Option (llvmOpts !! opt_lvl),
SysTools.Option $ "-relocation-model=" ++ rmodel,
SysTools.FileOption "" input_fn,
SysTools.Option "-o", SysTools.FileOption "" output_fn]
++ map SysTools.Option lc_opts)
- return (nphase, dflags, maybe_loc, output_fn)
+ return (nphase, output_fn)
where
#if darwin_TARGET_OS
llvmOpts = ["-O1", "-O2", "-O2"]
-----------------------------------------------------------------------------
-- LlvmMangle phase
-runPhase LlvmMangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
+runPhase LlvmMangle input_fn _dflags
= do
- let dflags = hsc_dflags hsc_env
- output_fn <- get_output_fn dflags As maybe_loc
- llvmFixupAsm input_fn output_fn
- return (As, dflags, maybe_loc, output_fn)
+ output_fn <- phaseOutputFilename As
+ io $ llvmFixupAsm input_fn output_fn
+ return (As, output_fn)
+
+-----------------------------------------------------------------------------
+-- merge in stub objects
+runPhase MergeStub input_fn dflags
+ = do
+ PipeState{maybe_stub_o} <- getPipeState
+ output_fn <- phaseOutputFilename StopLn
+ case maybe_stub_o of
+ Nothing ->
+ panic "runPhase(MergeStub): no stub"
+ Just stub_o -> do
+ io $ joinObjectFiles dflags [input_fn, stub_o] output_fn
+ return (StopLn, output_fn)
-- warning suppression
-runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc =
+runPhase other _input_fn _dflags =
panic ("runPhase: don't know how to run phase " ++ show other)
+
+maybeMergeStub :: CompPipeline Phase
+maybeMergeStub
+ = do
+ PipeState{maybe_stub_o} <- getPipeState
+ if isJust maybe_stub_o then return MergeStub else return StopLn
+
-----------------------------------------------------------------------------
-- MoveBinary sort-of-phase
-- After having produced a binary, move it somewhere else and generate a
oFile <- newTempName dflags "o"
writeFile cFile $ unlines xs
let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId
- (md_c_flags, _) = machdepCCOpts dflags
+ md_c_flags = machdepCCOpts dflags
SysTools.runCc dflags
([Option "-c",
FileOption "" cFile,
rc_objs <- maybeCreateManifest dflags output_fn
- let (md_c_flags, _) = machdepCCOpts dflags
+ let md_c_flags = machdepCCOpts dflags
SysTools.runLink dflags (
[ SysTools.Option verb
, SysTools.Option "-o"
-- probably _stub.o files
extra_ld_inputs <- readIORef v_Ld_inputs
- let (md_c_flags, _) = machdepCCOpts dflags
+ let md_c_flags = machdepCCOpts dflags
let extra_ld_opts = getOpts dflags opt_l
rtsEnabledObj <- mkRtsOptionsLevelObj dflags
| otherwise = (optc ++ md_c_flags)
where
optc = getOpts dflags opt_c
- (md_c_flags, _) = machdepCCOpts dflags
+ md_c_flags = machdepCCOpts dflags
let cpp_prog args | raw = SysTools.runCpp dflags args
| otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
ld_x_flag | null cLD_X = ""
| otherwise = "-Wl,-x"
- (md_c_flags, _) = machdepCCOpts dflags
+ md_c_flags = machdepCCOpts dflags
if cLdIsGNULd == "YES"
then do
HscInterpreted -> StopLn
_other -> StopLn
-
-hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget
-hscMaybeAdjustTarget dflags stop _ current_hsc_lang
- = hsc_lang
- where
- keep_hc = dopt Opt_KeepHcFiles dflags
- hsc_lang
- -- don't change the lang if we're interpreting
- | current_hsc_lang == HscInterpreted = current_hsc_lang
-
- -- force -fvia-C if we are being asked for a .hc file
- | HCc <- stop = HscC
- | keep_hc = HscC
- -- otherwise, stick to the plan
- | otherwise = current_hsc_lang
-
| Opt_Pp
| Opt_ForceRecomp
| Opt_DryRun
- | Opt_DoAsmMangling
| Opt_ExcessPrecision
| Opt_EagerBlackHoling
| Opt_ReadUserPackageConf
| Opt_KeepHiDiffs
| Opt_KeepHcFiles
| Opt_KeepSFiles
- | Opt_KeepRawSFiles
| Opt_KeepTmpFiles
| Opt_KeepRawTokenStream
| Opt_KeepLlvmFiles
#ifndef OMIT_NATIVE_CODEGEN
targetPlatform :: Platform, -- ^ The platform we're compiling for. Used by the NCG.
#endif
- stolen_x86_regs :: Int,
cmdlineHcIncludes :: [String], -- ^ @\-\#includes@
importPaths :: [FilePath],
mainModIs :: Module,
pgm_P :: (String,[Option]),
pgm_F :: String,
pgm_c :: (String,[Option]),
- pgm_m :: (String,[Option]),
pgm_s :: (String,[Option]),
pgm_a :: (String,[Option]),
pgm_l :: (String,[Option]),
#ifndef OMIT_NATIVE_CODEGEN
targetPlatform = defaultTargetPlatform,
#endif
- stolen_x86_regs = 4,
cmdlineHcIncludes = [],
importPaths = ["."],
mainModIs = mAIN,
pgm_P = panic "defaultDynFlags: No pgm_P",
pgm_F = panic "defaultDynFlags: No pgm_F",
pgm_c = panic "defaultDynFlags: No pgm_c",
- pgm_m = panic "defaultDynFlags: No pgm_m",
pgm_s = panic "defaultDynFlags: No pgm_s",
pgm_a = panic "defaultDynFlags: No pgm_a",
pgm_l = panic "defaultDynFlags: No pgm_l",
, Flag "pgmP" (hasArg setPgmP)
, Flag "pgmF" (hasArg (\f d -> d{ pgm_F = f}))
, Flag "pgmc" (hasArg (\f d -> d{ pgm_c = (f,[])}))
- , Flag "pgmm" (hasArg (\f d -> d{ pgm_m = (f,[])}))
+ , Flag "pgmm" (HasArg (\_ -> addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release"))
, Flag "pgms" (hasArg (\f d -> d{ pgm_s = (f,[])}))
, Flag "pgma" (hasArg (\f d -> d{ pgm_a = (f,[])}))
, Flag "pgml" (hasArg (\f d -> d{ pgm_l = (f,[])}))
, Flag "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles))
, Flag "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles))
, Flag "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles))
- , Flag "keep-raw-s-file" (NoArg (setDynFlag Opt_KeepRawSFiles))
- , Flag "keep-raw-s-files" (NoArg (setDynFlag Opt_KeepRawSFiles))
+ , Flag "keep-raw-s-file" (NoArg (addWarn "The -keep-raw-s-file flag does nothing; it will be removed in a future GHC release"))
+ , Flag "keep-raw-s-files" (NoArg (addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release"))
, Flag "keep-llvm-file" (NoArg (setDynFlag Opt_KeepLlvmFiles))
, Flag "keep-llvm-files" (NoArg (setDynFlag Opt_KeepLlvmFiles))
-- This only makes sense as plural
------ Machine dependant (-m<blah>) stuff ---------------------------
- , Flag "monly-2-regs" (noArg (\s -> s{stolen_x86_regs = 2}))
- , Flag "monly-3-regs" (noArg (\s -> s{stolen_x86_regs = 3}))
- , Flag "monly-4-regs" (noArg (\s -> s{stolen_x86_regs = 4}))
+ , Flag "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release"))
+ , Flag "monly-3-regs" (NoArg (addWarn "The -monly-3-regs flag does nothing; it will be removed in a future GHC release"))
+ , Flag "monly-4-regs" (NoArg (addWarn "The -monly-4-regs flag does nothing; it will be removed in a future GHC release"))
, Flag "msse2" (NoArg (setDynFlag Opt_SSE2))
------ Warning opts -------------------------------------------------
( "dicts-cheap", Opt_DictsCheap, nop ),
( "excess-precision", Opt_ExcessPrecision, nop ),
( "eager-blackholing", Opt_EagerBlackHoling, nop ),
- ( "asm-mangling", Opt_DoAsmMangling, nop ),
( "print-bind-result", Opt_PrintBindResult, nop ),
( "force-recomp", Opt_ForceRecomp, nop ),
( "hpc-no-auto", Opt_Hpc_No_Auto, nop ),
= [ Opt_AutoLinkPackages,
Opt_ReadUserPackageConf,
- Opt_DoAsmMangling,
-
Opt_SharedImplib,
Opt_GenManifest,
-- The options below are not dependent on the version of gcc, only the
-- platform.
-machdepCCOpts :: DynFlags -> ([String], -- flags for all C compilations
- [String]) -- for registerised HC compilations
-machdepCCOpts dflags = let (flagsAll, flagsRegHc) = machdepCCOpts' dflags
- in (cCcOpts ++ flagsAll, flagsRegHc)
+machdepCCOpts :: DynFlags -> [String] -- flags for all C compilations
+machdepCCOpts dflags = cCcOpts ++ machdepCCOpts'
-machdepCCOpts' :: DynFlags -> ([String], -- flags for all C compilations
- [String]) -- for registerised HC compilations
-machdepCCOpts' _dflags
+machdepCCOpts' :: [String] -- flags for all C compilations
+machdepCCOpts'
#if alpha_TARGET_ARCH
- = ( ["-w", "-mieee"
+ = ["-w", "-mieee"
#ifdef HAVE_THREADED_RTS_SUPPORT
, "-D_REENTRANT"
#endif
- ], [] )
+ ]
-- For now, to suppress the gcc warning "call-clobbered
-- register used for global register variable", we simply
-- disable all warnings altogether using the -w flag. Oh well.
#elif hppa_TARGET_ARCH
-- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
-- (very nice, but too bad the HP /usr/include files don't agree.)
- = ( ["-D_HPUX_SOURCE"], [] )
-
-#elif m68k_TARGET_ARCH
- -- -fno-defer-pop : for the .hc files, we want all the pushing/
- -- popping of args to routines to be explicit; if we let things
- -- be deferred 'til after an STGJUMP, imminent death is certain!
- --
- -- -fomit-frame-pointer : *don't*
- -- It's better to have a6 completely tied up being a frame pointer
- -- rather than let GCC pick random things to do with it.
- -- (If we want to steal a6, then we would try to do things
- -- as on iX86, where we *do* steal the frame pointer [%ebp].)
- = ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
+ = ["-D_HPUX_SOURCE"]
#elif i386_TARGET_ARCH
-- -fno-defer-pop : basically the same game as for m68k
--
-- -fomit-frame-pointer : *must* in .hc files; because we're stealing
-- the fp (%ebp) for our register maps.
- = let n_regs = stolen_x86_regs _dflags
- in
- (
- [ if opt_Static then "-DDONT_WANT_WIN32_DLL_SUPPORT" else ""
- ],
- [ "-fno-defer-pop",
- "-fomit-frame-pointer",
- -- we want -fno-builtin, because when gcc inlines
- -- built-in functions like memcpy() it tends to
- -- run out of registers, requiring -monly-n-regs
- "-fno-builtin",
- "-DSTOLEN_X86_REGS="++show n_regs ]
- )
-
-#elif ia64_TARGET_ARCH
- = ( [], ["-fomit-frame-pointer", "-G0"] )
-
-#elif x86_64_TARGET_ARCH
- = (
- [],
- ["-fomit-frame-pointer",
- "-fno-asynchronous-unwind-tables",
- -- the unwind tables are unnecessary for HC code,
- -- and get in the way of -split-objs. Another option
- -- would be to throw them away in the mangler, but this
- -- is easier.
- "-fno-builtin"
- -- calling builtins like strlen() using the FFI can
- -- cause gcc to run out of regs, so use the external
- -- version.
- ] )
-
-#elif sparc_TARGET_ARCH
- = ( [], ["-w"] )
- -- For now, to suppress the gcc warning "call-clobbered
- -- register used for global register variable", we simply
- -- disable all warnings altogether using the -w flag. Oh well.
+ = if opt_Static then ["-DDONT_WANT_WIN32_DLL_SUPPORT"] else []
-#elif powerpc_apple_darwin_TARGET
- -- -no-cpp-precomp:
- -- Disable Apple's precompiling preprocessor. It's a great thing
- -- for "normal" programs, but it doesn't support register variable
- -- declarations.
- = ( [], ["-no-cpp-precomp"] )
#else
- = ( [], [] )
+ = []
#endif
picCCOpts :: DynFlags -> [String]
:: DynFlags
-> ModuleName
-> ModLocation
- -> (FilePath,FilePath,FilePath)
+ -> FilePath
mkStubPaths dflags mod location
= let
| otherwise = src_basename
stub_basename = stub_basename0 ++ "_stub"
-
- obj = ml_obj_file location
- osuf = objectSuf dflags
- stub_obj_base = dropTail (length osuf + 1) obj ++ "_stub"
- -- NB. not takeFileName, see #3093
in
- (stub_basename <.> "c",
- stub_basename <.> "h",
- stub_obj_base <.> objectSuf dflags)
+ stub_basename <.> "h"
-- -----------------------------------------------------------------------------
-- findLinkable isn't related to the other stuff in here,
-- Make an object linkable when we know the object file exists, and we know
-- its modification time.
findObjectLinkable :: Module -> FilePath -> ClockTime -> IO Linkable
-findObjectLinkable mod obj_fn obj_time = do
- let stub_fn = (dropExtension obj_fn ++ "_stub") <.> "o"
- stub_exist <- doesFileExist stub_fn
- if stub_exist
- then return (LM obj_time mod [DotO obj_fn, DotO stub_fn])
- else return (LM obj_time mod [DotO obj_fn])
+findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn])
+ -- We used to look for _stub.o files here, but that was a bug (#706)
+ -- Now GHC merges the stub.o into the main .o (#3687)
-- -----------------------------------------------------------------------------
-- Error messages
--- -----------------------------------------------------------------------------\r
---\r
--- (c) The University of Glasgow, 2005\r
---\r
--- This module deals with --make\r
--- -----------------------------------------------------------------------------\r
-\r
-module GhcMake( \r
- depanal, \r
- load, LoadHowMuch(..),\r
-\r
- topSortModuleGraph, \r
-\r
- noModError, cyclicModuleErr\r
- ) where\r
-\r
-#include "HsVersions.h"\r
-\r
-#ifdef GHCI\r
-import qualified Linker ( unload )\r
-#endif\r
-\r
-import DriverPipeline\r
-import DriverPhases\r
-import GhcMonad\r
-import Module\r
-import HscTypes\r
-import ErrUtils\r
-import DynFlags\r
-import HsSyn hiding ((<.>))\r
-import Finder\r
-import HeaderInfo\r
-import TcIface ( typecheckIface )\r
-import TcRnMonad ( initIfaceCheck )\r
-import RdrName ( RdrName )\r
-\r
-import Exception ( evaluate, tryIO )\r
-import Panic\r
-import SysTools\r
-import BasicTypes\r
-import SrcLoc\r
-import Util\r
-import Digraph\r
-import Bag ( listToBag )\r
-import Maybes ( expectJust, mapCatMaybes )\r
-import StringBuffer\r
-import FastString\r
-import Outputable\r
-import UniqFM\r
-\r
-import qualified Data.Map as Map\r
-import qualified FiniteMap as Map( insertListWith)\r
-\r
-import System.Directory ( doesFileExist, getModificationTime )\r
-import System.IO ( fixIO )\r
-import System.IO.Error ( isDoesNotExistError )\r
-import System.Time ( ClockTime )\r
-import System.FilePath\r
-import Control.Monad\r
-import Data.Maybe\r
-import Data.List\r
-import qualified Data.List as List\r
-\r
--- -----------------------------------------------------------------------------\r
--- Loading the program\r
-\r
--- | Perform a dependency analysis starting from the current targets\r
--- and update the session with the new module graph.\r
---\r
--- Dependency analysis entails parsing the @import@ directives and may\r
--- therefore require running certain preprocessors.\r
---\r
--- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.\r
--- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the\r
--- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to\r
--- changes to the 'DynFlags' to take effect you need to call this function\r
--- again.\r
---\r
-depanal :: GhcMonad m =>\r
- [ModuleName] -- ^ excluded modules\r
- -> Bool -- ^ allow duplicate roots\r
- -> m ModuleGraph\r
-depanal excluded_mods allow_dup_roots = do\r
- hsc_env <- getSession\r
- let\r
- dflags = hsc_dflags hsc_env\r
- targets = hsc_targets hsc_env\r
- old_graph = hsc_mod_graph hsc_env\r
- \r
- liftIO $ showPass dflags "Chasing dependencies"\r
- liftIO $ debugTraceMsg dflags 2 (hcat [\r
- text "Chasing modules from: ",\r
- hcat (punctuate comma (map pprTarget targets))])\r
-\r
- mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots\r
- modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }\r
- return mod_graph\r
-\r
--- | Describes which modules of the module graph need to be loaded.\r
-data LoadHowMuch\r
- = LoadAllTargets\r
- -- ^ Load all targets and its dependencies.\r
- | LoadUpTo ModuleName\r
- -- ^ Load only the given module and its dependencies.\r
- | LoadDependenciesOf ModuleName\r
- -- ^ Load only the dependencies of the given module, but not the module\r
- -- itself.\r
-\r
--- | Try to load the program. See 'LoadHowMuch' for the different modes.\r
---\r
--- This function implements the core of GHC's @--make@ mode. It preprocesses,\r
--- compiles and loads the specified modules, avoiding re-compilation wherever\r
--- possible. Depending on the target (see 'DynFlags.hscTarget') compilating\r
--- and loading may result in files being created on disk.\r
---\r
--- Calls the 'reportModuleCompilationResult' callback after each compiling\r
--- each module, whether successful or not.\r
---\r
--- Throw a 'SourceError' if errors are encountered before the actual\r
--- compilation starts (e.g., during dependency analysis). All other errors\r
--- are reported using the callback.\r
---\r
-load :: GhcMonad m => LoadHowMuch -> m SuccessFlag\r
-load how_much = do\r
- mod_graph <- depanal [] False\r
- load2 how_much mod_graph\r
-\r
-load2 :: GhcMonad m => LoadHowMuch -> [ModSummary]\r
- -> m SuccessFlag\r
-load2 how_much mod_graph = do\r
- guessOutputFile\r
- hsc_env <- getSession\r
-\r
- let hpt1 = hsc_HPT hsc_env\r
- let dflags = hsc_dflags hsc_env\r
-\r
- -- The "bad" boot modules are the ones for which we have\r
- -- B.hs-boot in the module graph, but no B.hs\r
- -- The downsweep should have ensured this does not happen\r
- -- (see msDeps)\r
- let all_home_mods = [ms_mod_name s \r
- | s <- mod_graph, not (isBootSummary s)]\r
- bad_boot_mods = [s | s <- mod_graph, isBootSummary s,\r
- not (ms_mod_name s `elem` all_home_mods)]\r
- ASSERT( null bad_boot_mods ) return ()\r
-\r
- -- check that the module given in HowMuch actually exists, otherwise\r
- -- topSortModuleGraph will bomb later.\r
- let checkHowMuch (LoadUpTo m) = checkMod m\r
- checkHowMuch (LoadDependenciesOf m) = checkMod m\r
- checkHowMuch _ = id\r
-\r
- checkMod m and_then\r
- | m `elem` all_home_mods = and_then\r
- | otherwise = do \r
- liftIO $ errorMsg dflags (text "no such module:" <+>\r
- quotes (ppr m))\r
- return Failed\r
-\r
- checkHowMuch how_much $ do\r
-\r
- -- mg2_with_srcimps drops the hi-boot nodes, returning a \r
- -- graph with cycles. Among other things, it is used for\r
- -- backing out partially complete cycles following a failed\r
- -- upsweep, and for removing from hpt all the modules\r
- -- not in strict downwards closure, during calls to compile.\r
- let mg2_with_srcimps :: [SCC ModSummary]\r
- mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing\r
-\r
- -- If we can determine that any of the {-# SOURCE #-} imports\r
- -- are definitely unnecessary, then emit a warning.\r
- warnUnnecessarySourceImports mg2_with_srcimps\r
-\r
- let\r
- -- check the stability property for each module.\r
- stable_mods@(stable_obj,stable_bco)\r
- = checkStability hpt1 mg2_with_srcimps all_home_mods\r
-\r
- -- prune bits of the HPT which are definitely redundant now,\r
- -- to save space.\r
- pruned_hpt = pruneHomePackageTable hpt1 \r
- (flattenSCCs mg2_with_srcimps)\r
- stable_mods\r
-\r
- _ <- liftIO $ evaluate pruned_hpt\r
-\r
- -- before we unload anything, make sure we don't leave an old\r
- -- interactive context around pointing to dead bindings. Also,\r
- -- write the pruned HPT to allow the old HPT to be GC'd.\r
- modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext,\r
- hsc_HPT = pruned_hpt }\r
-\r
- liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$\r
- text "Stable BCO:" <+> ppr stable_bco)\r
-\r
- -- Unload any modules which are going to be re-linked this time around.\r
- let stable_linkables = [ linkable\r
- | m <- stable_obj++stable_bco,\r
- Just hmi <- [lookupUFM pruned_hpt m],\r
- Just linkable <- [hm_linkable hmi] ]\r
- liftIO $ unload hsc_env stable_linkables\r
-\r
- -- We could at this point detect cycles which aren't broken by\r
- -- a source-import, and complain immediately, but it seems better\r
- -- to let upsweep_mods do this, so at least some useful work gets\r
- -- done before the upsweep is abandoned.\r
- --hPutStrLn stderr "after tsort:\n"\r
- --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))\r
-\r
- -- Now do the upsweep, calling compile for each module in\r
- -- turn. Final result is version 3 of everything.\r
-\r
- -- Topologically sort the module graph, this time including hi-boot\r
- -- nodes, and possibly just including the portion of the graph\r
- -- reachable from the module specified in the 2nd argument to load.\r
- -- This graph should be cycle-free.\r
- -- If we're restricting the upsweep to a portion of the graph, we\r
- -- also want to retain everything that is still stable.\r
- let full_mg :: [SCC ModSummary]\r
- full_mg = topSortModuleGraph False mod_graph Nothing\r
-\r
- maybe_top_mod = case how_much of\r
- LoadUpTo m -> Just m\r
- LoadDependenciesOf m -> Just m\r
- _ -> Nothing\r
-\r
- partial_mg0 :: [SCC ModSummary]\r
- partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod\r
-\r
- -- LoadDependenciesOf m: we want the upsweep to stop just\r
- -- short of the specified module (unless the specified module\r
- -- is stable).\r
- partial_mg\r
- | LoadDependenciesOf _mod <- how_much\r
- = ASSERT( case last partial_mg0 of \r
- AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )\r
- List.init partial_mg0\r
- | otherwise\r
- = partial_mg0\r
- \r
- stable_mg = \r
- [ AcyclicSCC ms\r
- | AcyclicSCC ms <- full_mg,\r
- ms_mod_name ms `elem` stable_obj++stable_bco,\r
- ms_mod_name ms `notElem` [ ms_mod_name ms' | \r
- AcyclicSCC ms' <- partial_mg ] ]\r
-\r
- mg = stable_mg ++ partial_mg\r
-\r
- -- clean up between compilations\r
- let cleanup = cleanTempFilesExcept dflags\r
- (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps))\r
-\r
- liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")\r
- 2 (ppr mg))\r
-\r
- setSession hsc_env{ hsc_HPT = emptyHomePackageTable }\r
- (upsweep_ok, modsUpswept)\r
- <- upsweep pruned_hpt stable_mods cleanup mg\r
-\r
- -- Make modsDone be the summaries for each home module now\r
- -- available; this should equal the domain of hpt3.\r
- -- Get in in a roughly top .. bottom order (hence reverse).\r
-\r
- let modsDone = reverse modsUpswept\r
-\r
- -- Try and do linking in some form, depending on whether the\r
- -- upsweep was completely or only partially successful.\r
-\r
- if succeeded upsweep_ok\r
-\r
- then \r
- -- Easy; just relink it all.\r
- do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")\r
-\r
- -- Clean up after ourselves\r
- liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)\r
-\r
- -- Issue a warning for the confusing case where the user\r
- -- said '-o foo' but we're not going to do any linking.\r
- -- We attempt linking if either (a) one of the modules is\r
- -- called Main, or (b) the user said -no-hs-main, indicating\r
- -- that main() is going to come from somewhere else.\r
- --\r
- let ofile = outputFile dflags\r
- let no_hs_main = dopt Opt_NoHsMain dflags\r
- let \r
- main_mod = mainModIs dflags\r
- a_root_is_Main = any ((==main_mod).ms_mod) mod_graph\r
- do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib\r
-\r
- when (ghcLink dflags == LinkBinary \r
- && isJust ofile && not do_linking) $\r
- liftIO $ debugTraceMsg dflags 1 $\r
- text ("Warning: output was redirected with -o, " ++\r
- "but no output will be generated\n" ++\r
- "because there is no " ++ \r
- moduleNameString (moduleName main_mod) ++ " module.")\r
-\r
- -- link everything together\r
- hsc_env1 <- getSession\r
- linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)\r
-\r
- loadFinish Succeeded linkresult\r
-\r
- else \r
- -- Tricky. We need to back out the effects of compiling any\r
- -- half-done cycles, both so as to clean up the top level envs\r
- -- and to avoid telling the interactive linker to link them.\r
- do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")\r
-\r
- let modsDone_names\r
- = map ms_mod modsDone\r
- let mods_to_zap_names \r
- = findPartiallyCompletedCycles modsDone_names \r
- mg2_with_srcimps\r
- let mods_to_keep\r
- = filter ((`notElem` mods_to_zap_names).ms_mod) \r
- modsDone\r
-\r
- hsc_env1 <- getSession\r
- let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) \r
- (hsc_HPT hsc_env1)\r
-\r
- -- Clean up after ourselves\r
- liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep)\r
-\r
- -- there should be no Nothings where linkables should be, now\r
- ASSERT(all (isJust.hm_linkable) \r
- (eltsUFM (hsc_HPT hsc_env))) do\r
- \r
- -- Link everything together\r
- linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4\r
-\r
- modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 }\r
- loadFinish Failed linkresult\r
-\r
--- Finish up after a load.\r
-\r
--- If the link failed, unload everything and return.\r
-loadFinish :: GhcMonad m =>\r
- SuccessFlag -> SuccessFlag\r
- -> m SuccessFlag\r
-loadFinish _all_ok Failed\r
- = do hsc_env <- getSession\r
- liftIO $ unload hsc_env []\r
- modifySession discardProg\r
- return Failed\r
-\r
--- Empty the interactive context and set the module context to the topmost\r
--- newly loaded module, or the Prelude if none were loaded.\r
-loadFinish all_ok Succeeded\r
- = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext }\r
- return all_ok\r
-\r
-\r
--- Forget the current program, but retain the persistent info in HscEnv\r
-discardProg :: HscEnv -> HscEnv\r
-discardProg hsc_env\r
- = hsc_env { hsc_mod_graph = emptyMG, \r
- hsc_IC = emptyInteractiveContext,\r
- hsc_HPT = emptyHomePackageTable }\r
-\r
--- used to fish out the preprocess output files for the purposes of\r
--- cleaning up. The preprocessed file *might* be the same as the\r
--- source file, but that doesn't do any harm.\r
-ppFilesFromSummaries :: [ModSummary] -> [FilePath]\r
-ppFilesFromSummaries summaries = map ms_hspp_file summaries\r
-\r
--- | If there is no -o option, guess the name of target executable\r
--- by using top-level source file name as a base.\r
-guessOutputFile :: GhcMonad m => m ()\r
-guessOutputFile = modifySession $ \env ->\r
- let dflags = hsc_dflags env\r
- mod_graph = hsc_mod_graph env\r
- mainModuleSrcPath :: Maybe String\r
- mainModuleSrcPath = do\r
- let isMain = (== mainModIs dflags) . ms_mod\r
- [ms] <- return (filter isMain mod_graph)\r
- ml_hs_file (ms_location ms)\r
- name = fmap dropExtension mainModuleSrcPath\r
-\r
-#if defined(mingw32_HOST_OS)\r
- -- we must add the .exe extention unconditionally here, otherwise\r
- -- when name has an extension of its own, the .exe extension will\r
- -- not be added by DriverPipeline.exeFileName. See #2248\r
- name_exe = fmap (<.> "exe") name\r
-#else\r
- name_exe = name\r
-#endif\r
- in\r
- case outputFile dflags of\r
- Just _ -> env\r
- Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }\r
-\r
--- -----------------------------------------------------------------------------\r
-\r
--- | Prune the HomePackageTable\r
---\r
--- Before doing an upsweep, we can throw away:\r
---\r
--- - For non-stable modules:\r
--- - all ModDetails, all linked code\r
--- - all unlinked code that is out of date with respect to\r
--- the source file\r
---\r
--- This is VERY IMPORTANT otherwise we'll end up requiring 2x the\r
--- space at the end of the upsweep, because the topmost ModDetails of the\r
--- old HPT holds on to the entire type environment from the previous\r
--- compilation.\r
-\r
-pruneHomePackageTable\r
- :: HomePackageTable\r
- -> [ModSummary]\r
- -> ([ModuleName],[ModuleName])\r
- -> HomePackageTable\r
-\r
-pruneHomePackageTable hpt summ (stable_obj, stable_bco)\r
- = mapUFM prune hpt\r
- where prune hmi\r
- | is_stable modl = hmi'\r
- | otherwise = hmi'{ hm_details = emptyModDetails }\r
- where\r
- modl = moduleName (mi_module (hm_iface hmi))\r
- hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms\r
- = hmi{ hm_linkable = Nothing }\r
- | otherwise\r
- = hmi\r
- where ms = expectJust "prune" (lookupUFM ms_map modl)\r
-\r
- ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]\r
-\r
- is_stable m = m `elem` stable_obj || m `elem` stable_bco\r
-\r
--- -----------------------------------------------------------------------------\r
-\r
--- Return (names of) all those in modsDone who are part of a cycle\r
--- as defined by theGraph.\r
-findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]\r
-findPartiallyCompletedCycles modsDone theGraph\r
- = chew theGraph\r
- where\r
- chew [] = []\r
- chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting.\r
- chew ((CyclicSCC vs):rest)\r
- = let names_in_this_cycle = nub (map ms_mod vs)\r
- mods_in_this_cycle \r
- = nub ([done | done <- modsDone, \r
- done `elem` names_in_this_cycle])\r
- chewed_rest = chew rest\r
- in \r
- if notNull mods_in_this_cycle\r
- && length mods_in_this_cycle < length names_in_this_cycle\r
- then mods_in_this_cycle ++ chewed_rest\r
- else chewed_rest\r
-\r
-\r
--- ---------------------------------------------------------------------------\r
--- Unloading\r
-\r
-unload :: HscEnv -> [Linkable] -> IO ()\r
-unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'\r
- = case ghcLink (hsc_dflags hsc_env) of\r
-#ifdef GHCI\r
- LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables\r
-#else\r
- LinkInMemory -> panic "unload: no interpreter"\r
- -- urgh. avoid warnings:\r
- hsc_env stable_linkables\r
-#endif\r
- _other -> return ()\r
-\r
--- -----------------------------------------------------------------------------\r
-\r
-{- |\r
-\r
- Stability tells us which modules definitely do not need to be recompiled.\r
- There are two main reasons for having stability:\r
- \r
- - avoid doing a complete upsweep of the module graph in GHCi when\r
- modules near the bottom of the tree have not changed.\r
-\r
- - to tell GHCi when it can load object code: we can only load object code\r
- for a module when we also load object code fo all of the imports of the\r
- module. So we need to know that we will definitely not be recompiling\r
- any of these modules, and we can use the object code.\r
-\r
- The stability check is as follows. Both stableObject and\r
- stableBCO are used during the upsweep phase later.\r
-\r
-@\r
- stable m = stableObject m || stableBCO m\r
-\r
- stableObject m = \r
- all stableObject (imports m)\r
- && old linkable does not exist, or is == on-disk .o\r
- && date(on-disk .o) > date(.hs)\r
-\r
- stableBCO m =\r
- all stable (imports m)\r
- && date(BCO) > date(.hs)\r
-@\r
-\r
- These properties embody the following ideas:\r
-\r
- - if a module is stable, then:\r
-\r
- - if it has been compiled in a previous pass (present in HPT)\r
- then it does not need to be compiled or re-linked.\r
-\r
- - if it has not been compiled in a previous pass,\r
- then we only need to read its .hi file from disk and\r
- link it to produce a 'ModDetails'.\r
-\r
- - if a modules is not stable, we will definitely be at least\r
- re-linking, and possibly re-compiling it during the 'upsweep'.\r
- All non-stable modules can (and should) therefore be unlinked\r
- before the 'upsweep'.\r
-\r
- - Note that objects are only considered stable if they only depend\r
- on other objects. We can't link object code against byte code.\r
--}\r
-\r
-checkStability\r
- :: HomePackageTable -- HPT from last compilation\r
- -> [SCC ModSummary] -- current module graph (cyclic)\r
- -> [ModuleName] -- all home modules\r
- -> ([ModuleName], -- stableObject\r
- [ModuleName]) -- stableBCO\r
-\r
-checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs\r
- where\r
- checkSCC (stable_obj, stable_bco) scc0\r
- | stableObjects = (scc_mods ++ stable_obj, stable_bco)\r
- | stableBCOs = (stable_obj, scc_mods ++ stable_bco)\r
- | otherwise = (stable_obj, stable_bco)\r
- where\r
- scc = flattenSCC scc0\r
- scc_mods = map ms_mod_name scc\r
- home_module m = m `elem` all_home_mods && m `notElem` scc_mods\r
-\r
- scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))\r
- -- all imports outside the current SCC, but in the home pkg\r
- \r
- stable_obj_imps = map (`elem` stable_obj) scc_allimps\r
- stable_bco_imps = map (`elem` stable_bco) scc_allimps\r
-\r
- stableObjects = \r
- and stable_obj_imps\r
- && all object_ok scc\r
-\r
- stableBCOs = \r
- and (zipWith (||) stable_obj_imps stable_bco_imps)\r
- && all bco_ok scc\r
-\r
- object_ok ms\r
- | Just t <- ms_obj_date ms = t >= ms_hs_date ms \r
- && same_as_prev t\r
- | otherwise = False\r
- where\r
- same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of\r
- Just hmi | Just l <- hm_linkable hmi\r
- -> isObjectLinkable l && t == linkableTime l\r
- _other -> True\r
- -- why '>=' rather than '>' above? If the filesystem stores\r
- -- times to the nearset second, we may occasionally find that\r
- -- the object & source have the same modification time, \r
- -- especially if the source was automatically generated\r
- -- and compiled. Using >= is slightly unsafe, but it matches\r
- -- make's behaviour.\r
-\r
- bco_ok ms\r
- = case lookupUFM hpt (ms_mod_name ms) of\r
- Just hmi | Just l <- hm_linkable hmi ->\r
- not (isObjectLinkable l) && \r
- linkableTime l >= ms_hs_date ms\r
- _other -> False\r
-\r
--- -----------------------------------------------------------------------------\r
-\r
--- | The upsweep\r
---\r
--- This is where we compile each module in the module graph, in a pass\r
--- from the bottom to the top of the graph.\r
---\r
--- There better had not be any cyclic groups here -- we check for them.\r
-\r
-upsweep\r
- :: GhcMonad m\r
- => HomePackageTable -- ^ HPT from last time round (pruned)\r
- -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)\r
- -> IO () -- ^ How to clean up unwanted tmp files\r
- -> [SCC ModSummary] -- ^ Mods to do (the worklist)\r
- -> m (SuccessFlag,\r
- [ModSummary])\r
- -- ^ Returns:\r
- --\r
- -- 1. A flag whether the complete upsweep was successful.\r
- -- 2. The 'HscEnv' in the monad has an updated HPT\r
- -- 3. A list of modules which succeeded loading.\r
-\r
-upsweep old_hpt stable_mods cleanup sccs = do\r
- (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)\r
- return (res, reverse done)\r
- where\r
-\r
- upsweep' _old_hpt done\r
- [] _ _\r
- = return (Succeeded, done)\r
-\r
- upsweep' _old_hpt done\r
- (CyclicSCC ms:_) _ _\r
- = do dflags <- getSessionDynFlags\r
- liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)\r
- return (Failed, done)\r
-\r
- upsweep' old_hpt done\r
- (AcyclicSCC mod:mods) mod_index nmods\r
- = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ \r
- -- show (map (moduleUserString.moduleName.mi_module.hm_iface) \r
- -- (moduleEnvElts (hsc_HPT hsc_env)))\r
- let logger _mod = defaultWarnErrLogger\r
-\r
- hsc_env <- getSession\r
- mb_mod_info\r
- <- handleSourceError\r
- (\err -> do logger mod (Just err); return Nothing) $ do\r
- mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods\r
- mod mod_index nmods\r
- logger mod Nothing -- log warnings\r
- return (Just mod_info)\r
-\r
- liftIO cleanup -- Remove unwanted tmp files between compilations\r
-\r
- case mb_mod_info of\r
- Nothing -> return (Failed, done)\r
- Just mod_info -> do\r
- let this_mod = ms_mod_name mod\r
-\r
- -- Add new info to hsc_env\r
- hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info\r
- hsc_env1 = hsc_env { hsc_HPT = hpt1 }\r
-\r
- -- Space-saving: delete the old HPT entry\r
- -- for mod BUT if mod is a hs-boot\r
- -- node, don't delete it. For the\r
- -- interface, the HPT entry is probaby for the\r
- -- main Haskell source file. Deleting it\r
- -- would force the real module to be recompiled\r
- -- every time.\r
- old_hpt1 | isBootSummary mod = old_hpt\r
- | otherwise = delFromUFM old_hpt this_mod\r
-\r
- done' = mod:done\r
-\r
- -- fixup our HomePackageTable after we've finished compiling\r
- -- a mutually-recursive loop. See reTypecheckLoop, below.\r
- hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'\r
- setSession hsc_env2\r
-\r
- upsweep' old_hpt1 done' mods (mod_index+1) nmods\r
-\r
--- | Compile a single module. Always produce a Linkable for it if\r
--- successful. If no compilation happened, return the old Linkable.\r
-upsweep_mod :: HscEnv\r
- -> HomePackageTable\r
- -> ([ModuleName],[ModuleName])\r
- -> ModSummary\r
- -> Int -- index of module\r
- -> Int -- total number of modules\r
- -> IO HomeModInfo\r
-\r
-upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods\r
- = let \r
- this_mod_name = ms_mod_name summary\r
- this_mod = ms_mod summary\r
- mb_obj_date = ms_obj_date summary\r
- obj_fn = ml_obj_file (ms_location summary)\r
- hs_date = ms_hs_date summary\r
-\r
- is_stable_obj = this_mod_name `elem` stable_obj\r
- is_stable_bco = this_mod_name `elem` stable_bco\r
-\r
- old_hmi = lookupUFM old_hpt this_mod_name\r
-\r
- -- We're using the dflags for this module now, obtained by\r
- -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.\r
- dflags = ms_hspp_opts summary\r
- prevailing_target = hscTarget (hsc_dflags hsc_env)\r
- local_target = hscTarget dflags\r
-\r
- -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that\r
- -- we don't do anything dodgy: these should only work to change\r
- -- from -fvia-C to -fasm and vice-versa, otherwise we could \r
- -- end up trying to link object code to byte code.\r
- target = if prevailing_target /= local_target\r
- && (not (isObjectTarget prevailing_target)\r
- || not (isObjectTarget local_target))\r
- then prevailing_target\r
- else local_target \r
-\r
- -- store the corrected hscTarget into the summary\r
- summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }\r
-\r
- -- The old interface is ok if\r
- -- a) we're compiling a source file, and the old HPT\r
- -- entry is for a source file\r
- -- b) we're compiling a hs-boot file\r
- -- Case (b) allows an hs-boot file to get the interface of its\r
- -- real source file on the second iteration of the compilation\r
- -- manager, but that does no harm. Otherwise the hs-boot file\r
- -- will always be recompiled\r
- \r
- mb_old_iface \r
- = case old_hmi of\r
- Nothing -> Nothing\r
- Just hm_info | isBootSummary summary -> Just iface\r
- | not (mi_boot iface) -> Just iface\r
- | otherwise -> Nothing\r
- where \r
- iface = hm_iface hm_info\r
-\r
- compile_it :: Maybe Linkable -> IO HomeModInfo\r
- compile_it mb_linkable = \r
- compile hsc_env summary' mod_index nmods \r
- mb_old_iface mb_linkable\r
-\r
- compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo\r
- compile_it_discard_iface mb_linkable =\r
- compile hsc_env summary' mod_index nmods\r
- Nothing mb_linkable\r
-\r
- -- With the HscNothing target we create empty linkables to avoid\r
- -- recompilation. We have to detect these to recompile anyway if\r
- -- the target changed since the last compile.\r
- is_fake_linkable\r
- | Just hmi <- old_hmi, Just l <- hm_linkable hmi =\r
- null (linkableUnlinked l)\r
- | otherwise =\r
- -- we have no linkable, so it cannot be fake\r
- False\r
-\r
- implies False _ = True\r
- implies True x = x\r
-\r
- in\r
- case () of\r
- _\r
- -- Regardless of whether we're generating object code or\r
- -- byte code, we can always use an existing object file\r
- -- if it is *stable* (see checkStability).\r
- | is_stable_obj, Just hmi <- old_hmi -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "skipping stable obj mod:" <+> ppr this_mod_name)\r
- return hmi\r
- -- object is stable, and we have an entry in the\r
- -- old HPT: nothing to do\r
-\r
- | is_stable_obj, isNothing old_hmi -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "compiling stable on-disk mod:" <+> ppr this_mod_name)\r
- linkable <- liftIO $ findObjectLinkable this_mod obj_fn\r
- (expectJust "upsweep1" mb_obj_date)\r
- compile_it (Just linkable)\r
- -- object is stable, but we need to load the interface\r
- -- off disk to make a HMI.\r
-\r
- | not (isObjectTarget target), is_stable_bco,\r
- (target /= HscNothing) `implies` not is_fake_linkable ->\r
- ASSERT(isJust old_hmi) -- must be in the old_hpt\r
- let Just hmi = old_hmi in do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "skipping stable BCO mod:" <+> ppr this_mod_name)\r
- return hmi\r
- -- BCO is stable: nothing to do\r
-\r
- | not (isObjectTarget target),\r
- Just hmi <- old_hmi,\r
- Just l <- hm_linkable hmi,\r
- not (isObjectLinkable l),\r
- (target /= HscNothing) `implies` not is_fake_linkable,\r
- linkableTime l >= ms_hs_date summary -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)\r
- compile_it (Just l)\r
- -- we have an old BCO that is up to date with respect\r
- -- to the source: do a recompilation check as normal.\r
-\r
- -- When generating object code, if there's an up-to-date\r
- -- object file on the disk, then we can use it.\r
- -- However, if the object file is new (compared to any\r
- -- linkable we had from a previous compilation), then we\r
- -- must discard any in-memory interface, because this\r
- -- means the user has compiled the source file\r
- -- separately and generated a new interface, that we must\r
- -- read from the disk.\r
- --\r
- | isObjectTarget target,\r
- Just obj_date <- mb_obj_date,\r
- obj_date >= hs_date -> do\r
- case old_hmi of\r
- Just hmi\r
- | Just l <- hm_linkable hmi,\r
- isObjectLinkable l && linkableTime l == obj_date -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)\r
- compile_it (Just l)\r
- _otherwise -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)\r
- linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date\r
- compile_it_discard_iface (Just linkable)\r
-\r
- _otherwise -> do\r
- liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5\r
- (text "compiling mod:" <+> ppr this_mod_name)\r
- compile_it Nothing\r
-\r
-\r
-\r
--- Filter modules in the HPT\r
-retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable\r
-retainInTopLevelEnvs keep_these hpt\r
- = listToUFM [ (mod, expectJust "retain" mb_mod_info)\r
- | mod <- keep_these\r
- , let mb_mod_info = lookupUFM hpt mod\r
- , isJust mb_mod_info ]\r
-\r
--- ---------------------------------------------------------------------------\r
--- Typecheck module loops\r
-\r
-{-\r
-See bug #930. This code fixes a long-standing bug in --make. The\r
-problem is that when compiling the modules *inside* a loop, a data\r
-type that is only defined at the top of the loop looks opaque; but\r
-after the loop is done, the structure of the data type becomes\r
-apparent.\r
-\r
-The difficulty is then that two different bits of code have\r
-different notions of what the data type looks like.\r
-\r
-The idea is that after we compile a module which also has an .hs-boot\r
-file, we re-generate the ModDetails for each of the modules that\r
-depends on the .hs-boot file, so that everyone points to the proper\r
-TyCons, Ids etc. defined by the real module, not the boot module.\r
-Fortunately re-generating a ModDetails from a ModIface is easy: the\r
-function TcIface.typecheckIface does exactly that.\r
-\r
-Picking the modules to re-typecheck is slightly tricky. Starting from\r
-the module graph consisting of the modules that have already been\r
-compiled, we reverse the edges (so they point from the imported module\r
-to the importing module), and depth-first-search from the .hs-boot\r
-node. This gives us all the modules that depend transitively on the\r
-.hs-boot module, and those are exactly the modules that we need to\r
-re-typecheck.\r
-\r
-Following this fix, GHC can compile itself with --make -O2.\r
--}\r
-\r
-reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv\r
-reTypecheckLoop hsc_env ms graph\r
- | not (isBootSummary ms) && \r
- any (\m -> ms_mod m == this_mod && isBootSummary m) graph\r
- = do\r
- let mss = reachableBackwards (ms_mod_name ms) graph\r
- non_boot = filter (not.isBootSummary) mss\r
- debugTraceMsg (hsc_dflags hsc_env) 2 $\r
- text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)\r
- typecheckLoop hsc_env (map ms_mod_name non_boot)\r
- | otherwise\r
- = return hsc_env\r
- where\r
- this_mod = ms_mod ms\r
-\r
-typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv\r
-typecheckLoop hsc_env mods = do\r
- new_hpt <-\r
- fixIO $ \new_hpt -> do\r
- let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }\r
- mds <- initIfaceCheck new_hsc_env $ \r
- mapM (typecheckIface . hm_iface) hmis\r
- let new_hpt = addListToUFM old_hpt \r
- (zip mods [ hmi{ hm_details = details }\r
- | (hmi,details) <- zip hmis mds ])\r
- return new_hpt\r
- return hsc_env{ hsc_HPT = new_hpt }\r
- where\r
- old_hpt = hsc_HPT hsc_env\r
- hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods\r
-\r
-reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]\r
-reachableBackwards mod summaries\r
- = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]\r
- where -- the rest just sets up the graph:\r
- (graph, lookup_node) = moduleGraphNodes False summaries\r
- root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)\r
-\r
--- ---------------------------------------------------------------------------\r
--- Topological sort of the module graph\r
-\r
-type SummaryNode = (ModSummary, Int, [Int])\r
-\r
-topSortModuleGraph\r
- :: Bool\r
- -- ^ Drop hi-boot nodes? (see below)\r
- -> [ModSummary]\r
- -> Maybe ModuleName\r
- -- ^ Root module name. If @Nothing@, use the full graph.\r
- -> [SCC ModSummary]\r
--- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes\r
--- The resulting list of strongly-connected-components is in topologically\r
--- sorted order, starting with the module(s) at the bottom of the\r
--- dependency graph (ie compile them first) and ending with the ones at\r
--- the top.\r
---\r
--- Drop hi-boot nodes (first boolean arg)? \r
---\r
--- - @False@: treat the hi-boot summaries as nodes of the graph,\r
--- so the graph must be acyclic\r
---\r
--- - @True@: eliminate the hi-boot nodes, and instead pretend\r
--- the a source-import of Foo is an import of Foo\r
--- The resulting graph has no hi-boot nodes, but can be cyclic\r
-\r
-topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod\r
- = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph\r
- where\r
- (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries\r
- \r
- initial_graph = case mb_root_mod of\r
- Nothing -> graph\r
- Just root_mod ->\r
- -- restrict the graph to just those modules reachable from\r
- -- the specified module. We do this by building a graph with\r
- -- the full set of nodes, and determining the reachable set from\r
- -- the specified node.\r
- let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node\r
- | otherwise = ghcError (ProgramError "module does not exist")\r
- in graphFromEdgedVertices (seq root (reachableG graph root))\r
-\r
-summaryNodeKey :: SummaryNode -> Int\r
-summaryNodeKey (_, k, _) = k\r
-\r
-summaryNodeSummary :: SummaryNode -> ModSummary\r
-summaryNodeSummary (s, _, _) = s\r
-\r
-moduleGraphNodes :: Bool -> [ModSummary]\r
- -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)\r
-moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)\r
- where\r
- numbered_summaries = zip summaries [1..]\r
-\r
- lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode\r
- lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map\r
-\r
- lookup_key :: HscSource -> ModuleName -> Maybe Int\r
- lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)\r
-\r
- node_map :: NodeMap SummaryNode\r
- node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node)\r
- | node@(s, _, _) <- nodes ]\r
-\r
- -- We use integers as the keys for the SCC algorithm\r
- nodes :: [SummaryNode]\r
- nodes = [ (s, key, out_keys)\r
- | (s, key) <- numbered_summaries\r
- -- Drop the hi-boot ones if told to do so\r
- , not (isBootSummary s && drop_hs_boot_nodes)\r
- , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++\r
- out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++\r
- (-- see [boot-edges] below\r
- if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile \r
- then [] \r
- else case lookup_key HsBootFile (ms_mod_name s) of\r
- Nothing -> []\r
- Just k -> [k]) ]\r
-\r
- -- [boot-edges] if this is a .hs and there is an equivalent\r
- -- .hs-boot, add a link from the former to the latter. This\r
- -- has the effect of detecting bogus cases where the .hs-boot\r
- -- depends on the .hs, by introducing a cycle. Additionally,\r
- -- it ensures that we will always process the .hs-boot before\r
- -- the .hs, and so the HomePackageTable will always have the\r
- -- most up to date information.\r
-\r
- -- Drop hs-boot nodes by using HsSrcFile as the key\r
- hs_boot_key | drop_hs_boot_nodes = HsSrcFile\r
- | otherwise = HsBootFile\r
-\r
- out_edge_keys :: HscSource -> [ModuleName] -> [Int]\r
- out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms\r
- -- If we want keep_hi_boot_nodes, then we do lookup_key with\r
- -- the IsBootInterface parameter True; else False\r
-\r
-\r
-type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are \r
-type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs\r
-\r
-msKey :: ModSummary -> NodeKey\r
-msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)\r
-\r
-mkNodeMap :: [ModSummary] -> NodeMap ModSummary\r
-mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]\r
- \r
-nodeMapElts :: NodeMap a -> [a]\r
-nodeMapElts = Map.elems\r
-\r
--- | If there are {-# SOURCE #-} imports between strongly connected\r
--- components in the topological sort, then those imports can\r
--- definitely be replaced by ordinary non-SOURCE imports: if SOURCE\r
--- were necessary, then the edge would be part of a cycle.\r
-warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()\r
-warnUnnecessarySourceImports sccs = do\r
- logWarnings (listToBag (concatMap (check.flattenSCC) sccs))\r
- where check ms =\r
- let mods_in_this_cycle = map ms_mod_name ms in\r
- [ warn i | m <- ms, i <- ms_home_srcimps m,\r
- unLoc i `notElem` mods_in_this_cycle ]\r
-\r
- warn :: Located ModuleName -> WarnMsg\r
- warn (L loc mod) = \r
- mkPlainErrMsg loc\r
- (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")\r
- <+> quotes (ppr mod))\r
-\r
------------------------------------------------------------------------------\r
--- Downsweep (dependency analysis)\r
-\r
--- Chase downwards from the specified root set, returning summaries\r
--- for all home modules encountered. Only follow source-import\r
--- links.\r
-\r
--- We pass in the previous collection of summaries, which is used as a\r
--- cache to avoid recalculating a module summary if the source is\r
--- unchanged.\r
---\r
--- The returned list of [ModSummary] nodes has one node for each home-package\r
--- module, plus one for any hs-boot files. The imports of these nodes \r
--- are all there, including the imports of non-home-package modules.\r
-\r
-downsweep :: HscEnv\r
- -> [ModSummary] -- Old summaries\r
- -> [ModuleName] -- Ignore dependencies on these; treat\r
- -- them as if they were package modules\r
- -> Bool -- True <=> allow multiple targets to have \r
- -- the same module name; this is \r
- -- very useful for ghc -M\r
- -> IO [ModSummary]\r
- -- The elts of [ModSummary] all have distinct\r
- -- (Modules, IsBoot) identifiers, unless the Bool is true\r
- -- in which case there can be repeats\r
-downsweep hsc_env old_summaries excl_mods allow_dup_roots\r
- = do\r
- rootSummaries <- mapM getRootSummary roots\r
- let root_map = mkRootMap rootSummaries\r
- checkDuplicates root_map\r
- summs <- loop (concatMap msDeps rootSummaries) root_map\r
- return summs\r
- where\r
- roots = hsc_targets hsc_env\r
-\r
- old_summary_map :: NodeMap ModSummary\r
- old_summary_map = mkNodeMap old_summaries\r
-\r
- getRootSummary :: Target -> IO ModSummary\r
- getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)\r
- = do exists <- liftIO $ doesFileExist file\r
- if exists \r
- then summariseFile hsc_env old_summaries file mb_phase \r
- obj_allowed maybe_buf\r
- else throwOneError $ mkPlainErrMsg noSrcSpan $\r
- text "can't find file:" <+> text file\r
- getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)\r
- = do maybe_summary <- summariseModule hsc_env old_summary_map False \r
- (L rootLoc modl) obj_allowed \r
- maybe_buf excl_mods\r
- case maybe_summary of\r
- Nothing -> packageModErr modl\r
- Just s -> return s\r
-\r
- rootLoc = mkGeneralSrcSpan (fsLit "<command line>")\r
-\r
- -- In a root module, the filename is allowed to diverge from the module\r
- -- name, so we have to check that there aren't multiple root files\r
- -- defining the same module (otherwise the duplicates will be silently\r
- -- ignored, leading to confusing behaviour).\r
- checkDuplicates :: NodeMap [ModSummary] -> IO ()\r
- checkDuplicates root_map \r
- | allow_dup_roots = return ()\r
- | null dup_roots = return ()\r
- | otherwise = liftIO $ multiRootsErr (head dup_roots)\r
- where\r
- dup_roots :: [[ModSummary]] -- Each at least of length 2\r
- dup_roots = filterOut isSingleton (nodeMapElts root_map)\r
-\r
- loop :: [(Located ModuleName,IsBootInterface)]\r
- -- Work list: process these modules\r
- -> NodeMap [ModSummary]\r
- -- Visited set; the range is a list because\r
- -- the roots can have the same module names\r
- -- if allow_dup_roots is True\r
- -> IO [ModSummary]\r
- -- The result includes the worklist, except\r
- -- for those mentioned in the visited set\r
- loop [] done = return (concat (nodeMapElts done))\r
- loop ((wanted_mod, is_boot) : ss) done \r
- | Just summs <- Map.lookup key done\r
- = if isSingleton summs then\r
- loop ss done\r
- else\r
- do { multiRootsErr summs; return [] }\r
- | otherwise\r
- = do mb_s <- summariseModule hsc_env old_summary_map \r
- is_boot wanted_mod True\r
- Nothing excl_mods\r
- case mb_s of\r
- Nothing -> loop ss done\r
- Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done)\r
- where\r
- key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)\r
-\r
--- XXX Does the (++) here need to be flipped?\r
-mkRootMap :: [ModSummary] -> NodeMap [ModSummary]\r
-mkRootMap summaries = Map.insertListWith (flip (++))\r
- [ (msKey s, [s]) | s <- summaries ]\r
- Map.empty\r
-\r
-msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]\r
--- (msDeps s) returns the dependencies of the ModSummary s.\r
--- A wrinkle is that for a {-# SOURCE #-} import we return\r
--- *both* the hs-boot file\r
--- *and* the source file\r
--- as "dependencies". That ensures that the list of all relevant\r
--- modules always contains B.hs if it contains B.hs-boot.\r
--- Remember, this pass isn't doing the topological sort. It's\r
--- just gathering the list of all relevant ModSummaries\r
-msDeps s = \r
- concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ] \r
- ++ [ (m,False) | m <- ms_home_imps s ] \r
-\r
-home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]\r
-home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ]\r
- where isLocal Nothing = True\r
- isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special\r
- isLocal _ = False\r
-\r
-ms_home_allimps :: ModSummary -> [ModuleName]\r
-ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)\r
-\r
-ms_home_srcimps :: ModSummary -> [Located ModuleName]\r
-ms_home_srcimps = home_imps . ms_srcimps\r
-\r
-ms_home_imps :: ModSummary -> [Located ModuleName]\r
-ms_home_imps = home_imps . ms_imps\r
-\r
------------------------------------------------------------------------------\r
--- Summarising modules\r
-\r
--- We have two types of summarisation:\r
---\r
--- * Summarise a file. This is used for the root module(s) passed to\r
--- cmLoadModules. The file is read, and used to determine the root\r
--- module name. The module name may differ from the filename.\r
---\r
--- * Summarise a module. We are given a module name, and must provide\r
--- a summary. The finder is used to locate the file in which the module\r
--- resides.\r
-\r
-summariseFile\r
- :: HscEnv\r
- -> [ModSummary] -- old summaries\r
- -> FilePath -- source file name\r
- -> Maybe Phase -- start phase\r
- -> Bool -- object code allowed?\r
- -> Maybe (StringBuffer,ClockTime)\r
- -> IO ModSummary\r
-\r
-summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf\r
- -- we can use a cached summary if one is available and the\r
- -- source file hasn't changed, But we have to look up the summary\r
- -- by source file, rather than module name as we do in summarise.\r
- | Just old_summary <- findSummaryBySourceFile old_summaries file\r
- = do\r
- let location = ms_location old_summary\r
-\r
- -- return the cached summary if the source didn't change\r
- src_timestamp <- case maybe_buf of\r
- Just (_,t) -> return t\r
- Nothing -> liftIO $ getModificationTime file\r
- -- The file exists; we checked in getRootSummary above.\r
- -- If it gets removed subsequently, then this \r
- -- getModificationTime may fail, but that's the right\r
- -- behaviour.\r
-\r
- if ms_hs_date old_summary == src_timestamp \r
- then do -- update the object-file timestamp\r
- obj_timestamp <-\r
- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) \r
- || obj_allowed -- bug #1205\r
- then liftIO $ getObjTimestamp location False\r
- else return Nothing\r
- return old_summary{ ms_obj_date = obj_timestamp }\r
- else\r
- new_summary\r
-\r
- | otherwise\r
- = new_summary\r
- where\r
- new_summary = do\r
- let dflags = hsc_dflags hsc_env\r
-\r
- (dflags', hspp_fn, buf)\r
- <- preprocessFile hsc_env file mb_phase maybe_buf\r
-\r
- (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file\r
-\r
- -- Make a ModLocation for this file\r
- location <- liftIO $ mkHomeModLocation dflags mod_name file\r
-\r
- -- Tell the Finder cache where it is, so that subsequent calls\r
- -- to findModule will find it, even if it's not on any search path\r
- mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location\r
-\r
- src_timestamp <- case maybe_buf of\r
- Just (_,t) -> return t\r
- Nothing -> liftIO $ getModificationTime file\r
- -- getMofificationTime may fail\r
-\r
- -- when the user asks to load a source file by name, we only\r
- -- use an object file if -fobject-code is on. See #1205.\r
- obj_timestamp <-\r
- if isObjectTarget (hscTarget (hsc_dflags hsc_env)) \r
- || obj_allowed -- bug #1205\r
- then liftIO $ modificationTimeIfExists (ml_obj_file location)\r
- else return Nothing\r
-\r
- return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,\r
- ms_location = location,\r
- ms_hspp_file = hspp_fn,\r
- ms_hspp_opts = dflags',\r
- ms_hspp_buf = Just buf,\r
- ms_srcimps = srcimps, ms_imps = the_imps,\r
- ms_hs_date = src_timestamp,\r
- ms_obj_date = obj_timestamp })\r
-\r
-findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary\r
-findSummaryBySourceFile summaries file\r
- = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],\r
- expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of\r
- [] -> Nothing\r
- (x:_) -> Just x\r
-\r
--- Summarise a module, and pick up source and timestamp.\r
-summariseModule\r
- :: HscEnv\r
- -> NodeMap ModSummary -- Map of old summaries\r
- -> IsBootInterface -- True <=> a {-# SOURCE #-} import\r
- -> Located ModuleName -- Imported module to be summarised\r
- -> Bool -- object code allowed?\r
- -> Maybe (StringBuffer, ClockTime)\r
- -> [ModuleName] -- Modules to exclude\r
- -> IO (Maybe ModSummary) -- Its new summary\r
-\r
-summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) \r
- obj_allowed maybe_buf excl_mods\r
- | wanted_mod `elem` excl_mods\r
- = return Nothing\r
-\r
- | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map\r
- = do -- Find its new timestamp; all the \r
- -- ModSummaries in the old map have valid ml_hs_files\r
- let location = ms_location old_summary\r
- src_fn = expectJust "summariseModule" (ml_hs_file location)\r
-\r
- -- check the modification time on the source file, and\r
- -- return the cached summary if it hasn't changed. If the\r
- -- file has disappeared, we need to call the Finder again.\r
- case maybe_buf of\r
- Just (_,t) -> check_timestamp old_summary location src_fn t\r
- Nothing -> do\r
- m <- tryIO (getModificationTime src_fn)\r
- case m of\r
- Right t -> check_timestamp old_summary location src_fn t\r
- Left e | isDoesNotExistError e -> find_it\r
- | otherwise -> ioError e\r
-\r
- | otherwise = find_it\r
- where\r
- dflags = hsc_dflags hsc_env\r
-\r
- hsc_src = if is_boot then HsBootFile else HsSrcFile\r
-\r
- check_timestamp old_summary location src_fn src_timestamp\r
- | ms_hs_date old_summary == src_timestamp = do\r
- -- update the object-file timestamp\r
- obj_timestamp <- \r
- if isObjectTarget (hscTarget (hsc_dflags hsc_env))\r
- || obj_allowed -- bug #1205\r
- then getObjTimestamp location is_boot\r
- else return Nothing\r
- return (Just old_summary{ ms_obj_date = obj_timestamp })\r
- | otherwise = \r
- -- source changed: re-summarise.\r
- new_summary location (ms_mod old_summary) src_fn src_timestamp\r
-\r
- find_it = do\r
- -- Don't use the Finder's cache this time. If the module was\r
- -- previously a package module, it may have now appeared on the\r
- -- search path, so we want to consider it to be a home module. If\r
- -- the module was previously a home module, it may have moved.\r
- uncacheModule hsc_env wanted_mod\r
- found <- findImportedModule hsc_env wanted_mod Nothing\r
- case found of\r
- Found location mod \r
- | isJust (ml_hs_file location) ->\r
- -- Home package\r
- just_found location mod\r
- | otherwise -> \r
- -- Drop external-pkg\r
- ASSERT(modulePackageId mod /= thisPackage dflags)\r
- return Nothing\r
- \r
- err -> noModError dflags loc wanted_mod err\r
- -- Not found\r
-\r
- just_found location mod = do\r
- -- Adjust location to point to the hs-boot source file, \r
- -- hi file, object file, when is_boot says so\r
- let location' | is_boot = addBootSuffixLocn location\r
- | otherwise = location\r
- src_fn = expectJust "summarise2" (ml_hs_file location')\r
-\r
- -- Check that it exists\r
- -- It might have been deleted since the Finder last found it\r
- maybe_t <- modificationTimeIfExists src_fn\r
- case maybe_t of\r
- Nothing -> noHsFileErr loc src_fn\r
- Just t -> new_summary location' mod src_fn t\r
-\r
-\r
- new_summary location mod src_fn src_timestamp\r
- = do\r
- -- Preprocess the source file and get its imports\r
- -- The dflags' contains the OPTIONS pragmas\r
- (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf\r
- (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn\r
-\r
- when (mod_name /= wanted_mod) $\r
- throwOneError $ mkPlainErrMsg mod_loc $ \r
- text "File name does not match module name:" \r
- $$ text "Saw:" <+> quotes (ppr mod_name)\r
- $$ text "Expected:" <+> quotes (ppr wanted_mod)\r
-\r
- -- Find the object timestamp, and return the summary\r
- obj_timestamp <-\r
- if isObjectTarget (hscTarget (hsc_dflags hsc_env))\r
- || obj_allowed -- bug #1205\r
- then getObjTimestamp location is_boot\r
- else return Nothing\r
-\r
- return (Just (ModSummary { ms_mod = mod,\r
- ms_hsc_src = hsc_src,\r
- ms_location = location,\r
- ms_hspp_file = hspp_fn,\r
- ms_hspp_opts = dflags',\r
- ms_hspp_buf = Just buf,\r
- ms_srcimps = srcimps,\r
- ms_imps = the_imps,\r
- ms_hs_date = src_timestamp,\r
- ms_obj_date = obj_timestamp }))\r
-\r
-\r
-getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime)\r
-getObjTimestamp location is_boot\r
- = if is_boot then return Nothing\r
- else modificationTimeIfExists (ml_obj_file location)\r
-\r
-\r
-preprocessFile :: HscEnv\r
- -> FilePath\r
- -> Maybe Phase -- ^ Starting phase\r
- -> Maybe (StringBuffer,ClockTime)\r
- -> IO (DynFlags, FilePath, StringBuffer)\r
-preprocessFile hsc_env src_fn mb_phase Nothing\r
- = do\r
- (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)\r
- buf <- hGetStringBuffer hspp_fn\r
- return (dflags', hspp_fn, buf)\r
-\r
-preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))\r
- = do\r
- let dflags = hsc_dflags hsc_env\r
- -- case we bypass the preprocessing stage?\r
- let \r
- local_opts = getOptions dflags buf src_fn\r
- --\r
- (dflags', leftovers, warns)\r
- <- parseDynamicNoPackageFlags dflags local_opts\r
- checkProcessArgsResult leftovers\r
- handleFlagWarnings dflags' warns\r
-\r
- let\r
- needs_preprocessing\r
- | Just (Unlit _) <- mb_phase = True\r
- | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True\r
- -- note: local_opts is only required if there's no Unlit phase\r
- | xopt Opt_Cpp dflags' = True\r
- | dopt Opt_Pp dflags' = True\r
- | otherwise = False\r
-\r
- when needs_preprocessing $\r
- ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")\r
-\r
- return (dflags', src_fn, buf)\r
-\r
-\r
------------------------------------------------------------------------------\r
--- Error messages\r
------------------------------------------------------------------------------\r
-\r
-noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab\r
--- ToDo: we don't have a proper line number for this error\r
-noModError dflags loc wanted_mod err\r
- = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err\r
- \r
-noHsFileErr :: SrcSpan -> String -> IO a\r
-noHsFileErr loc path\r
- = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path\r
- \r
-packageModErr :: ModuleName -> IO a\r
-packageModErr mod\r
- = throwOneError $ mkPlainErrMsg noSrcSpan $\r
- text "module" <+> quotes (ppr mod) <+> text "is a package module"\r
-\r
-multiRootsErr :: [ModSummary] -> IO ()\r
-multiRootsErr [] = panic "multiRootsErr"\r
-multiRootsErr summs@(summ1:_)\r
- = throwOneError $ mkPlainErrMsg noSrcSpan $\r
- text "module" <+> quotes (ppr mod) <+> \r
- text "is defined in multiple files:" <+>\r
- sep (map text files)\r
- where\r
- mod = ms_mod summ1\r
- files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs\r
-\r
-cyclicModuleErr :: [ModSummary] -> SDoc\r
-cyclicModuleErr ms\r
- = hang (ptext (sLit "Module imports form a cycle for modules:"))\r
- 2 (vcat (map show_one ms))\r
- where\r
- mods_in_cycle = map ms_mod_name ms\r
- imp_modname = unLoc . ideclName . unLoc\r
- just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname)\r
-\r
- show_one ms = \r
- vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+>\r
- maybe empty (parens . text) (ml_hs_file (ms_location ms)),\r
- nest 2 $ ptext (sLit "imports:") <+> vcat [\r
- pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms),\r
- pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ]\r
- ]\r
- show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)\r
- pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps)\r
+-- -----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2011
+--
+-- This module implements multi-module compilation, and is used
+-- by --make and GHCi.
+--
+-- -----------------------------------------------------------------------------
+
+module GhcMake(
+ depanal,
+ load, LoadHowMuch(..),
+
+ topSortModuleGraph,
+
+ noModError, cyclicModuleErr
+ ) where
+
+#include "HsVersions.h"
+
+#ifdef GHCI
+import qualified Linker ( unload )
+#endif
+
+import DriverPipeline
+import DriverPhases
+import GhcMonad
+import Module
+import HscTypes
+import ErrUtils
+import DynFlags
+import HsSyn hiding ((<.>))
+import Finder
+import HeaderInfo
+import TcIface ( typecheckIface )
+import TcRnMonad ( initIfaceCheck )
+import RdrName ( RdrName )
+
+import Exception ( evaluate, tryIO )
+import Panic
+import SysTools
+import BasicTypes
+import SrcLoc
+import Util
+import Digraph
+import Bag ( listToBag )
+import Maybes ( expectJust, mapCatMaybes )
+import StringBuffer
+import FastString
+import Outputable
+import UniqFM
+
+import qualified Data.Map as Map
+import qualified FiniteMap as Map( insertListWith)
+
+import System.Directory ( doesFileExist, getModificationTime )
+import System.IO ( fixIO )
+import System.IO.Error ( isDoesNotExistError )
+import System.Time ( ClockTime )
+import System.FilePath
+import Control.Monad
+import Data.Maybe
+import Data.List
+import qualified Data.List as List
+
+-- -----------------------------------------------------------------------------
+-- Loading the program
+
+-- | Perform a dependency analysis starting from the current targets
+-- and update the session with the new module graph.
+--
+-- Dependency analysis entails parsing the @import@ directives and may
+-- therefore require running certain preprocessors.
+--
+-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'.
+-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the
+-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to
+-- changes to the 'DynFlags' to take effect you need to call this function
+-- again.
+--
+depanal :: GhcMonad m =>
+ [ModuleName] -- ^ excluded modules
+ -> Bool -- ^ allow duplicate roots
+ -> m ModuleGraph
+depanal excluded_mods allow_dup_roots = do
+ hsc_env <- getSession
+ let
+ dflags = hsc_dflags hsc_env
+ targets = hsc_targets hsc_env
+ old_graph = hsc_mod_graph hsc_env
+
+ liftIO $ showPass dflags "Chasing dependencies"
+ liftIO $ debugTraceMsg dflags 2 (hcat [
+ text "Chasing modules from: ",
+ hcat (punctuate comma (map pprTarget targets))])
+
+ mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots
+ modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph }
+ return mod_graph
+
+-- | Describes which modules of the module graph need to be loaded.
+data LoadHowMuch
+ = LoadAllTargets
+ -- ^ Load all targets and its dependencies.
+ | LoadUpTo ModuleName
+ -- ^ Load only the given module and its dependencies.
+ | LoadDependenciesOf ModuleName
+ -- ^ Load only the dependencies of the given module, but not the module
+ -- itself.
+
+-- | Try to load the program. See 'LoadHowMuch' for the different modes.
+--
+-- This function implements the core of GHC's @--make@ mode. It preprocesses,
+-- compiles and loads the specified modules, avoiding re-compilation wherever
+-- possible. Depending on the target (see 'DynFlags.hscTarget') compilating
+-- and loading may result in files being created on disk.
+--
+-- Calls the 'reportModuleCompilationResult' callback after each compiling
+-- each module, whether successful or not.
+--
+-- Throw a 'SourceError' if errors are encountered before the actual
+-- compilation starts (e.g., during dependency analysis). All other errors
+-- are reported using the callback.
+--
+load :: GhcMonad m => LoadHowMuch -> m SuccessFlag
+load how_much = do
+ mod_graph <- depanal [] False
+ load2 how_much mod_graph
+
+load2 :: GhcMonad m => LoadHowMuch -> [ModSummary]
+ -> m SuccessFlag
+load2 how_much mod_graph = do
+ guessOutputFile
+ hsc_env <- getSession
+
+ let hpt1 = hsc_HPT hsc_env
+ let dflags = hsc_dflags hsc_env
+
+ -- The "bad" boot modules are the ones for which we have
+ -- B.hs-boot in the module graph, but no B.hs
+ -- The downsweep should have ensured this does not happen
+ -- (see msDeps)
+ let all_home_mods = [ms_mod_name s
+ | s <- mod_graph, not (isBootSummary s)]
+ bad_boot_mods = [s | s <- mod_graph, isBootSummary s,
+ not (ms_mod_name s `elem` all_home_mods)]
+ ASSERT( null bad_boot_mods ) return ()
+
+ -- check that the module given in HowMuch actually exists, otherwise
+ -- topSortModuleGraph will bomb later.
+ let checkHowMuch (LoadUpTo m) = checkMod m
+ checkHowMuch (LoadDependenciesOf m) = checkMod m
+ checkHowMuch _ = id
+
+ checkMod m and_then
+ | m `elem` all_home_mods = and_then
+ | otherwise = do
+ liftIO $ errorMsg dflags (text "no such module:" <+>
+ quotes (ppr m))
+ return Failed
+
+ checkHowMuch how_much $ do
+
+ -- mg2_with_srcimps drops the hi-boot nodes, returning a
+ -- graph with cycles. Among other things, it is used for
+ -- backing out partially complete cycles following a failed
+ -- upsweep, and for removing from hpt all the modules
+ -- not in strict downwards closure, during calls to compile.
+ let mg2_with_srcimps :: [SCC ModSummary]
+ mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
+
+ -- If we can determine that any of the {-# SOURCE #-} imports
+ -- are definitely unnecessary, then emit a warning.
+ warnUnnecessarySourceImports mg2_with_srcimps
+
+ let
+ -- check the stability property for each module.
+ stable_mods@(stable_obj,stable_bco)
+ = checkStability hpt1 mg2_with_srcimps all_home_mods
+
+ -- prune bits of the HPT which are definitely redundant now,
+ -- to save space.
+ pruned_hpt = pruneHomePackageTable hpt1
+ (flattenSCCs mg2_with_srcimps)
+ stable_mods
+
+ _ <- liftIO $ evaluate pruned_hpt
+
+ -- before we unload anything, make sure we don't leave an old
+ -- interactive context around pointing to dead bindings. Also,
+ -- write the pruned HPT to allow the old HPT to be GC'd.
+ modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext,
+ hsc_HPT = pruned_hpt }
+
+ liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
+ text "Stable BCO:" <+> ppr stable_bco)
+
+ -- Unload any modules which are going to be re-linked this time around.
+ let stable_linkables = [ linkable
+ | m <- stable_obj++stable_bco,
+ Just hmi <- [lookupUFM pruned_hpt m],
+ Just linkable <- [hm_linkable hmi] ]
+ liftIO $ unload hsc_env stable_linkables
+
+ -- We could at this point detect cycles which aren't broken by
+ -- a source-import, and complain immediately, but it seems better
+ -- to let upsweep_mods do this, so at least some useful work gets
+ -- done before the upsweep is abandoned.
+ --hPutStrLn stderr "after tsort:\n"
+ --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
+
+ -- Now do the upsweep, calling compile for each module in
+ -- turn. Final result is version 3 of everything.
+
+ -- Topologically sort the module graph, this time including hi-boot
+ -- nodes, and possibly just including the portion of the graph
+ -- reachable from the module specified in the 2nd argument to load.
+ -- This graph should be cycle-free.
+ -- If we're restricting the upsweep to a portion of the graph, we
+ -- also want to retain everything that is still stable.
+ let full_mg :: [SCC ModSummary]
+ full_mg = topSortModuleGraph False mod_graph Nothing
+
+ maybe_top_mod = case how_much of
+ LoadUpTo m -> Just m
+ LoadDependenciesOf m -> Just m
+ _ -> Nothing
+
+ partial_mg0 :: [SCC ModSummary]
+ partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
+
+ -- LoadDependenciesOf m: we want the upsweep to stop just
+ -- short of the specified module (unless the specified module
+ -- is stable).
+ partial_mg
+ | LoadDependenciesOf _mod <- how_much
+ = ASSERT( case last partial_mg0 of
+ AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False )
+ List.init partial_mg0
+ | otherwise
+ = partial_mg0
+
+ stable_mg =
+ [ AcyclicSCC ms
+ | AcyclicSCC ms <- full_mg,
+ ms_mod_name ms `elem` stable_obj++stable_bco,
+ ms_mod_name ms `notElem` [ ms_mod_name ms' |
+ AcyclicSCC ms' <- partial_mg ] ]
+
+ mg = stable_mg ++ partial_mg
+
+ -- clean up between compilations
+ let cleanup hsc_env = intermediateCleanTempFiles dflags
+ (flattenSCCs mg2_with_srcimps)
+ hsc_env
+
+ liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep")
+ 2 (ppr mg))
+
+ setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
+ (upsweep_ok, modsUpswept)
+ <- upsweep pruned_hpt stable_mods cleanup mg
+
+ -- Make modsDone be the summaries for each home module now
+ -- available; this should equal the domain of hpt3.
+ -- Get in in a roughly top .. bottom order (hence reverse).
+
+ let modsDone = reverse modsUpswept
+
+ -- Try and do linking in some form, depending on whether the
+ -- upsweep was completely or only partially successful.
+
+ if succeeded upsweep_ok
+
+ then
+ -- Easy; just relink it all.
+ do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.")
+
+ -- Clean up after ourselves
+ hsc_env1 <- getSession
+ liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1
+
+ -- Issue a warning for the confusing case where the user
+ -- said '-o foo' but we're not going to do any linking.
+ -- We attempt linking if either (a) one of the modules is
+ -- called Main, or (b) the user said -no-hs-main, indicating
+ -- that main() is going to come from somewhere else.
+ --
+ let ofile = outputFile dflags
+ let no_hs_main = dopt Opt_NoHsMain dflags
+ let
+ main_mod = mainModIs dflags
+ a_root_is_Main = any ((==main_mod).ms_mod) mod_graph
+ do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib
+
+ when (ghcLink dflags == LinkBinary
+ && isJust ofile && not do_linking) $
+ liftIO $ debugTraceMsg dflags 1 $
+ text ("Warning: output was redirected with -o, " ++
+ "but no output will be generated\n" ++
+ "because there is no " ++
+ moduleNameString (moduleName main_mod) ++ " module.")
+
+ -- link everything together
+ linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1)
+
+ loadFinish Succeeded linkresult
+
+ else
+ -- Tricky. We need to back out the effects of compiling any
+ -- half-done cycles, both so as to clean up the top level envs
+ -- and to avoid telling the interactive linker to link them.
+ do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.")
+
+ let modsDone_names
+ = map ms_mod modsDone
+ let mods_to_zap_names
+ = findPartiallyCompletedCycles modsDone_names
+ mg2_with_srcimps
+ let mods_to_keep
+ = filter ((`notElem` mods_to_zap_names).ms_mod)
+ modsDone
+
+ hsc_env1 <- getSession
+ let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
+ (hsc_HPT hsc_env1)
+
+ -- Clean up after ourselves
+ liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1
+
+ -- there should be no Nothings where linkables should be, now
+ ASSERT(all (isJust.hm_linkable)
+ (eltsUFM (hsc_HPT hsc_env))) do
+
+ -- Link everything together
+ linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4
+
+ modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 }
+ loadFinish Failed linkresult
+
+-- Finish up after a load.
+
+-- If the link failed, unload everything and return.
+loadFinish :: GhcMonad m =>
+ SuccessFlag -> SuccessFlag
+ -> m SuccessFlag
+loadFinish _all_ok Failed
+ = do hsc_env <- getSession
+ liftIO $ unload hsc_env []
+ modifySession discardProg
+ return Failed
+
+-- Empty the interactive context and set the module context to the topmost
+-- newly loaded module, or the Prelude if none were loaded.
+loadFinish all_ok Succeeded
+ = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext }
+ return all_ok
+
+
+-- Forget the current program, but retain the persistent info in HscEnv
+discardProg :: HscEnv -> HscEnv
+discardProg hsc_env
+ = hsc_env { hsc_mod_graph = emptyMG,
+ hsc_IC = emptyInteractiveContext,
+ hsc_HPT = emptyHomePackageTable }
+
+intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO ()
+intermediateCleanTempFiles dflags summaries hsc_env
+ = cleanTempFilesExcept dflags except
+ where
+ except =
+ -- Save preprocessed files. The preprocessed file *might* be
+ -- the same as the source file, but that doesn't do any
+ -- harm.
+ map ms_hspp_file summaries ++
+ -- Save object files for loaded modules. The point of this
+ -- is that we might have generated and compiled a stub C
+ -- file, and in the case of GHCi the object file will be a
+ -- temporary file which we must not remove because we need
+ -- to load/link it later.
+ hptObjs (hsc_HPT hsc_env)
+
+-- | If there is no -o option, guess the name of target executable
+-- by using top-level source file name as a base.
+guessOutputFile :: GhcMonad m => m ()
+guessOutputFile = modifySession $ \env ->
+ let dflags = hsc_dflags env
+ mod_graph = hsc_mod_graph env
+ mainModuleSrcPath :: Maybe String
+ mainModuleSrcPath = do
+ let isMain = (== mainModIs dflags) . ms_mod
+ [ms] <- return (filter isMain mod_graph)
+ ml_hs_file (ms_location ms)
+ name = fmap dropExtension mainModuleSrcPath
+
+#if defined(mingw32_HOST_OS)
+ -- we must add the .exe extention unconditionally here, otherwise
+ -- when name has an extension of its own, the .exe extension will
+ -- not be added by DriverPipeline.exeFileName. See #2248
+ name_exe = fmap (<.> "exe") name
+#else
+ name_exe = name
+#endif
+ in
+ case outputFile dflags of
+ Just _ -> env
+ Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } }
+
+-- -----------------------------------------------------------------------------
+
+-- | Prune the HomePackageTable
+--
+-- Before doing an upsweep, we can throw away:
+--
+-- - For non-stable modules:
+-- - all ModDetails, all linked code
+-- - all unlinked code that is out of date with respect to
+-- the source file
+--
+-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the
+-- space at the end of the upsweep, because the topmost ModDetails of the
+-- old HPT holds on to the entire type environment from the previous
+-- compilation.
+
+pruneHomePackageTable
+ :: HomePackageTable
+ -> [ModSummary]
+ -> ([ModuleName],[ModuleName])
+ -> HomePackageTable
+
+pruneHomePackageTable hpt summ (stable_obj, stable_bco)
+ = mapUFM prune hpt
+ where prune hmi
+ | is_stable modl = hmi'
+ | otherwise = hmi'{ hm_details = emptyModDetails }
+ where
+ modl = moduleName (mi_module (hm_iface hmi))
+ hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms
+ = hmi{ hm_linkable = Nothing }
+ | otherwise
+ = hmi
+ where ms = expectJust "prune" (lookupUFM ms_map modl)
+
+ ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
+
+ is_stable m = m `elem` stable_obj || m `elem` stable_bco
+
+-- -----------------------------------------------------------------------------
+
+-- Return (names of) all those in modsDone who are part of a cycle
+-- as defined by theGraph.
+findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module]
+findPartiallyCompletedCycles modsDone theGraph
+ = chew theGraph
+ where
+ chew [] = []
+ chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting.
+ chew ((CyclicSCC vs):rest)
+ = let names_in_this_cycle = nub (map ms_mod vs)
+ mods_in_this_cycle
+ = nub ([done | done <- modsDone,
+ done `elem` names_in_this_cycle])
+ chewed_rest = chew rest
+ in
+ if notNull mods_in_this_cycle
+ && length mods_in_this_cycle < length names_in_this_cycle
+ then mods_in_this_cycle ++ chewed_rest
+ else chewed_rest
+
+
+-- ---------------------------------------------------------------------------
+-- Unloading
+
+unload :: HscEnv -> [Linkable] -> IO ()
+unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
+ = case ghcLink (hsc_dflags hsc_env) of
+#ifdef GHCI
+ LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables
+#else
+ LinkInMemory -> panic "unload: no interpreter"
+ -- urgh. avoid warnings:
+ hsc_env stable_linkables
+#endif
+ _other -> return ()
+
+-- -----------------------------------------------------------------------------
+
+{- |
+
+ Stability tells us which modules definitely do not need to be recompiled.
+ There are two main reasons for having stability:
+
+ - avoid doing a complete upsweep of the module graph in GHCi when
+ modules near the bottom of the tree have not changed.
+
+ - to tell GHCi when it can load object code: we can only load object code
+ for a module when we also load object code fo all of the imports of the
+ module. So we need to know that we will definitely not be recompiling
+ any of these modules, and we can use the object code.
+
+ The stability check is as follows. Both stableObject and
+ stableBCO are used during the upsweep phase later.
+
+@
+ stable m = stableObject m || stableBCO m
+
+ stableObject m =
+ all stableObject (imports m)
+ && old linkable does not exist, or is == on-disk .o
+ && date(on-disk .o) > date(.hs)
+
+ stableBCO m =
+ all stable (imports m)
+ && date(BCO) > date(.hs)
+@
+
+ These properties embody the following ideas:
+
+ - if a module is stable, then:
+
+ - if it has been compiled in a previous pass (present in HPT)
+ then it does not need to be compiled or re-linked.
+
+ - if it has not been compiled in a previous pass,
+ then we only need to read its .hi file from disk and
+ link it to produce a 'ModDetails'.
+
+ - if a modules is not stable, we will definitely be at least
+ re-linking, and possibly re-compiling it during the 'upsweep'.
+ All non-stable modules can (and should) therefore be unlinked
+ before the 'upsweep'.
+
+ - Note that objects are only considered stable if they only depend
+ on other objects. We can't link object code against byte code.
+-}
+
+checkStability
+ :: HomePackageTable -- HPT from last compilation
+ -> [SCC ModSummary] -- current module graph (cyclic)
+ -> [ModuleName] -- all home modules
+ -> ([ModuleName], -- stableObject
+ [ModuleName]) -- stableBCO
+
+checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs
+ where
+ checkSCC (stable_obj, stable_bco) scc0
+ | stableObjects = (scc_mods ++ stable_obj, stable_bco)
+ | stableBCOs = (stable_obj, scc_mods ++ stable_bco)
+ | otherwise = (stable_obj, stable_bco)
+ where
+ scc = flattenSCC scc0
+ scc_mods = map ms_mod_name scc
+ home_module m = m `elem` all_home_mods && m `notElem` scc_mods
+
+ scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc))
+ -- all imports outside the current SCC, but in the home pkg
+
+ stable_obj_imps = map (`elem` stable_obj) scc_allimps
+ stable_bco_imps = map (`elem` stable_bco) scc_allimps
+
+ stableObjects =
+ and stable_obj_imps
+ && all object_ok scc
+
+ stableBCOs =
+ and (zipWith (||) stable_obj_imps stable_bco_imps)
+ && all bco_ok scc
+
+ object_ok ms
+ | Just t <- ms_obj_date ms = t >= ms_hs_date ms
+ && same_as_prev t
+ | otherwise = False
+ where
+ same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
+ Just hmi | Just l <- hm_linkable hmi
+ -> isObjectLinkable l && t == linkableTime l
+ _other -> True
+ -- why '>=' rather than '>' above? If the filesystem stores
+ -- times to the nearset second, we may occasionally find that
+ -- the object & source have the same modification time,
+ -- especially if the source was automatically generated
+ -- and compiled. Using >= is slightly unsafe, but it matches
+ -- make's behaviour.
+
+ bco_ok ms
+ = case lookupUFM hpt (ms_mod_name ms) of
+ Just hmi | Just l <- hm_linkable hmi ->
+ not (isObjectLinkable l) &&
+ linkableTime l >= ms_hs_date ms
+ _other -> False
+
+-- -----------------------------------------------------------------------------
+
+-- | The upsweep
+--
+-- This is where we compile each module in the module graph, in a pass
+-- from the bottom to the top of the graph.
+--
+-- There better had not be any cyclic groups here -- we check for them.
+
+upsweep
+ :: GhcMonad m
+ => HomePackageTable -- ^ HPT from last time round (pruned)
+ -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability)
+ -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files
+ -> [SCC ModSummary] -- ^ Mods to do (the worklist)
+ -> m (SuccessFlag,
+ [ModSummary])
+ -- ^ Returns:
+ --
+ -- 1. A flag whether the complete upsweep was successful.
+ -- 2. The 'HscEnv' in the monad has an updated HPT
+ -- 3. A list of modules which succeeded loading.
+
+upsweep old_hpt stable_mods cleanup sccs = do
+ (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)
+ return (res, reverse done)
+ where
+
+ upsweep' _old_hpt done
+ [] _ _
+ = return (Succeeded, done)
+
+ upsweep' _old_hpt done
+ (CyclicSCC ms:_) _ _
+ = do dflags <- getSessionDynFlags
+ liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
+ return (Failed, done)
+
+ upsweep' old_hpt done
+ (AcyclicSCC mod:mods) mod_index nmods
+ = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
+ -- show (map (moduleUserString.moduleName.mi_module.hm_iface)
+ -- (moduleEnvElts (hsc_HPT hsc_env)))
+ let logger _mod = defaultWarnErrLogger
+
+ hsc_env <- getSession
+
+ -- Remove unwanted tmp files between compilations
+ liftIO (cleanup hsc_env)
+
+ mb_mod_info
+ <- handleSourceError
+ (\err -> do logger mod (Just err); return Nothing) $ do
+ mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods
+ mod mod_index nmods
+ logger mod Nothing -- log warnings
+ return (Just mod_info)
+
+ case mb_mod_info of
+ Nothing -> return (Failed, done)
+ Just mod_info -> do
+ let this_mod = ms_mod_name mod
+
+ -- Add new info to hsc_env
+ hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info
+ hsc_env1 = hsc_env { hsc_HPT = hpt1 }
+
+ -- Space-saving: delete the old HPT entry
+ -- for mod BUT if mod is a hs-boot
+ -- node, don't delete it. For the
+ -- interface, the HPT entry is probaby for the
+ -- main Haskell source file. Deleting it
+ -- would force the real module to be recompiled
+ -- every time.
+ old_hpt1 | isBootSummary mod = old_hpt
+ | otherwise = delFromUFM old_hpt this_mod
+
+ done' = mod:done
+
+ -- fixup our HomePackageTable after we've finished compiling
+ -- a mutually-recursive loop. See reTypecheckLoop, below.
+ hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'
+ setSession hsc_env2
+
+ upsweep' old_hpt1 done' mods (mod_index+1) nmods
+
+-- | Compile a single module. Always produce a Linkable for it if
+-- successful. If no compilation happened, return the old Linkable.
+upsweep_mod :: HscEnv
+ -> HomePackageTable
+ -> ([ModuleName],[ModuleName])
+ -> ModSummary
+ -> Int -- index of module
+ -> Int -- total number of modules
+ -> IO HomeModInfo
+
+upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
+ = let
+ this_mod_name = ms_mod_name summary
+ this_mod = ms_mod summary
+ mb_obj_date = ms_obj_date summary
+ obj_fn = ml_obj_file (ms_location summary)
+ hs_date = ms_hs_date summary
+
+ is_stable_obj = this_mod_name `elem` stable_obj
+ is_stable_bco = this_mod_name `elem` stable_bco
+
+ old_hmi = lookupUFM old_hpt this_mod_name
+
+ -- We're using the dflags for this module now, obtained by
+ -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas.
+ dflags = ms_hspp_opts summary
+ prevailing_target = hscTarget (hsc_dflags hsc_env)
+ local_target = hscTarget dflags
+
+ -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that
+ -- we don't do anything dodgy: these should only work to change
+ -- from -fvia-C to -fasm and vice-versa, otherwise we could
+ -- end up trying to link object code to byte code.
+ target = if prevailing_target /= local_target
+ && (not (isObjectTarget prevailing_target)
+ || not (isObjectTarget local_target))
+ then prevailing_target
+ else local_target
+
+ -- store the corrected hscTarget into the summary
+ summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } }
+
+ -- The old interface is ok if
+ -- a) we're compiling a source file, and the old HPT
+ -- entry is for a source file
+ -- b) we're compiling a hs-boot file
+ -- Case (b) allows an hs-boot file to get the interface of its
+ -- real source file on the second iteration of the compilation
+ -- manager, but that does no harm. Otherwise the hs-boot file
+ -- will always be recompiled
+
+ mb_old_iface
+ = case old_hmi of
+ Nothing -> Nothing
+ Just hm_info | isBootSummary summary -> Just iface
+ | not (mi_boot iface) -> Just iface
+ | otherwise -> Nothing
+ where
+ iface = hm_iface hm_info
+
+ compile_it :: Maybe Linkable -> IO HomeModInfo
+ compile_it mb_linkable =
+ compile hsc_env summary' mod_index nmods
+ mb_old_iface mb_linkable
+
+ compile_it_discard_iface :: Maybe Linkable -> IO HomeModInfo
+ compile_it_discard_iface mb_linkable =
+ compile hsc_env summary' mod_index nmods
+ Nothing mb_linkable
+
+ -- With the HscNothing target we create empty linkables to avoid
+ -- recompilation. We have to detect these to recompile anyway if
+ -- the target changed since the last compile.
+ is_fake_linkable
+ | Just hmi <- old_hmi, Just l <- hm_linkable hmi =
+ null (linkableUnlinked l)
+ | otherwise =
+ -- we have no linkable, so it cannot be fake
+ False
+
+ implies False _ = True
+ implies True x = x
+
+ in
+ case () of
+ _
+ -- Regardless of whether we're generating object code or
+ -- byte code, we can always use an existing object file
+ -- if it is *stable* (see checkStability).
+ | is_stable_obj, Just hmi <- old_hmi -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "skipping stable obj mod:" <+> ppr this_mod_name)
+ return hmi
+ -- object is stable, and we have an entry in the
+ -- old HPT: nothing to do
+
+ | is_stable_obj, isNothing old_hmi -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling stable on-disk mod:" <+> ppr this_mod_name)
+ linkable <- liftIO $ findObjectLinkable this_mod obj_fn
+ (expectJust "upsweep1" mb_obj_date)
+ compile_it (Just linkable)
+ -- object is stable, but we need to load the interface
+ -- off disk to make a HMI.
+
+ | not (isObjectTarget target), is_stable_bco,
+ (target /= HscNothing) `implies` not is_fake_linkable ->
+ ASSERT(isJust old_hmi) -- must be in the old_hpt
+ let Just hmi = old_hmi in do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "skipping stable BCO mod:" <+> ppr this_mod_name)
+ return hmi
+ -- BCO is stable: nothing to do
+
+ | not (isObjectTarget target),
+ Just hmi <- old_hmi,
+ Just l <- hm_linkable hmi,
+ not (isObjectLinkable l),
+ (target /= HscNothing) `implies` not is_fake_linkable,
+ linkableTime l >= ms_hs_date summary -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling non-stable BCO mod:" <+> ppr this_mod_name)
+ compile_it (Just l)
+ -- we have an old BCO that is up to date with respect
+ -- to the source: do a recompilation check as normal.
+
+ -- When generating object code, if there's an up-to-date
+ -- object file on the disk, then we can use it.
+ -- However, if the object file is new (compared to any
+ -- linkable we had from a previous compilation), then we
+ -- must discard any in-memory interface, because this
+ -- means the user has compiled the source file
+ -- separately and generated a new interface, that we must
+ -- read from the disk.
+ --
+ | isObjectTarget target,
+ Just obj_date <- mb_obj_date,
+ obj_date >= hs_date -> do
+ case old_hmi of
+ Just hmi
+ | Just l <- hm_linkable hmi,
+ isObjectLinkable l && linkableTime l == obj_date -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name)
+ compile_it (Just l)
+ _otherwise -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name)
+ linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date
+ compile_it_discard_iface (Just linkable)
+
+ _otherwise -> do
+ liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5
+ (text "compiling mod:" <+> ppr this_mod_name)
+ compile_it Nothing
+
+
+
+-- Filter modules in the HPT
+retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
+retainInTopLevelEnvs keep_these hpt
+ = listToUFM [ (mod, expectJust "retain" mb_mod_info)
+ | mod <- keep_these
+ , let mb_mod_info = lookupUFM hpt mod
+ , isJust mb_mod_info ]
+
+-- ---------------------------------------------------------------------------
+-- Typecheck module loops
+
+{-
+See bug #930. This code fixes a long-standing bug in --make. The
+problem is that when compiling the modules *inside* a loop, a data
+type that is only defined at the top of the loop looks opaque; but
+after the loop is done, the structure of the data type becomes
+apparent.
+
+The difficulty is then that two different bits of code have
+different notions of what the data type looks like.
+
+The idea is that after we compile a module which also has an .hs-boot
+file, we re-generate the ModDetails for each of the modules that
+depends on the .hs-boot file, so that everyone points to the proper
+TyCons, Ids etc. defined by the real module, not the boot module.
+Fortunately re-generating a ModDetails from a ModIface is easy: the
+function TcIface.typecheckIface does exactly that.
+
+Picking the modules to re-typecheck is slightly tricky. Starting from
+the module graph consisting of the modules that have already been
+compiled, we reverse the edges (so they point from the imported module
+to the importing module), and depth-first-search from the .hs-boot
+node. This gives us all the modules that depend transitively on the
+.hs-boot module, and those are exactly the modules that we need to
+re-typecheck.
+
+Following this fix, GHC can compile itself with --make -O2.
+-}
+
+reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
+reTypecheckLoop hsc_env ms graph
+ | not (isBootSummary ms) &&
+ any (\m -> ms_mod m == this_mod && isBootSummary m) graph
+ = do
+ let mss = reachableBackwards (ms_mod_name ms) graph
+ non_boot = filter (not.isBootSummary) mss
+ debugTraceMsg (hsc_dflags hsc_env) 2 $
+ text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot)
+ typecheckLoop hsc_env (map ms_mod_name non_boot)
+ | otherwise
+ = return hsc_env
+ where
+ this_mod = ms_mod ms
+
+typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv
+typecheckLoop hsc_env mods = do
+ new_hpt <-
+ fixIO $ \new_hpt -> do
+ let new_hsc_env = hsc_env{ hsc_HPT = new_hpt }
+ mds <- initIfaceCheck new_hsc_env $
+ mapM (typecheckIface . hm_iface) hmis
+ let new_hpt = addListToUFM old_hpt
+ (zip mods [ hmi{ hm_details = details }
+ | (hmi,details) <- zip hmis mds ])
+ return new_hpt
+ return hsc_env{ hsc_HPT = new_hpt }
+ where
+ old_hpt = hsc_HPT hsc_env
+ hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods
+
+reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary]
+reachableBackwards mod summaries
+ = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ]
+ where -- the rest just sets up the graph:
+ (graph, lookup_node) = moduleGraphNodes False summaries
+ root = expectJust "reachableBackwards" (lookup_node HsBootFile mod)
+
+-- ---------------------------------------------------------------------------
+-- Topological sort of the module graph
+
+type SummaryNode = (ModSummary, Int, [Int])
+
+topSortModuleGraph
+ :: Bool
+ -- ^ Drop hi-boot nodes? (see below)
+ -> [ModSummary]
+ -> Maybe ModuleName
+ -- ^ Root module name. If @Nothing@, use the full graph.
+ -> [SCC ModSummary]
+-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes
+-- The resulting list of strongly-connected-components is in topologically
+-- sorted order, starting with the module(s) at the bottom of the
+-- dependency graph (ie compile them first) and ending with the ones at
+-- the top.
+--
+-- Drop hi-boot nodes (first boolean arg)?
+--
+-- - @False@: treat the hi-boot summaries as nodes of the graph,
+-- so the graph must be acyclic
+--
+-- - @True@: eliminate the hi-boot nodes, and instead pretend
+-- the a source-import of Foo is an import of Foo
+-- The resulting graph has no hi-boot nodes, but can be cyclic
+
+topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod
+ = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
+ where
+ (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries
+
+ initial_graph = case mb_root_mod of
+ Nothing -> graph
+ Just root_mod ->
+ -- restrict the graph to just those modules reachable from
+ -- the specified module. We do this by building a graph with
+ -- the full set of nodes, and determining the reachable set from
+ -- the specified node.
+ let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node
+ | otherwise = ghcError (ProgramError "module does not exist")
+ in graphFromEdgedVertices (seq root (reachableG graph root))
+
+summaryNodeKey :: SummaryNode -> Int
+summaryNodeKey (_, k, _) = k
+
+summaryNodeSummary :: SummaryNode -> ModSummary
+summaryNodeSummary (s, _, _) = s
+
+moduleGraphNodes :: Bool -> [ModSummary]
+ -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode)
+moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node)
+ where
+ numbered_summaries = zip summaries [1..]
+
+ lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode
+ lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map
+
+ lookup_key :: HscSource -> ModuleName -> Maybe Int
+ lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod)
+
+ node_map :: NodeMap SummaryNode
+ node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node)
+ | node@(s, _, _) <- nodes ]
+
+ -- We use integers as the keys for the SCC algorithm
+ nodes :: [SummaryNode]
+ nodes = [ (s, key, out_keys)
+ | (s, key) <- numbered_summaries
+ -- Drop the hi-boot ones if told to do so
+ , not (isBootSummary s && drop_hs_boot_nodes)
+ , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++
+ out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++
+ (-- see [boot-edges] below
+ if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile
+ then []
+ else case lookup_key HsBootFile (ms_mod_name s) of
+ Nothing -> []
+ Just k -> [k]) ]
+
+ -- [boot-edges] if this is a .hs and there is an equivalent
+ -- .hs-boot, add a link from the former to the latter. This
+ -- has the effect of detecting bogus cases where the .hs-boot
+ -- depends on the .hs, by introducing a cycle. Additionally,
+ -- it ensures that we will always process the .hs-boot before
+ -- the .hs, and so the HomePackageTable will always have the
+ -- most up to date information.
+
+ -- Drop hs-boot nodes by using HsSrcFile as the key
+ hs_boot_key | drop_hs_boot_nodes = HsSrcFile
+ | otherwise = HsBootFile
+
+ out_edge_keys :: HscSource -> [ModuleName] -> [Int]
+ out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms
+ -- If we want keep_hi_boot_nodes, then we do lookup_key with
+ -- the IsBootInterface parameter True; else False
+
+
+type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are
+type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs
+
+msKey :: ModSummary -> NodeKey
+msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot)
+
+mkNodeMap :: [ModSummary] -> NodeMap ModSummary
+mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries]
+
+nodeMapElts :: NodeMap a -> [a]
+nodeMapElts = Map.elems
+
+-- | If there are {-# SOURCE #-} imports between strongly connected
+-- components in the topological sort, then those imports can
+-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE
+-- were necessary, then the edge would be part of a cycle.
+warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
+warnUnnecessarySourceImports sccs = do
+ logWarnings (listToBag (concatMap (check.flattenSCC) sccs))
+ where check ms =
+ let mods_in_this_cycle = map ms_mod_name ms in
+ [ warn i | m <- ms, i <- ms_home_srcimps m,
+ unLoc i `notElem` mods_in_this_cycle ]
+
+ warn :: Located ModuleName -> WarnMsg
+ warn (L loc mod) =
+ mkPlainErrMsg loc
+ (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")
+ <+> quotes (ppr mod))
+
+-----------------------------------------------------------------------------
+-- Downsweep (dependency analysis)
+
+-- Chase downwards from the specified root set, returning summaries
+-- for all home modules encountered. Only follow source-import
+-- links.
+
+-- We pass in the previous collection of summaries, which is used as a
+-- cache to avoid recalculating a module summary if the source is
+-- unchanged.
+--
+-- The returned list of [ModSummary] nodes has one node for each home-package
+-- module, plus one for any hs-boot files. The imports of these nodes
+-- are all there, including the imports of non-home-package modules.
+
+downsweep :: HscEnv
+ -> [ModSummary] -- Old summaries
+ -> [ModuleName] -- Ignore dependencies on these; treat
+ -- them as if they were package modules
+ -> Bool -- True <=> allow multiple targets to have
+ -- the same module name; this is
+ -- very useful for ghc -M
+ -> IO [ModSummary]
+ -- The elts of [ModSummary] all have distinct
+ -- (Modules, IsBoot) identifiers, unless the Bool is true
+ -- in which case there can be repeats
+downsweep hsc_env old_summaries excl_mods allow_dup_roots
+ = do
+ rootSummaries <- mapM getRootSummary roots
+ let root_map = mkRootMap rootSummaries
+ checkDuplicates root_map
+ summs <- loop (concatMap msDeps rootSummaries) root_map
+ return summs
+ where
+ roots = hsc_targets hsc_env
+
+ old_summary_map :: NodeMap ModSummary
+ old_summary_map = mkNodeMap old_summaries
+
+ getRootSummary :: Target -> IO ModSummary
+ getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf)
+ = do exists <- liftIO $ doesFileExist file
+ if exists
+ then summariseFile hsc_env old_summaries file mb_phase
+ obj_allowed maybe_buf
+ else throwOneError $ mkPlainErrMsg 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 False
+ (L rootLoc modl) obj_allowed
+ maybe_buf excl_mods
+ case maybe_summary of
+ Nothing -> packageModErr modl
+ Just s -> return s
+
+ rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
+
+ -- In a root module, the filename is allowed to diverge from the module
+ -- 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 [ModSummary] -> IO ()
+ checkDuplicates root_map
+ | allow_dup_roots = return ()
+ | null dup_roots = return ()
+ | otherwise = liftIO $ multiRootsErr (head dup_roots)
+ where
+ dup_roots :: [[ModSummary]] -- Each at least of length 2
+ dup_roots = filterOut isSingleton (nodeMapElts root_map)
+
+ loop :: [(Located ModuleName,IsBootInterface)]
+ -- Work list: process these modules
+ -> NodeMap [ModSummary]
+ -- Visited set; the range is a list because
+ -- the roots can have the same module names
+ -- if allow_dup_roots is True
+ -> IO [ModSummary]
+ -- The result includes the worklist, except
+ -- for those mentioned in the visited set
+ loop [] done = return (concat (nodeMapElts done))
+ loop ((wanted_mod, is_boot) : ss) done
+ | Just summs <- Map.lookup key done
+ = if isSingleton summs then
+ loop ss done
+ else
+ do { multiRootsErr summs; return [] }
+ | otherwise
+ = do mb_s <- summariseModule hsc_env old_summary_map
+ is_boot wanted_mod True
+ Nothing excl_mods
+ case mb_s of
+ Nothing -> loop ss done
+ Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done)
+ where
+ key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile)
+
+-- XXX Does the (++) here need to be flipped?
+mkRootMap :: [ModSummary] -> NodeMap [ModSummary]
+mkRootMap summaries = Map.insertListWith (flip (++))
+ [ (msKey s, [s]) | s <- summaries ]
+ Map.empty
+
+msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)]
+-- (msDeps s) returns the dependencies of the ModSummary s.
+-- A wrinkle is that for a {-# SOURCE #-} import we return
+-- *both* the hs-boot file
+-- *and* the source file
+-- as "dependencies". That ensures that the list of all relevant
+-- modules always contains B.hs if it contains B.hs-boot.
+-- Remember, this pass isn't doing the topological sort. It's
+-- just gathering the list of all relevant ModSummaries
+msDeps s =
+ concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ]
+ ++ [ (m,False) | m <- ms_home_imps s ]
+
+home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName]
+home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ]
+ where isLocal Nothing = True
+ isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
+ isLocal _ = False
+
+ms_home_allimps :: ModSummary -> [ModuleName]
+ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
+
+ms_home_srcimps :: ModSummary -> [Located ModuleName]
+ms_home_srcimps = home_imps . ms_srcimps
+
+ms_home_imps :: ModSummary -> [Located ModuleName]
+ms_home_imps = home_imps . ms_imps
+
+-----------------------------------------------------------------------------
+-- Summarising modules
+
+-- We have two types of summarisation:
+--
+-- * Summarise a file. This is used for the root module(s) passed to
+-- cmLoadModules. The file is read, and used to determine the root
+-- module name. The module name may differ from the filename.
+--
+-- * Summarise a module. We are given a module name, and must provide
+-- a summary. The finder is used to locate the file in which the module
+-- resides.
+
+summariseFile
+ :: HscEnv
+ -> [ModSummary] -- old summaries
+ -> FilePath -- source file name
+ -> Maybe Phase -- start phase
+ -> Bool -- object code allowed?
+ -> Maybe (StringBuffer,ClockTime)
+ -> IO ModSummary
+
+summariseFile hsc_env old_summaries file 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
+ = do
+ let location = ms_location old_summary
+
+ -- return the cached summary if the source didn't change
+ src_timestamp <- case maybe_buf of
+ Just (_,t) -> return t
+ Nothing -> liftIO $ getModificationTime file
+ -- The file exists; we checked in getRootSummary above.
+ -- If it gets removed subsequently, then this
+ -- getModificationTime may fail, but that's the right
+ -- behaviour.
+
+ if ms_hs_date old_summary == src_timestamp
+ then do -- update the object-file timestamp
+ obj_timestamp <-
+ if isObjectTarget (hscTarget (hsc_dflags hsc_env))
+ || obj_allowed -- bug #1205
+ then liftIO $ getObjTimestamp location False
+ else return Nothing
+ return old_summary{ ms_obj_date = obj_timestamp }
+ else
+ new_summary
+
+ | otherwise
+ = new_summary
+ where
+ new_summary = do
+ let dflags = hsc_dflags hsc_env
+
+ (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
+
+ -- 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
+
+ src_timestamp <- case maybe_buf of
+ Just (_,t) -> return t
+ Nothing -> liftIO $ getModificationTime file
+ -- getMofificationTime may fail
+
+ -- 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
+
+ return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile,
+ ms_location = location,
+ ms_hspp_file = hspp_fn,
+ ms_hspp_opts = dflags',
+ ms_hspp_buf = Just buf,
+ ms_srcimps = srcimps, ms_imps = the_imps,
+ ms_hs_date = src_timestamp,
+ ms_obj_date = obj_timestamp })
+
+findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
+findSummaryBySourceFile summaries file
+ = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms],
+ expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of
+ [] -> Nothing
+ (x:_) -> Just x
+
+-- Summarise a module, and pick up source and timestamp.
+summariseModule
+ :: HscEnv
+ -> NodeMap ModSummary -- Map of old summaries
+ -> IsBootInterface -- True <=> a {-# SOURCE #-} import
+ -> Located ModuleName -- Imported module to be summarised
+ -> Bool -- object code allowed?
+ -> Maybe (StringBuffer, ClockTime)
+ -> [ModuleName] -- Modules to exclude
+ -> IO (Maybe ModSummary) -- Its new summary
+
+summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
+ obj_allowed maybe_buf excl_mods
+ | wanted_mod `elem` excl_mods
+ = return Nothing
+
+ | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map
+ = do -- Find its new timestamp; all the
+ -- ModSummaries in the old map have valid ml_hs_files
+ let location = ms_location old_summary
+ src_fn = expectJust "summariseModule" (ml_hs_file location)
+
+ -- check the modification time on the source file, and
+ -- 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
+ Nothing -> do
+ m <- tryIO (getModificationTime src_fn)
+ case m of
+ Right t -> check_timestamp old_summary location src_fn t
+ Left e | isDoesNotExistError e -> find_it
+ | otherwise -> ioError e
+
+ | otherwise = find_it
+ where
+ dflags = hsc_dflags hsc_env
+
+ hsc_src = if is_boot then HsBootFile else HsSrcFile
+
+ check_timestamp old_summary location src_fn src_timestamp
+ | ms_hs_date old_summary == src_timestamp = 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
+ return (Just old_summary{ ms_obj_date = obj_timestamp })
+ | otherwise =
+ -- source changed: re-summarise.
+ new_summary location (ms_mod old_summary) src_fn src_timestamp
+
+ find_it = do
+ -- Don't use the Finder's cache this time. If the module was
+ -- previously a package module, it may have now appeared on the
+ -- search path, so we want to consider it to be a home module. If
+ -- the module was previously a home module, it may have moved.
+ uncacheModule hsc_env wanted_mod
+ found <- findImportedModule hsc_env wanted_mod Nothing
+ case found of
+ Found location mod
+ | isJust (ml_hs_file location) ->
+ -- Home package
+ just_found location mod
+ | otherwise ->
+ -- Drop external-pkg
+ ASSERT(modulePackageId mod /= thisPackage dflags)
+ return Nothing
+
+ err -> noModError dflags loc wanted_mod err
+ -- Not found
+
+ just_found location mod = do
+ -- Adjust location to point to the hs-boot source file,
+ -- hi file, object file, when is_boot says so
+ let location' | is_boot = addBootSuffixLocn location
+ | otherwise = location
+ src_fn = expectJust "summarise2" (ml_hs_file location')
+
+ -- Check that it exists
+ -- It might have been deleted since the Finder last found it
+ maybe_t <- modificationTimeIfExists src_fn
+ case maybe_t of
+ Nothing -> noHsFileErr 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
+
+ when (mod_name /= wanted_mod) $
+ throwOneError $ mkPlainErrMsg mod_loc $
+ text "File name does not match module name:"
+ $$ text "Saw:" <+> quotes (ppr mod_name)
+ $$ text "Expected:" <+> quotes (ppr wanted_mod)
+
+ -- 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
+
+ return (Just (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_srcimps = srcimps,
+ ms_imps = the_imps,
+ ms_hs_date = src_timestamp,
+ ms_obj_date = obj_timestamp }))
+
+
+getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime)
+getObjTimestamp location is_boot
+ = if is_boot then return Nothing
+ else modificationTimeIfExists (ml_obj_file location)
+
+
+preprocessFile :: HscEnv
+ -> FilePath
+ -> Maybe Phase -- ^ Starting phase
+ -> Maybe (StringBuffer,ClockTime)
+ -> IO (DynFlags, FilePath, StringBuffer)
+preprocessFile hsc_env src_fn mb_phase Nothing
+ = do
+ (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase)
+ buf <- hGetStringBuffer hspp_fn
+ return (dflags', hspp_fn, buf)
+
+preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
+ = do
+ let dflags = hsc_dflags hsc_env
+ -- case we bypass the preprocessing stage?
+ let
+ local_opts = getOptions dflags buf src_fn
+ --
+ (dflags', leftovers, warns)
+ <- parseDynamicNoPackageFlags dflags local_opts
+ checkProcessArgsResult leftovers
+ handleFlagWarnings dflags' warns
+
+ let
+ needs_preprocessing
+ | Just (Unlit _) <- mb_phase = True
+ | Nothing <- mb_phase, Unlit _ <- startPhase src_fn = True
+ -- note: local_opts is only required if there's no Unlit phase
+ | xopt Opt_Cpp dflags' = True
+ | dopt Opt_Pp dflags' = True
+ | otherwise = False
+
+ when needs_preprocessing $
+ ghcError (ProgramError "buffer needs preprocesing; interactive check disabled")
+
+ return (dflags', src_fn, buf)
+
+
+-----------------------------------------------------------------------------
+-- Error messages
+-----------------------------------------------------------------------------
+
+noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
+-- ToDo: we don't have a proper line number for this error
+noModError dflags loc wanted_mod err
+ = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
+
+noHsFileErr :: SrcSpan -> String -> IO a
+noHsFileErr loc path
+ = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
+
+packageModErr :: ModuleName -> IO a
+packageModErr mod
+ = throwOneError $ mkPlainErrMsg noSrcSpan $
+ text "module" <+> quotes (ppr mod) <+> text "is a package module"
+
+multiRootsErr :: [ModSummary] -> IO ()
+multiRootsErr [] = panic "multiRootsErr"
+multiRootsErr summs@(summ1:_)
+ = throwOneError $ mkPlainErrMsg noSrcSpan $
+ text "module" <+> quotes (ppr mod) <+>
+ text "is defined in multiple files:" <+>
+ sep (map text files)
+ where
+ mod = ms_mod summ1
+ files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
+
+cyclicModuleErr :: [ModSummary] -> SDoc
+cyclicModuleErr ms
+ = hang (ptext (sLit "Module imports form a cycle for modules:"))
+ 2 (vcat (map show_one ms))
+ where
+ mods_in_cycle = map ms_mod_name ms
+ imp_modname = unLoc . ideclName . unLoc
+ just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname)
+
+ show_one ms =
+ vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+>
+ maybe empty (parens . text) (ml_hs_file (ms_location ms)),
+ nest 2 $ ptext (sLit "imports:") <+> vcat [
+ pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms),
+ pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ]
+ ]
+ show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src)
+ pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps)
, hscParseIdentifier
, hscTcRcLookupName
, hscTcRnGetInfo
- , hscRnImportDecls
#ifdef GHCI
+ , hscRnImportDecls
, hscGetModuleExports
, hscTcRnLookupRdrName
, hscStmt, hscStmtWithLocation
import TcRnDriver
import TcIface ( typecheckIface )
import TcRnMonad
-import RnNames ( rnImports )
import IfaceEnv ( initNameCache )
import LoadIface ( ifaceStats, initExternalPackageState )
import PrelInfo ( wiredInThings, basicKnownKeyNames )
hscGetModuleExports :: HscEnv -> Module -> IO (Maybe [AvailInfo])
hscGetModuleExports hsc_env mdl =
runHsc hsc_env $ ioMsgMaybe' $ getModuleExports hsc_env mdl
-#endif
-- -----------------------------------------------------------------------------
-- | Rename some import declarations
-> [LImportDecl RdrName]
-> IO GlobalRdrEnv
-hscRnImportDecls hsc_env this_mod import_decls = runHsc hsc_env $ do
- (_, r, _, _) <-
- ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $
- rnImports import_decls
- return r
+-- It is important that we use tcRnImports instead of calling rnImports directly
+-- because tcRnImports will force-load any orphan modules necessary, making extra
+-- instances/family instances visible (GHC #4832)
+hscRnImportDecls hsc_env this_mod import_decls
+ = runHsc hsc_env $ ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $
+ fmap tcg_rdr_env $ tcRnImports hsc_env this_mod import_decls
+
+#endif
-- -----------------------------------------------------------------------------
-- | parse a file, returning the abstract syntax
data HscStatus' a
= HscNoRecomp
| HscRecomp
- Bool -- Has stub files. This is a hack. We can't compile C files here
+ (Maybe FilePath)
+ -- Has stub files. This is a hack. We can't compile C files here
-- since it's done in DriverPipeline. For now we just return True
-- if we want the caller to compile them for us.
a
, hscBackend = \ tc_result mod_summary mb_old_hash -> do
dflags <- getDynFlags
case hscTarget dflags of
- HscNothing -> return (HscRecomp False ())
+ HscNothing -> return (HscRecomp Nothing ())
_otherw -> genericHscBackend hscOneShotCompiler
tc_result mod_summary mb_old_hash
, hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
(iface, changed, _) <- hscSimpleIface tc_result mb_old_iface
hscWriteIface iface changed mod_summary
- return (HscRecomp False ())
+ return (HscRecomp Nothing ())
, hscGenOutput = \guts0 mod_summary mb_old_iface -> do
guts <- hscSimplify' guts0
, hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do
(iface, changed, details) <- hscSimpleIface tc_result mb_old_iface
hscWriteIface iface changed mod_summary
- return (HscRecomp False (), iface, details)
+ return (HscRecomp Nothing (), iface, details)
, hscGenOutput = \guts0 mod_summary mb_old_iface -> do
guts <- hscSimplify' guts0
, hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do
(iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
- return (HscRecomp False Nothing, iface, details)
+ return (HscRecomp Nothing Nothing, iface, details)
, hscGenOutput = \guts0 mod_summary mb_old_iface -> do
guts <- hscSimplify' guts0
, hscBackend = \tc_result _mod_summary mb_old_iface -> do
handleWarnings
(iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface
- return (HscRecomp False (), iface, details)
+ return (HscRecomp Nothing (), iface, details)
, hscGenBootOutput = \_ _ _ ->
panic "hscCompileNothing: hscGenBootOutput should not be called"
-- | Compile to hard-code.
hscGenHardCode :: CgGuts -> ModSummary
- -> Hsc Bool -- ^ @True@ <=> stub.c exists
+ -> Hsc (Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f
hscGenHardCode cgguts mod_summary
= do
hsc_env <- getHscEnv
-- * State relating to modules in this package
HomePackageTable, HomeModInfo(..), emptyHomePackageTable,
- hptInstances, hptRules, hptVectInfo,
-
+ hptInstances, hptRules, hptVectInfo,
+ hptObjs,
+
-- * State relating to known packages
ExternalPackageState(..), EpsStats(..), addEpsInStats,
PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
Warnings(..), WarningTxt(..), plusWarns,
-- * Linker stuff
- Linkable(..), isObjectLinkable,
+ Linkable(..), isObjectLinkable, linkableObjs,
Unlinked(..), CompiledByteCode,
isObject, nameOfObject, isInterpretable, byteCodeOfObject,
-- And get its dfuns
, thing <- things ]
+
+hptObjs :: HomePackageTable -> [FilePath]
+hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsUFM hpt))
\end{code}
%************************************************************************
-- compiling a module in HscNothing mode, and this choice
-- happens to work well with checkStability in module GHC.
+linkableObjs :: Linkable -> [FilePath]
+linkableObjs l = [ f | DotO f <- linkableUnlinked l ]
+
instance Outputable Linkable where
ppr (LM when_made mod unlinkeds)
= (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)
-- Interface to system tools
runUnlit, runCpp, runCc, -- [Option] -> IO ()
runPp, -- [Option] -> IO ()
- runMangle, runSplit, -- [Option] -> IO ()
+ runSplit, -- [Option] -> IO ()
runAs, runLink, -- [Option] -> IO ()
runMkDLL,
runWindres,
-- architecture-specific stuff is done when building Config.hs
unlit_path = installed cGHC_UNLIT_PGM
- -- split and mangle are Perl scripts
+ -- split is a Perl script
split_script = installed cGHC_SPLIT_PGM
- mangle_script = installed cGHC_MANGLER_PGM
windres_path = installed_mingw_bin "windres"
| isWindowsHost = installed cGHC_TOUCHY_PGM
| otherwise = "touch"
-- On Win32 we don't want to rely on #!/bin/perl, so we prepend
- -- a call to Perl to get the invocation of split and mangle.
+ -- a call to Perl to get the invocation of split.
-- On Unix, scripts are invoked using the '#!' method. Binary
-- installations of GHC on Unix place the correct line on the
-- front of the script at installation time, so we don't want
(split_prog, split_args)
| isWindowsHost = (perl_path, [Option split_script])
| otherwise = (split_script, [])
- (mangle_prog, mangle_args)
- | isWindowsHost = (perl_path, [Option mangle_script])
- | otherwise = (mangle_script, [])
(mkdll_prog, mkdll_args)
| not isWindowsHost
= panic "Can't build DLLs on a non-Win32 system"
pgm_P = cpp_path,
pgm_F = "",
pgm_c = (gcc_prog,[]),
- pgm_m = (mangle_prog,mangle_args),
pgm_s = (split_prog,split_args),
pgm_a = (as_prog,[]),
pgm_l = (ld_prog,[]),
= (path, '\"' : head b_dirs ++ "\";" ++ paths)
mangle_path other = other
-runMangle :: DynFlags -> [Option] -> IO ()
-runMangle dflags args = do
- let (p,args0) = pgm_m dflags
- runSomething dflags "Mangler" p (args0++args)
-
runSplit :: DynFlags -> [Option] -> IO ()
runSplit dflags args = do
let (p,args0) = pgm_s dflags
(c) Update the current assignment
- (d) If the intstruction is a branch:
+ (d) If the instruction is a branch:
if the destination block already has a register assignment,
Generate a new block with fixup code and redirect the
jump to the new block.
-- register does not already have an assignment,
-- and the source register is assigned to a register, not to a spill slot,
-- then we can eliminate the instruction.
- -- (we can't eliminitate it if the source register is on the stack, because
+ -- (we can't eliminate it if the source register is on the stack, because
-- we do not want to use one spill slot for different virtual registers)
case takeRegRegMoveInstr instr of
Just (src,dst) | src `elementOfUniqSet` (liveDieRead live),
saveClobberedTemps
- :: Instruction instr
+ :: (Outputable instr, Instruction instr)
=> [RealReg] -- real registers clobbered by this instruction
-> [Reg] -- registers which are no longer live after this insn
-> RegM [instr] -- return: instructions to spill any temps that will
--- | Mark all these regal regs as allocated,
+-- | Mark all these real regs as allocated,
-- and kick out their vreg assignments.
--
clobberRegs :: [RealReg] -> RegM ()
-- -----------------------------------------------------------------------------
-- allocateRegsAndSpill
+-- Why are we performing a spill?
+data SpillLoc = ReadMem StackSlot -- reading from register only in memory
+ | WriteNew -- writing to a new variable
+ | WriteMem -- writing to register only in memory
+-- Note that ReadNew is not valid, since you don't want to be reading
+-- from an uninitialized register. We also don't need the location of
+-- the register in memory, since that will be invalidated by the write.
+-- Technically, we could coalesce WriteNew and WriteMem into a single
+-- entry as well. -- EZY
+
-- This function does several things:
-- For each temporary referred to by this instruction,
-- we allocate a real register (spilling another temporary if necessary).
-- the list of free registers and free stack slots.
allocateRegsAndSpill
- :: Instruction instr
+ :: (Outputable instr, Instruction instr)
=> Bool -- True <=> reading (load up spilled regs)
-> [VirtualReg] -- don't push these out
-> [instr] -- spill insns
allocateRegsAndSpill reading keep spills alloc (r:rs)
= do assig <- getAssigR
+ let doSpill = allocRegsAndSpill_spill reading keep spills alloc r rs assig
case lookupUFM assig r of
-- case (1a): already in a register
Just (InReg my_reg) ->
allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
-- case (1b): already in a register (and memory)
- -- NB1. if we're writing this register, update its assignemnt to be
+ -- NB1. if we're writing this register, update its assignment to be
-- InReg, because the memory value is no longer valid.
-- NB2. This is why we must process written registers here, even if they
-- are also read by the same instruction.
allocateRegsAndSpill reading keep spills (my_reg:alloc) rs
-- Not already in a register, so we need to find a free one...
- loc -> allocRegsAndSpill_spill reading keep spills alloc r rs loc assig
+ Just (InMem slot) | reading -> doSpill (ReadMem slot)
+ | otherwise -> doSpill WriteMem
+ Nothing | reading ->
+ -- pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r)
+ -- ToDo: This case should be a panic, but we
+ -- sometimes see an unreachable basic block which
+ -- triggers this because the register allocator
+ -- will start with an empty assignment.
+ doSpill WriteNew
+
+ | otherwise -> doSpill WriteNew
-allocRegsAndSpill_spill reading keep spills alloc r rs loc assig
+-- reading is redundant with reason, but we keep it around because it's
+-- convenient and it maintains the recursive structure of the allocator. -- EZY
+allocRegsAndSpill_spill reading keep spills alloc r rs assig spill_loc
= do
freeRegs <- getFreeRegsR
let freeRegs_thisClass = getFreeRegs (classOfVirtualReg r) freeRegs
-- case (2): we have a free register
(my_reg : _) ->
- do spills' <- loadTemp reading r loc my_reg spills
-
- let new_loc
- -- if the tmp was in a slot, then now its in a reg as well
- | Just (InMem slot) <- loc
- , reading
- = InBoth my_reg slot
+ do spills' <- loadTemp r spill_loc my_reg spills
- -- tmp has been loaded into a reg
- | otherwise
- = InReg my_reg
-
- setAssigR (addToUFM assig r $! new_loc)
+ setAssigR (addToUFM assig r $! newLocation spill_loc my_reg)
setFreeRegsR $ allocateReg my_reg freeRegs
allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs
-- we have a temporary that is in both register and mem,
-- just free up its register for use.
| (temp, my_reg, slot) : _ <- candidates_inBoth
- = do spills' <- loadTemp reading r loc my_reg spills
+ = do spills' <- loadTemp r spill_loc my_reg spills
let assig1 = addToUFM assig temp (InMem slot)
- let assig2 = addToUFM assig1 r (InReg my_reg)
+ let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
setAssigR assig2
allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs
-- update the register assignment
let assig1 = addToUFM assig temp_to_push_out (InMem slot)
- let assig2 = addToUFM assig1 r (InReg my_reg)
+ let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg
setAssigR assig2
-- if need be, load up a spilled temp into the reg we've just freed up.
- spills' <- loadTemp reading r loc my_reg spills
+ spills' <- loadTemp r spill_loc my_reg spills
allocateRegsAndSpill reading keep
(spill_store ++ spills')
result
--- | Load up a spilled temporary if we need to.
+-- | Calculate a new location after a register has been loaded.
+newLocation :: SpillLoc -> RealReg -> Loc
+-- if the tmp was read from a slot, then now its in a reg as well
+newLocation (ReadMem slot) my_reg = InBoth my_reg slot
+-- writes will always result in only the register being available
+newLocation _ my_reg = InReg my_reg
+
+-- | Load up a spilled temporary if we need to (read from memory).
loadTemp
- :: Instruction instr
- => Bool
- -> VirtualReg -- the temp being loaded
- -> Maybe Loc -- the current location of this temp
+ :: (Outputable instr, Instruction instr)
+ => VirtualReg -- the temp being loaded
+ -> SpillLoc -- the current location of this temp
-> RealReg -- the hreg to load the temp into
-> [instr]
-> RegM [instr]
-loadTemp True vreg (Just (InMem slot)) hreg spills
+loadTemp vreg (ReadMem slot) hreg spills
= do
insn <- loadR (RegReal hreg) slot
recordSpill (SpillLoad $ getUnique vreg)
return $ {- COMMENT (fsLit "spill load") : -} insn : spills
-loadTemp _ _ _ _ spills =
+loadTemp _ _ _ spills =
return spills
size | not use_sse2 && isFloatSize sz = FF80
| otherwise = sz
--
- return (Fixed sz (getRegisterReg use_sse2 reg) nilOL)
+ return (Fixed size (getRegisterReg use_sse2 reg) nilOL)
getRegister tree@(CmmRegOff _ _)
#ifdef GHCI
tcRnStmt, tcRnExpr, tcRnType,
tcRnLookupRdrName,
- getModuleExports,
+ getModuleExports,
#endif
+ tcRnImports,
tcRnLookupName,
tcRnGetInfo,
tcRnModule,
+++ /dev/null
-#!/usr/bin/perl -w
-
-use strict;
-
-# Usage:
-#
-# ./darcs-all [-q] [-s] [-i] [-r repo]
-# [--nofib] [--testsuite] [--checked-out] cmd [darcs flags]
-#
-# Applies the darcs command "cmd" to each repository in the tree.
-#
-# e.g.
-# ./darcs-all -r http://darcs.haskell.org/ghc get
-# To get any repos which do not exist in the local tree
-#
-# ./darcs-all -r ~/ghc-validate push
-# To push all your repos to the ~/ghc-validate tree
-#
-# ./darcs-all pull -a
-# To pull everything from the default repos
-#
-# ./darc-all push --dry-run
-# To see what local patches you have relative to the main repos
-#
-# -------------- Flags -------------------
-# -q says to be quite, and -s to be silent.
-#
-# -i says to ignore darcs errors and move on to the next repository
-#
-# -r repo says to use repo as the location of package repositories
-#
-# --checked-out says that the remote repo is in checked-out layout, as
-# opposed to the layout used for the main repo. By default a repo on
-# the local filesystem is assumed to be checked-out, and repos accessed
-# via HTTP or SSH are assumed to be in the main repo layout; use
-# --checked-out to override the latter.
-#
-# --nofib, --testsuite also get the nofib and testsuite repos respectively
-#
-# The darcs get flag you are most likely to want is --complete. By
-# default we pass darcs the --partial flag.
-#
-# ------------ Which repos to use -------------
-# darcs-all uses the following algorithm to decide which remote repos to use
-#
-# It always computes the remote repos from a single base, $repo_base
-# How is $repo_base set?
-# If you say "-r repo", then that's $repo_base
-# othewise $repo_base is set thus:
-# look in _darcs/prefs/defaultrepo,
-# and remove the trailing 'ghc'
-#
-# Then darcs-all iterates over the package found in the file
-# ./packages, which has entries like:
-# libraries/array packages/array darcs
-# or, in general
-# <local-path> <remote-path> <vcs>
-#
-# If $repo_base looks like a local filesystem path, or if you give
-# the --checked-out flag, darcs-all works on repos of form
-# $repo_base/<local-path>
-# otherwise darcs-all works on repos of form
-# $repo_base/<remote-path>
-# This logic lets you say
-# both darcs-all -r http://darcs.haskell.org/ghc-6.12 pull
-# and darcs-all -r ../HEAD pull
-# The latter is called a "checked-out tree".
-
-# NB: darcs-all *ignores* the defaultrepo of all repos other than the
-# root one. So the remote repos must be laid out in one of the two
-# formats given by <local-path> and <remote-path> in the file 'packages'.
-
-
-$| = 1; # autoflush stdout after each print, to avoid output after die
-
-my $defaultrepo;
-
-my $verbose = 2;
-my $ignore_failure = 0;
-my $want_remote_repo = 0;
-my $checked_out_flag = 0;
-
-my %tags;
-
-my @packages;
-
-# Figure out where to get the other repositories from.
-sub getrepo {
- my $basedir = ".";
- my $repo = $defaultrepo || `cat $basedir/_darcs/prefs/defaultrepo`;
- chomp $repo;
-
- my $repo_base;
- my $checked_out_tree;
-
- if ($repo =~ /^...*:/) {
- # HTTP or SSH
- # Above regex says "at least two chars before the :", to avoid
- # catching Win32 drives ("C:\").
- $repo_base = $repo;
-
- # --checked-out is needed if you want to use a checked-out repo
- # over SSH or HTTP
- if ($checked_out_flag) {
- $checked_out_tree = 1;
- } else {
- $checked_out_tree = 0;
- }
-
- # Don't drop the last part of the path if specified with -r, as
- # it expects repos of the form:
- #
- # http://darcs.haskell.org
- #
- # rather than
- #
- # http://darcs.haskell.org/ghc
- #
- if (!$defaultrepo) {
- $repo_base =~ s#/[^/]+/?$##;
- }
- }
- elsif ($repo =~ /^\/|\.\.\/|.:(\/|\\)/) {
- # Local filesystem, either absolute or relative path
- # (assumes a checked-out tree):
- $repo_base = $repo;
- $checked_out_tree = 1;
- }
- else {
- die "Couldn't work out repo";
- }
-
- return $repo_base, $checked_out_tree;
-}
-
-sub message {
- if ($verbose >= 2) {
- print "@_\n";
- }
-}
-
-sub warning {
- if ($verbose >= 1) {
- print "warning: @_\n";
- }
-}
-
-sub darcs {
- message "== running darcs @_";
- system ("darcs", @_) == 0
- or $ignore_failure
- or die "darcs failed: $?";
-}
-
-sub parsePackages {
- my @repos;
- my $lineNum;
-
- my ($repo_base, $checked_out_tree) = getrepo();
-
- open IN, "< packages" or die "Can't open packages file";
- @repos = <IN>;
- close IN;
-
- @packages = ();
- $lineNum = 0;
- foreach (@repos) {
- chomp;
- $lineNum++;
- if (/^([^# ]+) +([^ ]+) +([^ ]+) +([^ ]+) +([^ ]+)$/) {
- my %line;
- $line{"localpath"} = $1;
- $line{"tag"} = $2;
- $line{"remotepath"} = $3;
- $line{"vcs"} = $4;
- $line{"upstream"} = $5;
- push @packages, \%line;
- }
- elsif (! /^(#.*)?$/) {
- die "Bad content on line $lineNum of packages file: $_";
- }
- }
-}
-
-sub darcsall {
- my $localpath;
- my $remotepath;
- my $path;
- my $tag;
- my @repos;
- my $command = $_[0];
- my $line;
-
- my ($repo_base, $checked_out_tree) = getrepo();
-
- for $line (@packages) {
- $localpath = $$line{"localpath"};
- $tag = $$line{"tag"};
- $remotepath = $$line{"remotepath"};
-
- if ($checked_out_tree) {
- $path = "$repo_base/$localpath";
- }
- else {
- $path = "$repo_base/$remotepath";
- }
-
- if (-d "$localpath/_darcs") {
- if ($want_remote_repo) {
- if ($command =~ /^opt/) {
- # Allows ./darcs-all optimize --relink
- darcs (@_, "--repodir", $localpath, "--sibling=$path");
- } else {
- darcs (@_, "--repodir", $localpath, $path);
- }
- } else {
- darcs (@_, "--repodir", $localpath);
- }
- }
- elsif ($tag eq "-") {
- message "== Required repo $localpath is missing! Skipping";
- }
- else {
- message "== $localpath repo not present; skipping";
- }
- }
-}
-
-sub darcsget {
- my $r_flags;
- my $localpath;
- my $remotepath;
- my $path;
- my $tag;
- my @repos;
- my $line;
-
- my ($repo_base, $checked_out_tree) = getrepo();
-
- if (! grep /(?:--complete|--partial|--lazy)/, @_) {
- warning("adding --partial, to override use --complete");
- $r_flags = [@_, "--partial"];
- }
- else {
- $r_flags = \@_;
- }
-
- for $line (@packages) {
- $localpath = $$line{"localpath"};
- $tag = $$line{"tag"};
- $remotepath = $$line{"remotepath"};
-
- if ($checked_out_tree) {
- $path = "$repo_base/$localpath";
- }
- else {
- $path = "$repo_base/$remotepath";
- }
-
- if ($tags{$tag} eq 1) {
- if (-d $localpath) {
- warning("$localpath already present; omitting");
- }
- else {
- darcs (@$r_flags, $path, $localpath);
- }
- }
- }
-}
-
-sub darcsupstreampull {
- my $localpath;
- my $upstream;
- my $line;
-
- for $line (@packages) {
- $localpath = $$line{"localpath"};
- $upstream = $$line{"upstream"};
-
- if ($upstream ne "-") {
- if (-d $localpath) {
- darcs ("pull", @_, "--repodir", $localpath, $upstream);
- }
- }
- }
-}
-
-sub main {
- if (! -d "compiler") {
- die "error: darcs-all must be run from the top level of the ghc tree."
- }
-
- $tags{"-"} = 1;
- $tags{"dph"} = 1;
- $tags{"nofib"} = 0;
- $tags{"testsuite"} = 0;
- $tags{"extra"} = 0;
-
- while ($#_ ne -1) {
- my $arg = shift;
- # We handle -q here as well as lower down as we need to skip over it
- # if it comes before the darcs command
- if ($arg eq "-q") {
- $verbose = 1;
- }
- elsif ($arg eq "-s") {
- $verbose = 0;
- }
- elsif ($arg eq "-r") {
- $defaultrepo = shift;
- }
- elsif ($arg eq "-i") {
- $ignore_failure = 1;
- }
- # --nofib tells get to also grab the nofib repo.
- # It has no effect on the other commands.
- elsif ($arg eq "--nofib") {
- $tags{"nofib"} = 1;
- }
- elsif ($arg eq "--no-nofib") {
- $tags{"nofib"} = 0;
- }
- # --testsuite tells get to also grab the testsuite repo.
- # It has no effect on the other commands.
- elsif ($arg eq "--testsuite") {
- $tags{"testsuite"} = 1;
- }
- elsif ($arg eq "--no-testsuite") {
- $tags{"testsuite"} = 0;
- }
- # --dph tells get to also grab the dph repo.
- # It has no effect on the other commands.
- elsif ($arg eq "--dph") {
- $tags{"dph"} = 1;
- }
- elsif ($arg eq "--no-dph") {
- $tags{"dph"} = 0;
- }
- # --extralibs tells get to also grab the extra repos.
- # It has no effect on the other commands.
- elsif ($arg eq "--extra") {
- $tags{"extra"} = 1;
- }
- elsif ($arg eq "--no-extra") {
- $tags{"extra"} = 0;
- }
- # Use --checked-out if the remote repos are a checked-out tree,
- # rather than the master trees.
- elsif ($arg eq "--checked-out") {
- $checked_out_flag = 1;
- }
- else {
- unshift @_, $arg;
- if (grep /^-q$/, @_) {
- $verbose = 1;
- }
- last;
- }
- }
-
- if ($#_ eq -1) {
- die "What do you want to do?";
- }
- my $command = $_[0];
- parsePackages;
- if ($command eq "get") {
- darcsget @_;
- }
- elsif ($command eq "upstreampull") {
- shift;
- darcsupstreampull @_;
- }
- else {
- if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) {
- # Hack around whatsnew failing if there are no changes
- $ignore_failure = 1;
- }
- if ($command =~ /^(pul|pus|sen|put|opt)/) {
- $want_remote_repo = 1;
- }
- darcsall @_;
- }
-}
-
-END {
- my $ec = $?;
-
- message "== Checking for old bytestring repo";
- if (-d "libraries/bytestring/_darcs") {
- if ((system "darcs annotate --repodir libraries/bytestring --match 'hash 20080118173113-3fd76-d5b74c04372a297b585ebea4e16d524551ce5035' > /dev/null 2> /dev/null") == 0) {
- print <<EOF;
-============================
-ATTENTION!
-
-You have an old bytestring repository in your GHC tree!
-
-Please remove it (e.g. "rm -r libraries/bytestring"), and the new
-version of bytestring will be used from a tarball instead.
-============================
-EOF
- }
- }
-
- message "== Checking for bytestring tarball";
- if (-d "libraries/bytestring" && not -d "libraries/bytestring/_darcs") {
- print <<EOF;
-============================
-ATTENTION!
-
-You have an old bytestring in your GHC tree!
-
-Please remove it (e.g. "rm -r libraries/bytestring"), and then run
-"./darcs-all get" to get the darcs repository.
-============================
-EOF
- }
-
- message "== Checking for unpulled tarball patches";
- if ((system "darcs annotate --match 'hash 20090930200358-3fd76-cab3bf4a0a9e3902eb6dd41f71712ad3a6a9bcd1' > /dev/null 2> /dev/null") == 0) {
- print <<EOF;
-============================
-ATTENTION!
-
-You have the unpulled tarball patches in your GHC tree!
-
-Please remove them:
- darcs unpull -p "Use mingw tarballs to get mingw on Windows"
-and say yes to each patch.
-============================
-EOF
- }
-
- $? = $ec;
-}
-
-main(@ARGV);
-
<entry>-</entry>
</row>
<row>
- <entry><option>-keep-raw-s-file</option> or
- <option>-keep-raw-s-files</option></entry>
- <entry>retain intermediate <literal>.raw_s</literal> files</entry>
- <entry>dynamic</entry>
- <entry>-</entry>
- </row>
- <row>
<entry><option>-keep-tmp-files</option></entry>
<entry>retain all intermediate temporary files</entry>
<entry>dynamic</entry>
<row>
<entry><option>-package-name</option> <replaceable>P</replaceable></entry>
<entry>Compile to be part of package <replaceable>P</replaceable></entry>
- <entry>dynamic</entry>
+ <entry>static</entry>
<entry>-</entry>
</row>
<row>
</row>
</row>
<row>
- <entry><option>-pgmm</option> <replaceable>cmd</replaceable></entry>
- <entry>Use <replaceable>cmd</replaceable> as the mangler</entry>
- <entry>dynamic</entry>
- <entry>-</entry>
- </row>
- <row>
<entry><option>-pgms</option> <replaceable>cmd</replaceable></entry>
<entry>Use <replaceable>cmd</replaceable> as the splitter</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
<row>
- <entry><option>-fno-asm-mangling</option></entry>
- <entry>Turn off assembly mangling (use <option>-unreg</option> instead)</entry>
- <entry>dynamic</entry>
- <entry>-</entry>
- </row>
- <row>
<entry><option>-fno-ghci-sandbox</option></entry>
<entry>Turn off the GHCi sandbox. Means computations are run in teh main thread, rather than a forked thread.</entry>
<entry>dynamic</entry>
<varlistentry>
<term>
- <option>-pgmm</option> <replaceable>cmd</replaceable>
- <indexterm><primary><option>-pgmm</option></primary></indexterm>
- </term>
- <listitem>
- <para>Use <replaceable>cmd</replaceable> as the
- mangler.</para>
- </listitem>
- </varlistentry>
-
- <varlistentry>
- <term>
<option>-pgms</option> <replaceable>cmd</replaceable>
<indexterm><primary><option>-pgms</option></primary></indexterm>
</term>
<varlistentry>
<term>
- <option>-keep-raw-s-file</option>,
- <option>-keep-raw-s-files</option>
- <indexterm><primary><option>-keep-raw-s-file</option></primary></indexterm>
- <indexterm><primary><option>-keep-raw-s-files</option></primary></indexterm>
- </term>
- <listitem>
- <para>Keep intermediate <literal>.raw-s</literal> files.
- These are the direct output from the C compiler, before
- GHC does “assembly mangling” to produce the
- <literal>.s</literal> file. Again, these are not produced
- when using the native code generator.</para>
- </listitem>
- </varlistentry>
-
- <varlistentry>
- <term>
<option>-keep-tmp-files</option>
<indexterm><primary><option>-keep-tmp-files</option></primary></indexterm>
<indexterm><primary>temporary files</primary><secondary>keeping</secondary></indexterm>
</listitem>
</varlistentry>
- <varlistentry>
- <term><option>-monly-[32]-regs</option>:</term>
- <listitem>
- <para>(x86 only)<indexterm><primary>-monly-N-regs
- option (iX86 only)</primary></indexterm> GHC tries to
- “steal” four registers from GCC, for performance
- reasons; it almost always works. However, when GCC is
- compiling some modules with four stolen registers, it will
- crash, probably saying:
-
-<screen>
-Foo.hc:533: fixed or forbidden register was spilled.
-This may be due to a compiler bug or to impossible asm
-statements or clauses.
-</screen>
-
- Just give some registers back with
- <option>-monly-N-regs</option>. Try `3' first, then `2'.
- If `2' doesn't work, please report the bug to us.</para>
- </listitem>
- </varlistentry>
</variablelist>
</sect1>
+++ /dev/null
-# -----------------------------------------------------------------------------
-#
-# (c) 2009 The University of Glasgow
-#
-# This file is part of the GHC build system.
-#
-# To understand how the build system works and how to modify it, see
-# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture
-# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying
-#
-# -----------------------------------------------------------------------------
-
-dir = driver/mangler
-TOP = ../..
-include $(TOP)/mk/sub-makefile.mk
+++ /dev/null
-%************************************************************************
-%* *
-\section[Driver-asm-fiddling]{Fiddling with assembler files}
-%* *
-%************************************************************************
-
-Tasks:
-\begin{itemize}
-\item
-Utterly stomp out C functions' prologues and epilogues; i.e., the
-stuff to do with the C stack.
-\item
-Any other required tidying up.
-\end{itemize}
-
-General note [chak]: Many regexps are very fragile because they rely on white
-space being in the right place. This caused trouble with gcc 2.95 (at least
-on Linux), where the use of white space in .s files generated by gcc suddenly
-changed. To guarantee compatibility across different versions of gcc, make
-sure (at least on i386-.*-linux) that regexps tolerate varying amounts of white
-space between an assembler statement and its arguments as well as after a the
-comma separating multiple arguments.
-
-\emph{For the time being, I have corrected the regexps for i386-.*-linux. I
-didn't touch all the regexps for other i386 platforms, as I don't have
-a box to test these changes.}
-
-HPPA specific notes:
-\begin{itemize}
-\item
-The HP linker is very picky about symbols being in the appropriate
-space (code vs. data). When we mangle the threaded code to put the
-info tables just prior to the code, they wind up in code space
-rather than data space. This means that references to *_info from
-un-mangled parts of the RTS (e.g. unthreaded GC code) get
-unresolved symbols. Solution: mini-mangler for .c files on HP. I
-think this should really be triggered in the driver by a new -rts
-option, so that user code doesn't get mangled inappropriately.
-\item
-With reversed tables, jumps are to the _info label rather than to
-the _entry label. The _info label is just an address in code
-space, rather than an entry point with the descriptive blob we
-talked about yesterday. As a result, you can't use the call-style
-JMP_ macro. However, some JMP_ macros take _info labels as targets
-and some take code entry points within the RTS. The latter won't
-work with the goto-style JMP_ macro. Sigh. Solution: Use the goto
-style JMP_ macro, and mangle some more assembly, changing all
-"RP'literal" and "LP'literal" references to "R'literal" and
-"L'literal," so that you get the real address of the code, rather
-than the descriptive blob. Also change all ".word P%literal"
-entries in info tables and vector tables to just ".word literal,"
-for the same reason. Advantage: No more ridiculous call sequences.
-\end{itemize}
-
-%************************************************************************
-%* *
-\subsection{Top-level code}
-%* *
-%************************************************************************
-
-\begin{code}
-$TargetPlatform = $TARGETPLATFORM;
-
-($Pgm = $0) =~ s|.*/||m;
-$ifile = $ARGV[0];
-$ofile = $ARGV[1];
-
-if ( $TargetPlatform =~ /^i386-/m ) {
- if ($ARGV[2] eq '') {
- $StolenX86Regs = 4;
- } else {
- $StolenX86Regs = $ARGV[2];
- }
-}
-
-&mangle_asm($ifile,$ofile);
-
-exit(0);
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Constants for various architectures}
-%* *
-%************************************************************************
-
-\begin{code}
-sub init_TARGET_STUFF {
-
- #--------------------------------------------------------#
- if ( $TargetPlatform =~ /^alpha-.*-.*/m ) {
-
- $T_STABBY = 0; # 1 iff .stab things (usually if a.out format)
- $T_US = ''; # _ if symbols have an underscore on the front
- $T_PRE_APP = 'DONT THINK THIS APPLIES'; # regexp that says what comes before APP/NO_APP
- $T_CONST_LBL = '^\$L?C(\d+):$'; # regexp for what such a lbl looks like
- $T_POST_LBL = ':';
-
- $T_MOVE_DIRVS = '^(\s*(\$.*\.\.ng:|\.align\s+\d+|\.(globl|ent)\s+\S+|\#.*|\.(file|loc)\s+\S+\s+\S+|\.text|\.r?data)\n)';
- $T_COPY_DIRVS = '^\s*(\$.*\.\.ng:|\#|\.(file|globl|ent|loc))';
-
- $T_DOT_WORD = '\.(long|quad|byte|word)';
- $T_DOT_GLOBAL = '^\t\.globl';
- $T_HDR_literal = "\.rdata\n\t\.align 3\n";
- $T_HDR_misc = "\.text\n\t\.align 3\n";
- $T_HDR_data = "\.data\n\t\.align 3\n";
- $T_HDR_rodata = "\.rdata\n\t\.align 3\n";
- $T_HDR_closure = "\.data\n\t\.align 3\n";
- $T_HDR_info = "\.text\n\t\.align 3\n";
- $T_HDR_entry = "\.text\n\t\.align 3\n";
- $T_HDR_vector = "\.text\n\t\.align 3\n";
-
- #--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^hppa/m ) {
-
- $T_STABBY = 0; # 1 iff .stab things (usually if a.out format)
- $T_US = ''; # _ if symbols have an underscore on the front
- $T_PRE_APP = 'DONT THINK THIS APPLIES'; # regexp that says what comes before APP/NO_APP
- $T_CONST_LBL = '^L\$C(\d+)$'; # regexp for what such a lbl looks like
- $T_POST_LBL = '';
-
- $T_MOVE_DIRVS = '^((\s+\.(IMPORT|EXPORT|PARAM).*|\s+\.align\s+\d+|\s+\.(SPACE|SUBSPA)\s+\S+|\s*)\n)';
- $T_COPY_DIRVS = '^\s+\.(IMPORT|EXPORT)';
-
- $T_DOT_WORD = '\.(blockz|word|half|byte)';
- $T_DOT_GLOBAL = '^\s+\.EXPORT';
- $T_HDR_literal = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$LIT\$\n";
- $T_HDR_misc = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
- $T_HDR_data = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n";
- $T_HDR_rodata = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n";
- $T_HDR_closure = "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$DATA\$\n\t\.align 4\n";
- $T_HDR_info = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
- $T_HDR_entry = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
- $T_HDR_vector = "\t.SPACE \$TEXT\$\n\t.SUBSPA \$CODE\$\n\t\.align 4\n";
-
- #--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^i386-.*-(linuxaout|freebsd2|nextstep3|cygwin32|mingw32)$/m ) {
- # NeXT added but not tested. CaS
-
- $T_STABBY = 1; # 1 iff .stab things (usually if a.out format)
- $T_US = '_'; # _ if symbols have an underscore on the front
- $T_PRE_APP = '^#'; # regexp that says what comes before APP/NO_APP
- $T_CONST_LBL = '^LC(\d+):$';
- $T_POST_LBL = ':';
- $T_X86_PRE_LLBL_PAT = 'L';
- $T_X86_PRE_LLBL = 'L';
- $T_X86_BADJMP = '^\tjmp [^L\*]';
-
- $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s.*|\.globl\s+\S+|\.text|\.data|\.stab[^n].*|\.type\s+.*|\.size\s+.*|\.lcomm.*)\n)';
- $T_COPY_DIRVS = '\.(globl|stab|lcomm)';
- $T_DOT_WORD = '\.(long|word|value|byte|space)';
- $T_DOT_GLOBAL = '\.globl';
- $T_HDR_literal = "\.text\n\t\.align 4\n";
- $T_HDR_misc = "\.text\n\t\.align 4,0x90\n";
- $T_HDR_data = "\.data\n\t\.align 4\n";
- $T_HDR_rodata = "\.text\n\t\.align 4\n";
- $T_HDR_closure = "\.data\n\t\.align 4\n";
- $T_HDR_info = "\.text\n\t\.align 4\n"; # NB: requires padding
- $T_HDR_entry = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?)
- $T_HDR_vector = "\.text\n\t\.align 4\n"; # NB: requires padding
-
- #--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^i386-.*-(solaris2|linux|gnu|freebsd|dragonfly|netbsd|openbsd|kfreebsdgnu)$/m ) {
-
- $T_STABBY = 0; # 1 iff .stab things (usually if a.out format)
- $T_US = ''; # _ if symbols have an underscore on the front
- $T_PRE_APP = # regexp that says what comes before APP/NO_APP
- ($TargetPlatform =~ /-(linux|gnu|freebsd|dragonfly|netbsd|openbsd)$/m) ? '#' : '/' ;
- $T_CONST_LBL = '^\.LC(\d+):$'; # regexp for what such a lbl looks like
- $T_POST_LBL = ':';
- $T_X86_PRE_LLBL_PAT = '\.L';
- $T_X86_PRE_LLBL = '.L';
- $T_X86_BADJMP = '^\tjmp\s+[^\.\*]';
-
- $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s.*|\.globl\s+\S+|\.text|\.data|\.section\s+.*|\.type\s+.*|\.size\s+\S+\s*,\s*\d+|\.ident.*|\.local.*)\n)';
- if ( $TargetPlatform =~ /solaris2/m ) {
- # newer Solaris linkers are picky about .size information, so
- # omit it (see #1421)
- $T_COPY_DIRVS = '^\s*\.(globl|local)';
- } else {
- $T_COPY_DIRVS = '^\s*\.(globl|type|size|local)';
- }
-
- $T_DOT_WORD = '\.(long|value|word|byte|zero)';
- $T_DOT_GLOBAL = '\.globl';
- $T_HDR_literal = "\.section\t\.rodata\n"; # or just use .text??? (WDP 95/11)
- $T_HDR_misc = "\.text\n\t\.align 4\n";
- $T_HDR_data = "\.data\n\t\.align 4\n";
- $T_HDR_rodata = "\.section\t\.rodata\n\t\.align 4\n";
- $T_HDR_closure = "\.data\n\t\.align 4\n";
- $T_HDR_info = "\.text\n\t\.align 4\n";
- $T_HDR_entry = "\.text\n"; # no .align so we're right next to _info (arguably wrong...?)
- $T_HDR_vector = "\.text\n\t\.align 4\n"; # NB: requires padding
-
- #--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^ia64-.*-linux$/m ) {
-
- $T_STABBY = 0; # 1 iff .stab things (usually if a.out format)
- $T_US = ''; # _ if symbols have an underscore on the front
- $T_PRE_APP = '#';
- $T_CONST_LBL = '^\.LC(\d+):$'; # regexp for what such a lbl looks like
- $T_POST_LBL = ':';
-
- $T_MOVE_DIRVS = '^(\s*\.(global|proc|pred\.safe_across_calls|text|data|section|subsection|align|size|type|ident)\s+.*\n)';
- $T_COPY_DIRVS = '\.(global|proc)';
-
- $T_DOT_WORD = '\.(long|value|byte|zero)';
- $T_DOT_GLOBAL = '\.global';
- $T_HDR_literal = "\.section\t\.rodata\n";
- $T_HDR_misc = "\.text\n\t\.align 16\n"; # May contain code; align like 'entry'
- $T_HDR_data = "\.data\n\t\.align 8\n";
- $T_HDR_rodata = "\.section\t\.rodata\n\t\.align 8\n";
- $T_HDR_closure = "\.data\n\t\.align 8\n";
- $T_HDR_info = "\.text\n\t\.align 8\n";
- $T_HDR_entry = "\.text\n\t\.align 16\n";
- $T_HDR_vector = "\.text\n\t\.align 8\n";
-
- #--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^x86_64-.*-(linux|openbsd|freebsd|dragonfly|netbsd|kfreebsdgnu)$/m ) {
-
- $T_STABBY = 0; # 1 iff .stab things (usually if a.out format)
- $T_US = ''; # _ if symbols have an underscore on the front
- $T_PRE_APP = '#';
- $T_CONST_LBL = '^\.LC(\d+):$'; # regexp for what such a lbl looks like
- $T_POST_LBL = ':';
-
- $T_MOVE_DIRVS = '^(\s*\.(globl|text|data|section|align|size|type|ident|local)([ \t].*)?\n)';
- $T_COPY_DIRVS = '\.(globl|type|size|local)';
-
- $T_DOT_WORD = '\.(quad|long|value|byte|zero)';
- $T_DOT_GLOBAL = '\.global';
-
- $T_HDR_literal16 = "\.section\t\.rodata.cst16\n\t.align 16\n";
- $T_HDR_literal = "\.section\t\.rodata\n";
-
- $T_HDR_misc = "\.text\n\t\.align 8\n";
- $T_HDR_data = "\.data\n\t\.align 8\n";
- $T_HDR_rodata = "\.section\t\.rodata\n\t\.align 8\n";
-
- # the assembler on x86_64/Linux refuses to generate code for
- # .quad x - y
- # where x is in the text section and y in the rodata section.
- # It works if y is in the text section, though. This is probably
- # going to cause difficulties for PIC, I imagine.
- #
- # See Note [x86-64-relative] in includes/InfoTables.h
- $T_HDR_relrodata= "\.text\n\t\.align 8\n";
-
- $T_HDR_closure = "\.data\n\t\.align 8\n";
- $T_HDR_info = "\.text\n\t\.align 8\n";
- $T_HDR_entry = "\.text\n\t\.align 8\n";
- $T_HDR_vector = "\.text\n\t\.align 8\n";
-
- #--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^m68k-.*-sunos4/m ) {
-
- $T_STABBY = 1; # 1 iff .stab things (usually if a.out format)
- $T_US = '_'; # _ if symbols have an underscore on the front
- $T_PRE_APP = '^# MAY NOT APPLY'; # regexp that says what comes before APP/NO_APP
- $T_CONST_LBL = '^LC(\d+):$';
- $T_POST_LBL = ':';
-
- $T_MOVE_DIRVS = '^(\s*(\.align\s+\d+|\.proc\s+\d+|\.const|\.cstring|\.globl\s+\S+|\.text|\.data|\.even|\.stab[^n].*)\n)';
- $T_COPY_DIRVS = '\.(globl|proc|stab)';
-
- $T_DOT_WORD = '\.long';
- $T_DOT_GLOBAL = '\.globl';
- $T_HDR_literal = "\.text\n\t\.even\n";
- $T_HDR_misc = "\.text\n\t\.even\n";
- $T_HDR_data = "\.data\n\t\.even\n";
- $T_HDR_rodata = "\.text\n\t\.even\n";
- $T_HDR_closure = "\.data\n\t\.even\n";
- $T_HDR_info = "\.text\n\t\.even\n";
- $T_HDR_entry = "\.text\n\t\.even\n";
- $T_HDR_vector = "\.text\n\t\.even\n";
-
- #--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^mips-.*/m ) {
-
- $T_STABBY = 0; # 1 iff .stab things (usually if a.out format)
- $T_US = ''; # _ if symbols have an underscore on the front
- $T_PRE_APP = '^\s*#'; # regexp that says what comes before APP/NO_APP
- $T_CONST_LBL = '^\$LC(\d+):$'; # regexp for what such a lbl looks like
- $T_POST_LBL = ':';
-
- $T_MOVE_DIRVS = '^(\s*(\.align\s+\d+|\.(globl|ent)\s+\S+|\.text|\.r?data)\n)';
- $T_COPY_DIRVS = '\.(globl|ent)';
-
- $T_DOT_WORD = '\.word';
- $T_DOT_GLOBAL = '^\t\.globl';
- $T_HDR_literal = "\t\.rdata\n\t\.align 2\n";
- $T_HDR_misc = "\t\.text\n\t\.align 2\n";
- $T_HDR_data = "\t\.data\n\t\.align 2\n";
- $T_HDR_rodata = "\t\.rdata\n\t\.align 2\n";
- $T_HDR_closure = "\t\.data\n\t\.align 2\n";
- $T_HDR_info = "\t\.text\n\t\.align 2\n";
- $T_HDR_entry = "\t\.text\n\t\.align 2\n";
- $T_HDR_vector = "\t\.text\n\t\.align 2\n";
-
- #--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^powerpc-apple-darwin.*/m ) {
- # Apple PowerPC Darwin/MacOS X.
- $T_STABBY = 0; # 1 iff .stab things (usually if a.out format)
- $T_US = '_'; # _ if symbols have an underscore on the front
- $T_PRE_APP = 'DOESNT APPLY'; # regexp that says what comes before APP/NO_APP
- $T_CONST_LBL = '^\LC\d+:'; # regexp for what such a lbl looks like
- $T_POST_LBL = ':';
-
- $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s.*|\.text|\.data|\.const_data|\.cstring|\.non_lazy_symbol_pointer|\.const|\.static_const|\.literal4|\.literal8|\.static_data|\.globl \S+|\.section .*|\.lcomm.*)\n)';
- $T_COPY_DIRVS = '\.(globl|lcomm)';
-
- $T_DOT_WORD = '\.(long|short|byte|fill|space)';
- $T_DOT_GLOBAL = '\.globl';
- $T_HDR_toc = "\.toc\n";
- $T_HDR_literal = "\t\.const\n\t\.align 2\n";
- $T_HDR_misc = "\t\.text\n\t\.align 2\n";
- $T_HDR_data = "\t\.data\n\t\.align 2\n";
- $T_HDR_rodata = "\t\.const\n\t\.align 2\n";
- $T_HDR_relrodata= "\t\.const_data\n\t\.align 2\n";
- $T_HDR_closure = "\t\.data\n\t\.align 2\n";
- $T_HDR_info = "\t\.text\n\t\.align 2\n";
- $T_HDR_entry = "\t\.text\n\t\.align 2\n";
- $T_HDR_vector = "\t\.text\n\t\.align 2\n";
-
- #--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^i386-apple-darwin.*/m ) {
- # Apple i386 Darwin/MacOS X.
- $T_STABBY = 0; # 1 iff .stab things (usually if a.out format)
- $T_US = '_'; # _ if symbols have an underscore on the front
- $T_PRE_APP = 'DOESNT APPLY'; # regexp that says what comes before APP/NO_APP
- $T_CONST_LBL = '^\LC\d+:'; # regexp for what such a lbl looks like
- $T_POST_LBL = ':';
- $T_X86_PRE_LLBL_PAT = 'L';
- $T_X86_PRE_LLBL = 'L';
- $T_X86_BADJMP = '^\tjmp [^L\*]';
-
- $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s.*|\.text|\.data|\.const_data|\.cstring|\.non_lazy_symbol_pointer|\.const|\.static_const|\.literal4|\.literal8|\.static_data|\.globl \S+|\.section .*|\.lcomm.*)\n)';
- $T_COPY_DIRVS = '\.(globl|lcomm)';
-
- $T_DOT_WORD = '\.(long|short|byte|fill|space)';
- $T_DOT_GLOBAL = '\.globl';
- $T_HDR_toc = "\.toc\n";
- $T_HDR_literal16= "\t\.literal8\n\t\.align 4\n";
- $T_HDR_literal = "\t\.const\n\t\.align 4\n";
- $T_HDR_misc = "\t\.text\n\t\.align 2\n";
- $T_HDR_data = "\t\.data\n\t\.align 2\n";
- $T_HDR_rodata = "\t\.const\n\t\.align 2\n";
- $T_HDR_relrodata= "\t\.const_data\n\t\.align 2\n";
- $T_HDR_closure = "\t\.data\n\t\.align 2\n";
- $T_HDR_info = "\t\.text\n\t\.align 2\n";
- $T_HDR_entry = "\t\.text\n\t\.align 2\n";
- $T_HDR_vector = "\t\.text\n\t\.align 2\n";
-
- #--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^x86_64-apple-darwin.*/m ) {
- # Apple amd64 Darwin/MacOS X.
- $T_STABBY = 0; # 1 iff .stab things (usually if a.out format)
- $T_US = '_'; # _ if symbols have an underscore on the front
- $T_PRE_APP = 'DOESNT APPLY'; # regexp that says what comes before APP/NO_APP
- $T_CONST_LBL = '^\LC\d+:'; # regexp for what such a lbl looks like
- $T_POST_LBL = ':';
-
- $T_MOVE_DIRVS = '^(\s*(\.align \d+|\.text|\.data|\.const_data|\.cstring|\.non_lazy_symbol_pointer|\.const|\.static_const|\.literal4|\.literal8|\.static_data|\.globl \S+|\.section .*|\.lcomm.*)\n)';
- $T_COPY_DIRVS = '\.(globl|lcomm)';
-
- $T_DOT_WORD = '\.(quad|long|short|byte|fill|space)';
- $T_DOT_GLOBAL = '\.globl';
- $T_HDR_toc = "\.toc\n";
- $T_HDR_literal16= "\t\.literal8\n\t\.align 4\n";
- $T_HDR_literal = "\t\.const\n\t\.align 4\n";
- $T_HDR_misc = "\t\.text\n\t\.align 2\n";
- $T_HDR_data = "\t\.data\n\t\.align 2\n";
- $T_HDR_rodata = "\t\.const\n\t\.align 2\n";
- $T_HDR_relrodata= "\t\.const_data\n\t\.align 2\n";
- $T_HDR_closure = "\t\.data\n\t\.align 2\n";
- $T_HDR_info = "\t\.text\n\t\.align 2\n";
- $T_HDR_entry = "\t\.text\n\t\.align 2\n";
- $T_HDR_vector = "\t\.text\n\t\.align 2\n";
-
- #--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^powerpc-.*-linux/m ) {
- # PowerPC Linux
- $T_STABBY = 0; # 1 iff .stab things (usually if a.out format)
- $T_US = ''; # _ if symbols have an underscore on the front
- $T_PRE_APP = '^#'; # regexp that says what comes before APP/NO_APP
- $T_CONST_LBL = '^\.LC\d+:'; # regexp for what such a lbl looks like
- $T_POST_LBL = ':';
-
- $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s+\d+(,\s*0x90)?|\.globl\s+\S+|\.text|\.data|\.section\s+.*|\.type\s+.*|\.size\s+\S+\s*,\s*\d+|\.ident.*|\.local.*)\n)';
- $T_COPY_DIRVS = '^\s*\.(globl|type|size|local)';
-
- $T_DOT_WORD = '\.(long|short|byte|fill|space)';
- $T_DOT_GLOBAL = '\.globl';
- $T_HDR_toc = "\.toc\n";
- $T_HDR_literal = "\t\.section\t.rodata\n\t\.align 2\n";
- $T_HDR_misc = "\t\.text\n\t\.align 2\n";
- $T_HDR_data = "\t\.data\n\t\.align 2\n";
- $T_HDR_rodata = "\t\.section\t.rodata\n\t\.align 2\n";
- $T_HDR_closure = "\t\.data\n\t\.align 2\n";
- $T_HDR_info = "\t\.text\n\t\.align 2\n";
- $T_HDR_entry = "\t\.text\n\t\.align 2\n";
- $T_HDR_vector = "\t\.text\n\t\.align 2\n";
-
- #--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^powerpc64-.*-linux/m ) {
- # PowerPC 64 Linux
- $T_STABBY = 0; # 1 iff .stab things (usually if a.out format)
- $T_US = '\.'; # _ if symbols have an underscore on the front
- $T_PRE_APP = '^#'; # regexp that says what comes before APP/NO_APP
- $T_CONST_LBL = '^\.LC\d+:'; # regexp for what such a lbl looks like
- $T_POST_LBL = ':';
-
- $T_MOVE_DIRVS = '^(\s*(\.(p2)?align\s+\d+(,\s*0x90)?|\.globl\s+\S+|\.text|\.data|\.section\s+.*|\.type\s+.*|\.size\s+\S+\s*,\s*\d+|\.ident.*|\.local.*)\n)';
- $T_COPY_DIRVS = '^\s*\.(globl|type|size|local)';
-
- $T_DOT_WORD = '\.(long|short|byte|fill|space)';
- $T_DOT_GLOBAL = '\.globl';
- $T_HDR_toc = "\.toc\n";
- $T_HDR_literal = "\t\.section\t\".toc\",\"aw\"\n";
- $T_HDR_misc = "\t\.text\n\t\.align 2\n";
- $T_HDR_data = "\t\.data\n\t\.align 2\n";
- $T_HDR_rodata = "\t\.section\t.rodata\n\t\.align 2\n";
- $T_HDR_closure = "\t\.data\n\t\.align 2\n";
- $T_HDR_info = "\t\.text\n\t\.align 2\n";
- $T_HDR_entry = "\t\.text\n\t\.align 2\n";
- $T_HDR_vector = "\t\.text\n\t\.align 2\n";
-
- #--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^sparc-.*-(solaris2|openbsd)/m ) {
-
- $T_STABBY = 0; # 1 iff .stab things (usually if a.out format)
- $T_US = ''; # _ if symbols have an underscore on the front
- $T_PRE_APP = 'DOES NOT SEEM TO APPLY'; # regexp that says what comes before APP/NO_APP
- $T_CONST_LBL = '^\.LLC(\d+):$'; # regexp for what such a lbl looks like
- $T_POST_LBL = ':';
-
- $T_MOVE_DIRVS = '^((\s+\.align\s+\d+|\s+\.proc\s+\d+|\s+\.global\s+\S+|\s+\.local\s+\S+|\.text|\.data|\.stab.*|\s*\.section.*|\s+\.type.*|\s+\.size.*)\n)';
- $T_COPY_DIRVS = '\.(global|local|proc|stab)';
-
- $T_DOT_WORD = '\.(long|word|byte|half|skip|uahalf|uaword)';
- $T_DOT_GLOBAL = '^\t\.global';
- $T_HDR_literal = "\.text\n\t\.align 8\n";
- $T_HDR_misc = "\.text\n\t\.align 4\n";
- $T_HDR_data = "\.data\n\t\.align 8\n";
- $T_HDR_rodata = "\.text\n\t\.align 4\n";
- $T_HDR_closure = "\.data\n\t\.align 4\n";
- $T_HDR_info = "\.text\n\t\.align 4\n";
- $T_HDR_entry = "\.text\n\t\.align 4\n";
- $T_HDR_vector = "\.text\n\t\.align 4\n";
-
- #--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^sparc-.*-sunos4/m ) {
-
- $T_STABBY = 1; # 1 iff .stab things (usually if a.out format)
- $T_US = '_'; # _ if symbols have an underscore on the front
- $T_PRE_APP = '^# DOES NOT SEEM TO APPLY'; # regexp that says what comes before APP/NO_APP
- $T_CONST_LBL = '^LC(\d+):$';
- $T_POST_LBL = ':';
-
- $T_MOVE_DIRVS = '^((\s+\.align\s+\d+|\s+\.proc\s+\d+|\s+\.global\s+\S+|\.text|\.data|\.stab.*)\n)';
- $T_COPY_DIRVS = '\.(global|proc|stab)';
-
- $T_DOT_WORD = '\.word';
- $T_DOT_GLOBAL = '^\t\.global';
- $T_HDR_literal = "\.text\n\t\.align 8\n";
- $T_HDR_misc = "\.text\n\t\.align 4\n";
- $T_HDR_data = "\.data\n\t\.align 8\n";
- $T_HDR_rodata = "\.text\n\t\.align 4\n";
- $T_HDR_closure = "\.data\n\t\.align 4\n";
- $T_HDR_info = "\.text\n\t\.align 4\n";
- $T_HDR_entry = "\.text\n\t\.align 4\n";
- $T_HDR_vector = "\.text\n\t\.align 4\n";
-
- #--------------------------------------------------------#
- } elsif ( $TargetPlatform =~ /^sparc-.*-linux/m ) {
- $T_STABBY = 0; # 1 iff .stab things (usually if a.out format)
- $T_US = ''; # _ if symbols have an underscore on the front
- $T_PRE_APP = '#'; # regexp that says what comes before APP/NO_APP
- # Probably doesn't apply anyway
- $T_CONST_LBL = '^\.LLC(\d+):$'; # regexp for what such a lbl looks like
- $T_POST_LBL = ':';
-
- $T_MOVE_DIRVS = '^((\s+\.align\s+\d+|\s+\.proc\s+\d+|\s+\.global\s+\S+|\s+\.local\s+\S+|\.text|\.data|\.seg|\.stab.*|\s+?\.section.*|\s+\.type.*|\s+\.size.*)\n)';
- $T_COPY_DIRVS = '\.(global|local|globl|proc|stab)';
-
- $T_DOT_WORD = '\.(long|word|nword|xword|byte|half|short|skip|uahalf|uaword)';
- $T_DOT_GLOBAL = '^\t\.global';
- $T_HDR_literal = "\.text\n\t\.align 8\n";
- $T_HDR_misc = "\.text\n\t\.align 4\n";
- $T_HDR_data = "\.data\n\t\.align 8\n";
- $T_HDR_rodata = "\.text\n\t\.align 4\n";
- $T_HDR_closure = "\.data\n\t\.align 4\n";
- $T_HDR_info = "\.text\n\t\.align 4\n";
- $T_HDR_entry = "\.text\n\t\.align 4\n";
- $T_HDR_vector = "\.text\n\t\.align 4\n";
-
- #--------------------------------------------------------#
- } else {
- print STDERR "$Pgm: don't know how to mangle assembly language for: $TargetPlatform\n";
- exit 1;
- }
-
- if($T_HDR_relrodata eq "") {
- # default values:
- # relrodata defaults to rodata.
- $T_HDR_relrodata = $T_HDR_rodata;
- }
-
-if ( 0 ) {
-print STDERR "T_STABBY: $T_STABBY\n";
-print STDERR "T_US: $T_US\n";
-print STDERR "T_PRE_APP: $T_PRE_APP\n";
-print STDERR "T_CONST_LBL: $T_CONST_LBL\n";
-print STDERR "T_POST_LBL: $T_POST_LBL\n";
-if ( $TargetPlatform =~ /^i386-/m ) {
- print STDERR "T_X86_PRE_LLBL_PAT: $T_X86_PRE_LLBL_PAT\n";
- print STDERR "T_X86_PRE_LLBL: $T_X86_PRE_LLBL\n";
- print STDERR "T_X86_BADJMP: $T_X86_BADJMP\n";
-}
-print STDERR "T_MOVE_DIRVS: $T_MOVE_DIRVS\n";
-print STDERR "T_COPY_DIRVS: $T_COPY_DIRVS\n";
-print STDERR "T_DOT_WORD: $T_DOT_WORD\n";
-print STDERR "T_HDR_literal: $T_HDR_literal\n";
-print STDERR "T_HDR_misc: $T_HDR_misc\n";
-print STDERR "T_HDR_data: $T_HDR_data\n";
-print STDERR "T_HDR_rodata: $T_HDR_rodata\n";
-print STDERR "T_HDR_closure: $T_HDR_closure\n";
-print STDERR "T_HDR_info: $T_HDR_info\n";
-print STDERR "T_HDR_entry: $T_HDR_entry\n";
-print STDERR "T_HDR_vector: $T_HDR_vector\n";
-}
-
-}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Mangle away}
-%* *
-%************************************************************************
-
-\begin{code}
-sub mangle_asm {
- local($in_asmf, $out_asmf) = @_;
- local($i, $c);
-
- # ia64-specific information for code chunks
- my $ia64_locnum;
- my $ia64_outnum;
-
- &init_TARGET_STUFF();
- &init_FUNNY_THINGS();
-
- open(INASM, "< $in_asmf")
- || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n");
- open(OUTASM,"> $out_asmf")
- || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n");
-
- # read whole file, divide into "chunks":
- # record some info about what we've found...
-
- @chk = (); # contents of the chunk
- $numchks = 0; # number of them
- @chkcat = (); # what category of thing in each chunk
- @chksymb = (); # what symbol(base) is defined in this chunk
- %entrychk = (); # ditto, its entry code
- %closurechk = (); # ditto, the (static) closure
- %srtchk = (); # ditto, its SRT (for top-level things)
- %infochk = (); # given a symbol base, say what chunk its info tbl is in
- %vectorchk = (); # ditto, return vector table
- $EXTERN_DECLS = ''; # .globl <foo> .text (MIPS only)
-
- $i = 0; $chkcat[0] = 'misc'; $chk[0] = '';
-
- while (<INASM>) {
- tr/\r//d if $TargetPlatform =~ /-mingw32$/m; # In case Perl doesn't convert line endings
- next if $T_STABBY && /^\.stab.*${T_US}__stg_split_marker/om;
- next if $T_STABBY && /^\.stab.*ghc.*c_ID/m;
- next if /^\t\.def.*endef$/m;
- next if /${T_PRE_APP}(NO_)?APP/om;
- next if /^;/m && $TargetPlatform =~ /^hppa/m;
-
- next if /(^$|^\t\.file\t|^ # )/m && $TargetPlatform =~ /(^mips-|^ia64-|-mingw32$)/m;
-
- if ( $TargetPlatform =~ /^mips-/m
- && /^\t\.(globl\S+\.text|comm\t)/m ) {
- $EXTERN_DECLS .= $_ unless /(__DISCARD__|\b(PK_|ASSIGN_)(FLT|DBL)\b)/m;
- # Treat .comm variables as data. These show up in two (known) places:
- #
- # - the module_registered variable used in the __stginit fragment.
- # even though these are declared static and initialised, gcc 3.3
- # likes to make them .comm, presumably to save space in the
- # object file.
- #
- # - global variables used to pass arguments from C to STG in
- # a foreign export. (is this still true? --SDM)
- #
- } elsif ( /^\t\.comm.*$/m ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'data';
- $chksymb[$i] = '';
-
- # Labels ending "_str": these are literal strings.
- } elsif ( /^${T_US}([A-Za-z0-9_]+)_str${T_POST_LBL}$/m ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'relrodata';
- $chksymb[$i] = '';
- } elsif ( $TargetPlatform =~ /-darwin/m
- && (/^\s*\.subsections_via_symbols/m
- ||/^\s*\.no_dead_strip.*/m)) {
- # Don't allow Apple's linker to do any dead-stripping of symbols
- # in this file, because it will mess up info-tables in mangled
- # code.
- # The .no_dead_strip directives are actually put there by
- # the gcc3 "used" attribute on entry points.
-
- } elsif ( $TargetPlatform =~ /^.*-apple-darwin.*/m && (
- /^\s*\.picsymbol_stub/m
- || /^\s*\.section __TEXT,__picsymbol_stub\d,.*/m
- || /^\s*\.section __TEXT,__picsymbolstub\d,.*/m
- || /^\s*\.symbol_stub/m
- || /^\s*\.section __TEXT,__symbol_stub\d,.*/m
- || /^\s*\.section __TEXT,__symbolstub\d,.*/m
- || /^\s*\.lazy_symbol_pointer/m
- || /^\s*\.non_lazy_symbol_pointer/m
- || /^\s*\.section __IMPORT.*/m))
- {
- $chk[++$i] = $_;
- $chkcat[$i] = 'dyld';
- $chksymb[$i] = '';
- $dyld_section = $_;
-
- } elsif ( $TargetPlatform =~ /^.*-apple-darwin.*/m && $chkcat[$i] eq 'dyld' && /^\s*\.data/m)
- { # non_lazy_symbol_ptrs that point to local symbols
- $chk[++$i] = $_;
- $chkcat[$i] = 'dyld';
- $chksymb[$i] = '';
- $dyld_section = $_;
- } elsif ( $TargetPlatform =~ /^.*-apple-darwin.*/m && $chkcat[$i] eq 'dyld' && /^\s*\.align/m)
- { # non_lazy_symbol_ptrs that point to local symbols
- $dyld_section .= $_;
- } elsif ( $TargetPlatform =~ /^.*-apple-darwin.*/m && $chkcat[$i] eq 'dyld' && /^L_.*:$/m)
- { # non_lazy_symbol_ptrs that point to local symbols
- $chk[++$i] = $dyld_section . $_;
- $chkcat[$i] = 'dyld';
- $chksymb[$i] = '';
-
- } elsif ( /^\s+/m ) { # most common case first -- a simple line!
- # duplicated from the bottom
-
- $chk[$i] .= $_;
-
- } elsif ( /\.\.ng:$/m && $TargetPlatform =~ /^alpha-/m ) {
- # Alphas: Local labels not to be confused with new chunks
- $chk[$i] .= $_;
- # NB: all the rest start with a non-space
-
- } elsif ( $TargetPlatform =~ /^mips-/m
- && /^\d+:/m ) { # a funny-looking very-local label
- $chk[$i] .= $_;
-
- } elsif ( /$T_CONST_LBL/om ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'literal';
- $chksymb[$i] = $1;
-
- } elsif ( /^${T_US}__stg_split_marker(\d*)${T_POST_LBL}$/om ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'splitmarker';
- $chksymb[$i] = $1;
-
- } elsif ( /^${T_US}([A-Za-z0-9_]+)_info${T_POST_LBL}$/om ) {
- $symb = $1;
- $chk[++$i] = $_;
- $chkcat[$i] = 'infotbl';
- $chksymb[$i] = $symb;
-
- die "Info table already? $symb; $i\n" if defined($infochk{$symb});
-
- $infochk{$symb} = $i;
-
- } elsif ( /^${T_US}([A-Za-z0-9_]+)_(entry|ret)${T_POST_LBL}$/om ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'entry';
- $chksymb[$i] = $1;
-
- $entrychk{$1} = $i;
-
- } elsif ( /^${T_US}([A-Za-z0-9_]+)_closure${T_POST_LBL}$/om ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'closure';
- $chksymb[$i] = $1;
-
- $closurechk{$1} = $i;
-
- } elsif ( /^${T_US}([A-Za-z0-9_]+)_srt${T_POST_LBL}$/om ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'srt';
- $chksymb[$i] = $1;
-
- $srtchk{$1} = $i;
-
- } elsif ( /^${T_US}([A-Za-z0-9_]+)_ct${T_POST_LBL}$/om ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'data';
- $chksymb[$i] = '';
-
- } elsif ( /^${T_US}(stg_ap_stack_entries|stg_stack_save_entries|stg_arg_bitmaps)${T_POST_LBL}$/om ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'data';
- $chksymb[$i] = '';
-
- } elsif ( /^(${T_US}__gnu_compiled_c|gcc2_compiled\.)${T_POST_LBL}/om ) {
- ; # toss it
-
- } elsif ( /^${T_US}[A-Za-z0-9_]+\.\d+${T_POST_LBL}$/om
- || /^${T_US}.*_CAT${T_POST_LBL}$/om # PROF: _entryname_CAT
- || /^${T_US}.*_done${T_POST_LBL}$/om # PROF: _module_done
- || /^${T_US}_module_registered${T_POST_LBL}$/om # PROF: _module_registered
- ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'data';
- $chksymb[$i] = '';
-
- } elsif ( /^([A-Za-z0-9_]+)\s+\.comm/m && $TargetPlatform =~ /^hppa/m ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'bss';
- $chksymb[$i] = '';
-
- } elsif ( /^${T_US}([A-Za-z0-9_]+)_cc(s)?${T_POST_LBL}$/om ) {
- # all CC_ symbols go in the data section...
- $chk[++$i] = $_;
- $chkcat[$i] = 'data';
- $chksymb[$i] = '';
-
- } elsif ( /^${T_US}([A-Za-z0-9_]+)_hpc${T_POST_LBL}$/om ) {
- # hpc shares tick boxes across modules
- $chk[++$i] = $_;
- $chkcat[$i] = 'data';
- $chksymb[$i] = '';
-
- } elsif ( /^${T_US}([A-Za-z0-9_]+)_(alt|dflt)${T_POST_LBL}$/om ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = '';
- } elsif ( /^${T_US}([A-Za-z0-9_]+)_vtbl${T_POST_LBL}$/om ) {
- $chk[++$i] = $_;
- $chkcat[$i] = 'vector';
- $chksymb[$i] = $1;
-
- $vectorchk{$1} = $i;
-
- } elsif ( $TargetPlatform =~ /^i386-.*-solaris2/m
- && /^[A-Za-z0-9][A-Za-z0-9_]*:/m ) {
- # Some Solaris system headers contain function definitions (as
- # opposed to mere prototypes), which end up in the .hc file when
- # a Haskell module foreign imports the corresponding system
- # functions (most notably stat()). We put them into the text
- # segment. Note that this currently does not extend to function
- # names starting with an underscore.
- # - chak 7/2001
- $chk[++$i] = $_;
- $chkcat[$i] = 'misc';
- $chksymb[$i] = $1;
-
- } elsif ( $TargetPlatform =~ /^i386-apple-darwin/m && /^(___i686\.get_pc_thunk\.[abcd]x):/om) {
- # To handle PIC on Darwin/x86, we need to appropriately pass through
- # the get_pc_thunk functions. The need to be put into a special section
- # marked as coalesced (otherwise the .weak_definition doesn't work
- # on Darwin).
- $chk[++$i] = $_;
- $chkcat[$i] = 'get_pc_thunk';
- $chksymb[$i] = $1;
-
- } elsif ( /^${T_US}[A-Za-z0-9_]/om
- && ( $TargetPlatform !~ /^hppa/m # need to avoid local labels in this case
- || ! /^L\$\d+$/m )
- && ( $TargetPlatform !~ /^powerpc64/m # we need to avoid local labels in this case
- || ! /^\.L\d+:$/m ) ) {
- local($thing);
- chop($thing = $_);
- $thing =~ s/:$//m;
- $chk[++$i] = $_;
- $chksymb[$i] = '';
- if (
- /^${T_US}stg_.*${T_POST_LBL}$/om # RTS internals
- || /^${T_US}__stg_.*${T_POST_LBL}$/om # more RTS internals
- || /^${T_US}__fexp_.*${T_POST_LBL}$/om # foreign export
- || /^${T_US}.*_slow${T_POST_LBL}$/om # slow entry
- || /^${T_US}__stginit.*${T_POST_LBL}$/om # __stginit<module>
- || /^${T_US}.*_btm${T_POST_LBL}$/om # large bitmaps
- || /^${T_US}.*_fast${T_POST_LBL}$/om # primops
- || /^_uname:/om # x86/Solaris2
- )
- {
- $chkcat[$i] = 'misc';
- } elsif (
- /^${T_US}.*_srtd${T_POST_LBL}$/om # large bitmaps
- || /^${T_US}.*_closure_tbl${T_POST_LBL}$/om # closure tables
- )
- {
- $chkcat[$i] = 'relrodata';
- } else
- {
- print STDERR "Warning: retaining unknown function \`$thing' in output from C compiler\n";
- $chkcat[$i] = 'unknown';
- }
-
- } elsif ( $TargetPlatform =~ /^powerpc-.*-linux/m && /^\.LCTOC1 = /om ) {
- # PowerPC Linux's large-model PIC (-fPIC) generates a gobal offset
- # table "by hand". Be sure to copy it over.
- # Note that this label and all entries in the table should actually
- # go into the .got2 section, but it isn't easy to distinguish them
- # from other constant literals (.LC\d+), so we just put everything
- # in .rodata.
- $chk[++$i] = $_;
- $chkcat[$i] = 'literal';
- $chksymb[$i] = 'LCTOC1';
- } else { # simple line (duplicated at the top)
-
- $chk[$i] .= $_;
- }
- }
- $numchks = $#chk + 1;
- $chk[$numchks] = ''; # We might push .note.GNU-stack into this
- $chkcat[$numchks] = 'verbatim'; # If we do, write it straight back out
-
- # open CHUNKS, ">/tmp/chunks1" or die "Cannot open /tmp/chunks1: $!\n";
- # for (my $i = 0; $i < @chk; ++$i) { print CHUNKS "======= $i =======\n", $chk[$i] }
- # close CHUNKS;
-
- # the division into chunks is imperfect;
- # we throw some things over the fence into the next
- # chunk.
- #
- # also, there are things we would like to know
- # about the whole module before we start spitting
- # output.
-
- local($FIRST_MANGLABLE) = ($TargetPlatform =~ /^(alpha-|hppa|mips-)/m) ? 1 : 0;
- local($FIRST_TOSSABLE ) = ($TargetPlatform =~ /^(hppa|mips-)/m) ? 1 : 0;
-
-# print STDERR "first chunk to mangle: $FIRST_MANGLABLE\n";
-
- # Alphas: NB: we start meddling at chunk 1, not chunk 0
- # The first ".rdata" is quite magical; as of GCC 2.7.x, it
- # spits a ".quad 0" in after the very first ".rdata"; we
- # detect this special case (tossing the ".quad 0")!
- local($magic_rdata_seen) = 0;
-
- # HPPAs, MIPSen: also start medding at chunk 1
-
- for ($i = $FIRST_TOSSABLE; $i < $numchks; $i++) {
- $c = $chk[$i]; # convenience copy
-
-# print STDERR "\nCHK $i (BEFORE) (",$chkcat[$i],"):\n", $c;
-
- # toss all prologue stuff; HPPA is pretty weird
- # (see elsewhere)
- $c = &hppa_mash_prologue($c) if $TargetPlatform =~ /^hppa-/m;
-
- undef $ia64_locnum;
- undef $ia64_outnum;
-
- # be slightly paranoid to make sure there's
- # nothing surprising in there
- if ( $c =~ /--- BEGIN ---/m ) {
- if (($p, $r) = split(/--- BEGIN ---/m, $c)) {
-
- # remove junk whitespace around the split point
- $p =~ s/\t+$//m;
- $r =~ s/^\s*\n//m;
-
- if ($TargetPlatform =~ /^i386-/m) {
- if ($p =~ /^\tsubl\s+\$(\d+),\s*\%esp\n/m) {
- if ($1 >= 8192) {
- die "Error: reserved stack space exceeded!\n Possible workarounds: compile with -fasm, or try another version of gcc.\n"
- }
- }
-
- # gcc 3.4.3 puts this kind of stuff in the prologue, eg.
- # when compiling PrimOps.cmm with -optc-O2:
- # xorl %ecx, %ecx
- # xorl %edx, %edx
- # movl %ecx, 16(%esp)
- # movl %edx, 20(%esp)
- # but then the code of the function doesn't assume
- # anything about the contnets of these stack locations.
- # I think it's to do with the use of inline functions for
- # PK_Word64() and friends, where gcc is initialising the
- # contents of the struct to zero, and failing to optimise
- # away the initialisation. Let's live dangerously and
- # discard these initalisations.
-
- $p =~ s/^\tpushl\s+\%e(di|si|bx)\n//gm;
- $p =~ s/^\txorl\s+\%e(ax|cx|dx),\s*\%e(ax|cx|dx)\n//gm;
- $p =~ s/^\tmovl\s+\%e(ax|cx|dx|si|di),\s*\d*\(\%esp\)\n//gm;
- $p =~ s/^\tmovl\s+\$\d+,\s*\d*\(\%esp\)\n//gm;
- $p =~ s/^\tsubl\s+\$\d+,\s*\%esp\n//m;
- $p =~ s/^\tmovl\s+\$\d+,\s*\%eax\n\tcall\s+__alloca\n//m if ($TargetPlatform =~ /^.*-(cygwin32|mingw32)/m);
-
- if ($TargetPlatform =~ /^i386-apple-darwin/m) {
- $pcrel_label = $p;
- $pcrel_label =~ s/(.|\n)*^(\"?L\d+\$pb\"?):\n(.|\n)*/$2/m or $pcrel_label = "";
- $pcrel_reg = $p;
- $pcrel_reg =~ s/(.|\n)*.*___i686\.get_pc_thunk\.([abcd]x)\n(.|\n)*/$2/m or $pcrel_reg = "";
- $p =~ s/^\s+call\s+___i686\.get_pc_thunk\..x//m;
- $p =~ s/^\"?L\d+\$pb\"?:\n//m;
-
- if ($pcrel_reg eq "bx") {
- # Bad gcc. Goes and uses %ebx, our BaseReg, for PIC. Bad gcc.
- die "Darwin/x86: -fPIC -via-C doesn't work yet, use -fasm. Aborting."
- }
- }
-
- } elsif ($TargetPlatform =~ /^x86_64-/m) {
- $p =~ s/^\tpushq\s+\%r(bx|bp|12|13|14)\n//gm;
- $p =~ s/^\tmovq\s+\%r(bx|bp|12|13|14),\s*\d*\(\%rsp\)\n//gm;
- $p =~ s/^\tsubq\s+\$\d+,\s*\%rsp\n//m;
-
- } elsif ($TargetPlatform =~ /^ia64-/m) {
- $p =~ s/^\t\.prologue .*\n//m;
-
- # Record the number of local and out registers for register relocation later
- $p =~ s/^\t\.save ar\.pfs, r\d+\n\talloc r\d+ = ar\.pfs, 0, (\d+), (\d+), 0\n//m;
- $ia64_locnum = $1;
- $ia64_outnum = $2;
-
- $p =~ s/^\t\.fframe \d+\n\tadds r12 = -\d+, r12\n//m;
- $p =~ s/^\t\.save rp, r\d+\n\tmov r\d+ = b0\n//m;
-
- # Ignore save/restore of these registers; they're taken
- # care of in StgRun()
- $p =~ s/^\t\.save ar\.lc, r\d+\n//m;
- $p =~ s/^\t\.save pr, r\d+\n//m;
- $p =~ s/^\tmov r\d+ = ar\.lc\n//m;
- $p =~ s/^\tmov r\d+ = pr\n//m;
-
- # Remove .proc and .body directives
- $p =~ s/^\t\.proc [a-zA-Z0-9_.]+#\n//m;
- $p =~ s/^\t\.body\n//m;
-
- # If there's a label, move it to the body
- if ($p =~ /^[a-zA-Z0-9.]+:\n/m) {
- $p = $` . $';
- $r = $& . $r;
- }
-
- # Remove floating-point spill instructions.
- # Only fp registers 2-5 and 16-23 are saved by the runtime.
- if ($p =~ s/^\tstf\.spill \[r1[4-9]\] = f([2-5]|1[6-9]|2[0-3])(, [0-9]+)?\n//gm) {
- # Being paranoid, only try to remove these if we saw a
- # spill operation.
- $p =~ s/^\tmov r1[4-9] = r12\n//m;
- $p =~ s/^\tadds r1[4-9] = -[0-9]+, r12\n//gm;
- $p =~ s/^\t\.save\.f 0x[0-9a-fA-F]\n//gm;
- $p =~ s/^\t\.save\.gf 0x0, 0x[0-9a-fA-F]+\n//gm;
- }
-
- $p =~ s/^\tnop(?:\.[mifb])?\s+\d+\n//gm; # remove nop instructions
- $p =~ s/^\t\.(mii|mmi|mfi)\n//gm; # bundling is no longer sensible
- $p =~ s/^\t;;\n//gm; # discard stops
- $p =~ s/^\t\/\/.*\n//gm; # gcc inserts timings in // comments
-
- # GCC 3.3 saves r1 in the prologue, move this to the body
- # (Does this register get restored anywhere?)
- if ($p =~ /^\tmov r\d+ = r1\n/m) {
- $p = $` . $';
- $r = $& . $r;
- }
- } elsif ($TargetPlatform =~ /^m68k-/m) {
- $p =~ s/^\tlink a6,#-?\d.*\n//m;
- $p =~ s/^\tpea a6@\n\tmovel sp,a6\n//m;
- # The above showed up in the asm code,
- # so I added it here.
- # I hope it's correct.
- # CaS
- $p =~ s/^\tmovel d2,sp\@-\n//m;
- $p =~ s/^\tmovel d5,sp\@-\n//m; # SMmark.* only?
- $p =~ s/^\tmoveml \#0x[0-9a-f]+,sp\@-\n//m; # SMmark.* only?
- } elsif ($TargetPlatform =~ /^mips-/m) {
- # the .frame/.mask/.fmask that we use is the same
- # as that produced by GCC for miniInterpret; this
- # gives GDB some chance of figuring out what happened
- $FRAME = "\t.frame\t\$sp,2168,\$31\n\t.mask\t0x90000000,-4\n\t.fmask\t0x00000000,0\n";
- $p =~ s/^\t\.(frame).*\n/__FRAME__/gm;
- $p =~ s/^\t\.(mask|fmask).*\n//gm;
- $p =~ s/^\t\.cprestore.*\n/\t\.cprestore 416\n/m; # 16 + 100 4-byte args
- $p =~ s/^\tsubu\t\$sp,\$sp,\d+\n//m;
- $p =~ s/^\tsw\t\$31,\d+\(\$sp\)\n//m;
- $p =~ s/^\tsw\t\$fp,\d+\(\$sp\)\n//m;
- $p =~ s/^\tsw\t\$28,\d+\(\$sp\)\n//m;
- $p =~ s/__FRAME__/$FRAME/m;
- } elsif ($TargetPlatform =~ /^powerpc-apple-darwin.*/m) {
- $pcrel_label = $p;
- $pcrel_label =~ s/(.|\n)*^(\"?L\d+\$pb\"?):\n(.|\n)*/$2/m or $pcrel_label = "";
-
- $p =~ s/^\tmflr r0\n//m;
- $p =~ s/^\tbl saveFP # f\d+\n//m;
- $p =~ s/^\tbl saveFP ; save f\d+-f\d+\n//m;
- $p =~ s/^\"?L\d+\$pb\"?:\n//m;
- $p =~ s/^\tstmw r\d+,-\d+\(r1\)\n//m;
- $p =~ s/^\tstfd f\d+,-\d+\(r1\)\n//gm;
- $p =~ s/^\tstw r0,\d+\(r1\)\n//gm;
- $p =~ s/^\tstwu r1,-\d+\(r1\)\n//m;
- $p =~ s/^\tstw r\d+,-\d+\(r1\)\n//gm;
- $p =~ s/^\tbcl 20,31,\"?L\d+\$pb\"?\n//m;
- $p =~ s/^\"?L\d+\$pb\"?:\n//m;
- $p =~ s/^\tmflr r31\n//m;
-
- # This is bad: GCC 3 seems to zero-fill some local variables in the prologue
- # under some circumstances, only when generating position dependent code.
- # I have no idea why, and I don't think it is necessary, so let's toss it.
- $p =~ s/^\tli r\d+,0\n//gm;
- $p =~ s/^\tstw r\d+,\d+\(r1\)\n//gm;
- } elsif ($TargetPlatform =~ /^powerpc-.*-linux/m) {
- $p =~ s/^\tmflr 0\n//m;
- $p =~ s/^\tstmw \d+,\d+\(1\)\n//m;
- $p =~ s/^\tstfd \d+,\d+\(1\)\n//gm;
- $p =~ s/^\tstw r0,8\(1\)\n//m;
- $p =~ s/^\tstwu 1,-\d+\(1\)\n//m;
- $p =~ s/^\tstw \d+,\d+\(1\)\n//gm;
-
- # GCC's "large-model" PIC (-fPIC)
- $pcrel_label = $p;
- $pcrel_label =~ s/(.|\n)*^.LCF(\d+):\n(.|\n)*/$2/m or $pcrel_label = "";
-
- $p =~ s/^\tbcl 20,31,.LCF\d+\n//m;
- $p =~ s/^.LCF\d+:\n//m;
- $p =~ s/^\tmflr 30\n//m;
- $p =~ s/^\tlwz 0,\.LCL\d+-\.LCF\d+\(30\)\n//m;
- $p =~ s/^\tadd 30,0,30\n//m;
-
- # This is bad: GCC 3 seems to zero-fill some local variables in the prologue
- # under some circumstances, only when generating position dependent code.
- # I have no idea why, and I don't think it is necessary, so let's toss it.
- $p =~ s/^\tli \d+,0\n//gm;
- $p =~ s/^\tstw \d+,\d+\(1\)\n//gm;
- } elsif ($TargetPlatform =~ /^powerpc64-.*-linux/m) {
- $p =~ s/^\tmr 31,1\n//m;
- $p =~ s/^\tmflr 0\n//m;
- $p =~ s/^\tstmw \d+,\d+\(1\)\n//m;
- $p =~ s/^\tstfd \d+,-?\d+\(1\)\n//gm;
- $p =~ s/^\tstd r0,8\(1\)\n//m;
- $p =~ s/^\tstdu 1,-\d+\(1\)\n//m;
- $p =~ s/^\tstd \d+,-?\d+\(1\)\n//gm;
-
- # This is bad: GCC 3 seems to zero-fill some local variables in the prologue
- # under some circumstances, only when generating position dependent code.
- # I have no idea why, and I don't think it is necessary, so let's toss it.
- $p =~ s/^\tli \d+,0\n//gm;
- $p =~ s/^\tstd \d+,\d+\(1\)\n//gm;
- } else {
- print STDERR "$Pgm: unknown prologue mangling? $TargetPlatform\n";
- }
-
- # HWL HACK: dont die, just print a warning
- #print stderr "HWL: this should die! Prologue junk?: $p\n" if $p =~ /^\t[^\.]/;
- die "Prologue junk?: $p\n" if $p =~ /^\s+[^\s\.]/m;
-
- # For PIC, we want to keep part of the prologue
- if ($TargetPlatform =~ /^powerpc-apple-darwin.*/m && $pcrel_label ne "") {
- # Darwin: load the current instruction pointer into register r31
- $p .= "bcl 20,31,$pcrel_label\n";
- $p .= "$pcrel_label:\n";
- $p .= "\tmflr r31\n";
- } elsif ($TargetPlatform =~ /^powerpc-.*-linux/m && $pcrel_label ne "") {
- # Linux: load the GOT pointer into register 30
- $p .= "\tbcl 20,31,.LCF$pcrel_label\n";
- $p .= ".LCF$pcrel_label:\n";
- $p .= "\tmflr 30\n";
- $p .= "\tlwz 0,.LCL$pcrel_label-.LCF$pcrel_label(30)\n";
- $p .= "\tadd 30,0,30\n";
- } elsif ($TargetPlatform =~ /^i386-apple-darwin.*/m && $pcrel_label ne "") {
- $p .= "\tcall ___i686.get_pc_thunk.$pcrel_reg\n";
- $p .= "$pcrel_label:\n";
- }
-
- # glue together what's left
- $c = $p . $r;
- }
- }
-
- if ( $TargetPlatform =~ /^mips-/m ) {
- # MIPS: first, this basic sequence may occur "--- END ---" or not
- $c =~ s/^\tlw\t\$31,\d+\(\$sp\)\n\taddu\t\$sp,\$sp,\d+\n\tj\t\$31\n\t\.end/\t\.end/m;
- }
-
- # toss all epilogue stuff; again, paranoidly
- if ( $c =~ /--- END ---/m ) {
- # Gcc may decide to replicate the function epilogue. We want
- # to process all epilogues, so we split the function and then
- # loop here.
- @fragments = split(/--- END ---/m, $c);
- $r = shift(@fragments);
-
- # Rebuild `c'; processed fragments will be appended to `c'
- $c = $r;
-
- foreach $e (@fragments) {
- # etail holds code that is after the epilogue in the assembly-code
- # layout and should not be filtered as part of the epilogue.
- $etail = "";
- if ($TargetPlatform =~ /^i386-/m) {
- $e =~ s/^\tret\n//m;
- $e =~ s/^\tpopl\s+\%edi\n//m;
- $e =~ s/^\tpopl\s+\%esi\n//m;
- $e =~ s/^\tpopl\s+\%edx\n//m;
- $e =~ s/^\tpopl\s+\%ecx\n//m;
- $e =~ s/^\taddl\s+\$\d+,\s*\%esp\n//m;
- $e =~ s/^\tsubl\s+\$-\d+,\s*\%esp\n//m;
- } elsif ($TargetPlatform =~ /^ia64-/m) {
- # The epilogue is first split into:
- # $e, the epilogue code (up to the return instruction)
- # $etail, non-epilogue code (after the return instruction)
- # The return instruction is stripped in the process.
- if (!(($e, $etail) = split(/^\tbr\.ret\.sptk\.many b0\n/m, $e))) {
- die "Epilogue doesn't seem to have one return instruction: $e\n";
- }
- # Remove 'endp' directive from the tail
- $etail =~ s/^\t\.endp [a-zA-Z0-9_.]+#\n//m;
-
- # If a return value is saved here, discard it
- $e =~ s/^\tmov r8 = r14\n//m;
-
- # Remove floating-point fill instructions.
- # Only fp registers 2-5 and 16-23 are saved by the runtime.
- if ($e =~ s/^\tldf\.fill f([2-5]|1[6-9]|2[0-3]) = \[r1[4-9]\](, [0-9]+)?\n//gm) {
- # Being paranoid, only try to remove this if we saw a fill
- # operation.
- $e =~ s/^\tadds r1[4-9] = [0-9]+, r12//gm;
- }
-
- $e =~ s/^\tnop(?:\.[mifb])?\s+\d+\n//gm; # remove nop instructions
- $e =~ s/^\tmov ar\.pfs = r\d+\n//m;
- $e =~ s/^\tmov ar\.lc = r\d+\n//m;
- $e =~ s/^\tmov pr = r\d+, -1\n//m;
- $e =~ s/^\tmov b0 = r\d+\n//m;
- $e =~ s/^\t\.restore sp\n\tadds r12 = \d+, r12\n//m;
- #$e =~ s/^\tbr\.ret\.sptk\.many b0\n//; # already removed
- $e =~ s/^\t\.(mii|mmi|mfi|mib)\n//gm; # bundling is no longer sensible
- $e =~ s/^\t;;\n//gm; # discard stops - stop at end of body is sufficient
- $e =~ s/^\t\/\/.*\n//gm; # gcc inserts timings in // comments
- } elsif ($TargetPlatform =~ /^m68k-/m) {
- $e =~ s/^\tunlk a6\n//m;
- $e =~ s/^\trts\n//m;
- } elsif ($TargetPlatform =~ /^mips-/m) {
- $e =~ s/^\tlw\t\$31,\d+\(\$sp\)\n//m;
- $e =~ s/^\tlw\t\$fp,\d+\(\$sp\)\n//m;
- $e =~ s/^\taddu\t\$sp,\$sp,\d+\n//m;
- $e =~ s/^\tj\t\$31\n//m;
- } elsif ($TargetPlatform =~ /^powerpc-apple-darwin.*/m) {
- $e =~ s/^\taddi r1,r1,\d+\n//m;
- $e =~ s/^\tlwz r\d+,\d+\(r1\)\n//m;
- $e =~ s/^\tlmw r\d+,-\d+\(r1\)\n//m;
- $e =~ s/^\tmtlr r0\n//m;
- $e =~ s/^\tblr\n//m;
- $e =~ s/^\tb restFP ;.*\n//m;
- } elsif ($TargetPlatform =~ /^powerpc64-.*-linux/m) {
- $e =~ s/^\tmr 3,0\n//m;
- $e =~ s/^\taddi 1,1,\d+\n//m;
- $e =~ s/^\tld 0,16\(1\)\n//m;
- $e =~ s/^\tmtlr 0\n//m;
-
- # callee-save registers
- $e =~ s/^\tld \d+,-?\d+\(1\)\n//gm;
- $e =~ s/^\tlfd \d+,-?\d+\(1\)\n//gm;
-
- # get rid of the debug junk along with the blr
- $e =~ s/^\tblr\n\t.long .*\n\t.byte .*\n//m;
-
- # incase we missed it with the last one get the blr alone
- $e =~ s/^\tblr\n//m;
- } else {
- print STDERR "$Pgm: unknown epilogue mangling? $TargetPlatform\n";
- }
-
- print STDERR "WARNING: Epilogue junk?: $e\n" if $e =~ /^\t\s*[^\.\s\n]/m;
-
- # glue together what's left
- $c .= $e . $etail;
- }
- $c =~ s/\n\t\n/\n/m; # junk blank line
- }
- else {
- if ($TargetPlatform =~ /^ia64-/m) {
- # On IA64, remove an .endp directive even if no epilogue was found.
- # Code optimizations may have removed the "--- END ---" token.
- $c =~ s/^\t\.endp [a-zA-Z0-9_.]+#\n//m;
- }
- }
-
- # On SPARCs, we don't do --- BEGIN/END ---, we just
- # toss the register-windowing save/restore/ret* instructions
- # directly unless they've been generated by function definitions in header
- # files on Solaris:
- if ( $TargetPlatform =~ /^sparc-/m ) {
- if ( ! ( $TargetPlatform =~ /solaris2$/m && $chkcat[$i] eq 'unknown' )) {
- $c =~ s/^\t(save.*|restore.*|ret|retl)\n//gm;
- }
- # throw away PROLOGUE comments
- $c =~ s/^\t!#PROLOGUE# 0\n\t!#PROLOGUE# 1\n//m;
- }
-
- # On Alphas, the prologue mangling is done a little later (below)
-
- # toss all calls to __DISCARD__
- $c =~ s/^\t(call|jbsr|jal)\s+${T_US}__DISCARD__\n//gom;
- $c =~ s/^\tjsr\s+\$26\s*,\s*${T_US}__DISCARD__\n//gom if $TargetPlatform =~ /^alpha-/m;
- $c =~ s/^\tbl\s+L___DISCARD__\$stub\n//gom if $TargetPlatform =~ /^powerpc-apple-darwin.*/m;
- $c =~ s/^\tbl\s+__DISCARD__(\@plt)?\n//gom if $TargetPlatform =~ /^powerpc-.*-linux/m;
- $c =~ s/^\tbl\s+\.__DISCARD__\n\s+nop\n//gom if $TargetPlatform =~ /^powerpc64-.*-linux/m;
- $c =~ s/^\tcall\s+L___DISCARD__\$stub\n//gom if $TargetPlatform =~ /i386-apple-darwin.*/m;
-
- # IA64: fix register allocation; mangle tailcalls into jumps
- if ($TargetPlatform =~ /^ia64-/m) {
- ia64_rename_registers($ia64_locnum, $ia64_outnum) if (defined($ia64_locnum));
- ia64_mangle_tailcalls();
- }
-
- # MIPS: that may leave some gratuitous asm macros around
- # (no harm done; but we get rid of them to be tidier)
- $c =~ s/^\t\.set\tnoreorder\n\t\.set\tnomacro\n\taddu\t(\S+)\n\t\.set\tmacro\n\t\.set\treorder\n/\taddu\t$1\n/m
- if $TargetPlatform =~ /^mips-/m;
-
- # toss stack adjustment after DoSparks
- $c =~ s/^(\tjbsr _DoSparks\n)\taddqw #8,sp/$1/gm
- if $TargetPlatform =~ /^m68k-/m; # this looks old...
-
- if ( $TargetPlatform =~ /^alpha-/m &&
- ! $magic_rdata_seen &&
- $c =~ /^\s*\.rdata\n\t\.quad 0\n\t\.align \d\n/m ) {
- $c =~ s/^\s*\.rdata\n\t\.quad 0\n\t\.align (\d)\n/\.rdata\n\t\.align $1\n/m;
- $magic_rdata_seen = 1;
- }
-
- # pick some end-things and move them to the next chunk
-
- # pin a funny end-thing on (for easier matching):
- $c .= 'FUNNY#END#THING';
-
- while ( $c =~ /${T_MOVE_DIRVS}FUNNY#END#THING/om ) {
-
- $to_move = $1;
-
- # on x86 we try not to copy any directives into a literal
- # chunk, rather we keep looking for the next real chunk. This
- # is because we get things like
- #
- # .globl blah_closure
- # .LC32
- # .string "..."
- # blah_closure:
- # ...
- #
- if ( $TargetPlatform =~ /^(i386|sparc|powerpc)/m && $to_move =~ /${T_COPY_DIRVS}/m ) {
- $j = $i + 1;
- while ( $j < $numchks && $chk[$j] =~ /$T_CONST_LBL/m) {
- $j++;
- }
- if ( $j < $numchks ) {
- $chk[$j] = $to_move . $chk[$j];
- }
- }
-
- elsif ( ( $i < ($numchks - 1)
- && ( $to_move =~ /${T_COPY_DIRVS}/m
- || ( $TargetPlatform =~ /^hppa/m
- && $to_move =~ /align/m
- && $chkcat[$i+1] eq 'literal')
- )
- )
- || ($to_move =~ /^[ \t]*\.section[ \t]+\.note\.GNU-stack,/m)
- ) {
- $chk[$i + 1] = $to_move . $chk[$i + 1];
- # otherwise they're tossed
- }
-
- $c =~ s/${T_MOVE_DIRVS}FUNNY#END#THING/FUNNY#END#THING/om;
- }
-
- if ( $TargetPlatform =~ /^alpha-/m && $c =~ /^\t\.ent\s+(\S+)/m ) {
- $ent = $1;
- # toss all prologue stuff, except for loading gp, and the ..ng address
- unless ($c =~ /\.ent.*\n\$.*\.\.ng:/m) {
- if (($p, $r) = split(/^\t\.prologue/m, $c)) {
- # use vars '$junk'; # Unused?
- if (($keep, $junk) = split(/\.\.ng:/m, $p)) {
- $keep =~ s/^\t\.frame.*\n/\t.frame \$30,0,\$26,0\n/m;
- $keep =~ s/^\t\.(mask|fmask).*\n//gm;
- $c = $keep . "..ng:\n";
- } else {
- print STDERR "malformed code block ($ent)?\n"
- }
- }
- $c .= "\t.prologue" . $r;
- }
- }
-
- $c =~ s/FUNNY#END#THING//m;
-
-# print STDERR "\nCHK $i (AFTER) (",$chkcat[$i],"):\n", $c;
-
- $chk[$i] = $c; # update w/ convenience copy
- }
-
- # open CHUNKS, ">/tmp/chunks2" or die "Cannot open /tmp/chunks2: $!\n";
- # for (my $i = 0; $i < @chk; ++$i) { print CHUNKS "======= $i =======\n", $chk[$i] }
- # close CHUNKS;
-
- if ( $TargetPlatform =~ /^alpha-/m ) {
- # print out the header stuff first
- $chk[0] =~ s/^(\t\.file.*)"(ghc\d+\.c)"/$1"$ifile_root.hc"/m;
- print OUTASM $chk[0];
-
- } elsif ( $TargetPlatform =~ /^hppa/m ) {
- print OUTASM $chk[0];
-
- } elsif ( $TargetPlatform =~ /^mips-/m ) {
- $chk[0] = "\t\.file\t1 \"$ifile_root.hc\"\n" . $chk[0];
-
- # get rid of horrible "<dollar>Revision: .*$" strings
- local(@lines0) = split(/\n/m, $chk[0]);
- local($z) = 0;
- while ( $z <= $#lines0 ) {
- if ( $lines0[$z] =~ /^\t\.byte\t0x24,0x52,0x65,0x76,0x69,0x73,0x69,0x6f$/m ) {
- undef($lines0[$z]);
- $z++;
- while ( $z <= $#lines0 ) {
- undef($lines0[$z]);
- last if $lines0[$z] =~ /[,\t]0x0$/m;
- $z++;
- }
- }
- $z++;
- }
- $chk[0] = join("\n", @lines0);
- $chk[0] =~ s/\n\n+/\n/m;
- print OUTASM $chk[0];
- }
-
- # print out all the literal strings next
- for ($i = 0; $i < $numchks; $i++) {
- if ( $chkcat[$i] eq 'literal' ) {
-
- # HACK: try to detect 16-byte constants and align them
- # on a 16-byte boundary. x86_64 sometimes needs 128-bit
- # aligned constants, and so does Darwin/x86.
- if ( $TargetPlatform =~ /^x86_64/m
- || $TargetPlatform =~ /^i386-apple-darwin/m ) {
- $z = $chk[$i];
- if ($z =~ /(\.long.*\n.*\.long.*\n.*\.long.*\n.*\.long|\.quad.*\n.*\.quad)/m) {
- print OUTASM $T_HDR_literal16;
- } else {
- print OUTASM $T_HDR_literal;
- }
- } else {
- print OUTASM $T_HDR_literal;
- }
-
- print OUTASM $chk[$i];
- print OUTASM "; end literal\n" if $TargetPlatform =~ /^hppa/m; # for the splitter
-
- $chkcat[$i] = 'DONE ALREADY';
- }
- }
-
- # on the HPPA, print out all the bss next
- if ( $TargetPlatform =~ /^hppa/m ) {
- for ($i = 1; $i < $numchks; $i++) {
- if ( $chkcat[$i] eq 'bss' ) {
- print OUTASM "\t.SPACE \$PRIVATE\$\n\t.SUBSPA \$BSS\$\n\t.align 4\n";
- print OUTASM $chk[$i];
-
- $chkcat[$i] = 'DONE ALREADY';
- }
- }
- }
-
- # $numchks + 1 as we have the extra one for .note.GNU-stack
- for ($i = $FIRST_MANGLABLE; $i < $numchks + 1; $i++) {
-# print STDERR "$i: cat $chkcat[$i], symb $chksymb[$i]\n";
-
- next if $chkcat[$i] eq 'DONE ALREADY';
-
- if ( $chkcat[$i] eq 'misc' || $chkcat[$i] eq 'unknown' ) {
- if ($chk[$i] ne '') {
- print OUTASM $T_HDR_misc;
- &print_doctored($chk[$i], 0);
- }
-
- } elsif ( $chkcat[$i] eq 'verbatim' ) {
- print OUTASM $chk[$i];
-
- } elsif ( $chkcat[$i] eq 'toss' ) {
- print STDERR "*** NB: TOSSING code for $chksymb[$i] !!! ***\n";
-
- } elsif ( $chkcat[$i] eq 'data' ) {
- if ($chk[$i] ne '') {
- print OUTASM $T_HDR_data;
- print OUTASM $chk[$i];
- }
-
- } elsif ( $chkcat[$i] eq 'splitmarker' ) {
- # we can just re-constitute this one...
- # NB: we emit _three_ underscores no matter what,
- # so ghc-split doesn't have to care.
- print OUTASM "___stg_split_marker",$chksymb[$i],"${T_POST_LBL}\n";
-
- } elsif ( $chkcat[$i] eq 'closure'
- || $chkcat[$i] eq 'srt'
- || $chkcat[$i] eq 'infotbl'
- || $chkcat[$i] eq 'entry') { # do them in that order
- $symb = $chksymb[$i];
-
- # CLOSURE
- if ( defined($closurechk{$symb}) ) {
- print OUTASM $T_HDR_closure;
- print OUTASM $chk[$closurechk{$symb}];
- $chkcat[$closurechk{$symb}] = 'DONE ALREADY';
- }
-
- # SRT
- if ( defined($srtchk{$symb}) ) {
- print OUTASM $T_HDR_relrodata;
- print OUTASM $chk[$srtchk{$symb}];
- $chkcat[$srtchk{$symb}] = 'DONE ALREADY';
- }
-
- # INFO TABLE
- if ( defined($infochk{$symb}) ) {
-
- print OUTASM $T_HDR_info;
- print OUTASM &rev_tbl($symb, $chk[$infochk{$symb}], 1);
-
- # entry code will be put here!
-
- $chkcat[$infochk{$symb}] = 'DONE ALREADY';
- }
-
- # ENTRY POINT
- if ( defined($entrychk{$symb}) ) {
-
- $c = $chk[$entrychk{$symb}];
-
- # If this is an entry point with an info table,
- # eliminate the entry symbol and all directives involving it.
- if (defined($infochk{$symb}) && $TargetPlatform !~ /^ia64-/m
- && $TABLES_NEXT_TO_CODE eq "YES") {
- @o = ();
- foreach $l (split(/\n/m,$c)) {
- next if $l =~ /^.*$symb_(entry|ret)${T_POST_LBL}/m;
-
- # If we have .type/.size direrctives involving foo_entry,
- # then make them refer to foo_info instead. The information
- # in these directives is used by the cachegrind annotator,
- # so it is worthwhile keeping.
- if ($l =~ /^\s*\.(type|size).*$symb_(entry|ret)/m) {
- $l =~ s/$symb(_entry|_ret)/${symb}_info/gm;
- push(@o,$l);
- next;
- }
- next if $l =~ /^\s*\..*$symb.*\n?/m;
- push(@o,$l);
- }
- $c = join("\n",@o) . "\n";
- }
-
- print OUTASM $T_HDR_entry;
-
- &print_doctored($c, 1); # NB: the 1!!!
-
- $chkcat[$entrychk{$symb}] = 'DONE ALREADY';
- }
-
- } elsif ( $chkcat[$i] eq 'vector' ) {
- $symb = $chksymb[$i];
-
- # VECTOR TABLE
- if ( defined($vectorchk{$symb}) ) {
- print OUTASM $T_HDR_vector;
- print OUTASM &rev_tbl($symb, $chk[$vectorchk{$symb}], 0);
-
- # direct return code will be put here!
- $chkcat[$vectorchk{$symb}] = 'DONE ALREADY';
-
- } elsif ( $TargetPlatform =~ /^alpha-/m ) {
- # Alphas: the commented nop is for the splitter, to ensure
- # that no module ends with a label as the very last
- # thing. (The linker will adjust the label to point
- # to the first code word of the next module linked in,
- # even if alignment constraints cause the label to move!)
-
- print OUTASM "\t# nop\n";
- }
-
- } elsif ( $chkcat[$i] eq 'rodata' ) {
- print OUTASM $T_HDR_rodata;
- print OUTASM $chk[$i];
- $chkcat[$i] = 'DONE ALREADY';
- } elsif ( $chkcat[$i] eq 'relrodata' ) {
- print OUTASM $T_HDR_relrodata;
- print OUTASM $chk[$i];
- $chkcat[$i] = 'DONE ALREADY';
- } elsif ( $chkcat[$i] eq 'toc' ) {
- # silly optimisation to print tocs, since they come in groups...
- print OUTASM $T_HDR_toc;
- local($j) = $i;
- while ($chkcat[$j] eq 'toc')
- { if ( $chk[$j] !~ /\.tc UpdatePAP\[TC\]/m # not needed: always turned into a jump.
- )
- {
- print OUTASM $chk[$j];
- }
- $chkcat[$j] = 'DONE ALREADY';
- $j++;
- }
-
- } elsif ( $TargetPlatform =~ /^.*-apple-darwin.*/m && $chkcat[$i] eq 'dyld' ) {
- # apple-darwin: dynamic linker stubs
- if($chk[$i] !~ /\.indirect_symbol ___DISCARD__/m)
- { # print them out unchanged, but remove the stubs for __DISCARD__
- print OUTASM $chk[$i];
- }
- } elsif ( $TargetPlatform =~ /^i386-apple-darwin.*/m && $chkcat[$i] eq 'get_pc_thunk' ) {
- # i386-apple-darwin: __i686.get_pc_thunk.[abcd]x
- print OUTASM ".section __TEXT,__textcoal_nt,coalesced,no_toc\n";
- print OUTASM $chk[$i];
- } else {
- &tidy_up_and_die(1,"$Pgm: unknown chkcat (ghc-asm: $TargetPlatform)\n$chkcat[$i]\n$chk[$i]\n");
- }
- }
-
- print OUTASM $EXTERN_DECLS if $TargetPlatform =~ /^mips-/m;
-
- # finished
- close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n");
- close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n");
-}
-\end{code}
-
-On IA64, tail calls are converted to branches at this point. The mangler
-searches for function calls immediately followed by a '--- TAILCALL ---'
-token. Since the compiler can put various combinations of labels, bundling
-directives, nop instructions, stops, and a move of the return value
-between the branch and the tail call, proper matching of the tail call
-gets a little hairy. This subroutine does the mangling.
-
-Here is an example of a tail call before mangling:
-
-\begin{verbatim}
- br.call.sptk.many b0 = b6
-.L211
- ;;
- .mmi
- mov r1 = r32
- ;;
- nop.m 0
- nop.i 0
- ;;
- --- TAILCALL --
- ;;
-.L123
-\end{verbatim}
-
-\begin{code}
-sub ia64_mangle_tailcalls {
- # Function input and output are in $c
-
- # Construct the tailcall-mangling expression the first time this function
- # is called.
- if (!defined($IA64_MATCH_TAILCALL)) {
- # One-line pattern matching constructs. None of these
- # should bind references; all parenthesized terms
- # should be (?:) terms.
- my $stop = q/(?:\t;;\n)/;
- my $bundle = q/(?:\t\.(?:mii|mib|mmi|mmb|mfi|mfb|mbb|bbb)\n)/;
- my $nop = q/(?:\tnop(?:\.[mifb])?\s+\d+\n)/;
- my $movgp = q/(?:\tmov r1 = r\d+\n)/;
- my $postbr = q/(?:\tbr \.L\d+\n)/;
-
- my $noeffect = "(?:$stop$bundle?|$nop)*";
- my $postbundle = "(?:$bundle?$nop?$nop?$postbr)?";
-
- # Important parts of the pattern match. The branch target
- # and subsequent jump label are bound to $1 and $2
- # respectively. Sometimes there is no label.
- my $callbr = q/^\tbr\.call\.sptk\.many b0 = (.*)\n/;
- my $label = q/(?:^\.L([0-9]*):\n)/;
- my $tailcall = q/\t--- TAILCALL ---\n/;
-
- $IA64_MATCH_TAILCALL =
- $callbr . $label . '?' . $noeffect . $movgp . '?' . $noeffect .
- $tailcall . $stop . '?' . '(?:' . $postbundle . ')?';
- }
-
- # Find and mangle tailcalls
- while ($c =~ s/$IA64_MATCH_TAILCALL/\tbr\.few $1\n/om) {
- # Eek, the gcc optimiser is getting smarter... if we see a jump to the
- # --- TAILCALL --- marker then we reapply the substitution at the source sites
- $c =~ s/^\tbr \.L$2\n/\t--- TAILCALL ---\n/gm if ($2);
- }
-
- # Verify that all instances of TAILCALL were processed
- if ($c =~ /^\t--- TAILCALL ---\n/m) {
- die "Unmangled TAILCALL tokens remain after mangling"
- }
-}
-\end{code}
-
-The number of registers allocated on the IA64 register stack is set
-upon entry to the runtime with an `alloc' instruction at the entry
-point of \verb+StgRun()+. Gcc uses its own `alloc' to allocate
-however many registers it likes in each function. When we discard
-gcc's alloc, we have to reconcile its register assignment with what
-the STG uses.
-
-There are three stack areas: fixed registers, input/local registers,
-and output registers. We move the output registers to the output
-register space and leave the other registers where they are.
-
-\begin{code}
-sub ia64_rename_registers() {
- # The text to be mangled is in $c
- # Find number of registers in each stack area
- my ($loc, $out) = @_;
- my $cout;
- my $first_out_reg;
- my $regnum;
- my $fragment;
-
- # These are the register numbers used in the STG runtime
- my $STG_FIRST_OUT_REG = 32 + 34;
- my $STG_LAST_OUT_REG = $STG_FIRST_OUT_REG + 7;
-
- $first_out_reg = 32 + $loc;
-
- if ($first_out_reg > $STG_FIRST_OUT_REG) {
- die "Too many local registers allocated by gcc";
- }
-
- # Split the string into fragments containing one register name each.
- # Rename the register in each fragment and concatenate.
- $cout = "";
- foreach $fragment (split(/(?=r\d+[^a-zA-Z0-9_.])/sm, $c)) {
- if ($fragment =~ /^r(\d+)((?:[^a-zA-Z0-9_.].*)?)$/sm) {
- $regnum = $1;
-
- if ($regnum < $first_out_reg) {
- # This is a local or fixed register
-
- # Local registers 32 and 33 (r64 and r65) are
- # used to hold saved state; they shouldn't be touched
- if ($regnum == 64 || $regnum == 65) {
- die "Reserved register $regnum is in use";
- }
- }
- else {
- # This is an output register
- $regnum = $regnum - $first_out_reg + $STG_FIRST_OUT_REG;
- if ($regnum > $STG_LAST_OUT_REG) {
- die "Register number ($regnum) is out of expected range";
- }
- }
-
- # Update this fragment
- $fragment = "r" . $regnum . $2;
- }
- $cout .= $fragment;
- }
-
- $c = $cout;
-}
-
-\end{code}
-
-\begin{code}
-sub hppa_mash_prologue { # OK, epilogue, too
- local($_) = @_;
-
- # toss all prologue stuff
- s/^\s+\.ENTRY[^\0]*--- BEGIN ---/\t.ENTRY/m;
-
- # Lie about our .CALLINFO
- s/^\s+\.CALLINFO.*$/\t.CALLINFO NO_CALLS,NO_UNWIND/m;
-
- # Get rid of P'
-
- s/LP'/L'/gm;
- s/RP'/R'/gm;
-
- # toss all epilogue stuff
- s/^\s+--- END ---[^\0]*\.EXIT/\t.EXIT/m;
-
- # Sorry; we moved the _info stuff to the code segment.
- s/_info,DATA/_info,CODE/gm;
-
- return($_);
-}
-\end{code}
-
-\begin{code}
-sub print_doctored {
- local($_, $need_fallthru_patch) = @_;
-
- if ( $TargetPlatform =~ /^x86_64-/m ) {
- # Catch things like
- #
- # movq -4(%ebp), %rax
- # jmp *%rax
- #
- # and optimise:
- #
- s/^\tmovq\s+(-?\d*\(\%r(bx|bp|13)\)),\s*(\%r(ax|cx|dx|10|11))\n\tjmp\s+\*\3/\tjmp\t\*$1/gm;
- s/^\tmovl\s+\$${T_US}(.*),\s*(\%e(ax|cx|si|di))\n\tjmp\s+\*\%r\3/\tjmp\t$T_US$1/gm;
- }
-
- if ( $TargetPlatform !~ /^i386-/m
- || ! /^\t[a-z]/m # no instructions in here, apparently
- || /^${T_US}__stginit_[A-Za-z0-9_]+${T_POST_LBL}/m) {
- print OUTASM $_;
- return;
- }
-
- # OK, must do some x86 **HACKING**
-
- local($entry_patch) = '';
- local($exit_patch) = '';
-
- # gotta watch out for weird instructions that
- # invisibly smash various regs:
- # rep* %ecx used for counting
- # scas* %edi used for destination index
- # cmps* %e[sd]i used for indices
- # loop* %ecx used for counting
- #
- # SIGH.
-
- # We cater for:
- # * use of STG reg [ nn(%ebx) ] where no machine reg avail
- #
- # * GCC used an "STG reg" for its own purposes
- #
- # * some secret uses of machine reg, requiring STG reg
- # to be saved/restored
-
- # The most dangerous "GCC uses" of an "STG reg" are when
- # the reg holds the target of a jmp -- it's tricky to
- # insert the patch-up code before we get to the target!
- # So here we change the jmps:
-
- # --------------------------------------------------------
- # it can happen that we have jumps of the form...
- # jmp *<something involving %esp>
- # or
- # jmp <something involving another naughty register...>
- #
- # a reasonably-common case is:
- #
- # movl $_blah,<bad-reg>
- # jmp *<bad-reg>
- #
- s/^\tmovl\s+\$${T_US}(.*),\s*(\%e[acd]x)\n\tjmp\s+\*\2/\tjmp $T_US$1/gm;
-
- # Catch things like
- #
- # movl -4(%ebx), %eax
- # jmp *%eax
- #
- # and optimise:
- #
- s/^\tmovl\s+(-?\d*\(\%e(bx|si)\)),\s*(\%e[acd]x)\n\tjmp\s+\*\3/\tjmp\t\*$1/gm;
-
- if ($StolenX86Regs <= 2 ) { # YURGH! spurious uses of esi?
- s/^\tmovl\s+(.*),\s*\%esi\n\tjmp\s+\*%esi\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/gm;
- s/^\tjmp\s+\*(.*\(.*\%esi.*\))\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/gm;
- s/^\tjmp\s+\*\%esi\n/\tmovl \%esi,\%eax\n\tjmp \*\%eax\n/gm;
- die "$Pgm: (mangler) still have jump involving \%esi!\n$_"
- if /(jmp|call)\s+.*\%esi/m;
- }
- if ($StolenX86Regs <= 3 ) { # spurious uses of edi?
- s/^\tmovl\s+(.*),\s*\%edi\n\tjmp\s+\*%edi\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/gm;
- s/^\tjmp\s+\*(.*\(.*\%edi.*\))\n/\tmovl $1,\%eax\n\tjmp \*\%eax\n/gm;
- s/^\tjmp\s+\*\%edi\n/\tmovl \%edi,\%eax\n\tjmp \*\%eax\n/gm;
- die "$Pgm: (mangler) still have jump involving \%edi!\n$_"
- if /(jmp|call)\s+.*\%edi/m;
- }
-
- # OK, now we can decide what our patch-up code is going to
- # be:
-
- # Offsets into register table - you'd better update these magic
- # numbers should you change its contents!
- # local($OFFSET_R1)=0; No offset for R1 in new RTS.
- local($OFFSET_Hp)=88;
-
- # Note funky ".=" stuff; we're *adding* to these _patch guys
- if ( $StolenX86Regs <= 2
- && ( /[^0-9]\(\%ebx\)/m || /\%esi/m || /^\tcmps/m ) ) { # R1 (esi)
- $entry_patch .= "\tmovl \%esi,(\%ebx)\n";
- $exit_patch .= "\tmovl (\%ebx),\%esi\n";
-
- # nothing for call_{entry,exit} because %esi is callee-save
- }
- if ( $StolenX86Regs <= 3
- && ( /${OFFSET_Hp}\(\%ebx\)/m || /\%edi/m || /^\t(scas|cmps)/m ) ) { # Hp (edi)
- $entry_patch .= "\tmovl \%edi,${OFFSET_Hp}(\%ebx)\n";
- $exit_patch .= "\tmovl ${OFFSET_Hp}(\%ebx),\%edi\n";
-
- # nothing for call_{entry,exit} because %edi is callee-save
- }
-
- # --------------------------------------------------------
- # next, here we go with non-%esp patching!
- #
- s/^(\t[a-z])/$entry_patch$1/m; # before first instruction
-
-# Before calling GC we must set up the exit condition before the call
-# and entry condition when we come back
-
- # fix _all_ non-local jumps:
-
- if ( $TargetPlatform =~ /^.*-apple-darwin.*/m ) {
- # On Darwin, we've got local-looking jumps that are
- # actually global (i.e. jumps to Lfoo$stub or via
- # Lfoo$non_lazy_ptr), so we fix those first.
- # In fact, we just fix everything that contains a dollar
- # because false positives don't hurt here.
-
- s/^(\tjmp\s+\*?L.*\$.*\n)/$exit_patch$1/gm;
- }
-
- s/^\tjmp\s+\*${T_X86_PRE_LLBL_PAT}/\tJMP___SL/gom;
- s/^\tjmp\s+${T_X86_PRE_LLBL_PAT}/\tJMP___L/gom;
-
- s/^(\tjmp\s+.*\n)/$exit_patch$1/gm; # here's the fix...
-
- s/^\tJMP___SL/\tjmp \*${T_X86_PRE_LLBL}/gom;
- s/^\tJMP___L/\tjmp ${T_X86_PRE_LLBL}/gom;
-
- if ($StolenX86Regs == 2 ) {
- die "ARGH! Jump uses \%esi or \%edi with -monly-2-regs:\n$_"
- if /^\t(jmp|call)\s+.*\%e(si|di)/m;
- } elsif ($StolenX86Regs == 3 ) {
- die "ARGH! Jump uses \%edi with -monly-3-regs:\n$_"
- if /^\t(jmp|call)\s+.*\%edi/m;
- }
-
- # --------------------------------------------------------
- # that's it -- print it
- #
- #die "Funny jumps?\n$_" if /${T_X86_BADJMP}/o; # paranoia
-
- print OUTASM $_;
-
- if ( $need_fallthru_patch ) { # exit patch for end of slow entry code
- print OUTASM $exit_patch;
- # ToDo: make it not print if there is a "jmp" at the end
- }
-}
-\end{code}
-
-\begin{code}
-sub init_FUNNY_THINGS {
- # use vars '%KNOWN_FUNNY_THING'; # Unused?
- %KNOWN_FUNNY_THING = (
- # example
- # "${T_US}stg_.*{T_POST_LBL}", 1,
- );
-}
-\end{code}
-
-The following table reversal is used for both info tables and return
-vectors. In both cases, we remove the first entry from the table,
-reverse the table, put the label at the end, and paste some code
-(that which is normally referred to by the first entry in the table)
-right after the table itself. (The code pasting is done elsewhere.)
-
-\begin{code}
-sub rev_tbl {
- # use vars '$discard1'; # Unused?
- local($symb, $tbl, $discard1) = @_;
-
- return ($tbl) if ($TargetPlatform =~ /^ia64-/m
- || $TABLES_NEXT_TO_CODE eq "NO");
-
- local($before) = '';
- local($label) = '';
- local(@imports) = (); # hppa only
- local(@words) = ();
- local($after) = '';
- local(@lines) = split(/\n/m, $tbl);
- local($i, $j);
-
- # Deal with the header...
- for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t?${T_DOT_WORD}\s+/om; $i++) {
- $label .= $lines[$i] . "\n",
- next if $lines[$i] =~ /^[A-Za-z0-9_]+_info${T_POST_LBL}$/om
- || $lines[$i] =~ /${T_DOT_GLOBAL}/om
- || $lines[$i] =~ /^${T_US}\S+_vtbl${T_POST_LBL}$/om;
-
- $before .= $lines[$i] . "\n"; # otherwise...
- }
-
- $infoname = $label;
- $infoname =~ s/(.|\n)*^([A-Za-z0-9_]+_info)${T_POST_LBL}$(.|\n)*/$2/m;
-
- # Grab the table data...
- if ( $TargetPlatform !~ /^hppa/m ) {
- for ( ; $i <= $#lines && $lines[$i] =~ /^\t?${T_DOT_WORD}\s+/om; $i++) {
- $line = $lines[$i];
- # Convert addresses of SRTs, slow entrypoints and large bitmaps
- # to offsets (relative to the info label),
- # in order to support position independent code.
- $line =~ s/$infoname/0/m
- || $line =~ s/([A-Za-z0-9_]+_srtd)$/$1 - $infoname/m
- || $line =~ s/([A-Za-z0-9_]+_srt(\+\d+)?)$/$1 - $infoname/m
- || $line =~ s/([A-Za-z0-9_]+_str)$/$1 - $infoname/m
- || $line =~ s/([A-Za-z0-9_]+_slow)$/$1 - $infoname/m
- || $line =~ s/([A-Za-z0-9_]+_btm)$/$1 - $infoname/m
- || $line =~ s/([A-Za-z0-9_]+_alt)$/$1 - $infoname/m
- || $line =~ s/([A-Za-z0-9_]+_dflt)$/$1 - $infoname/m
- || $line =~ s/([A-Za-z0-9_]+_ret)$/$1 - $infoname/m;
- push(@words, $line);
- }
- } else { # hppa weirdness
- for ( ; $i <= $#lines && $lines[$i] =~ /^\s+(${T_DOT_WORD}|\.IMPORT)/m; $i++) {
- # FIXME: the RTS now expects offsets instead of addresses
- # for all labels in info tables.
- if ($lines[$i] =~ /^\s+\.IMPORT/m) {
- push(@imports, $lines[$i]);
- } else {
- # We don't use HP's ``function pointers''
- # We just use labels in code space, like normal people
- $lines[$i] =~ s/P%//m;
- push(@words, $lines[$i]);
- }
- }
- }
-
- # Now throw away any initial zero word from the table. This is a hack
- # that lets us reduce the size of info tables when the SRT field is not
- # needed: see comments StgFunInfoTable in InfoTables.h.
- #
- # The .zero business is for Linux/ELF.
- # The .skip business is for Sparc/Solaris/ELF.
- # The .blockz business is for HPPA.
-# if ($discard1) {
-# if ($words[0] =~ /^\t?(${T_DOT_WORD}\s+0|\.zero\s+4|\.skip\s+4|\.blockz\s+4)/) {
-# shift(@words);
-# }
-# }
-
- for (; $i <= $#lines; $i++) {
- $after .= $lines[$i] . "\n";
- }
-
- # Alphas: If we have anonymous text (not part of a procedure), the
- # linker may complain about missing exception information. Bleh.
- # To suppress this, we place a .ent/.end pair around the code.
- # At the same time, we have to be careful and not enclose any leading
- # .file/.loc directives.
- if ( $TargetPlatform =~ /^alpha-/m && $label =~ /^([A-Za-z0-9_]+):$/m) {
- local ($ident) = $1;
- $before =~ s/^((\s*\.(file|loc)\s+[^\n]*\n)*)/$1\t.ent $ident\n/m;
- $after .= "\t.end $ident\n";
- }
-
- # Alphas: The heroic Simon Marlow found a bug in the Digital UNIX
- # assembler (!) wherein .quad constants inside .text sections are
- # first narrowed to 32 bits then sign-extended back to 64 bits.
- # This obviously screws up our 64-bit bitmaps, so we work around
- # the bug by replacing .quad with .align 3 + .long + .long [ccshan]
- if ( $TargetPlatform =~ /^alpha-/m ) {
- foreach (@words) {
- if (/^\s*\.quad\s+([-+0-9].*\S)\s*$/m && length $1 >= 10) {
- local ($number) = $1;
- if ($number =~ /^([-+])?(0x?)?([0-9]+)$/m) {
- local ($sign, $base, $digits) = ($1, $2, $3);
- $base = (10, 8, 16)[length $base];
- local ($hi, $lo) = (0, 0);
- foreach $i (split(//, $digits)) {
- $j = $lo * $base + $i;
- $lo = $j % 4294967296;
- $hi = $hi * $base + ($j - $lo) / 4294967296;
- }
- ($hi, $lo) = (4294967295 - $hi, 4294967296 - $lo)
- if $sign eq "-";
- $_ = "\t.align 3\n\t.long $lo\n\t.long $hi\n";
- # printf STDERR "TURNING %s into 0x %08x %08x\n", $number, $hi, $lo;
- } else {
- print STDERR "Cannot handle \".quad $number\" in info table\n";
- exit 1;
- }
- }
- }
- }
-
- if ( $TargetPlatform =~ /x86_64-apple-darwin/m ) {
- # Tack a label to the front of the info table, too.
- # For now, this just serves to work around a crash in Apple's new
- # 64-bit linker (it seems to assume that there is no data before the
- # first label in a section).
-
- # The plan for the future is to do this on all Darwin platforms, and
- # to add a reference to this label after the entry code, just as the
- # NCG does, so we can enable dead-code-stripping in the linker without
- # losing our info tables. (Hence the name _dsp, for dead-strip preventer)
-
- $before .= "\n${infoname}_dsp:\n";
- }
-
- $tbl = $before
- . (($TargetPlatform !~ /^hppa/m) ? '' : join("\n", @imports) . "\n")
- . join("\n", @words) . "\n"
- . $label . $after;
-
-# print STDERR "before=$before\n";
-# print STDERR "label=$label\n";
-# print STDERR "words=",(reverse @words),"\n";
-# print STDERR "after=$after\n";
-
- $tbl;
-}
-\end{code}
-
-The HP is a major nuisance. The threaded code mangler moved info
-tables from data space to code space, but unthreaded code in the RTS
-still has references to info tables in data space. Since the HP
-linker is very precise about where symbols live, we need to patch the
-references in the unthreaded RTS as well.
-
-\begin{code}
-sub mini_mangle_asm_hppa {
- local($in_asmf, $out_asmf) = @_;
-
- open(INASM, "< $in_asmf")
- || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n");
- open(OUTASM,"> $out_asmf")
- || &tidy_up_and_die(1,"$Pgm: failed to open `$out_asmf' (to write)\n");
-
- while (<INASM>) {
- s/_info,DATA/_info,CODE/m; # Move _info references to code space
- s/P%_PR/_PR/m;
- print OUTASM;
- }
-
- # finished:
- close(OUTASM) || &tidy_up_and_die(1,"Failed writing to $out_asmf\n");
- close(INASM) || &tidy_up_and_die(1,"Failed reading from $in_asmf\n");
-}
-
-\end{code}
-
-\begin{code}
-sub tidy_up_and_die {
- local($return_val, $msg) = @_;
- print STDERR $msg;
- exit (($return_val == 0) ? 0 : 1);
-}
-\end{code}
+++ /dev/null
-# -----------------------------------------------------------------------------
-#
-# (c) 2009 The University of Glasgow
-#
-# This file is part of the GHC build system.
-#
-# To understand how the build system works and how to modify it, see
-# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture
-# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying
-#
-# -----------------------------------------------------------------------------
-
-driver/mangler_PERL_SRC = ghc-asm.lprl
-driver/mangler_dist_PROG = $(GHC_MANGLER_PGM)
-driver/mangler_dist_TOPDIR = YES
-driver/mangler_dist_INSTALL_IN = $(DESTDIR)$(topdir)
-
-$(eval $(call build-perl,driver/mangler,dist))
-
ifneq "$(GhcUnregisterised)" "YES"
BUILD_DIRS += \
- $(GHC_MANGLER_DIR) \
$(GHC_SPLIT_DIR)
endif
macros <- readIORef macros_ref
let{ (str, cmds) = case str' of
':' : rest -> (rest, builtin_commands)
- _ -> (str', macros ++ builtin_commands) }
+ _ -> (str', builtin_commands ++ macros) }
-- look for exact match first, then the first prefix match
+ -- We consider builtin commands first: since new macros are appended
+ -- on the *end* of the macros list, this is consistent with the view
+ -- that things defined earlier should take precedence. See also #3858
return $ case [ c | c <- cmds, str == cmdName c ] of
c:_ -> Just c
[] -> case [ c | c@(s,_,_) <- cmds, str `isPrefixOf` s ] of
haskellish (f,Nothing) =
looksLikeModuleName f || isHaskellSrcFilename f || '.' `notElem` f
haskellish (_,Just phase) =
- phase `notElem` [As, Cc, CmmCpp, Cmm, StopLn]
+ phase `notElem` [As, Cc, Cobjc, CmmCpp, Cmm, StopLn]
hsc_env <- GHC.getSession
# The GHC programs need to depend on all the helper programs they might call
ifeq "$(GhcUnregisterised)" "NO"
-$(GHC_STAGE1) : $(MANGLER) $(SPLIT)
-$(GHC_STAGE2) : $(MANGLER) $(SPLIT)
-$(GHC_STAGE3) : $(MANGLER) $(SPLIT)
+$(GHC_STAGE1) : $(SPLIT)
+$(GHC_STAGE2) : $(SPLIT)
+$(GHC_STAGE3) : $(SPLIT)
endif
$(GHC_STAGE1) : $(INPLACE_LIB)/extra-gcc-opts
put (stability ipi)
put (homepage ipi)
put (pkgUrl ipi)
+ put (synopsis ipi)
put (description ipi)
put (category ipi)
put (exposed ipi)
stability <- get
homepage <- get
pkgUrl <- get
+ synopsis <- get
description <- get
category <- get
exposed <- get
GHC_GHCTAGS_PGM = ghctags$(exeext)
GHC_HSC2HS_PGM = hsc2hs$(exeext)
GHC_TOUCHY_PGM = touchy$(exeext)
-GHC_MANGLER_PGM = ghc-asm
GHC_SPLIT_PGM = ghc-split
GHC_SYSMAN_PGM = SysMan
GHC_GENPRIMOP_PGM = genprimopcode$(exeext)
endif
HP2PS = $(GHC_HP2PS_DIR)/$(GHC_HP2PS_PGM)
-MANGLER = $(INPLACE_LIB)/$(GHC_MANGLER_PGM)
SPLIT = $(INPLACE_LIB)/$(GHC_SPLIT_PGM)
SYSMAN = $(GHC_SYSMAN_DIR)/$(GHC_SYSMAN_PGM)
LTX = $(GHC_LTX_DIR)/$(GHC_LTX_PGM)
GHC_GENPRIMOP_DIR = $(GHC_UTILS_DIR)/genprimopcode
GHC_GENAPPLY_DIR = $(GHC_UTILS_DIR)/genapply
GHC_CABAL_DIR = $(GHC_UTILS_DIR)/ghc-cabal
-GHC_MANGLER_DIR = $(GHC_DRIVER_DIR)/mangler
GHC_SPLIT_DIR = $(GHC_DRIVER_DIR)/split
GHC_SYSMAN_DIR = $(GHC_RTS_DIR)/parallel
+++ /dev/null
-# Despite the name "package", this file contains the master list of
-# the *repositories* that make up GHC. It is parsed by boot and darcs-all.
-#
-# Some of this information is duplicated elsewhere in the build system:
-# See Trac #3896
-# In particular when adding libraries to this file, you also need to add
-# the library to the SUBDIRS variable in libraries/Makefile so that they
-# actually get built
-#
-# The repos are of several kinds:
-# - The main GHC source repo
-# - Each boot package lives in a repo
-# - DPH is a repo that contains several packages
-# - Haddock and hsc2hs are applications, built on top of GHC,
-# and in turn needed to bootstrap GHC
-# - ghc-tarballs is need to build GHC
-# - nofib and testsuite are optional helpers
-#
-# The format of the lines in this file is:
-# localpath tag remotepath VCS upstream
-# where
-# * 'localpath' is where to put the repository in a checked out tree.
-# * 'remotepath' is where the repository is in the central repository.
-# * 'VCS' is what version control system the repo uses.
-#
-# * The 'tag' determines when "darcs-all get" will get the
-# repo. If the tag is "-" then it will always get it, but if there
-# is a tag then a corresponding flag must be given to darcs-all, e.g.
-# if you want to get the packages with an "extralibs" or "testsuite"
-# tag then you need to use "darcs-all --extra --testsuite get".
-# Support for new tags must be manually added to the darcs-all script.
-#
-# 'tag' is also used to determine which packages the build system
-# deems to have the EXTRA_PACKAGE property: tags 'dph' and 'extra'
-# both give this property
-#
-# * 'upstream' is the URL of the upstream repo, where there is one, or
-# "-" if there is no upstream.
-#
-# Lines that start with a '#' are comments.
-. - ghc.git git -
-ghc-tarballs - ghc-tarballs darcs -
-utils/hsc2hs - hsc2hs darcs -
-# haddock does have an upstream:
-# http://code.haskell.org/haddock/
-# but it stays buildable with the last stable release rather than tracking HEAD,
-# and is resynced with the GHC HEAD branch by David Waern when appropriate
-utils/haddock - haddock2 darcs -
-libraries/array - packages/array darcs -
-libraries/base - packages/base darcs -
-libraries/binary - packages/binary darcs http://code.haskell.org/binary/
-libraries/bytestring - packages/bytestring darcs http://darcs.haskell.org/bytestring/
-libraries/Cabal - packages/Cabal darcs http://darcs.haskell.org/cabal/
-libraries/containers - packages/containers darcs -
-libraries/directory - packages/directory darcs -
-libraries/extensible-exceptions - packages/extensible-exceptions darcs -
-libraries/filepath - packages/filepath darcs -
-libraries/ghc-prim - packages/ghc-prim darcs -
-libraries/haskeline - packages/haskeline darcs http://code.haskell.org/haskeline/
-libraries/haskell98 - packages/haskell98 darcs -
-libraries/haskell2010 - packages/haskell2010 darcs -
-libraries/hoopl - packages/hoopl darcs -
-libraries/hpc - packages/hpc darcs -
-libraries/integer-gmp - packages/integer-gmp darcs -
-libraries/integer-simple - packages/integer-simple darcs -
-libraries/mtl - packages/mtl darcs -
-libraries/old-locale - packages/old-locale darcs -
-libraries/old-time - packages/old-time darcs -
-libraries/pretty - packages/pretty darcs -
-libraries/process - packages/process darcs -
-libraries/random - packages/random darcs -
-libraries/template-haskell - packages/template-haskell darcs -
-libraries/terminfo - packages/terminfo darcs http://code.haskell.org/terminfo/
-libraries/unix - packages/unix darcs -
-libraries/utf8-string - packages/utf8-string darcs http://code.haskell.org/utf8-string/
-libraries/Win32 - packages/Win32 darcs -
-libraries/xhtml - packages/xhtml darcs -
-testsuite testsuite testsuite darcs -
-nofib nofib nofib darcs -
-libraries/deepseq extra packages/deepseq darcs -
-libraries/parallel extra packages/parallel darcs -
-libraries/stm extra packages/stm darcs -
-libraries/primitive dph packages/primitive darcs http://code.haskell.org/primitive
-libraries/vector dph packages/vector darcs http://code.haskell.org/vector
-libraries/dph dph packages/dph darcs -
int pagesize, size;
static nat fixed = 0;
+ IF_DEBUG(linker, debugBelch("mmapForLinker: start\n"));
pagesize = getpagesize();
size = ROUND_UP(bytes, pagesize);
}
#endif
+ IF_DEBUG(linker, debugBelch("mmapForLinker: \tprotection %#0x\n", PROT_EXEC | PROT_READ | PROT_WRITE));
+ IF_DEBUG(linker, debugBelch("mmapForLinker: \tflags %#0x\n", MAP_PRIVATE | TRY_MAP_32BIT | fixed | flags));
result = mmap(map_addr, size, PROT_EXEC|PROT_READ|PROT_WRITE,
MAP_PRIVATE|TRY_MAP_32BIT|fixed|flags, fd, 0);
}
#endif
+ IF_DEBUG(linker, debugBelch("mmapForLinker: mapped %lu bytes starting at %p\n", (lnat)size, result));
+ IF_DEBUG(linker, debugBelch("mmapForLinker: done\n"));
return result;
}
#endif // USE_MMAP
) {
ObjectCode* oc;
+ IF_DEBUG(linker, debugBelch("mkOc: start\n"));
oc = stgMallocBytes(sizeof(ObjectCode), "loadArchive(oc)");
# if defined(OBJFORMAT_ELF)
oc->next = objects;
objects = oc;
+ IF_DEBUG(linker, debugBelch("mkOc: done\n"));
return oc;
}
int misalignment;
#endif
+ IF_DEBUG(linker, debugBelch("loadArchive: start\n"));
IF_DEBUG(linker, debugBelch("loadArchive: Loading archive `%s'\n", path));
gnuFileIndex = NULL;
barf("loadObj: can't read `%s'", path);
n = fread ( tmp, 1, 8, f );
- if (strncmp(tmp, "!<arch>\n", 8) != 0)
+ if (strncmp(tmp, "!<arch>\n", 8) != 0) {
barf("loadArchive: Not an archive: `%s'", path);
+ }
+
+ IF_DEBUG(linker, debugBelch("loadArchive: loading archive contents\n"));
while(1) {
n = fread ( fileName, 1, 16, f );
if (n != 16) {
if (feof(f)) {
+ IF_DEBUG(linker, debugBelch("loadArchive: EOF while reading from '%s'\n", path));
break;
}
else {
barf("loadArchive: Failed reading file name from `%s'", path);
}
}
+#if defined(darwin_HOST_OS)
+ else {
+ if (strncmp(fileName, "!<arch>\n", 8) == 0) {
+ IF_DEBUG(linker, debugBelch("loadArchive: found the start of another archive, breaking\n"));
+ break;
+ }
+ }
+#endif
+
n = fread ( tmp, 1, 12, f );
if (n != 12)
barf("loadArchive: Failed reading mod time from `%s'", path);
for (n = 0; isdigit(tmp[n]); n++);
tmp[n] = '\0';
memberSize = atoi(tmp);
+
+ IF_DEBUG(linker, debugBelch("loadArchive: size of this archive member is %d\n", memberSize));
n = fread ( tmp, 1, 2, f );
if (strncmp(tmp, "\x60\x0A", 2) != 0)
barf("loadArchive: Failed reading magic from `%s' at %ld. Got %c%c",
path);
}
fileName[thisFileNameSize] = 0;
+
+ /* On OS X at least, thisFileNameSize is the size of the
+ fileName field, not the length of the fileName
+ itself. */
+ thisFileNameSize = strlen(fileName);
}
else {
barf("loadArchive: BSD-variant filename size not found while reading filename from `%s'", path);
&& fileName[thisFileNameSize - 2] == '.'
&& fileName[thisFileNameSize - 1] == 'o';
+ IF_DEBUG(linker, debugBelch("loadArchive: \tthisFileNameSize = %d\n", (int)thisFileNameSize));
+ IF_DEBUG(linker, debugBelch("loadArchive: \tisObject = %d\n", isObject));
+
if (isObject) {
char *archiveMemberName;
gnuFileIndexSize = memberSize;
}
else {
+ IF_DEBUG(linker, debugBelch("loadArchive: '%s' does not appear to be an object file\n", fileName));
n = fseek(f, memberSize, SEEK_CUR);
if (n != 0)
barf("loadArchive: error whilst seeking by %d in `%s'",
memberSize, path);
}
+
/* .ar files are 2-byte aligned */
if (memberSize % 2) {
+ IF_DEBUG(linker, debugBelch("loadArchive: trying to read one pad byte\n"));
n = fread ( tmp, 1, 1, f );
if (n != 1) {
if (feof(f)) {
+ IF_DEBUG(linker, debugBelch("loadArchive: found EOF while reading one pad byte\n"));
break;
}
else {
barf("loadArchive: Failed reading padding from `%s'", path);
}
}
+ IF_DEBUG(linker, debugBelch("loadArchive: successfully read one pad byte\n"));
}
+ IF_DEBUG(linker, debugBelch("loadArchive: reached end of archive loading while loop\n"));
}
fclose(f);
#endif
}
+ IF_DEBUG(linker, debugBelch("loadArchive: done\n"));
return 1;
}
loadOc( ObjectCode* oc ) {
int r;
- IF_DEBUG(linker, debugBelch("loadOc\n"));
+ IF_DEBUG(linker, debugBelch("loadOc: start\n"));
# if defined(OBJFORMAT_MACHO) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH))
r = ocAllocateSymbolExtras_MachO ( oc );
if (!r) {
- IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO failed\n"));
+ IF_DEBUG(linker, debugBelch("loadOc: ocAllocateSymbolExtras_MachO failed\n"));
return r;
}
# elif defined(OBJFORMAT_ELF) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH))
r = ocAllocateSymbolExtras_ELF ( oc );
if (!r) {
- IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_ELF failed\n"));
+ IF_DEBUG(linker, debugBelch("loadOc: ocAllocateSymbolExtras_ELF failed\n"));
return r;
}
#endif
barf("loadObj: no verify method");
# endif
if (!r) {
- IF_DEBUG(linker, debugBelch("ocVerifyImage_* failed\n"));
+ IF_DEBUG(linker, debugBelch("loadOc: ocVerifyImage_* failed\n"));
return r;
}
barf("loadObj: no getNames method");
# endif
if (!r) {
- IF_DEBUG(linker, debugBelch("ocGetNames_* failed\n"));
+ IF_DEBUG(linker, debugBelch("loadOc: ocGetNames_* failed\n"));
return r;
}
/* loaded, but not resolved yet */
oc->status = OBJECT_LOADED;
- IF_DEBUG(linker, debugBelch("loadObj done.\n"));
+ IF_DEBUG(linker, debugBelch("loadOc: done.\n"));
return 1;
}
* which may be prodded during relocation, and abort if we try and write
* outside any of these.
*/
-static void addProddableBlock ( ObjectCode* oc, void* start, int size )
+static void
+addProddableBlock ( ObjectCode* oc, void* start, int size )
{
ProddableBlock* pb
= stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock");
- IF_DEBUG(linker, debugBelch("addProddableBlock %p %p %d\n", oc, start, size));
+
+ IF_DEBUG(linker, debugBelch("addProddableBlock: %p %p %d\n", oc, start, size));
ASSERT(size > 0);
pb->start = start;
pb->size = size;
oc->proddables = pb;
}
-static void checkProddableBlock ( ObjectCode* oc, void* addr )
+static void
+checkProddableBlock (ObjectCode *oc, void *addr )
{
ProddableBlock* pb;
+
for (pb = oc->proddables; pb != NULL; pb = pb->next) {
char* s = (char*)(pb->start);
char* e = s + pb->size - 1;
/* -----------------------------------------------------------------------------
* Section management.
*/
-static void addSection ( ObjectCode* oc, SectionKind kind,
+static void
+addSection ( ObjectCode* oc, SectionKind kind,
void* start, void* end )
{
Section* s = stgMallocBytes(sizeof(Section), "addSection");
s->kind = kind;
s->next = oc->sections;
oc->sections = s;
- /*
- debugBelch("addSection: %p-%p (size %d), kind %d\n",
- start, ((char*)end)-1, end - start + 1, kind );
- */
+
+ IF_DEBUG(linker, debugBelch("addSection: %p-%p (size %ld), kind %d\n",
+ start, ((char*)end)-1, (long)end - (long)start + 1, kind ));
}
Because the PPC has split data/instruction caches, we have to
do that whenever we modify code at runtime.
*/
-static void ocFlushInstructionCacheFrom(void* begin, size_t length)
+
+static void
+ocFlushInstructionCacheFrom(void* begin, size_t length)
{
size_t n = (length + 3) / 4;
unsigned long* p = begin;
"isync"
);
}
-static void ocFlushInstructionCache( ObjectCode *oc )
+
+static void
+ocFlushInstructionCache( ObjectCode *oc )
{
/* The main object code */
ocFlushInstructionCacheFrom(oc->image + oc->misalignment, oc->fileSize);
/* Jump Islands */
ocFlushInstructionCacheFrom(oc->symbol_extras, sizeof(SymbolExtra) * oc->n_symbol_extras);
}
-#endif
+#endif /* powerpc_HOST_ARCH */
+
/* --------------------------------------------------------------------------
* PEi386 specifics (Win32 targets)
#endif
#ifdef powerpc_HOST_ARCH
-static int ocAllocateSymbolExtras_MachO(ObjectCode* oc)
+static int
+ocAllocateSymbolExtras_MachO(ObjectCode* oc)
{
struct mach_header *header = (struct mach_header *) oc->image;
struct load_command *lc = (struct load_command *) (header + 1);
unsigned i;
- for( i = 0; i < header->ncmds; i++ )
- {
- if( lc->cmd == LC_SYMTAB )
- {
+ IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: start\n"));
+
+ for (i = 0; i < header->ncmds; i++) {
+ if (lc->cmd == LC_SYMTAB) {
+
// Find out the first and last undefined external
// symbol, so we don't have to allocate too many
- // jump islands.
+ // jump islands/GOT entries.
+
struct symtab_command *symLC = (struct symtab_command *) lc;
unsigned min = symLC->nsyms, max = 0;
struct nlist *nlist =
symLC ? (struct nlist*) ((char*) oc->image + symLC->symoff)
: NULL;
- for(i=0;i<symLC->nsyms;i++)
- {
- if(nlist[i].n_type & N_STAB)
+
+ for (i = 0; i < symLC->nsyms; i++) {
+
+ if (nlist[i].n_type & N_STAB) {
;
- else if(nlist[i].n_type & N_EXT)
- {
+ } else if (nlist[i].n_type & N_EXT) {
+
if((nlist[i].n_type & N_TYPE) == N_UNDF
- && (nlist[i].n_value == 0))
- {
- if(i < min)
+ && (nlist[i].n_value == 0)) {
+
+ if (i < min) {
min = i;
- if(i > max)
+ }
+
+ if (i > max) {
max = i;
}
}
}
- if(max >= min)
+ }
+
+ if (max >= min) {
return ocAllocateSymbolExtras(oc, max - min + 1, min);
+ }
break;
}
lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
}
+
return ocAllocateSymbolExtras(oc,0,0);
}
+
#endif
#ifdef x86_64_HOST_ARCH
-static int ocAllocateSymbolExtras_MachO(ObjectCode* oc)
+static int
+ocAllocateSymbolExtras_MachO(ObjectCode* oc)
{
struct mach_header *header = (struct mach_header *) oc->image;
struct load_command *lc = (struct load_command *) (header + 1);
unsigned i;
- for( i = 0; i < header->ncmds; i++ )
- {
- if( lc->cmd == LC_SYMTAB )
- {
+ IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: start\n"));
+
+ for (i = 0; i < header->ncmds; i++) {
+ if (lc->cmd == LC_SYMTAB) {
+
// Just allocate one entry for every symbol
struct symtab_command *symLC = (struct symtab_command *) lc;
+ IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: allocate %d symbols\n", symLC->nsyms));
+ IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: done\n"));
return ocAllocateSymbolExtras(oc, symLC->nsyms, 0);
}
lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize );
}
+
+ IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: allocated no symbols\n"));
+ IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: done\n"));
return ocAllocateSymbolExtras(oc,0,0);
}
#endif
-static int ocVerifyImage_MachO(ObjectCode* oc)
+static int
+ocVerifyImage_MachO(ObjectCode * oc)
{
char *image = (char*) oc->image;
struct mach_header *header = (struct mach_header*) image;
+ IF_DEBUG(linker, debugBelch("ocVerifyImage_MachO: start\n"));
+
#if x86_64_HOST_ARCH || powerpc64_HOST_ARCH
if(header->magic != MH_MAGIC_64) {
errorBelch("%s: Bad magic. Expected: %08x, got: %08x.\n",
return 0;
}
#endif
+
// FIXME: do some more verifying here
+ IF_DEBUG(linker, debugBelch("ocVerifyImage_MachO: done\n"));
return 1;
}
-static int resolveImports(
+static int
+resolveImports(
ObjectCode* oc,
char *image,
struct symtab_command *symLC,
#if i386_HOST_ARCH
int isJumpTable = 0;
- if(!strcmp(sect->sectname,"__jump_table"))
- {
+
+ if (strcmp(sect->sectname,"__jump_table") == 0) {
isJumpTable = 1;
itemSize = 5;
ASSERT(sect->reserved2 == itemSize);
}
+
#endif
for(i=0; i*itemSize < sect->size;i++)
void *addr = NULL;
IF_DEBUG(linker, debugBelch("resolveImports: resolving %s\n", nm));
+
if ((symbol->n_type & N_TYPE) == N_UNDF
&& (symbol->n_type & N_EXT) && (symbol->n_value != 0)) {
addr = (void*) (symbol->n_value);
ASSERT(addr);
#if i386_HOST_ARCH
- if(isJumpTable)
- {
+ if (isJumpTable) {
checkProddableBlock(oc,image + sect->offset + i*itemSize);
- *(image + sect->offset + i*itemSize) = 0xe9; // jmp
+
+ *(image + sect->offset + i * itemSize) = 0xe9; // jmp opcode
*(unsigned*)(image + sect->offset + i*itemSize + 1)
= (char*)addr - (image + sect->offset + i*itemSize + 5);
}
# All the .a/.so library file dependencies for this library
$1_$2_$3_DEPS_LIBS=$$(foreach dep,$$($1_$2_DEPS),$$($$(dep)_$2_$3_LIB))
-ifneq "$$(BootingFromHc)" "YES"
-$1_$2_$3_MKSTUBOBJS = $$(FIND) $1/$2/build -name "*_stub.$$($3_osuf)" -print
-# HACK ^^^ we tried to use $(wildcard), but apparently it fails due to
-# make using cached directory contents, or something.
-else
-$1_$2_$3_MKSTUBOBJS = true
+ifeq "$$(BootingFromHc)" "YES"
$1_$2_$3_C_OBJS += $$(shell $$(FIND) $1/$2/build -name "*_stub.c" -print | sed 's/c$$$$/o/')
endif
ifeq "$$(HOSTPLATFORM)" "i386-unknown-mingw32"
$$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS)
"$$($1_$2_HC)" $$($1_$2_$3_ALL_OBJS) \
- `$$($1_$2_$3_MKSTUBOBJS)` \
-shared -dynamic -dynload deploy \
$$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) \
-no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \
else
$$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS)
"$$($1_$2_HC)" $$($1_$2_$3_ALL_OBJS) \
- `$$($1_$2_$3_MKSTUBOBJS)` \
-shared -dynamic -dynload deploy \
-dylib-install-name $(ghclibdir)/`basename "$$@" | sed 's/^libHS//;s/[-]ghc.*//'`/`basename "$$@"` \
-no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \
"$$(RM)" $$(RM_OPTS) $$@ $$@.contents
ifeq "$$($1_$2_SplitObjs)" "YES"
$$(FIND) $$(patsubst %.$$($3_osuf),%_$$($3_osuf)_split,$$($1_$2_$3_HS_OBJS)) -name '*.$$($3_osuf)' -print >> $$@.contents
- echo $$($1_$2_$3_NON_HS_OBJS) `$$($1_$2_$3_MKSTUBOBJS)` >> $$@.contents
+ echo $$($1_$2_$3_NON_HS_OBJS) >> $$@.contents
else
- echo $$($1_$2_$3_ALL_OBJS) `$$($1_$2_$3_MKSTUBOBJS)` >> $$@.contents
+ echo $$($1_$2_$3_ALL_OBJS) >> $$@.contents
endif
ifeq "$$(ArSupportsAtFile)" "YES"
"$$(AR)" $$(AR_OPTS) $$(EXTRA_AR_ARGS) $$@ @$$@.contents
endif
endif
$$($1_$2_GHCI_LIB) : $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS)
- "$$(LD)" -r -o $$@ $$(EXTRA_LD_OPTS) $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) `$$($1_$2_$3_MKSTUBOBJS)` $$($1_$2_EXTRA_OBJS)
+ "$$(LD)" -r -o $$@ $$(EXTRA_LD_OPTS) $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS)
ifeq "$$($1_$2_BUILD_GHCI_LIB)" "YES"
# Don't bother making ghci libs for bootstrapping packages
use strict;
use Cwd;
+# Usage:
+#
+# ./sync-all [-q] [-s] [--ignore-failure] [-r repo]
+# [--nofib] [--testsuite] [--checked-out] cmd [git flags]
+#
+# Applies the command "cmd" to each repository in the tree.
+# sync-all will try to do the right thing for both git and darcs repositories.
+#
+# e.g.
+# ./sync-all -r http://darcs.haskell.org/ghc get
+# To get any repos which do not exist in the local tree
+#
+# ./sync-all pull
+# To pull everything from the default repos
+#
+# -------------- Flags -------------------
+# -q says to be quite, and -s to be silent.
+#
+# --ignore-failure says to ignore errors and move on to the next repository
+#
+# -r repo says to use repo as the location of package repositories
+#
+# --checked-out says that the remote repo is in checked-out layout, as
+# opposed to the layout used for the main repo. By default a repo on
+# the local filesystem is assumed to be checked-out, and repos accessed
+# via HTTP or SSH are assumed to be in the main repo layout; use
+# --checked-out to override the latter.
+#
+# --nofib, --testsuite also get the nofib and testsuite repos respectively
+#
+# ------------ Which repos to use -------------
+# sync-all uses the following algorithm to decide which remote repos to use
+#
+# It always computes the remote repos from a single base, $repo_base
+# How is $repo_base set?
+# If you say "-r repo", then that's $repo_base
+# otherwise $repo_base is set by asking git where the ghc repo came
+# from, and removing the last component (e.g. /ghc.git/ of /ghc/).
+#
+# Then sync-all iterates over the package found in the file
+# ./packages; see that file for a description of the contents.
+#
+# If $repo_base looks like a local filesystem path, or if you give
+# the --checked-out flag, sync-all works on repos of form
+# $repo_base/<local-path>
+# otherwise sync-all works on repos of form
+# $repo_base/<remote-path>
+# This logic lets you say
+# both sync-all -r http://darcs.haskell.org/ghc-6.12 pull
+# and sync-all -r ../HEAD pull
+# The latter is called a "checked-out tree".
+
+# NB: sync-all *ignores* the defaultrepo of all repos other than the
+# root one. So the remote repos must be laid out in one of the two
+# formats given by <local-path> and <remote-path> in the file 'packages'.
+
+$| = 1; # autoflush stdout after each print, to avoid output after die
+
my $defaultrepo;
my @packages;
my $verbose = 2;
my $scm;
my $upstream;
my $line;
+ my $branch_name;
+ my $subcommand;
my $path;
my $wd_before = getcwd;
my @scm_args;
my $pwd;
+ my @args;
my ($repo_base, $checked_out_tree) = getrepo();
+ my $is_github_repo = $repo_base =~ m/(git@|git:\/\/|https:\/\/)github.com/;
+
parsePackages;
+ @args = ();
+
+ if ($command =~ /^remote$/) {
+ while (@_ > 0 && $_[0] =~ /^-/) {
+ push(@args,shift);
+ }
+ if (@_ < 1) { help(); }
+ $subcommand = shift;
+ if ($subcommand ne 'add' && $subcommand ne 'rm' && $subcommand ne 'set-url') {
+ help();
+ }
+ while (@_ > 0 && $_[0] =~ /^-/) {
+ push(@args,shift);
+ }
+ if (($subcommand eq 'add' || $subcommand eq 'rm') && @_ < 1) {
+ help();
+ } elsif (@_ < 1) { # set-url
+ $branch_name = 'origin';
+ } else {
+ $branch_name = shift;
+ }
+ } elsif ($command eq 'new' || $command eq 'fetch') {
+ if (@_ < 1) {
+ $branch_name = 'origin';
+ } else {
+ $branch_name = shift;
+ }
+ }
+
+ push(@args, @_);
+
for $line (@packages) {
$localpath = $$line{"localpath"};
$scm = $$line{"vcs"};
$upstream = $$line{"upstream"};
+ # We can't create directories on GitHub, so we translate
+ # "package/foo" into "package-foo".
+ if ($is_github_repo) {
+ $remotepath =~ s/\//-/;
+ }
+
# Check the SCM is OK as early as possible
die "Unknown SCM: $scm" if (($scm ne "darcs") and ($scm ne "git"));
}
# Work out the arguments we should give to the SCM
- if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew)$/) {
+ if ($command =~ /^(?:w|wh|wha|what|whats|whatsn|whatsne|whatsnew|status)$/) {
@scm_args = (($scm eq "darcs" and "whatsnew")
or ($scm eq "git" and "status"));
# Hack around 'darcs whatsnew' failing if there are no changes
$ignore_failure = 1;
}
+ elsif ($command =~ /^commit$/) {
+ @scm_args = ("commit");
+ # git fails if there is nothing to commit, so ignore failures
+ $ignore_failure = 1;
+ }
elsif ($command =~ /^(?:pus|push)$/) {
@scm_args = "push";
$want_remote_repo = 1;
}
elsif ($command =~ /^(?:pul|pull)$/) {
@scm_args = "pull";
- $want_remote_repo = 1;
# Q: should we append the -a argument for darcs repos?
}
elsif ($command =~ /^(?:g|ge|get)$/) {
}
# The first time round the loop, default the get-mode
- if (not defined($get_mode)) {
+ if ($scm eq "darcs" && not defined($get_mode)) {
warning("adding --partial, to override use --complete");
$get_mode = "--partial";
}
or ($scm eq "git" and "send-email"));
$want_remote_repo = 1;
}
- elsif ($command =~ /^set-origin$/) {
- @scm_args = ("remote", "set-url", "origin", $path);
- }
elsif ($command =~ /^fetch$/) {
- @scm_args = ("fetch", "origin");
+ @scm_args = ("fetch", "$branch_name");
}
elsif ($command =~ /^new$/) {
- @scm_args = ("log", "origin..");
+ @scm_args = ("log", "$branch_name..");
+ }
+ elsif ($command =~ /^remote$/) {
+ if ($subcommand eq 'add') {
+ @scm_args = ("remote", "add", $branch_name, $path);
+ } elsif ($subcommand eq 'rm') {
+ @scm_args = ("remote", "rm", $branch_name);
+ } elsif ($subcommand eq 'set-url') {
+ @scm_args = ("remote", "set-url", $branch_name, $path);
+ }
+ }
+ elsif ($command =~ /^grep$/) {
+ @scm_args = ("grep");
+ # Hack around 'git grep' failing if there are no matches
+ $ignore_failure = 1;
}
else {
die "Unknown command: $command";
if (repoexists ($scm, $localpath)) {
if ($want_remote_repo) {
if ($scm eq "darcs") {
- scm (".", $scm, @scm_args, @_, "--repodir=$localpath", $path);
+ scm (".", $scm, @scm_args, @args, "--repodir=$localpath", $path);
} else {
# git pull doesn't like to be used with --work-dir
# I couldn't find an alternative to chdir() here
- scm ($localpath, $scm, @scm_args, @_, $path, "master");
+ scm ($localpath, $scm, @scm_args, @args, $path, "master");
}
} else {
# git status *must* be used with --work-dir, if we don't chdir() to the dir
- scm ($localpath, $scm, @scm_args, @_);
+ scm ($localpath, $scm, @scm_args, @args);
}
}
elsif ($local_repo_unnecessary) {
# Don't bother to change directory in this case
- scm (".", $scm, @scm_args, @_);
+ scm (".", $scm, @scm_args, @args);
}
elsif ($tag eq "") {
message "== Required repo $localpath is missing! Skipping";
}
}
+
+sub help()
+{
+ # Get the built in help
+ my $help = <<END;
+What do you want to do?
+Supported commands:
+
+ * whatsnew
+ * commit
+ * push
+ * pull
+ * get, with options:
+ * --<package-tag>
+ * --complete
+ * --partial
+ * fetch
+ * send
+ * new
+ * remote add <branch-name>
+ * remote rm <branch-name>
+ * remote set-url [--push] <branch-name>
+ * grep
+
+Available package-tags are:
+END
+
+ # Collect all the tags in the packages file
+ my %available_tags;
+ open IN, "< packages" or die "Can't open packages file";
+ while (<IN>) {
+ chomp;
+ if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)/) {
+ if (defined($2) && $2 ne "-") {
+ $available_tags{$2} = 1;
+ }
+ }
+ elsif (! /^(#.*)?$/) {
+ die "Bad line: $_";
+ }
+ }
+ close IN;
+
+ # Show those tags and the help text
+ my @available_tags = keys %available_tags;
+ print "$help@available_tags\n";
+ exit 1;
+}
+
sub main {
if (! -d ".git" || ! -d "compiler") {
die "error: sync-all must be run from the top level of the ghc tree."
}
if ($#_ eq -1) {
- # Get the built in help
- my $help = <<END;
-What do you want to do?
-Supported commands:
-
- * whatsnew
- * push
- * pull
- * get, with options:
- * --<package-tag>
- * --complete
- * --partial
- * fetch
- * send
- * set-origin
- * new
-
-Available package-tags are:
-END
-
- # Collect all the tags in the packages file
- my %available_tags;
- open IN, "< packages" or die "Can't open packages file";
- while (<IN>) {
- chomp;
- if (/^([^# ]+) +(?:([^ ]+) +)?([^ ]+) +([^ ]+)/) {
- if (defined($2) && $2 ne "-") {
- $available_tags{$2} = 1;
- }
- }
- elsif (! /^(#.*)?$/) {
- die "Bad line: $_";
- }
- }
- close IN;
-
- # Show those tags and the help text
- my @available_tags = keys %available_tags;
- print "$help@available_tags\n";
- exit 1;
+ help();
}
else {
# Give the command and rest of the arguments to the main loop
projects / ghc-hetmet.git / commitdiff