compiler/main/DriverPipeline.hs

   1 {-# OPTIONS -fno-cse #-}
   2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
   3
   4 -----------------------------------------------------------------------------
   5 --
   6 -- GHC Driver
   7 --
   8 -- (c) The University of Glasgow 2005
   9 --
  10 -----------------------------------------------------------------------------
  11
  12 module DriverPipeline (
  13         -- Run a series of compilation steps in a pipeline, for a
  14         -- collection of source files.
  15    oneShot, compileFile,
  16
  17         -- Interfaces for the batch-mode driver
  18    linkBinary,
  19
  20         -- Interfaces for the compilation manager (interpreted/batch-mode)
  21    preprocess,
  22    compile, compile',
  23    link,
  24
  25   ) where
  26
  27 #include "HsVersions.h"
  28
  29 import Packages
  30 import HeaderInfo
  31 import DriverPhases
  32 import SysTools
  33 import HscMain
  34 import Finder
  35 import HscTypes
  36 import Outputable
  37 import Module
  38 import UniqFM           ( eltsUFM )
  39 import ErrUtils
  40 import DynFlags
  41 import StaticFlags      ( v_Ld_inputs, opt_PIC, opt_Static, WayName(..) )
  42 import Config
  43 import Panic
  44 import Util
  45 import StringBuffer     ( hGetStringBuffer )
  46 import BasicTypes       ( SuccessFlag(..) )
  47 import Maybes           ( expectJust )
  48 import ParserCoreUtils  ( getCoreModuleName )
  49 import SrcLoc
  50 import FastString
  51 import LlvmCodeGen      ( llvmFixupAsm )
  52 -- import MonadUtils
  53
  54 -- import Data.Either
  55 import Exception
  56 import Data.IORef       ( readIORef )
  57 -- import GHC.Exts              ( Int(..) )
  58 import System.Directory
  59 import System.FilePath
  60 import System.IO
  61 import System.IO.Error as IO
  62 import Control.Monad
  63 import Data.List        ( isSuffixOf )
  64 import Data.Maybe
  65 import System.Environment
  66
  67 -- ---------------------------------------------------------------------------
  68 -- Pre-process
  69
  70 -- | Just preprocess a file, put the result in a temp. file (used by the
  71 -- compilation manager during the summary phase).
  72 --
  73 -- We return the augmented DynFlags, because they contain the result
  74 -- of slurping in the OPTIONS pragmas
  75
  76 preprocess :: GhcMonad m =>
  77               HscEnv
  78            -> (FilePath, Maybe Phase) -- ^ filename and starting phase
  79            -> m (DynFlags, FilePath)
  80 preprocess hsc_env (filename, mb_phase) =
  81   ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
  82   runPipeline anyHsc hsc_env (filename, mb_phase)
  83         Nothing Temporary Nothing{-no ModLocation-}
  84
  85 -- ---------------------------------------------------------------------------
  86
  87 -- | Compile
  88 --
  89 -- Compile a single module, under the control of the compilation manager.
  90 --
  91 -- This is the interface between the compilation manager and the
  92 -- compiler proper (hsc), where we deal with tedious details like
  93 -- reading the OPTIONS pragma from the source file, and passing the
  94 -- output of hsc through the C compiler.
  95 --
  96 -- NB.  No old interface can also mean that the source has changed.
  97
  98 compile :: GhcMonad m =>
  99            HscEnv
 100         -> ModSummary      -- ^ summary for module being compiled
 101         -> Int             -- ^ module N ...
 102         -> Int             -- ^ ... of M
 103         -> Maybe ModIface  -- ^ old interface, if we have one
 104         -> Maybe Linkable  -- ^ old linkable, if we have one
 105         -> m HomeModInfo   -- ^ the complete HomeModInfo, if successful
 106
 107 compile = compile' (hscCompileNothing, hscCompileInteractive, hscCompileBatch)
 108
 109 type Compiler m a = HscEnv -> ModSummary -> Bool
 110                   -> Maybe ModIface -> Maybe (Int, Int)
 111                   -> m a
 112
 113 compile' :: GhcMonad m =>
 114            (Compiler m (HscStatus, ModIface, ModDetails),
 115             Compiler m (InteractiveStatus, ModIface, ModDetails),
 116             Compiler m (HscStatus, ModIface, ModDetails))
 117         -> HscEnv
 118         -> ModSummary      -- ^ summary for module being compiled
 119         -> Int             -- ^ module N ...
 120         -> Int             -- ^ ... of M
 121         -> Maybe ModIface  -- ^ old interface, if we have one
 122         -> Maybe Linkable  -- ^ old linkable, if we have one
 123         -> m HomeModInfo   -- ^ the complete HomeModInfo, if successful
 124
 125 compile' (nothingCompiler, interactiveCompiler, batchCompiler)
 126         hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
 127  = do
 128    let dflags0     = ms_hspp_opts summary
 129        this_mod    = ms_mod summary
 130        src_flavour = ms_hsc_src summary
 131        location    = ms_location summary
 132        input_fn    = expectJust "compile:hs" (ml_hs_file location)
 133        input_fnpp  = ms_hspp_file summary
 134
 135    liftIO $ debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp)
 136
 137    let basename = dropExtension input_fn
 138
 139   -- We add the directory in which the .hs files resides) to the import path.
 140   -- This is needed when we try to compile the .hc file later, if it
 141   -- imports a _stub.h file that we created here.
 142    let current_dir = case takeDirectory basename of
 143                      "" -> "." -- XXX Hack
 144                      d -> d
 145        old_paths   = includePaths dflags0
 146        dflags      = dflags0 { includePaths = current_dir : old_paths }
 147        hsc_env     = hsc_env0 {hsc_dflags = dflags}
 148
 149    -- Figure out what lang we're generating
 150    let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags)
 151    -- ... and what the next phase should be
 152    let next_phase = hscNextPhase dflags src_flavour hsc_lang
 153    -- ... and what file to generate the output into
 154    output_fn <- liftIO $ getOutputFilename next_phase
 155                         Temporary basename dflags next_phase (Just location)
 156
 157    let dflags' = dflags { hscTarget = hsc_lang,
 158                                 hscOutName = output_fn,
 159                                 extCoreName = basename ++ ".hcr" }
 160    let hsc_env' = hsc_env { hsc_dflags = dflags' }
 161
 162    -- -fforce-recomp should also work with --make
 163    let force_recomp = dopt Opt_ForceRecomp dflags
 164        source_unchanged = isJust maybe_old_linkable && not force_recomp
 165        object_filename = ml_obj_file location
 166
 167    let getStubLinkable False = return []
 168        getStubLinkable True
 169            = do stub_o <- compileStub hsc_env' this_mod location
 170                 return [ DotO stub_o ]
 171
 172        handleBatch HscNoRecomp
 173            = ASSERT (isJust maybe_old_linkable)
 174              return maybe_old_linkable
 175
 176        handleBatch (HscRecomp hasStub _)
 177            | isHsBoot src_flavour
 178                = do when (isObjectTarget hsc_lang) $ -- interpreted reaches here too
 179                        liftIO $ SysTools.touch dflags' "Touching object file"
 180                                    object_filename
 181                     return maybe_old_linkable
 182
 183            | otherwise
 184                = do stub_unlinked <- getStubLinkable hasStub
 185                     (hs_unlinked, unlinked_time) <-
 186                         case hsc_lang of
 187                           HscNothing
 188                             -> return ([], ms_hs_date summary)
 189                           -- We're in --make mode: finish the compilation pipeline.
 190                           _other
 191                             -> do _ <- runPipeline StopLn hsc_env' (output_fn,Nothing)
 192                                               (Just basename)
 193                                               Persistent
 194                                               (Just location)
 195                                   -- The object filename comes from the ModLocation
 196                                   o_time <- liftIO $ getModificationTime object_filename
 197                                   return ([DotO object_filename], o_time)
 198                     let linkable = LM unlinked_time this_mod
 199                                    (hs_unlinked ++ stub_unlinked)
 200                     return (Just linkable)
 201
 202        handleInterpreted HscNoRecomp
 203            = ASSERT (isJust maybe_old_linkable)
 204              return maybe_old_linkable
 205        handleInterpreted (HscRecomp _hasStub Nothing)
 206            = ASSERT (isHsBoot src_flavour)
 207              return maybe_old_linkable
 208        handleInterpreted (HscRecomp hasStub (Just (comp_bc, modBreaks)))
 209            = do stub_unlinked <- getStubLinkable hasStub
 210                 let hs_unlinked = [BCOs comp_bc modBreaks]
 211                     unlinked_time = ms_hs_date summary
 212                   -- Why do we use the timestamp of the source file here,
 213                   -- rather than the current time?  This works better in
 214                   -- the case where the local clock is out of sync
 215                   -- with the filesystem's clock.  It's just as accurate:
 216                   -- if the source is modified, then the linkable will
 217                   -- be out of date.
 218                 let linkable = LM unlinked_time this_mod
 219                                (hs_unlinked ++ stub_unlinked)
 220                 return (Just linkable)
 221
 222    let -- runCompiler :: Compiler result -> (result -> Maybe Linkable)
 223        --            -> m HomeModInfo
 224        runCompiler compiler handle
 225            = do (result, iface, details)
 226                     <- compiler hsc_env' summary source_unchanged mb_old_iface
 227                                 (Just (mod_index, nmods))
 228                 linkable <- handle result
 229                 return (HomeModInfo{ hm_details  = details,
 230                                      hm_iface    = iface,
 231                                      hm_linkable = linkable })
 232    -- run the compiler
 233    case hsc_lang of
 234       HscInterpreted ->
 235                 runCompiler interactiveCompiler handleInterpreted
 236       HscNothing ->
 237                 runCompiler nothingCompiler handleBatch
 238       _other ->
 239                 runCompiler batchCompiler handleBatch
 240
 241
 242 -----------------------------------------------------------------------------
 243 -- stub .h and .c files (for foreign export support)
 244
 245 -- The _stub.c file is derived from the haskell source file, possibly taking
 246 -- into account the -stubdir option.
 247 --
 248 -- Consequently, we derive the _stub.o filename from the haskell object
 249 -- filename.
 250 --
 251 -- This isn't necessarily the same as the object filename we
 252 -- would get if we just compiled the _stub.c file using the pipeline.
 253 -- For example:
 254 --
 255 --    ghc src/A.hs -odir obj
 256 --
 257 -- results in obj/A.o, and src/A_stub.c.  If we compile src/A_stub.c with
 258 -- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want
 259 -- obj/A_stub.o.
 260
 261 compileStub :: GhcMonad m => HscEnv -> Module -> ModLocation
 262             -> m FilePath
 263 compileStub hsc_env mod location = do
 264         -- compile the _stub.c file w/ gcc
 265         let (stub_c,_,stub_o) = mkStubPaths (hsc_dflags hsc_env)
 266                                    (moduleName mod) location
 267
 268         _ <- runPipeline StopLn hsc_env (stub_c,Nothing)  Nothing
 269                 (SpecificFile stub_o) Nothing{-no ModLocation-}
 270
 271         return stub_o
 272
 273
 274 -- ---------------------------------------------------------------------------
 275 -- Link
 276
 277 link :: GhcLink                 -- interactive or batch
 278      -> DynFlags                -- dynamic flags
 279      -> Bool                    -- attempt linking in batch mode?
 280      -> HomePackageTable        -- what to link
 281      -> IO SuccessFlag
 282
 283 -- For the moment, in the batch linker, we don't bother to tell doLink
 284 -- which packages to link -- it just tries all that are available.
 285 -- batch_attempt_linking should only be *looked at* in batch mode.  It
 286 -- should only be True if the upsweep was successful and someone
 287 -- exports main, i.e., we have good reason to believe that linking
 288 -- will succeed.
 289
 290 #ifdef GHCI
 291 link LinkInMemory _ _ _
 292     = do -- Not Linking...(demand linker will do the job)
 293          return Succeeded
 294 #endif
 295
 296 link NoLink _ _ _
 297    = return Succeeded
 298
 299 link LinkBinary dflags batch_attempt_linking hpt
 300    = link' dflags batch_attempt_linking hpt
 301
 302 link LinkDynLib dflags batch_attempt_linking hpt
 303    = link' dflags batch_attempt_linking hpt
 304
 305 #ifndef GHCI
 306 -- warning suppression
 307 link other _ _ _ = panicBadLink other
 308 #endif
 309
 310 panicBadLink :: GhcLink -> a
 311 panicBadLink other = panic ("link: GHC not built to link this way: " ++
 312                             show other)
 313
 314 link' :: DynFlags                -- dynamic flags
 315       -> Bool                    -- attempt linking in batch mode?
 316       -> HomePackageTable        -- what to link
 317       -> IO SuccessFlag
 318
 319 link' dflags batch_attempt_linking hpt
 320    | batch_attempt_linking
 321    = do
 322         let
 323             home_mod_infos = eltsUFM hpt
 324
 325             -- the packages we depend on
 326             pkg_deps  = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos
 327
 328             -- the linkables to link
 329             linkables = map (expectJust "link".hm_linkable) home_mod_infos
 330
 331         debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
 332
 333         -- check for the -no-link flag
 334         if isNoLink (ghcLink dflags)
 335           then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).")
 336                   return Succeeded
 337           else do
 338
 339         let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
 340             obj_files = concatMap getOfiles linkables
 341
 342             exe_file = exeFileName dflags
 343
 344         linking_needed <- linkingNeeded dflags linkables pkg_deps
 345
 346         if not (dopt Opt_ForceRecomp dflags) && not linking_needed
 347            then do debugTraceMsg dflags 2 (text exe_file <+> ptext (sLit "is up to date, linking not required."))
 348                    return Succeeded
 349            else do
 350
 351         debugTraceMsg dflags 1 (ptext (sLit "Linking") <+> text exe_file
 352                                  <+> text "...")
 353
 354         -- Don't showPass in Batch mode; doLink will do that for us.
 355         let link = case ghcLink dflags of
 356                 LinkBinary  -> linkBinary
 357                 LinkDynLib  -> linkDynLib
 358                 other       -> panicBadLink other
 359         link dflags obj_files pkg_deps
 360
 361         debugTraceMsg dflags 3 (text "link: done")
 362
 363         -- linkBinary only returns if it succeeds
 364         return Succeeded
 365
 366    | otherwise
 367    = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$
 368                                 text "   Main.main not exported; not linking.")
 369         return Succeeded
 370
 371
 372 linkingNeeded :: DynFlags -> [Linkable] -> [PackageId] -> IO Bool
 373 linkingNeeded dflags linkables pkg_deps = do
 374         -- if the modification time on the executable is later than the
 375         -- modification times on all of the objects and libraries, then omit
 376         -- linking (unless the -fforce-recomp flag was given).
 377   let exe_file = exeFileName dflags
 378   e_exe_time <- IO.try $ getModificationTime exe_file
 379   case e_exe_time of
 380     Left _  -> return True
 381     Right t -> do
 382         -- first check object files and extra_ld_inputs
 383         extra_ld_inputs <- readIORef v_Ld_inputs
 384         e_extra_times <- mapM (IO.try . getModificationTime) extra_ld_inputs
 385         let (errs,extra_times) = splitEithers e_extra_times
 386         let obj_times =  map linkableTime linkables ++ extra_times
 387         if not (null errs) || any (t <) obj_times
 388             then return True
 389             else do
 390
 391         -- next, check libraries. XXX this only checks Haskell libraries,
 392         -- not extra_libraries or -l things from the command line.
 393         let pkg_map = pkgIdMap (pkgState dflags)
 394             pkg_hslibs  = [ (libraryDirs c, lib)
 395                           | Just c <- map (lookupPackage pkg_map) pkg_deps,
 396                             lib <- packageHsLibs dflags c ]
 397
 398         pkg_libfiles <- mapM (uncurry findHSLib) pkg_hslibs
 399         if any isNothing pkg_libfiles then return True else do
 400         e_lib_times <- mapM (IO.try . getModificationTime)
 401                           (catMaybes pkg_libfiles)
 402         let (lib_errs,lib_times) = splitEithers e_lib_times
 403         if not (null lib_errs) || any (t <) lib_times
 404            then return True
 405            else return False
 406
 407 findHSLib :: [String] -> String -> IO (Maybe FilePath)
 408 findHSLib dirs lib = do
 409   let batch_lib_file = "lib" ++ lib <.> "a"
 410   found <- filterM doesFileExist (map (</> batch_lib_file) dirs)
 411   case found of
 412     [] -> return Nothing
 413     (x:_) -> return (Just x)
 414
 415 -- -----------------------------------------------------------------------------
 416 -- Compile files in one-shot mode.
 417
 418 oneShot :: GhcMonad m =>
 419            HscEnv -> Phase -> [(String, Maybe Phase)] -> m ()
 420 oneShot hsc_env stop_phase srcs = do
 421   o_files <- mapM (compileFile hsc_env stop_phase) srcs
 422   liftIO $ doLink (hsc_dflags hsc_env) stop_phase o_files
 423
 424 compileFile :: GhcMonad m =>
 425                HscEnv -> Phase -> (FilePath, Maybe Phase) -> m FilePath
 426 compileFile hsc_env stop_phase (src, mb_phase) = do
 427    exists <- liftIO $ doesFileExist src
 428    when (not exists) $
 429         ghcError (CmdLineError ("does not exist: " ++ src))
 430
 431    let
 432         dflags = hsc_dflags hsc_env
 433         split     = dopt Opt_SplitObjs dflags
 434         mb_o_file = outputFile dflags
 435         ghc_link  = ghcLink dflags      -- Set by -c or -no-link
 436
 437         -- When linking, the -o argument refers to the linker's output.
 438         -- otherwise, we use it as the name for the pipeline's output.
 439         output
 440          | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
 441                 -- -o foo applies to linker
 442          | Just o_file <- mb_o_file = SpecificFile o_file
 443                 -- -o foo applies to the file we are compiling now
 444          | otherwise = Persistent
 445
 446         stop_phase' = case stop_phase of
 447                         As | split -> SplitAs
 448                         _          -> stop_phase
 449
 450    ( _, out_file) <- runPipeline stop_phase' hsc_env
 451                             (src, mb_phase) Nothing output
 452                             Nothing{-no ModLocation-}
 453    return out_file
 454
 455
 456 doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
 457 doLink dflags stop_phase o_files
 458   | not (isStopLn stop_phase)
 459   = return ()           -- We stopped before the linking phase
 460
 461   | otherwise
 462   = case ghcLink dflags of
 463         NoLink     -> return ()
 464         LinkBinary -> linkBinary dflags o_files []
 465         LinkDynLib -> linkDynLib dflags o_files []
 466         other      -> panicBadLink other
 467
 468
 469 -- ---------------------------------------------------------------------------
 470
 471 data PipelineOutput
 472   = Temporary
 473         -- ^ Output should be to a temporary file: we're going to
 474         -- run more compilation steps on this output later.
 475   | Persistent
 476         -- ^ We want a persistent file, i.e. a file in the current directory
 477         -- derived from the input filename, but with the appropriate extension.
 478         -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o.
 479   | SpecificFile FilePath
 480         -- ^ The output must go into the specified file.
 481
 482 -- | Run a compilation pipeline, consisting of multiple phases.
 483 --
 484 -- This is the interface to the compilation pipeline, which runs
 485 -- a series of compilation steps on a single source file, specifying
 486 -- at which stage to stop.
 487 --
 488 -- The DynFlags can be modified by phases in the pipeline (eg. by
 489 -- OPTIONS_GHC pragmas), and the changes affect later phases in the
 490 -- pipeline.
 491 runPipeline
 492   :: GhcMonad m =>
 493      Phase                      -- ^ When to stop
 494   -> HscEnv                     -- ^ Compilation environment
 495   -> (FilePath,Maybe Phase)     -- ^ Input filename (and maybe -x suffix)
 496   -> Maybe FilePath             -- ^ original basename (if different from ^^^)
 497   -> PipelineOutput             -- ^ Output filename
 498   -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module
 499   -> m (DynFlags, FilePath)     -- ^ (final flags, output filename)
 500
 501 runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc
 502   = do
 503   let dflags0 = hsc_dflags hsc_env0
 504       (input_basename, suffix) = splitExtension input_fn
 505       suffix' = drop 1 suffix -- strip off the .
 506       basename | Just b <- mb_basename = b
 507                | otherwise             = input_basename
 508
 509       -- Decide where dump files should go based on the pipeline output
 510       dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
 511       hsc_env = hsc_env0 {hsc_dflags = dflags}
 512
 513         -- If we were given a -x flag, then use that phase to start from
 514       start_phase = fromMaybe (startPhase suffix') mb_phase
 515
 516   -- We want to catch cases of "you can't get there from here" before
 517   -- we start the pipeline, because otherwise it will just run off the
 518   -- end.
 519   --
 520   -- There is a partial ordering on phases, where A < B iff A occurs
 521   -- before B in a normal compilation pipeline.
 522
 523   when (not (start_phase `happensBefore` stop_phase)) $
 524         ghcError (UsageError
 525                     ("cannot compile this file to desired target: "
 526                        ++ input_fn))
 527
 528   -- this is a function which will be used to calculate output file names
 529   -- as we go along (we partially apply it to some of its inputs here)
 530   let get_output_fn = getOutputFilename stop_phase output basename
 531
 532   -- Execute the pipeline...
 533   (dflags', output_fn, maybe_loc) <-
 534         pipeLoop hsc_env start_phase stop_phase input_fn
 535                  basename suffix' get_output_fn maybe_loc
 536
 537   -- Sometimes, a compilation phase doesn't actually generate any output
 538   -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
 539   -- stage, but we wanted to keep the output, then we have to explicitly
 540   -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
 541   -- further compilation stages can tell what the original filename was.
 542   case output of
 543     Temporary ->
 544         return (dflags', output_fn)
 545     _other -> liftIO $
 546         do final_fn <- get_output_fn dflags' stop_phase maybe_loc
 547            when (final_fn /= output_fn) $ do
 548               let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'")
 549                   line_prag = Just ("{-# LINE 1 \"" ++ input_fn ++ "\" #-}\n")
 550               copyWithHeader dflags msg line_prag output_fn final_fn
 551            return (dflags', final_fn)
 552
 553
 554
 555 pipeLoop :: GhcMonad m =>
 556             HscEnv -> Phase -> Phase
 557          -> FilePath  -> String -> Suffix
 558          -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
 559          -> Maybe ModLocation
 560          -> m (DynFlags, FilePath, Maybe ModLocation)
 561
 562 pipeLoop hsc_env phase stop_phase
 563          input_fn orig_basename orig_suff
 564          orig_get_output_fn maybe_loc
 565
 566   | phase `eqPhase` stop_phase            -- All done
 567   = return (hsc_dflags hsc_env, input_fn, maybe_loc)
 568
 569   | not (phase `happensBefore` stop_phase)
 570         -- Something has gone wrong.  We'll try to cover all the cases when
 571         -- this could happen, so if we reach here it is a panic.
 572         -- eg. it might happen if the -C flag is used on a source file that
 573         -- has {-# OPTIONS -fasm #-}.
 574   = panic ("pipeLoop: at phase " ++ show phase ++
 575            " but I wanted to stop at phase " ++ show stop_phase)
 576
 577   | otherwise
 578   = do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 4
 579                               (ptext (sLit "Running phase") <+> ppr phase)
 580        (next_phase, dflags', maybe_loc, output_fn)
 581           <- runPhase phase stop_phase hsc_env orig_basename
 582                       orig_suff input_fn orig_get_output_fn maybe_loc
 583        let hsc_env' = hsc_env {hsc_dflags = dflags'}
 584        pipeLoop hsc_env' next_phase stop_phase output_fn
 585                 orig_basename orig_suff orig_get_output_fn maybe_loc
 586
 587 getOutputFilename
 588   :: Phase -> PipelineOutput -> String
 589   -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
 590 getOutputFilename stop_phase output basename
 591  = func
 592  where
 593         func dflags next_phase maybe_location
 594            | is_last_phase, Persistent <- output     = persistent_fn
 595            | is_last_phase, SpecificFile f <- output = return f
 596            | keep_this_output                        = persistent_fn
 597            | otherwise                               = newTempName dflags suffix
 598            where
 599                 hcsuf      = hcSuf dflags
 600                 odir       = objectDir dflags
 601                 osuf       = objectSuf dflags
 602                 keep_hc    = dopt Opt_KeepHcFiles dflags
 603                 keep_raw_s = dopt Opt_KeepRawSFiles dflags
 604                 keep_s     = dopt Opt_KeepSFiles dflags
 605                 keep_bc    = dopt Opt_KeepLlvmFiles dflags
 606
 607                 myPhaseInputExt HCc    = hcsuf
 608                 myPhaseInputExt StopLn = osuf
 609                 myPhaseInputExt other  = phaseInputExt other
 610
 611                 is_last_phase = next_phase `eqPhase` stop_phase
 612
 613                 -- sometimes, we keep output from intermediate stages
 614                 keep_this_output =
 615                      case next_phase of
 616                              StopLn               -> True
 617                              Mangle  | keep_raw_s -> True
 618                              As      | keep_s     -> True
 619                              LlvmOpt | keep_bc    -> True
 620                              HCc     | keep_hc    -> True
 621                              _other               -> False
 622
 623                 suffix = myPhaseInputExt next_phase
 624
 625                 -- persistent object files get put in odir
 626                 persistent_fn
 627                    | StopLn <- next_phase = return odir_persistent
 628                    | otherwise            = return persistent
 629
 630                 persistent = basename <.> suffix
 631
 632                 odir_persistent
 633                    | Just loc <- maybe_location = ml_obj_file loc
 634                    | Just d <- odir = d </> persistent
 635                    | otherwise      = persistent
 636
 637
 638 -- -----------------------------------------------------------------------------
 639 -- | Each phase in the pipeline returns the next phase to execute, and the
 640 -- name of the file in which the output was placed.
 641 --
 642 -- We must do things dynamically this way, because we often don't know
 643 -- what the rest of the phases will be until part-way through the
 644 -- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
 645 -- of a source file can change the latter stages of the pipeline from
 646 -- taking the via-C route to using the native code generator.
 647 --
 648 runPhase :: GhcMonad m =>
 649             Phase       -- ^ Do this phase first
 650          -> Phase       -- ^ Stop just before this phase
 651          -> HscEnv
 652          -> String      -- ^ basename of original input source
 653          -> String      -- ^ its extension
 654          -> FilePath    -- ^ name of file which contains the input to this phase.
 655          -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
 656                         -- ^ how to calculate the output filename
 657          -> Maybe ModLocation           -- ^ the ModLocation, if we have one
 658          -> m (Phase,                   -- next phase
 659                DynFlags,                -- new dynamic flags
 660                Maybe ModLocation,       -- the ModLocation, if we have one
 661                FilePath)                -- output filename
 662
 663         -- Invariant: the output filename always contains the output
 664         -- Interesting case: Hsc when there is no recompilation to do
 665         --                   Then the output filename is still a .o file
 666
 667 -------------------------------------------------------------------------------
 668 -- Unlit phase
 669
 670 runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 671   = do
 672        let dflags = hsc_dflags hsc_env
 673        output_fn <- liftIO $ get_output_fn dflags (Cpp sf) maybe_loc
 674
 675        let unlit_flags = getOpts dflags opt_L
 676            flags = map SysTools.Option unlit_flags ++
 677                    [ -- The -h option passes the file name for unlit to
 678                      -- put in a #line directive
 679                      SysTools.Option     "-h"
 680                      -- cpp interprets \b etc as escape sequences,
 681                      -- so we use / for filenames in pragmas
 682                    , SysTools.Option $ reslash Forwards $ normalise input_fn
 683                    , SysTools.FileOption "" input_fn
 684                    , SysTools.FileOption "" output_fn
 685                    ]
 686
 687        liftIO $ SysTools.runUnlit dflags flags
 688
 689        return (Cpp sf, dflags, maybe_loc, output_fn)
 690
 691 -------------------------------------------------------------------------------
 692 -- Cpp phase : (a) gets OPTIONS out of file
 693 --             (b) runs cpp if necessary
 694
 695 runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 696   = do let dflags0 = hsc_dflags hsc_env
 697        let dflags0' = flattenExtensionFlags dflags0
 698        src_opts <- liftIO $ getOptionsFromFile dflags0' input_fn
 699        (dflags1, unhandled_flags, warns)
 700            <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
 701        checkProcessArgsResult unhandled_flags
 702        let dflags1' = flattenExtensionFlags dflags1
 703
 704        if not (xopt Opt_Cpp dflags1') then do
 705            -- we have to be careful to emit warnings only once.
 706            unless (dopt Opt_Pp dflags1') $ handleFlagWarnings dflags1' warns
 707
 708            -- no need to preprocess CPP, just pass input file along
 709            -- to the next phase of the pipeline.
 710            return (HsPp sf, dflags1, maybe_loc, input_fn)
 711         else do
 712             output_fn <- liftIO $ get_output_fn dflags1' (HsPp sf) maybe_loc
 713             liftIO $ doCpp dflags1' True{-raw-} False{-no CC opts-} input_fn output_fn
 714             -- re-read the pragmas now that we've preprocessed the file
 715             -- See #2464,#3457
 716             src_opts <- liftIO $ getOptionsFromFile dflags0' output_fn
 717             (dflags2, unhandled_flags, warns)
 718                 <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
 719             let dflags2' = flattenExtensionFlags dflags2
 720             unless (dopt Opt_Pp dflags2') $ handleFlagWarnings dflags2' warns
 721             -- the HsPp pass below will emit warnings
 722             checkProcessArgsResult unhandled_flags
 723
 724             return (HsPp sf, dflags2, maybe_loc, output_fn)
 725
 726 -------------------------------------------------------------------------------
 727 -- HsPp phase
 728
 729 runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
 730   = do let dflags = hsc_dflags hsc_env
 731            dflags' = flattenExtensionFlags dflags
 732        if not (dopt Opt_Pp dflags) then
 733            -- no need to preprocess, just pass input file along
 734            -- to the next phase of the pipeline.
 735           return (Hsc sf, dflags', maybe_loc, input_fn)
 736         else do
 737             let hspp_opts = getOpts dflags opt_F
 738             let orig_fn = basename <.> suff
 739             output_fn <- liftIO $ get_output_fn dflags (Hsc sf) maybe_loc
 740             liftIO $ SysTools.runPp dflags
 741                            ( [ SysTools.Option     orig_fn
 742                              , SysTools.Option     input_fn
 743                              , SysTools.FileOption "" output_fn
 744                              ] ++
 745                              map SysTools.Option hspp_opts
 746                            )
 747
 748             -- re-read pragmas now that we've parsed the file (see #3674)
 749             src_opts <- liftIO $ getOptionsFromFile dflags' output_fn
 750             (dflags1, unhandled_flags, warns)
 751                 <- liftIO $ parseDynamicNoPackageFlags dflags src_opts
 752             let dflags1' = flattenExtensionFlags dflags1
 753             handleFlagWarnings dflags1' warns
 754             checkProcessArgsResult unhandled_flags
 755
 756             return (Hsc sf, dflags1', maybe_loc, output_fn)
 757
 758 -----------------------------------------------------------------------------
 759 -- Hsc phase
 760
 761 -- Compilation of a single module, in "legacy" mode (_not_ under
 762 -- the direction of the compilation manager).
 763 runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _maybe_loc
 764  = do   -- normal Hsc mode, not mkdependHS
 765         let dflags0 = hsc_dflags hsc_env
 766
 767   -- we add the current directory (i.e. the directory in which
 768   -- the .hs files resides) to the include path, since this is
 769   -- what gcc does, and it's probably what you want.
 770         let current_dir = case takeDirectory basename of
 771                       "" -> "." -- XXX Hack
 772                       d -> d
 773
 774             paths = includePaths dflags0
 775             dflags = dflags0 { includePaths = current_dir : paths }
 776
 777   -- gather the imports and module name
 778         (hspp_buf,mod_name,imps,src_imps) <-
 779             case src_flavour of
 780                 ExtCoreFile -> do  -- no explicit imports in ExtCore input.
 781                     m <- liftIO $ getCoreModuleName input_fn
 782                     return (Nothing, mkModuleName m, [], [])
 783
 784                 _           -> do
 785                     buf <- liftIO $ hGetStringBuffer input_fn
 786                     (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
 787                     return (Just buf, mod_name, imps, src_imps)
 788
 789   -- Build a ModLocation to pass to hscMain.
 790   -- The source filename is rather irrelevant by now, but it's used
 791   -- by hscMain for messages.  hscMain also needs
 792   -- the .hi and .o filenames, and this is as good a way
 793   -- as any to generate them, and better than most. (e.g. takes
 794   -- into accout the -osuf flags)
 795         location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
 796
 797   -- Boot-ify it if necessary
 798         let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
 799                       | otherwise            = location1
 800
 801
 802   -- Take -ohi into account if present
 803   -- This can't be done in mkHomeModuleLocation because
 804   -- it only applies to the module being compiles
 805         let ohi = outputHi dflags
 806             location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
 807                       | otherwise      = location2
 808
 809   -- Take -o into account if present
 810   -- Very like -ohi, but we must *only* do this if we aren't linking
 811   -- (If we're linking then the -o applies to the linked thing, not to
 812   -- the object file for one module.)
 813   -- Note the nasty duplication with the same computation in compileFile above
 814         let expl_o_file = outputFile dflags
 815             location4 | Just ofile <- expl_o_file
 816                       , isNoLink (ghcLink dflags)
 817                       = location3 { ml_obj_file = ofile }
 818                       | otherwise = location3
 819
 820             o_file = ml_obj_file location4      -- The real object file
 821
 822
 823   -- Figure out if the source has changed, for recompilation avoidance.
 824   --
 825   -- Setting source_unchanged to True means that M.o seems
 826   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 827   -- changed (which the compiler itself figures out).
 828   -- Setting source_unchanged to False tells the compiler that M.o is out of
 829   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 830         src_timestamp <- liftIO $ getModificationTime (basename <.> suff)
 831
 832         let force_recomp = dopt Opt_ForceRecomp dflags
 833             hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags)
 834         source_unchanged <-
 835           if force_recomp || not (isStopLn stop)
 836                 -- Set source_unchanged to False unconditionally if
 837                 --      (a) recompilation checker is off, or
 838                 --      (b) we aren't going all the way to .o file (e.g. ghc -S)
 839              then return False
 840                 -- Otherwise look at file modification dates
 841              else do o_file_exists <- liftIO $ doesFileExist o_file
 842                      if not o_file_exists
 843                         then return False       -- Need to recompile
 844                         else do t2 <- liftIO $ getModificationTime o_file
 845                                 if t2 > src_timestamp
 846                                   then return True
 847                                   else return False
 848
 849   -- get the DynFlags
 850         let next_phase = hscNextPhase dflags src_flavour hsc_lang
 851         output_fn  <- liftIO $ get_output_fn dflags next_phase (Just location4)
 852
 853         let dflags' = dflags { hscTarget = hsc_lang,
 854                                hscOutName = output_fn,
 855                                extCoreName = basename ++ ".hcr" }
 856
 857         let hsc_env' = hsc_env {hsc_dflags = dflags'}
 858
 859   -- Tell the finder cache about this module
 860         mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location4
 861
 862   -- Make the ModSummary to hand to hscMain
 863         let
 864             mod_summary = ModSummary {  ms_mod       = mod,
 865                                         ms_hsc_src   = src_flavour,
 866                                         ms_hspp_file = input_fn,
 867                                         ms_hspp_opts = dflags,
 868                                         ms_hspp_buf  = hspp_buf,
 869                                         ms_location  = location4,
 870                                         ms_hs_date   = src_timestamp,
 871                                         ms_obj_date  = Nothing,
 872                                         ms_imps      = imps,
 873                                         ms_srcimps   = src_imps }
 874
 875   -- run the compiler!
 876         result <- hscCompileOneShot hsc_env'
 877                           mod_summary source_unchanged
 878                           Nothing       -- No iface
 879                           Nothing       -- No "module i of n" progress info
 880
 881         case result of
 882           HscNoRecomp
 883               -> do liftIO $ SysTools.touch dflags' "Touching object file" o_file
 884                     -- The .o file must have a later modification date
 885                     -- than the source file (else we wouldn't be in HscNoRecomp)
 886                     -- but we touch it anyway, to keep 'make' happy (we think).
 887                     return (StopLn, dflags', Just location4, o_file)
 888           (HscRecomp hasStub _)
 889               -> do when hasStub $
 890                          do stub_o <- compileStub hsc_env' mod location4
 891                             liftIO $ consIORef v_Ld_inputs stub_o
 892                     -- In the case of hs-boot files, generate a dummy .o-boot
 893                     -- stamp file for the benefit of Make
 894                     when (isHsBoot src_flavour) $
 895                       liftIO $ SysTools.touch dflags' "Touching object file" o_file
 896                     return (next_phase, dflags', Just location4, output_fn)
 897
 898 -----------------------------------------------------------------------------
 899 -- Cmm phase
 900
 901 runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 902   = do
 903        let dflags = hsc_dflags hsc_env
 904            dflags' = flattenExtensionFlags dflags
 905        output_fn <- liftIO $ get_output_fn dflags' Cmm maybe_loc
 906        liftIO $ doCpp dflags' False{-not raw-} True{-include CC opts-} input_fn output_fn
 907        return (Cmm, dflags', maybe_loc, output_fn)
 908
 909 runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc
 910   = do
 911         let dflags = ensureFlattenedExtensionFlags $ hsc_dflags hsc_env
 912         let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
 913         let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
 914         output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc
 915
 916         let dflags' = dflags { hscTarget = hsc_lang,
 917                                hscOutName = output_fn,
 918                                extCoreName = basename ++ ".hcr" }
 919         let hsc_env' = hsc_env {hsc_dflags = dflags'}
 920
 921         hscCmmFile hsc_env' input_fn
 922
 923         -- XXX: catch errors above and convert them into ghcError?  Original
 924         -- code was:
 925         --
 926         --when (not ok) $ ghcError (PhaseFailed "cmm" (ExitFailure 1))
 927
 928         return (next_phase, dflags, maybe_loc, output_fn)
 929
 930 -----------------------------------------------------------------------------
 931 -- Cc phase
 932
 933 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 934 -- way too many hacks, and I can't say I've ever used it anyway.
 935
 936 runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 937    | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc
 938    = do let dflags = hsc_dflags hsc_env
 939         let cc_opts = getOpts dflags opt_c
 940             hcc = cc_phase `eqPhase` HCc
 941
 942         let cmdline_include_paths = includePaths dflags
 943
 944         -- HC files have the dependent packages stamped into them
 945         pkgs <- if hcc then liftIO (getHCFilePackages input_fn) else return []
 946
 947         -- add package include paths even if we're just compiling .c
 948         -- files; this is the Value Add(TM) that using ghc instead of
 949         -- gcc gives you :)
 950         pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs
 951         let include_paths = foldr (\ x xs -> "-I" : x : xs) []
 952                               (cmdline_include_paths ++ pkg_include_dirs)
 953
 954         let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags
 955         gcc_extra_viac_flags <- liftIO $ getExtraViaCOpts dflags
 956         let pic_c_flags = picCCOpts dflags
 957
 958         let verb = getVerbFlag dflags
 959
 960         -- cc-options are not passed when compiling .hc files.  Our
 961         -- hc code doesn't not #include any header files anyway, so these
 962         -- options aren't necessary.
 963         pkg_extra_cc_opts <-
 964           if cc_phase `eqPhase` HCc
 965              then return []
 966              else liftIO $ getPackageExtraCcOpts dflags pkgs
 967
 968 #ifdef darwin_TARGET_OS
 969         pkg_framework_paths <- liftIO $ getPackageFrameworkPath dflags pkgs
 970         let cmdline_framework_paths = frameworkPaths dflags
 971         let framework_paths = map ("-F"++)
 972                         (cmdline_framework_paths ++ pkg_framework_paths)
 973 #endif
 974
 975         let split_objs = dopt Opt_SplitObjs dflags
 976             split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 977                       | otherwise         = [ ]
 978
 979         let cc_opt | optLevel dflags >= 2 = "-O2"
 980                    | otherwise            = "-O"
 981
 982         -- Decide next phase
 983
 984         let mangle = dopt Opt_DoAsmMangling dflags
 985             next_phase
 986                 | hcc && mangle     = Mangle
 987                 | otherwise         = As
 988         output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc
 989
 990         let
 991           more_hcc_opts =
 992 #if i386_TARGET_ARCH
 993                 -- on x86 the floating point regs have greater precision
 994                 -- than a double, which leads to unpredictable results.
 995                 -- By default, we turn this off with -ffloat-store unless
 996                 -- the user specified -fexcess-precision.
 997                 (if dopt Opt_ExcessPrecision dflags
 998                         then []
 999                         else [ "-ffloat-store" ]) ++
1000 #endif
1001
1002                 -- gcc's -fstrict-aliasing allows two accesses to memory
1003                 -- to be considered non-aliasing if they have different types.
1004                 -- This interacts badly with the C code we generate, which is
1005                 -- very weakly typed, being derived from C--.
1006                 ["-fno-strict-aliasing"]
1007
1008         liftIO $ SysTools.runCc dflags (
1009                 -- force the C compiler to interpret this file as C when
1010                 -- compiling .hc files, by adding the -x c option.
1011                 -- Also useful for plain .c files, just in case GHC saw a
1012                 -- -x c option.
1013                         [ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp
1014                                                 then SysTools.Option "c++"
1015                                                 else SysTools.Option "c"] ++
1016                         [ SysTools.FileOption "" input_fn
1017                         , SysTools.Option "-o"
1018                         , SysTools.FileOption "" output_fn
1019                         ]
1020                        ++ map SysTools.Option (
1021                           md_c_flags
1022                        ++ pic_c_flags
1023
1024 #if    defined(mingw32_TARGET_OS)
1025                 -- Stub files generated for foreign exports references the runIO_closure
1026                 -- and runNonIO_closure symbols, which are defined in the base package.
1027                 -- These symbols are imported into the stub.c file via RtsAPI.h, and the
1028                 -- way we do the import depends on whether we're currently compiling
1029                 -- the base package or not.
1030                        ++ (if thisPackage dflags == basePackageId
1031                                 then [ "-DCOMPILING_BASE_PACKAGE" ]
1032                                 else [])
1033 #endif
1034
1035 #ifdef sparc_TARGET_ARCH
1036         -- We only support SparcV9 and better because V8 lacks an atomic CAS
1037         -- instruction. Note that the user can still override this
1038         -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
1039         -- regardless of the ordering.
1040         --
1041         -- This is a temporary hack.
1042                        ++ ["-mcpu=v9"]
1043 #endif
1044                        ++ (if hcc && mangle
1045                              then md_regd_c_flags
1046                              else [])
1047                        ++ (if hcc
1048                              then if mangle
1049                                      then gcc_extra_viac_flags
1050                                      else filter (=="-fwrapv")
1051                                                 gcc_extra_viac_flags
1052                                 -- still want -fwrapv even for unreg'd
1053                              else [])
1054                        ++ (if hcc
1055                              then more_hcc_opts
1056                              else [])
1057                        ++ [ verb, "-S", "-Wimplicit", cc_opt ]
1058                        ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
1059 #ifdef darwin_TARGET_OS
1060                        ++ framework_paths
1061 #endif
1062                        ++ cc_opts
1063                        ++ split_opt
1064                        ++ include_paths
1065                        ++ pkg_extra_cc_opts
1066                        ))
1067
1068         return (next_phase, dflags, maybe_loc, output_fn)
1069
1070         -- ToDo: postprocess the output from gcc
1071
1072 -----------------------------------------------------------------------------
1073 -- Mangle phase
1074
1075 runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
1076    = do let dflags = hsc_dflags hsc_env
1077         let mangler_opts = getOpts dflags opt_m
1078
1079 #if i386_TARGET_ARCH
1080         machdep_opts <- return [ show (stolen_x86_regs dflags) ]
1081 #else
1082         machdep_opts <- return []
1083 #endif
1084
1085         let split = dopt Opt_SplitObjs dflags
1086             next_phase
1087                 | split = SplitMangle
1088                 | otherwise = As
1089         output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc
1090
1091         liftIO $ SysTools.runMangle dflags (map SysTools.Option mangler_opts
1092                           ++ [ SysTools.FileOption "" input_fn
1093                              , SysTools.FileOption "" output_fn
1094                              ]
1095                           ++ map SysTools.Option machdep_opts)
1096
1097         return (next_phase, dflags, maybe_loc, output_fn)
1098
1099 -----------------------------------------------------------------------------
1100 -- Splitting phase
1101
1102 runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc
1103   = liftIO $
1104     do  -- tmp_pfx is the prefix used for the split .s files
1105         -- We also use it as the file to contain the no. of split .s files (sigh)
1106         let dflags = hsc_dflags hsc_env
1107         split_s_prefix <- SysTools.newTempName dflags "split"
1108         let n_files_fn = split_s_prefix
1109
1110         SysTools.runSplit dflags
1111                           [ SysTools.FileOption "" input_fn
1112                           , SysTools.FileOption "" split_s_prefix
1113                           , SysTools.FileOption "" n_files_fn
1114                           ]
1115
1116         -- Save the number of split files for future references
1117         s <- readFile n_files_fn
1118         let n_files = read s :: Int
1119             dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }
1120
1121         -- Remember to delete all these files
1122         addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s"
1123                                 | n <- [1..n_files]]
1124
1125         return (SplitAs, dflags', maybe_loc, "**splitmangle**")
1126           -- we don't use the filename
1127
1128 -----------------------------------------------------------------------------
1129 -- As phase
1130
1131 runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
1132   = liftIO $
1133     do  let dflags = hsc_dflags hsc_env
1134         let as_opts =  getOpts dflags opt_a
1135         let cmdline_include_paths = includePaths dflags
1136
1137         output_fn <- get_output_fn dflags StopLn maybe_loc
1138
1139         -- we create directories for the object file, because it
1140         -- might be a hierarchical module.
1141         createDirectoryHierarchy (takeDirectory output_fn)
1142
1143         let (md_c_flags, _) = machdepCCOpts dflags
1144         SysTools.runAs dflags
1145                        (map SysTools.Option as_opts
1146                        ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
1147 #ifdef sparc_TARGET_ARCH
1148         -- We only support SparcV9 and better because V8 lacks an atomic CAS
1149         -- instruction so we have to make sure that the assembler accepts the
1150         -- instruction set. Note that the user can still override this
1151         -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1152         -- regardless of the ordering.
1153         --
1154         -- This is a temporary hack.
1155                        ++ [ SysTools.Option "-mcpu=v9" ]
1156 #endif
1157                        ++ [ SysTools.Option "-c"
1158                           , SysTools.FileOption "" input_fn
1159                           , SysTools.Option "-o"
1160                           , SysTools.FileOption "" output_fn
1161                           ]
1162                        ++ map SysTools.Option md_c_flags)
1163
1164         return (StopLn, dflags, maybe_loc, output_fn)
1165
1166
1167 runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc
1168   = liftIO $ do
1169         let dflags = hsc_dflags hsc_env
1170         output_fn <- get_output_fn dflags StopLn maybe_loc
1171
1172         let base_o = dropExtension output_fn
1173             osuf = objectSuf dflags
1174             split_odir  = base_o ++ "_" ++ osuf ++ "_split"
1175
1176         createDirectoryHierarchy split_odir
1177
1178         -- remove M_split/ *.o, because we're going to archive M_split/ *.o
1179         -- later and we don't want to pick up any old objects.
1180         fs <- getDirectoryContents split_odir
1181         mapM_ removeFile $ map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
1182
1183         let as_opts = getOpts dflags opt_a
1184
1185         let (split_s_prefix, n) = case splitInfo dflags of
1186                                   Nothing -> panic "No split info"
1187                                   Just x -> x
1188
1189         let split_s   n = split_s_prefix ++ "__" ++ show n <.> "s"
1190             split_obj n = split_odir </>
1191                           takeFileName base_o ++ "__" ++ show n <.> osuf
1192
1193         let (md_c_flags, _) = machdepCCOpts dflags
1194         let assemble_file n
1195               = SysTools.runAs dflags
1196                          (map SysTools.Option as_opts ++
1197 #ifdef sparc_TARGET_ARCH
1198         -- We only support SparcV9 and better because V8 lacks an atomic CAS
1199         -- instruction so we have to make sure that the assembler accepts the
1200         -- instruction set. Note that the user can still override this
1201         -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1202         -- regardless of the ordering.
1203         --
1204         -- This is a temporary hack.
1205                           [ SysTools.Option "-mcpu=v9" ] ++
1206 #endif
1207                           [ SysTools.Option "-c"
1208                           , SysTools.Option "-o"
1209                           , SysTools.FileOption "" (split_obj n)
1210                           , SysTools.FileOption "" (split_s n)
1211                           ]
1212                        ++ map SysTools.Option md_c_flags)
1213
1214         mapM_ assemble_file [1..n]
1215
1216         -- and join the split objects into a single object file:
1217         let ld_r args = SysTools.runLink dflags ([
1218                             SysTools.Option "-nostdlib",
1219                             SysTools.Option "-nodefaultlibs",
1220                             SysTools.Option "-Wl,-r",
1221                             SysTools.Option ld_x_flag,
1222                             SysTools.Option "-o",
1223                             SysTools.FileOption "" output_fn ]
1224                          ++ map SysTools.Option md_c_flags
1225                          ++ args)
1226             ld_x_flag | null cLD_X = ""
1227                       | otherwise  = "-Wl,-x"
1228
1229         if cLdIsGNULd == "YES"
1230             then do
1231                   let script = split_odir </> "ld.script"
1232                   writeFile script $
1233                       "INPUT(" ++ unwords (map split_obj [1..n]) ++ ")"
1234                   ld_r [SysTools.FileOption "" script]
1235             else do
1236                   ld_r (map (SysTools.FileOption "" . split_obj) [1..n])
1237
1238         return (StopLn, dflags, maybe_loc, output_fn)
1239
1240
1241 -----------------------------------------------------------------------------
1242 -- LlvmOpt phase
1243
1244 runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
1245   = liftIO $ do
1246     let dflags  = hsc_dflags hsc_env
1247     let lo_opts = getOpts dflags opt_lo
1248     let opt_lvl = max 0 (min 2 $ optLevel dflags)
1249     -- don't specify anything if user has specified commands. We do this for
1250     -- opt but not llc since opt is very specifically for optimisation passes
1251     -- only, so if the user is passing us extra options we assume they know
1252     -- what they are doing and don't get in the way.
1253     let optFlag = if null lo_opts
1254                      then [SysTools.Option (llvmOpts !! opt_lvl)]
1255                      else []
1256
1257     output_fn <- get_output_fn dflags LlvmLlc maybe_loc
1258
1259     SysTools.runLlvmOpt dflags
1260                ([ SysTools.FileOption "" input_fn,
1261                     SysTools.Option "-o",
1262                     SysTools.FileOption "" output_fn]
1263                 ++ optFlag
1264                 ++ map SysTools.Option lo_opts)
1265
1266     return (LlvmLlc, dflags, maybe_loc, output_fn)
1267   where
1268         -- we always (unless -optlo specified) run Opt since we rely on it to
1269         -- fix up some pretty big deficiencies in the code we generate
1270         llvmOpts = ["-mem2reg", "-O1", "-O2"]
1271
1272
1273 -----------------------------------------------------------------------------
1274 -- LlvmLlc phase
1275
1276 runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
1277   = liftIO $ do
1278     let dflags  = hsc_dflags hsc_env
1279     let lc_opts = getOpts dflags opt_lc
1280     let opt_lvl = max 0 (min 2 $ optLevel dflags)
1281 #if darwin_TARGET_OS
1282     let nphase = LlvmMangle
1283 #else
1284     let nphase = As
1285 #endif
1286     let rmodel | opt_PIC        = "pic"
1287                | not opt_Static = "dynamic-no-pic"
1288                | otherwise      = "static"
1289
1290     output_fn <- get_output_fn dflags nphase maybe_loc
1291
1292     SysTools.runLlvmLlc dflags
1293                 ([ SysTools.Option (llvmOpts !! opt_lvl),
1294                     SysTools.Option $ "-relocation-model=" ++ rmodel,
1295                     SysTools.FileOption "" input_fn,
1296                     SysTools.Option "-o", SysTools.FileOption "" output_fn]
1297                 ++ map SysTools.Option lc_opts)
1298
1299     return (nphase, dflags, maybe_loc, output_fn)
1300   where
1301 #if darwin_TARGET_OS
1302         llvmOpts = ["-O1", "-O2", "-O2"]
1303 #else
1304         llvmOpts = ["-O1", "-O2", "-O3"]
1305 #endif
1306
1307
1308 -----------------------------------------------------------------------------
1309 -- LlvmMangle phase
1310
1311 runPhase LlvmMangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
1312   = liftIO $ do
1313     let dflags = hsc_dflags hsc_env
1314     output_fn <- get_output_fn dflags As maybe_loc
1315     llvmFixupAsm input_fn output_fn
1316     return (As, dflags, maybe_loc, output_fn)
1317
1318
1319 -- warning suppression
1320 runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc =
1321    panic ("runPhase: don't know how to run phase " ++ show other)
1322 -----------------------------------------------------------------------------
1323 -- MoveBinary sort-of-phase
1324 -- After having produced a binary, move it somewhere else and generate a
1325 -- wrapper script calling the binary. Currently, we need this only in
1326 -- a parallel way (i.e. in GUM), because PVM expects the binary in a
1327 -- central directory.
1328 -- This is called from linkBinary below, after linking. I haven't made it
1329 -- a separate phase to minimise interfering with other modules, and
1330 -- we don't need the generality of a phase (MoveBinary is always
1331 -- done after linking and makes only sense in a parallel setup)   -- HWL
1332
1333 runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool
1334 runPhase_MoveBinary dflags input_fn
1335     | WayPar `elem` (wayNames dflags) && not opt_Static =
1336         panic ("Don't know how to combine PVM wrapper and dynamic wrapper")
1337     | WayPar `elem` (wayNames dflags) = do
1338         let sysMan = pgm_sysman dflags
1339         pvm_root <- getEnv "PVM_ROOT"
1340         pvm_arch <- getEnv "PVM_ARCH"
1341         let
1342            pvm_executable_base = "=" ++ input_fn
1343            pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
1344         -- nuke old binary; maybe use configur'ed names for cp and rm?
1345         _ <- tryIO (removeFile pvm_executable)
1346         -- move the newly created binary into PVM land
1347         copy dflags "copying PVM executable" input_fn pvm_executable
1348         -- generate a wrapper script for running a parallel prg under PVM
1349         writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
1350         return True
1351     | otherwise = return True
1352
1353 mkExtraCObj :: DynFlags -> [String] -> IO FilePath
1354 mkExtraCObj dflags xs
1355  = do cFile <- newTempName dflags "c"
1356       oFile <- newTempName dflags "o"
1357       writeFile cFile $ unlines xs
1358       let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId
1359           (md_c_flags, _) = machdepCCOpts dflags
1360       SysTools.runCc dflags
1361                      ([Option        "-c",
1362                        FileOption "" cFile,
1363                        Option        "-o",
1364                        FileOption "" oFile] ++
1365                       map (FileOption "-I") (includeDirs rtsDetails) ++
1366                       map Option md_c_flags)
1367       return oFile
1368
1369 -- generates a Perl skript starting a parallel prg under PVM
1370 mk_pvm_wrapper_script :: String -> String -> String -> String
1371 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
1372  [
1373   "eval 'exec perl -S $0 ${1+\"$@\"}'",
1374   "  if $running_under_some_shell;",
1375   "# =!=!=!=!=!=!=!=!=!=!=!",
1376   "# This script is automatically generated: DO NOT EDIT!!!",
1377   "# Generated by Glasgow Haskell Compiler",
1378   "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
1379   "#",
1380   "$pvm_executable      = '" ++ pvm_executable ++ "';",
1381   "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
1382   "$SysMan = '" ++ sysMan ++ "';",
1383   "",
1384   {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
1385   "# first, some magical shortcuts to run "commands" on the binary",
1386   "# (which is hidden)",
1387   "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
1388   "    local($cmd) = $1;",
1389   "    system("$cmd $pvm_executable");",
1390   "    exit(0); # all done",
1391   "}", -}
1392   "",
1393   "# Now, run the real binary; process the args first",
1394   "$ENV{'PE'} = $pvm_executable_base;", --  ++ pvm_executable_base,
1395   "$debug = '';",
1396   "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
1397   "@nonPVM_args = ();",
1398   "$in_RTS_args = 0;",
1399   "",
1400   "args: while ($a = shift(@ARGV)) {",
1401   "    if ( $a eq '+RTS' ) {",
1402   "        $in_RTS_args = 1;",
1403   "    } elsif ( $a eq '-RTS' ) {",
1404   "        $in_RTS_args = 0;",
1405   "    }",
1406   "    if ( $a eq '-d' && $in_RTS_args ) {",
1407   "        $debug = '-';",
1408   "    } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
1409   "        $nprocessors = $1;",
1410   "    } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
1411   "        $nprocessors = $1;",
1412   "    } else {",
1413   "        push(@nonPVM_args, $a);",
1414   "    }",
1415   "}",
1416   "",
1417   "local($return_val) = 0;",
1418   "# Start the parallel execution by calling SysMan",
1419   "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
1420   "$return_val = $?;",
1421   "# ToDo: fix race condition moving files and flushing them!!",
1422   "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
1423   "exit($return_val);"
1424  ]
1425
1426 -----------------------------------------------------------------------------
1427 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
1428
1429 getHCFilePackages :: FilePath -> IO [PackageId]
1430 getHCFilePackages filename =
1431   Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
1432     l <- hGetLine h
1433     case l of
1434       '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
1435           return (map stringToPackageId (words rest))
1436       _other ->
1437           return []
1438
1439 -----------------------------------------------------------------------------
1440 -- Static linking, of .o files
1441
1442 -- The list of packages passed to link is the list of packages on
1443 -- which this program depends, as discovered by the compilation
1444 -- manager.  It is combined with the list of packages that the user
1445 -- specifies on the command line with -package flags.
1446 --
1447 -- In one-shot linking mode, we can't discover the package
1448 -- dependencies (because we haven't actually done any compilation or
1449 -- read any interface files), so the user must explicitly specify all
1450 -- the packages.
1451
1452 linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO ()
1453 linkBinary dflags o_files dep_packages = do
1454     let verb = getVerbFlag dflags
1455         output_fn = exeFileName dflags
1456
1457     -- get the full list of packages to link with, by combining the
1458     -- explicit packages with the auto packages and all of their
1459     -- dependencies, and eliminating duplicates.
1460
1461     pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1462     let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths)
1463 #ifdef elf_OBJ_FORMAT
1464         get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1465                                 | otherwise = ["-L" ++ l]
1466 #else
1467         get_pkg_lib_path_opts l = ["-L" ++ l]
1468 #endif
1469
1470     let lib_paths = libraryPaths dflags
1471     let lib_path_opts = map ("-L"++) lib_paths
1472
1473     -- The C "main" function is not in the rts but in a separate static
1474     -- library libHSrtsmain.a that sits next to the rts lib files. Assuming
1475     -- we're using a Haskell main function then we need to link it in.
1476     let no_hs_main = dopt Opt_NoHsMain dflags
1477     let main_lib | no_hs_main = []
1478                  | otherwise  = [ "-lHSrtsmain" ]
1479     let mkRtsEnabledObj val = do fn <- mkExtraCObj dflags
1480                                            ["#include \"Rts.h\"",
1481                                             "#include \"RtsOpts.h\"",
1482                                             "const rtsOptsEnabledEnum rtsOptsEnabled = "
1483                                                 ++ val ++ ";"]
1484                                  return [fn]
1485     rtsEnabledObj <- case rtsOptsEnabled dflags of
1486                      RtsOptsNone     -> mkRtsEnabledObj "rtsOptsNone"
1487                      RtsOptsSafeOnly -> return []
1488                      RtsOptsAll      -> mkRtsEnabledObj "rtsOptsAll"
1489     rtsOptsObj <- case rtsOpts dflags of
1490                   Just opts ->
1491                       do fn <- mkExtraCObj dflags
1492                                  -- We assume that the Haskell "show" does
1493                                  -- the right thing here
1494                                  ["char *ghc_rts_opts = " ++ show opts ++ ";"]
1495                          return [fn]
1496                   Nothing -> return []
1497
1498     pkg_link_opts <- getPackageLinkOpts dflags dep_packages
1499
1500 #ifdef darwin_TARGET_OS
1501     pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
1502     let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths
1503
1504     let framework_paths = frameworkPaths dflags
1505         framework_path_opts = map ("-F"++) framework_paths
1506
1507     pkg_frameworks <- getPackageFrameworks dflags dep_packages
1508     let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1509
1510     let frameworks = cmdlineFrameworks dflags
1511         framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ]
1512          -- reverse because they're added in reverse order from the cmd line
1513 #endif
1514         -- probably _stub.o files
1515     extra_ld_inputs <- readIORef v_Ld_inputs
1516
1517         -- opts from -optl-<blah> (including -l<blah> options)
1518     let extra_ld_opts = getOpts dflags opt_l
1519
1520     let ways = wayNames dflags
1521
1522     -- Here are some libs that need to be linked at the *end* of
1523     -- the command line, because they contain symbols that are referred to
1524     -- by the RTS.  We can't therefore use the ordinary way opts for these.
1525     let
1526         debug_opts | WayDebug `elem` ways = [
1527 #if defined(HAVE_LIBBFD)
1528                         "-lbfd", "-liberty"
1529 #endif
1530                          ]
1531                    | otherwise            = []
1532
1533     let
1534         thread_opts | WayThreaded `elem` ways = [
1535 #if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) && !defined(openbsd_TARGET_OS) && !defined(haiku_TARGET_OS)
1536                         "-lpthread"
1537 #endif
1538 #if defined(osf3_TARGET_OS)
1539                         , "-lexc"
1540 #endif
1541                         ]
1542                     | otherwise               = []
1543
1544     rc_objs <- maybeCreateManifest dflags output_fn
1545
1546     let (md_c_flags, _) = machdepCCOpts dflags
1547     SysTools.runLink dflags (
1548                        [ SysTools.Option verb
1549                        , SysTools.Option "-o"
1550                        , SysTools.FileOption "" output_fn
1551                        ]
1552                       ++ map SysTools.Option (
1553                          md_c_flags
1554
1555 #ifdef mingw32_TARGET_OS
1556                       -- Permit the linker to auto link _symbol to _imp_symbol.
1557                       -- This lets us link against DLLs without needing an "import library".
1558                       ++ ["-Wl,--enable-auto-import"]
1559 #endif
1560                       ++ o_files
1561                       ++ extra_ld_inputs
1562                       ++ lib_path_opts
1563                       ++ extra_ld_opts
1564                       ++ rc_objs
1565 #ifdef darwin_TARGET_OS
1566                       ++ framework_path_opts
1567                       ++ framework_opts
1568 #endif
1569                       ++ pkg_lib_path_opts
1570                       ++ main_lib
1571                       ++ rtsEnabledObj
1572                       ++ rtsOptsObj
1573                       ++ pkg_link_opts
1574 #ifdef darwin_TARGET_OS
1575                       ++ pkg_framework_path_opts
1576                       ++ pkg_framework_opts
1577 #endif
1578                       ++ debug_opts
1579                       ++ thread_opts
1580                     ))
1581
1582     -- parallel only: move binary to another dir -- HWL
1583     success <- runPhase_MoveBinary dflags output_fn
1584     if success then return ()
1585                else ghcError (InstallationError ("cannot move binary"))
1586
1587
1588 exeFileName :: DynFlags -> FilePath
1589 exeFileName dflags
1590   | Just s <- outputFile dflags =
1591 #if defined(mingw32_HOST_OS)
1592       if null (takeExtension s)
1593         then s <.> "exe"
1594         else s
1595 #else
1596       s
1597 #endif
1598   | otherwise =
1599 #if defined(mingw32_HOST_OS)
1600         "main.exe"
1601 #else
1602         "a.out"
1603 #endif
1604
1605 maybeCreateManifest
1606    :: DynFlags
1607    -> FilePath                          -- filename of executable
1608    -> IO [FilePath]                     -- extra objects to embed, maybe
1609 #ifndef mingw32_TARGET_OS
1610 maybeCreateManifest _ _ = do
1611   return []
1612 #else
1613 maybeCreateManifest dflags exe_filename = do
1614   if not (dopt Opt_GenManifest dflags) then return [] else do
1615
1616   let manifest_filename = exe_filename <.> "manifest"
1617
1618   writeFile manifest_filename $
1619       "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
1620       "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
1621       "  <assemblyIdentity version=\"1.0.0.0\"\n"++
1622       "     processorArchitecture=\"X86\"\n"++
1623       "     name=\"" ++ dropExtension exe_filename ++ "\"\n"++
1624       "     type=\"win32\"/>\n\n"++
1625       "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
1626       "    <security>\n"++
1627       "      <requestedPrivileges>\n"++
1628       "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
1629       "        </requestedPrivileges>\n"++
1630       "       </security>\n"++
1631       "  </trustInfo>\n"++
1632       "</assembly>\n"
1633
1634   -- Windows will find the manifest file if it is named foo.exe.manifest.
1635   -- However, for extra robustness, and so that we can move the binary around,
1636   -- we can embed the manifest in the binary itself using windres:
1637   if not (dopt Opt_EmbedManifest dflags) then return [] else do
1638
1639   rc_filename <- newTempName dflags "rc"
1640   rc_obj_filename <- newTempName dflags (objectSuf dflags)
1641
1642   writeFile rc_filename $
1643       "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
1644         -- magic numbers :-)
1645         -- show is a bit hackish above, but we need to escape the
1646         -- backslashes in the path.
1647
1648   let wr_opts = getOpts dflags opt_windres
1649   runWindres dflags $ map SysTools.Option $
1650         ["--input="++rc_filename,
1651          "--output="++rc_obj_filename,
1652          "--output-format=coff"]
1653         ++ wr_opts
1654         -- no FileOptions here: windres doesn't like seeing
1655         -- backslashes, apparently
1656
1657   removeFile manifest_filename
1658
1659   return [rc_obj_filename]
1660 #endif
1661
1662
1663 linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
1664 linkDynLib dflags o_files dep_packages = do
1665     let verb = getVerbFlag dflags
1666     let o_file = outputFile dflags
1667
1668     pkgs <- getPreloadPackagesAnd dflags dep_packages
1669
1670     let pkg_lib_paths = collectLibraryPaths pkgs
1671     let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1672 #ifdef elf_OBJ_FORMAT
1673         get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1674                                 | otherwise = ["-L" ++ l]
1675 #else
1676         get_pkg_lib_path_opts l = ["-L" ++ l]
1677 #endif
1678
1679     let lib_paths = libraryPaths dflags
1680     let lib_path_opts = map ("-L"++) lib_paths
1681
1682     -- We don't want to link our dynamic libs against the RTS package,
1683     -- because the RTS lib comes in several flavours and we want to be
1684     -- able to pick the flavour when a binary is linked.
1685     -- On Windows we need to link the RTS import lib as Windows does
1686     -- not allow undefined symbols.
1687     -- The RTS library path is still added to the library search path
1688     -- above in case the RTS is being explicitly linked in (see #3807).
1689 #if !defined(mingw32_HOST_OS)
1690     let pkgs_no_rts = filter ((/= rtsPackageId) . packageConfigId) pkgs
1691 #else
1692     let pkgs_no_rts = pkgs
1693 #endif
1694     let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts
1695
1696         -- probably _stub.o files
1697     extra_ld_inputs <- readIORef v_Ld_inputs
1698
1699     let (md_c_flags, _) = machdepCCOpts dflags
1700     let extra_ld_opts = getOpts dflags opt_l
1701 #if defined(mingw32_HOST_OS)
1702     -----------------------------------------------------------------------------
1703     -- Making a DLL
1704     -----------------------------------------------------------------------------
1705     let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
1706
1707     SysTools.runLink dflags
1708          ([ SysTools.Option verb
1709           , SysTools.Option "-o"
1710           , SysTools.FileOption "" output_fn
1711           , SysTools.Option "-shared"
1712           ] ++
1713           [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
1714           | dopt Opt_SharedImplib dflags
1715           ]
1716          ++ map (SysTools.FileOption "") o_files
1717          ++ map SysTools.Option (
1718             md_c_flags
1719
1720          -- Permit the linker to auto link _symbol to _imp_symbol
1721          -- This lets us link against DLLs without needing an "import library"
1722          ++ ["-Wl,--enable-auto-import"]
1723
1724          ++ extra_ld_inputs
1725          ++ lib_path_opts
1726          ++ extra_ld_opts
1727          ++ pkg_lib_path_opts
1728          ++ pkg_link_opts
1729         ))
1730 #elif defined(darwin_TARGET_OS)
1731     -----------------------------------------------------------------------------
1732     -- Making a darwin dylib
1733     -----------------------------------------------------------------------------
1734     -- About the options used for Darwin:
1735     -- -dynamiclib
1736     --   Apple's way of saying -shared
1737     -- -undefined dynamic_lookup:
1738     --   Without these options, we'd have to specify the correct dependencies
1739     --   for each of the dylibs. Note that we could (and should) do without this
1740     --   for all libraries except the RTS; all we need to do is to pass the
1741     --   correct HSfoo_dyn.dylib files to the link command.
1742     --   This feature requires Mac OS X 10.3 or later; there is a similar feature,
1743     --   -flat_namespace -undefined suppress, which works on earlier versions,
1744     --   but it has other disadvantages.
1745     -- -single_module
1746     --   Build the dynamic library as a single "module", i.e. no dynamic binding
1747     --   nonsense when referring to symbols from within the library. The NCG
1748     --   assumes that this option is specified (on i386, at least).
1749     -- -install_name
1750     --   Mac OS/X stores the path where a dynamic library is (to be) installed
1751     --   in the library itself.  It's called the "install name" of the library.
1752     --   Then any library or executable that links against it before it's
1753     --   installed will search for it in its ultimate install location.  By
1754     --   default we set the install name to the absolute path at build time, but
1755     --   it can be overridden by the -dylib-install-name option passed to ghc.
1756     --   Cabal does this.
1757     -----------------------------------------------------------------------------
1758
1759     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1760
1761     instName <- case dylibInstallName dflags of
1762         Just n -> return n
1763         Nothing -> do
1764             pwd <- getCurrentDirectory
1765             return $ pwd `combine` output_fn
1766     SysTools.runLink dflags
1767          ([ SysTools.Option verb
1768           , SysTools.Option "-dynamiclib"
1769           , SysTools.Option "-o"
1770           , SysTools.FileOption "" output_fn
1771           ]
1772          ++ map SysTools.Option (
1773             md_c_flags
1774          ++ o_files
1775          ++ [ "-undefined", "dynamic_lookup", "-single_module",
1776               "-Wl,-read_only_relocs,suppress", "-install_name", instName ]
1777          ++ extra_ld_inputs
1778          ++ lib_path_opts
1779          ++ extra_ld_opts
1780          ++ pkg_lib_path_opts
1781          ++ pkg_link_opts
1782         ))
1783 #else
1784     -----------------------------------------------------------------------------
1785     -- Making a DSO
1786     -----------------------------------------------------------------------------
1787
1788     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1789     let buildingRts = thisPackage dflags == rtsPackageId
1790     let bsymbolicFlag = if buildingRts
1791                         then -- -Bsymbolic breaks the way we implement
1792                              -- hooks in the RTS
1793                              []
1794                         else -- we need symbolic linking to resolve
1795                              -- non-PIC intra-package-relocations
1796                              ["-Wl,-Bsymbolic"]
1797
1798     SysTools.runLink dflags
1799          ([ SysTools.Option verb
1800           , SysTools.Option "-o"
1801           , SysTools.FileOption "" output_fn
1802           ]
1803          ++ map SysTools.Option (
1804             md_c_flags
1805          ++ o_files
1806          ++ [ "-shared" ]
1807          ++ bsymbolicFlag
1808          ++ [ "-Wl,-soname," ++ takeFileName output_fn ] -- set the library soname
1809          ++ extra_ld_inputs
1810          ++ lib_path_opts
1811          ++ extra_ld_opts
1812          ++ pkg_lib_path_opts
1813          ++ pkg_link_opts
1814         ))
1815 #endif
1816 -- -----------------------------------------------------------------------------
1817 -- Running CPP
1818
1819 doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO ()
1820 doCpp dflags raw include_cc_opts input_fn output_fn = do
1821     let hscpp_opts = getOpts dflags opt_P
1822     let cmdline_include_paths = includePaths dflags
1823
1824     pkg_include_dirs <- getPackageIncludePath dflags []
1825     let include_paths = foldr (\ x xs -> "-I" : x : xs) []
1826                           (cmdline_include_paths ++ pkg_include_dirs)
1827
1828     let verb = getVerbFlag dflags
1829
1830     let cc_opts
1831           | not include_cc_opts = []
1832           | otherwise           = (optc ++ md_c_flags)
1833                 where
1834                       optc = getOpts dflags opt_c
1835                       (md_c_flags, _) = machdepCCOpts dflags
1836
1837     let cpp_prog args | raw       = SysTools.runCpp dflags args
1838                       | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
1839
1840     let target_defs =
1841           [ "-D" ++ HOST_OS     ++ "_BUILD_OS=1",
1842             "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH=1",
1843             "-D" ++ TARGET_OS   ++ "_HOST_OS=1",
1844             "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ]
1845         -- remember, in code we *compile*, the HOST is the same our TARGET,
1846         -- and BUILD is the same as our HOST.
1847
1848     cpp_prog       ([SysTools.Option verb]
1849                     ++ map SysTools.Option include_paths
1850                     ++ map SysTools.Option hsSourceCppOpts
1851                     ++ map SysTools.Option target_defs
1852                     ++ map SysTools.Option hscpp_opts
1853                     ++ map SysTools.Option cc_opts
1854                     ++ [ SysTools.Option     "-x"
1855                        , SysTools.Option     "c"
1856                        , SysTools.Option     input_fn
1857         -- We hackily use Option instead of FileOption here, so that the file
1858         -- name is not back-slashed on Windows.  cpp is capable of
1859         -- dealing with / in filenames, so it works fine.  Furthermore
1860         -- if we put in backslashes, cpp outputs #line directives
1861         -- with *double* backslashes.   And that in turn means that
1862         -- our error messages get double backslashes in them.
1863         -- In due course we should arrange that the lexer deals
1864         -- with these \\ escapes properly.
1865                        , SysTools.Option     "-o"
1866                        , SysTools.FileOption "" output_fn
1867                        ])
1868
1869 cHaskell1Version :: String
1870 cHaskell1Version = "5" -- i.e., Haskell 98
1871
1872 hsSourceCppOpts :: [String]
1873 -- Default CPP defines in Haskell source
1874 hsSourceCppOpts =
1875         [ "-D__HASKELL1__="++cHaskell1Version
1876         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
1877         , "-D__HASKELL98__"
1878         , "-D__CONCURRENT_HASKELL__"
1879         ]
1880
1881
1882 -- -----------------------------------------------------------------------------
1883 -- Misc.
1884
1885 hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase
1886 hscNextPhase _ HsBootFile _        =  StopLn
1887 hscNextPhase dflags _ hsc_lang =
1888   case hsc_lang of
1889         HscC -> HCc
1890         HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle
1891                | otherwise -> As
1892         HscLlvm        -> LlvmOpt
1893         HscNothing     -> StopLn
1894         HscInterpreted -> StopLn
1895         _other         -> StopLn
1896
1897
1898 hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget
1899 hscMaybeAdjustTarget dflags stop _ current_hsc_lang
1900   = hsc_lang
1901   where
1902         keep_hc = dopt Opt_KeepHcFiles dflags
1903         hsc_lang
1904                 -- don't change the lang if we're interpreting
1905                  | current_hsc_lang == HscInterpreted = current_hsc_lang
1906
1907                 -- force -fvia-C if we are being asked for a .hc file
1908                  | HCc <- stop = HscC
1909                  | keep_hc     = HscC
1910                 -- otherwise, stick to the plan
1911                  | otherwise = current_hsc_lang
1912