compiler/main/DriverPipeline.hs

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