*.o.cmd
*.depend*
log
+tags
autom4te.cache
config.log
# 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)
])
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' >> $@
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"
| 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 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 "m" = Cobjc
startPhase "cc" = Ccpp
startPhase "cxx" = Ccpp
-startPhase "raw_s" = Mangle
startPhase "split_s" = SplitMangle
startPhase "s" = As
startPhase "S" = As
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,
{-# 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
+runPhase cc_phase input_fn dflags
| cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc || cc_phase `eqPhase` Cobjc
- = do let dflags = hsc_dflags hsc_env
+ = 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 =
let gcc_lang_opt | cc_phase `eqPhase` Ccpp = "c++"
| cc_phase `eqPhase` Cobjc = "objective-c"
| otherwise = "c"
- SysTools.runCc dflags (
+ 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
-- 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)
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
dumpTcRn :: SDoc -> TcRn ()
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv
; dflags <- getDOpts
- ; liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
+ ; when (not opt_NoDebugOutput) $ liftIO (printForUser stderr (mkPrintUnqualified dflags rdr_env) doc) }
debugDumpTcRn :: SDoc -> TcRn ()
debugDumpTcRn doc | opt_NoDebugOutput = return ()
+++ /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
# 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
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 -
# 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"));
}
# 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
+ * 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