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_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 link_pkgs
 465         LinkDynLib -> linkDynLib dflags o_files []
 466         other      -> panicBadLink other
 467   where
 468    -- Always link in the haskell98 package for static linking.  Other
 469    -- packages have to be specified via the -package flag.
 470     link_pkgs
 471      | dopt Opt_AutoLinkPackages dflags = [haskell98PackageId]
 472      | otherwise                        = []
 473
 474
 475 -- ---------------------------------------------------------------------------
 476
 477 data PipelineOutput
 478   = Temporary
 479         -- ^ Output should be to a temporary file: we're going to
 480         -- run more compilation steps on this output later.
 481   | Persistent
 482         -- ^ We want a persistent file, i.e. a file in the current directory
 483         -- derived from the input filename, but with the appropriate extension.
 484         -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o.
 485   | SpecificFile FilePath
 486         -- ^ The output must go into the specified file.
 487
 488 -- | Run a compilation pipeline, consisting of multiple phases.
 489 --
 490 -- This is the interface to the compilation pipeline, which runs
 491 -- a series of compilation steps on a single source file, specifying
 492 -- at which stage to stop.
 493 --
 494 -- The DynFlags can be modified by phases in the pipeline (eg. by
 495 -- OPTIONS_GHC pragmas), and the changes affect later phases in the
 496 -- pipeline.
 497 runPipeline
 498   :: GhcMonad m =>
 499      Phase                      -- ^ When to stop
 500   -> HscEnv                     -- ^ Compilation environment
 501   -> (FilePath,Maybe Phase)     -- ^ Input filename (and maybe -x suffix)
 502   -> Maybe FilePath             -- ^ original basename (if different from ^^^)
 503   -> PipelineOutput             -- ^ Output filename
 504   -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module
 505   -> m (DynFlags, FilePath)     -- ^ (final flags, output filename)
 506
 507 runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc
 508   = do
 509   let dflags0 = hsc_dflags hsc_env0
 510       (input_basename, suffix) = splitExtension input_fn
 511       suffix' = drop 1 suffix -- strip off the .
 512       basename | Just b <- mb_basename = b
 513                | otherwise             = input_basename
 514
 515       -- Decide where dump files should go based on the pipeline output
 516       dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
 517       hsc_env = hsc_env0 {hsc_dflags = dflags}
 518
 519         -- If we were given a -x flag, then use that phase to start from
 520       start_phase = fromMaybe (startPhase suffix') mb_phase
 521
 522   -- We want to catch cases of "you can't get there from here" before
 523   -- we start the pipeline, because otherwise it will just run off the
 524   -- end.
 525   --
 526   -- There is a partial ordering on phases, where A < B iff A occurs
 527   -- before B in a normal compilation pipeline.
 528
 529   when (not (start_phase `happensBefore` stop_phase)) $
 530         ghcError (UsageError
 531                     ("cannot compile this file to desired target: "
 532                        ++ input_fn))
 533
 534   -- this is a function which will be used to calculate output file names
 535   -- as we go along (we partially apply it to some of its inputs here)
 536   let get_output_fn = getOutputFilename stop_phase output basename
 537
 538   -- Execute the pipeline...
 539   (dflags', output_fn, maybe_loc) <-
 540         pipeLoop hsc_env start_phase stop_phase input_fn
 541                  basename suffix' get_output_fn maybe_loc
 542
 543   -- Sometimes, a compilation phase doesn't actually generate any output
 544   -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
 545   -- stage, but we wanted to keep the output, then we have to explicitly
 546   -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
 547   -- further compilation stages can tell what the original filename was.
 548   case output of
 549     Temporary ->
 550         return (dflags', output_fn)
 551     _other -> liftIO $
 552         do final_fn <- get_output_fn dflags' stop_phase maybe_loc
 553            when (final_fn /= output_fn) $ do
 554               let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'")
 555                   line_prag = Just ("{-# LINE 1 \"" ++ input_fn ++ "\" #-}\n")
 556               copyWithHeader dflags msg line_prag output_fn final_fn
 557            return (dflags', final_fn)
 558
 559
 560
 561 pipeLoop :: GhcMonad m =>
 562             HscEnv -> Phase -> Phase
 563          -> FilePath  -> String -> Suffix
 564          -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
 565          -> Maybe ModLocation
 566          -> m (DynFlags, FilePath, Maybe ModLocation)
 567
 568 pipeLoop hsc_env phase stop_phase
 569          input_fn orig_basename orig_suff
 570          orig_get_output_fn maybe_loc
 571
 572   | phase `eqPhase` stop_phase            -- All done
 573   = return (hsc_dflags hsc_env, input_fn, maybe_loc)
 574
 575   | not (phase `happensBefore` stop_phase)
 576         -- Something has gone wrong.  We'll try to cover all the cases when
 577         -- this could happen, so if we reach here it is a panic.
 578         -- eg. it might happen if the -C flag is used on a source file that
 579         -- has {-# OPTIONS -fasm #-}.
 580   = panic ("pipeLoop: at phase " ++ show phase ++
 581            " but I wanted to stop at phase " ++ show stop_phase)
 582
 583   | otherwise
 584   = do (next_phase, dflags', maybe_loc, output_fn)
 585           <- runPhase phase stop_phase hsc_env orig_basename
 586                       orig_suff input_fn orig_get_output_fn maybe_loc
 587        let hsc_env' = hsc_env {hsc_dflags = dflags'}
 588        pipeLoop hsc_env' next_phase stop_phase output_fn
 589                 orig_basename orig_suff orig_get_output_fn maybe_loc
 590
 591 getOutputFilename
 592   :: Phase -> PipelineOutput -> String
 593   -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
 594 getOutputFilename stop_phase output basename
 595  = func
 596  where
 597         func dflags next_phase maybe_location
 598            | is_last_phase, Persistent <- output     = persistent_fn
 599            | is_last_phase, SpecificFile f <- output = return f
 600            | keep_this_output                        = persistent_fn
 601            | otherwise                               = newTempName dflags suffix
 602            where
 603                 hcsuf      = hcSuf dflags
 604                 odir       = objectDir dflags
 605                 osuf       = objectSuf dflags
 606                 keep_hc    = dopt Opt_KeepHcFiles dflags
 607                 keep_raw_s = dopt Opt_KeepRawSFiles dflags
 608                 keep_s     = dopt Opt_KeepSFiles dflags
 609                 keep_bc    = dopt Opt_KeepLlvmFiles dflags
 610
 611                 myPhaseInputExt HCc    = hcsuf
 612                 myPhaseInputExt StopLn = osuf
 613                 myPhaseInputExt other  = phaseInputExt other
 614
 615                 is_last_phase = next_phase `eqPhase` stop_phase
 616
 617                 -- sometimes, we keep output from intermediate stages
 618                 keep_this_output =
 619                      case next_phase of
 620                              StopLn               -> True
 621                              Mangle  | keep_raw_s -> True
 622                              As      | keep_s     -> True
 623                              LlvmOpt | keep_bc    -> True
 624                              HCc     | keep_hc    -> True
 625                              _other               -> False
 626
 627                 suffix = myPhaseInputExt next_phase
 628
 629                 -- persistent object files get put in odir
 630                 persistent_fn
 631                    | StopLn <- next_phase = return odir_persistent
 632                    | otherwise            = return persistent
 633
 634                 persistent = basename <.> suffix
 635
 636                 odir_persistent
 637                    | Just loc <- maybe_location = ml_obj_file loc
 638                    | Just d <- odir = d </> persistent
 639                    | otherwise      = persistent
 640
 641
 642 -- -----------------------------------------------------------------------------
 643 -- | Each phase in the pipeline returns the next phase to execute, and the
 644 -- name of the file in which the output was placed.
 645 --
 646 -- We must do things dynamically this way, because we often don't know
 647 -- what the rest of the phases will be until part-way through the
 648 -- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
 649 -- of a source file can change the latter stages of the pipeline from
 650 -- taking the via-C route to using the native code generator.
 651 --
 652 runPhase :: GhcMonad m =>
 653             Phase       -- ^ Do this phase first
 654          -> Phase       -- ^ Stop just before this phase
 655          -> HscEnv
 656          -> String      -- ^ basename of original input source
 657          -> String      -- ^ its extension
 658          -> FilePath    -- ^ name of file which contains the input to this phase.
 659          -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
 660                         -- ^ how to calculate the output filename
 661          -> Maybe ModLocation           -- ^ the ModLocation, if we have one
 662          -> m (Phase,                   -- next phase
 663                DynFlags,                -- new dynamic flags
 664                Maybe ModLocation,       -- the ModLocation, if we have one
 665                FilePath)                -- output filename
 666
 667         -- Invariant: the output filename always contains the output
 668         -- Interesting case: Hsc when there is no recompilation to do
 669         --                   Then the output filename is still a .o file
 670
 671 -------------------------------------------------------------------------------
 672 -- Unlit phase
 673
 674 runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 675   = do
 676        let dflags = hsc_dflags hsc_env
 677        output_fn <- liftIO $ get_output_fn dflags (Cpp sf) maybe_loc
 678
 679        let unlit_flags = getOpts dflags opt_L
 680            flags = map SysTools.Option unlit_flags ++
 681                    [ -- The -h option passes the file name for unlit to
 682                      -- put in a #line directive
 683                      SysTools.Option     "-h"
 684                      -- cpp interprets \b etc as escape sequences,
 685                      -- so we use / for filenames in pragmas
 686                    , SysTools.Option $ reslash Forwards $ normalise input_fn
 687                    , SysTools.FileOption "" input_fn
 688                    , SysTools.FileOption "" output_fn
 689                    ]
 690
 691        liftIO $ SysTools.runUnlit dflags flags
 692
 693        return (Cpp sf, dflags, maybe_loc, output_fn)
 694
 695 -------------------------------------------------------------------------------
 696 -- Cpp phase : (a) gets OPTIONS out of file
 697 --             (b) runs cpp if necessary
 698
 699 runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 700   = do let dflags0 = hsc_dflags hsc_env
 701        let dflags0' = flattenExtensionFlags dflags0
 702        src_opts <- liftIO $ getOptionsFromFile dflags0' input_fn
 703        (dflags1, unhandled_flags, warns)
 704            <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
 705        checkProcessArgsResult unhandled_flags
 706        let dflags1' = flattenExtensionFlags dflags1
 707
 708        if not (dopt Opt_Cpp dflags1') then do
 709            -- we have to be careful to emit warnings only once.
 710            unless (dopt Opt_Pp dflags1') $ handleFlagWarnings dflags1' warns
 711
 712            -- no need to preprocess CPP, just pass input file along
 713            -- to the next phase of the pipeline.
 714            return (HsPp sf, dflags1, maybe_loc, input_fn)
 715         else do
 716             output_fn <- liftIO $ get_output_fn dflags1' (HsPp sf) maybe_loc
 717             liftIO $ doCpp dflags1' True{-raw-} False{-no CC opts-} input_fn output_fn
 718             -- re-read the pragmas now that we've preprocessed the file
 719             -- See #2464,#3457
 720             src_opts <- liftIO $ getOptionsFromFile dflags0' output_fn
 721             (dflags2, unhandled_flags, warns)
 722                 <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts
 723             let dflags2' = flattenExtensionFlags dflags2
 724             unless (dopt Opt_Pp dflags2') $ handleFlagWarnings dflags2' warns
 725             -- the HsPp pass below will emit warnings
 726             checkProcessArgsResult unhandled_flags
 727
 728             return (HsPp sf, dflags2, maybe_loc, output_fn)
 729
 730 -------------------------------------------------------------------------------
 731 -- HsPp phase
 732
 733 runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
 734   = do let dflags = hsc_dflags hsc_env
 735            dflags' = flattenExtensionFlags dflags
 736        if not (dopt Opt_Pp dflags) then
 737            -- no need to preprocess, just pass input file along
 738            -- to the next phase of the pipeline.
 739           return (Hsc sf, dflags', maybe_loc, input_fn)
 740         else do
 741             let hspp_opts = getOpts dflags opt_F
 742             let orig_fn = basename <.> suff
 743             output_fn <- liftIO $ get_output_fn dflags (Hsc sf) maybe_loc
 744             liftIO $ SysTools.runPp dflags
 745                            ( [ SysTools.Option     orig_fn
 746                              , SysTools.Option     input_fn
 747                              , SysTools.FileOption "" output_fn
 748                              ] ++
 749                              map SysTools.Option hspp_opts
 750                            )
 751
 752             -- re-read pragmas now that we've parsed the file (see #3674)
 753             src_opts <- liftIO $ getOptionsFromFile dflags' output_fn
 754             (dflags1, unhandled_flags, warns)
 755                 <- liftIO $ parseDynamicNoPackageFlags dflags src_opts
 756             let dflags1' = flattenExtensionFlags dflags1
 757             handleFlagWarnings dflags1' warns
 758             checkProcessArgsResult unhandled_flags
 759
 760             return (Hsc sf, dflags1', maybe_loc, output_fn)
 761
 762 -----------------------------------------------------------------------------
 763 -- Hsc phase
 764
 765 -- Compilation of a single module, in "legacy" mode (_not_ under
 766 -- the direction of the compilation manager).
 767 runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _maybe_loc
 768  = do   -- normal Hsc mode, not mkdependHS
 769         let dflags0 = hsc_dflags hsc_env
 770
 771   -- we add the current directory (i.e. the directory in which
 772   -- the .hs files resides) to the include path, since this is
 773   -- what gcc does, and it's probably what you want.
 774         let current_dir = case takeDirectory basename of
 775                       "" -> "." -- XXX Hack
 776                       d -> d
 777
 778             paths = includePaths dflags0
 779             dflags = dflags0 { includePaths = current_dir : paths }
 780
 781   -- gather the imports and module name
 782         (hspp_buf,mod_name,imps,src_imps) <-
 783             case src_flavour of
 784                 ExtCoreFile -> do  -- no explicit imports in ExtCore input.
 785                     m <- liftIO $ getCoreModuleName input_fn
 786                     return (Nothing, mkModuleName m, [], [])
 787
 788                 _           -> do
 789                     buf <- liftIO $ hGetStringBuffer input_fn
 790                     (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
 791                     return (Just buf, mod_name, imps, src_imps)
 792
 793   -- Build a ModLocation to pass to hscMain.
 794   -- The source filename is rather irrelevant by now, but it's used
 795   -- by hscMain for messages.  hscMain also needs
 796   -- the .hi and .o filenames, and this is as good a way
 797   -- as any to generate them, and better than most. (e.g. takes
 798   -- into accout the -osuf flags)
 799         location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff
 800
 801   -- Boot-ify it if necessary
 802         let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
 803                       | otherwise            = location1
 804
 805
 806   -- Take -ohi into account if present
 807   -- This can't be done in mkHomeModuleLocation because
 808   -- it only applies to the module being compiles
 809         let ohi = outputHi dflags
 810             location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
 811                       | otherwise      = location2
 812
 813   -- Take -o into account if present
 814   -- Very like -ohi, but we must *only* do this if we aren't linking
 815   -- (If we're linking then the -o applies to the linked thing, not to
 816   -- the object file for one module.)
 817   -- Note the nasty duplication with the same computation in compileFile above
 818         let expl_o_file = outputFile dflags
 819             location4 | Just ofile <- expl_o_file
 820                       , isNoLink (ghcLink dflags)
 821                       = location3 { ml_obj_file = ofile }
 822                       | otherwise = location3
 823
 824             o_file = ml_obj_file location4      -- The real object file
 825
 826
 827   -- Figure out if the source has changed, for recompilation avoidance.
 828   --
 829   -- Setting source_unchanged to True means that M.o seems
 830   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 831   -- changed (which the compiler itself figures out).
 832   -- Setting source_unchanged to False tells the compiler that M.o is out of
 833   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 834         src_timestamp <- liftIO $ getModificationTime (basename <.> suff)
 835
 836         let force_recomp = dopt Opt_ForceRecomp dflags
 837             hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags)
 838         source_unchanged <-
 839           if force_recomp || not (isStopLn stop)
 840                 -- Set source_unchanged to False unconditionally if
 841                 --      (a) recompilation checker is off, or
 842                 --      (b) we aren't going all the way to .o file (e.g. ghc -S)
 843              then return False
 844                 -- Otherwise look at file modification dates
 845              else do o_file_exists <- liftIO $ doesFileExist o_file
 846                      if not o_file_exists
 847                         then return False       -- Need to recompile
 848                         else do t2 <- liftIO $ getModificationTime o_file
 849                                 if t2 > src_timestamp
 850                                   then return True
 851                                   else return False
 852
 853   -- get the DynFlags
 854         let next_phase = hscNextPhase dflags src_flavour hsc_lang
 855         output_fn  <- liftIO $ get_output_fn dflags next_phase (Just location4)
 856
 857         let dflags' = dflags { hscTarget = hsc_lang,
 858                                hscOutName = output_fn,
 859                                extCoreName = basename ++ ".hcr" }
 860
 861         let hsc_env' = hsc_env {hsc_dflags = dflags'}
 862
 863   -- Tell the finder cache about this module
 864         mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location4
 865
 866   -- Make the ModSummary to hand to hscMain
 867         let
 868             mod_summary = ModSummary {  ms_mod       = mod,
 869                                         ms_hsc_src   = src_flavour,
 870                                         ms_hspp_file = input_fn,
 871                                         ms_hspp_opts = dflags,
 872                                         ms_hspp_buf  = hspp_buf,
 873                                         ms_location  = location4,
 874                                         ms_hs_date   = src_timestamp,
 875                                         ms_obj_date  = Nothing,
 876                                         ms_imps      = imps,
 877                                         ms_srcimps   = src_imps }
 878
 879   -- run the compiler!
 880         result <- hscCompileOneShot hsc_env'
 881                           mod_summary source_unchanged
 882                           Nothing       -- No iface
 883                           Nothing       -- No "module i of n" progress info
 884
 885         case result of
 886           HscNoRecomp
 887               -> do liftIO $ SysTools.touch dflags' "Touching object file" o_file
 888                     -- The .o file must have a later modification date
 889                     -- than the source file (else we wouldn't be in HscNoRecomp)
 890                     -- but we touch it anyway, to keep 'make' happy (we think).
 891                     return (StopLn, dflags', Just location4, o_file)
 892           (HscRecomp hasStub _)
 893               -> do when hasStub $
 894                          do stub_o <- compileStub hsc_env' mod location4
 895                             liftIO $ consIORef v_Ld_inputs stub_o
 896                     -- In the case of hs-boot files, generate a dummy .o-boot
 897                     -- stamp file for the benefit of Make
 898                     when (isHsBoot src_flavour) $
 899                       liftIO $ SysTools.touch dflags' "Touching object file" o_file
 900                     return (next_phase, dflags', Just location4, output_fn)
 901
 902 -----------------------------------------------------------------------------
 903 -- Cmm phase
 904
 905 runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 906   = do
 907        let dflags = hsc_dflags hsc_env
 908            dflags' = flattenExtensionFlags dflags
 909        output_fn <- liftIO $ get_output_fn dflags' Cmm maybe_loc
 910        liftIO $ doCpp dflags' False{-not raw-} True{-include CC opts-} input_fn output_fn
 911        return (Cmm, dflags', maybe_loc, output_fn)
 912
 913 runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc
 914   = do
 915         let dflags = hsc_dflags hsc_env
 916         let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
 917         let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
 918         output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc
 919
 920         let dflags' = dflags { hscTarget = hsc_lang,
 921                                hscOutName = output_fn,
 922                                extCoreName = basename ++ ".hcr" }
 923         let hsc_env' = hsc_env {hsc_dflags = dflags'}
 924
 925         hscCmmFile hsc_env' input_fn
 926
 927         -- XXX: catch errors above and convert them into ghcError?  Original
 928         -- code was:
 929         --
 930         --when (not ok) $ ghcError (PhaseFailed "cmm" (ExitFailure 1))
 931
 932         return (next_phase, dflags, maybe_loc, output_fn)
 933
 934 -----------------------------------------------------------------------------
 935 -- Cc phase
 936
 937 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 938 -- way too many hacks, and I can't say I've ever used it anyway.
 939
 940 runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 941    | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc
 942    = do let dflags = hsc_dflags hsc_env
 943         let cc_opts = getOpts dflags opt_c
 944             hcc = cc_phase `eqPhase` HCc
 945
 946         let cmdline_include_paths = includePaths dflags
 947
 948         -- HC files have the dependent packages stamped into them
 949         pkgs <- if hcc then liftIO (getHCFilePackages input_fn) else return []
 950
 951         -- add package include paths even if we're just compiling .c
 952         -- files; this is the Value Add(TM) that using ghc instead of
 953         -- gcc gives you :)
 954         pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs
 955         let include_paths = foldr (\ x xs -> "-I" : x : xs) []
 956                               (cmdline_include_paths ++ pkg_include_dirs)
 957
 958         let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags
 959         gcc_extra_viac_flags <- liftIO $ getExtraViaCOpts dflags
 960         let pic_c_flags = picCCOpts dflags
 961
 962         let verb = getVerbFlag dflags
 963
 964         -- cc-options are not passed when compiling .hc files.  Our
 965         -- hc code doesn't not #include any header files anyway, so these
 966         -- options aren't necessary.
 967         pkg_extra_cc_opts <-
 968           if cc_phase `eqPhase` HCc
 969              then return []
 970              else liftIO $ getPackageExtraCcOpts dflags pkgs
 971
 972 #ifdef darwin_TARGET_OS
 973         pkg_framework_paths <- liftIO $ getPackageFrameworkPath dflags pkgs
 974         let cmdline_framework_paths = frameworkPaths dflags
 975         let framework_paths = map ("-F"++)
 976                         (cmdline_framework_paths ++ pkg_framework_paths)
 977 #endif
 978
 979         let split_objs = dopt Opt_SplitObjs dflags
 980             split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 981                       | otherwise         = [ ]
 982
 983         let cc_opt | optLevel dflags >= 2 = "-O2"
 984                    | otherwise            = "-O"
 985
 986         -- Decide next phase
 987
 988         let mangle = dopt Opt_DoAsmMangling dflags
 989             next_phase
 990                 | hcc && mangle     = Mangle
 991                 | otherwise         = As
 992         output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc
 993
 994         let
 995           more_hcc_opts =
 996 #if i386_TARGET_ARCH
 997                 -- on x86 the floating point regs have greater precision
 998                 -- than a double, which leads to unpredictable results.
 999                 -- By default, we turn this off with -ffloat-store unless
1000                 -- the user specified -fexcess-precision.
1001                 (if dopt Opt_ExcessPrecision dflags
1002                         then []
1003                         else [ "-ffloat-store" ]) ++
1004 #endif
1005
1006                 -- gcc's -fstrict-aliasing allows two accesses to memory
1007                 -- to be considered non-aliasing if they have different types.
1008                 -- This interacts badly with the C code we generate, which is
1009                 -- very weakly typed, being derived from C--.
1010                 ["-fno-strict-aliasing"]
1011
1012         liftIO $ SysTools.runCc dflags (
1013                 -- force the C compiler to interpret this file as C when
1014                 -- compiling .hc files, by adding the -x c option.
1015                 -- Also useful for plain .c files, just in case GHC saw a
1016                 -- -x c option.
1017                         [ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp
1018                                                 then SysTools.Option "c++"
1019                                                 else SysTools.Option "c"] ++
1020                         [ SysTools.FileOption "" input_fn
1021                         , SysTools.Option "-o"
1022                         , SysTools.FileOption "" output_fn
1023                         ]
1024                        ++ map SysTools.Option (
1025                           md_c_flags
1026                        ++ pic_c_flags
1027
1028 #if    defined(mingw32_TARGET_OS)
1029                 -- Stub files generated for foreign exports references the runIO_closure
1030                 -- and runNonIO_closure symbols, which are defined in the base package.
1031                 -- These symbols are imported into the stub.c file via RtsAPI.h, and the
1032                 -- way we do the import depends on whether we're currently compiling
1033                 -- the base package or not.
1034                        ++ (if thisPackage dflags == basePackageId
1035                                 then [ "-DCOMPILING_BASE_PACKAGE" ]
1036                                 else [])
1037 #endif
1038
1039 #ifdef sparc_TARGET_ARCH
1040         -- We only support SparcV9 and better because V8 lacks an atomic CAS
1041         -- instruction. Note that the user can still override this
1042         -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
1043         -- regardless of the ordering.
1044         --
1045         -- This is a temporary hack.
1046                        ++ ["-mcpu=v9"]
1047 #endif
1048                        ++ (if hcc && mangle
1049                              then md_regd_c_flags
1050                              else [])
1051                        ++ (if hcc
1052                              then if mangle
1053                                      then gcc_extra_viac_flags
1054                                      else filter (=="-fwrapv")
1055                                                 gcc_extra_viac_flags
1056                                 -- still want -fwrapv even for unreg'd
1057                              else [])
1058                        ++ (if hcc
1059                              then more_hcc_opts
1060                              else [])
1061                        ++ [ verb, "-S", "-Wimplicit", cc_opt ]
1062                        ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
1063 #ifdef darwin_TARGET_OS
1064                        ++ framework_paths
1065 #endif
1066                        ++ cc_opts
1067                        ++ split_opt
1068                        ++ include_paths
1069                        ++ pkg_extra_cc_opts
1070                        ))
1071
1072         return (next_phase, dflags, maybe_loc, output_fn)
1073
1074         -- ToDo: postprocess the output from gcc
1075
1076 -----------------------------------------------------------------------------
1077 -- Mangle phase
1078
1079 runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
1080    = do let dflags = hsc_dflags hsc_env
1081         let mangler_opts = getOpts dflags opt_m
1082
1083 #if i386_TARGET_ARCH
1084         machdep_opts <- return [ show (stolen_x86_regs dflags) ]
1085 #else
1086         machdep_opts <- return []
1087 #endif
1088
1089         let split = dopt Opt_SplitObjs dflags
1090             next_phase
1091                 | split = SplitMangle
1092                 | otherwise = As
1093         output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc
1094
1095         liftIO $ SysTools.runMangle dflags (map SysTools.Option mangler_opts
1096                           ++ [ SysTools.FileOption "" input_fn
1097                              , SysTools.FileOption "" output_fn
1098                              ]
1099                           ++ map SysTools.Option machdep_opts)
1100
1101         return (next_phase, dflags, maybe_loc, output_fn)
1102
1103 -----------------------------------------------------------------------------
1104 -- Splitting phase
1105
1106 runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc
1107   = liftIO $
1108     do  -- tmp_pfx is the prefix used for the split .s files
1109         -- We also use it as the file to contain the no. of split .s files (sigh)
1110         let dflags = hsc_dflags hsc_env
1111         split_s_prefix <- SysTools.newTempName dflags "split"
1112         let n_files_fn = split_s_prefix
1113
1114         SysTools.runSplit dflags
1115                           [ SysTools.FileOption "" input_fn
1116                           , SysTools.FileOption "" split_s_prefix
1117                           , SysTools.FileOption "" n_files_fn
1118                           ]
1119
1120         -- Save the number of split files for future references
1121         s <- readFile n_files_fn
1122         let n_files = read s :: Int
1123             dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }
1124
1125         -- Remember to delete all these files
1126         addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s"
1127                                 | n <- [1..n_files]]
1128
1129         return (SplitAs, dflags', maybe_loc, "**splitmangle**")
1130           -- we don't use the filename
1131
1132 -----------------------------------------------------------------------------
1133 -- As phase
1134
1135 runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
1136   = liftIO $
1137     do  let dflags = hsc_dflags hsc_env
1138         let as_opts =  getOpts dflags opt_a
1139         let cmdline_include_paths = includePaths dflags
1140
1141         output_fn <- get_output_fn dflags StopLn maybe_loc
1142
1143         -- we create directories for the object file, because it
1144         -- might be a hierarchical module.
1145         createDirectoryHierarchy (takeDirectory output_fn)
1146
1147         let (md_c_flags, _) = machdepCCOpts dflags
1148         SysTools.runAs dflags
1149                        (map SysTools.Option as_opts
1150                        ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
1151 #ifdef sparc_TARGET_ARCH
1152         -- We only support SparcV9 and better because V8 lacks an atomic CAS
1153         -- instruction so we have to make sure that the assembler accepts the
1154         -- instruction set. Note that the user can still override this
1155         -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1156         -- regardless of the ordering.
1157         --
1158         -- This is a temporary hack.
1159                        ++ [ SysTools.Option "-mcpu=v9" ]
1160 #endif
1161                        ++ [ SysTools.Option "-c"
1162                           , SysTools.FileOption "" input_fn
1163                           , SysTools.Option "-o"
1164                           , SysTools.FileOption "" output_fn
1165                           ]
1166                        ++ map SysTools.Option md_c_flags)
1167
1168         return (StopLn, dflags, maybe_loc, output_fn)
1169
1170
1171 runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc
1172   = liftIO $ do
1173         let dflags = hsc_dflags hsc_env
1174         output_fn <- get_output_fn dflags StopLn maybe_loc
1175
1176         let base_o = dropExtension output_fn
1177             osuf = objectSuf dflags
1178             split_odir  = base_o ++ "_" ++ osuf ++ "_split"
1179
1180         createDirectoryHierarchy split_odir
1181
1182         -- remove M_split/ *.o, because we're going to archive M_split/ *.o
1183         -- later and we don't want to pick up any old objects.
1184         fs <- getDirectoryContents split_odir
1185         mapM_ removeFile $ map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
1186
1187         let as_opts = getOpts dflags opt_a
1188
1189         let (split_s_prefix, n) = case splitInfo dflags of
1190                                   Nothing -> panic "No split info"
1191                                   Just x -> x
1192
1193         let split_s   n = split_s_prefix ++ "__" ++ show n <.> "s"
1194             split_obj n = split_odir </>
1195                           takeFileName base_o ++ "__" ++ show n <.> osuf
1196
1197         let (md_c_flags, _) = machdepCCOpts dflags
1198         let assemble_file n
1199               = SysTools.runAs dflags
1200                          (map SysTools.Option as_opts ++
1201 #ifdef sparc_TARGET_ARCH
1202         -- We only support SparcV9 and better because V8 lacks an atomic CAS
1203         -- instruction so we have to make sure that the assembler accepts the
1204         -- instruction set. Note that the user can still override this
1205         -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1206         -- regardless of the ordering.
1207         --
1208         -- This is a temporary hack.
1209                           [ SysTools.Option "-mcpu=v9" ] ++
1210 #endif
1211                           [ SysTools.Option "-c"
1212                           , SysTools.Option "-o"
1213                           , SysTools.FileOption "" (split_obj n)
1214                           , SysTools.FileOption "" (split_s n)
1215                           ]
1216                        ++ map SysTools.Option md_c_flags)
1217
1218         mapM_ assemble_file [1..n]
1219
1220         -- and join the split objects into a single object file:
1221         let ld_r args = SysTools.runLink dflags ([
1222                             SysTools.Option "-nostdlib",
1223                             SysTools.Option "-nodefaultlibs",
1224                             SysTools.Option "-Wl,-r",
1225                             SysTools.Option ld_x_flag,
1226                             SysTools.Option "-o",
1227                             SysTools.FileOption "" output_fn ]
1228                          ++ map SysTools.Option md_c_flags
1229                          ++ args)
1230             ld_x_flag | null cLD_X = ""
1231                       | otherwise  = "-Wl,-x"
1232
1233         if cLdIsGNULd == "YES"
1234             then do
1235                   let script = split_odir </> "ld.script"
1236                   writeFile script $
1237                       "INPUT(" ++ unwords (map split_obj [1..n]) ++ ")"
1238                   ld_r [SysTools.FileOption "" script]
1239             else do
1240                   ld_r (map (SysTools.FileOption "" . split_obj) [1..n])
1241
1242         return (StopLn, dflags, maybe_loc, output_fn)
1243
1244
1245 -----------------------------------------------------------------------------
1246 -- LlvmOpt phase
1247
1248 runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
1249   = liftIO $ do
1250     let dflags  = hsc_dflags hsc_env
1251     let lo_opts = getOpts dflags opt_lo
1252     let opt_lvl = max 0 (min 2 $ optLevel dflags)
1253     -- don't specify anything if user has specified commands. We do this for
1254     -- opt but not llc since opt is very specifically for optimisation passes
1255     -- only, so if the user is passing us extra options we assume they know
1256     -- what they are doing and don't get in the way.
1257     let optFlag = if null lo_opts
1258                      then [SysTools.Option (llvmOpts !! opt_lvl)]
1259                      else []
1260
1261     output_fn <- get_output_fn dflags LlvmLlc maybe_loc
1262
1263     SysTools.runLlvmOpt dflags
1264                ([ SysTools.FileOption "" input_fn,
1265                     SysTools.Option "-o",
1266                     SysTools.FileOption "" output_fn]
1267                 ++ optFlag
1268                 ++ map SysTools.Option lo_opts)
1269
1270     return (LlvmLlc, dflags, maybe_loc, output_fn)
1271   where
1272         -- we always (unless -optlo specified) run Opt since we rely on it to
1273         -- fix up some pretty big deficiencies in the code we generate
1274         llvmOpts = ["-mem2reg", "-O1", "-O2"]
1275
1276
1277 -----------------------------------------------------------------------------
1278 -- LlvmLlc phase
1279
1280 runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
1281   = liftIO $ do
1282     let dflags  = hsc_dflags hsc_env
1283     let lc_opts = getOpts dflags opt_lc
1284     let opt_lvl = max 0 (min 2 $ optLevel dflags)
1285 #if darwin_TARGET_OS
1286     let nphase = LlvmMangle
1287 #else
1288     let nphase = As
1289 #endif
1290
1291     output_fn <- get_output_fn dflags nphase maybe_loc
1292
1293     SysTools.runLlvmLlc dflags
1294                 ([ SysTools.Option (llvmOpts !! opt_lvl),
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 -> [PackageId] -> IO Bool
1334 runPhase_MoveBinary dflags input_fn dep_packages
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     | not opt_Static =
1352         case (dynLibLoader dflags) of
1353           Wrapped wrapmode ->
1354               do
1355                 let (o_base, o_ext) = splitExtension input_fn
1356                 let wrapped_executable | o_ext == "exe" = (o_base ++ ".dyn") <.> o_ext
1357                                        | otherwise = input_fn ++ ".dyn"
1358                 behaviour <- wrapper_behaviour dflags wrapmode dep_packages
1359
1360                 -- THINKME isn't this possible to do a bit nicer?
1361                 let behaviour' = concatMap (\x -> if x=='\\' then "\\\\" else [x]) behaviour
1362                 renameFile input_fn wrapped_executable
1363                 let rtsDetails = (getPackageDetails (pkgState dflags) rtsPackageId);
1364                     (md_c_flags, _) = machdepCCOpts dflags
1365                 SysTools.runCc dflags
1366                   ([ SysTools.FileOption "" ((head (libraryDirs rtsDetails)) ++ "/dyn-wrapper.c")
1367                    , SysTools.Option ("-DBEHAVIOUR=\"" ++ behaviour' ++ "\"")
1368                    , SysTools.Option "-o"
1369                    , SysTools.FileOption "" input_fn] ++
1370                    map (SysTools.FileOption "-I") (includeDirs rtsDetails) ++
1371                    map Option md_c_flags)
1372                 return True
1373           _ -> return True
1374     | otherwise = return True
1375
1376 wrapper_behaviour :: DynFlags -> Maybe [Char] -> [PackageId] -> IO [Char]
1377 wrapper_behaviour dflags mode dep_packages =
1378     let seperateBySemiColon strs = tail $ concatMap (';':) strs
1379     in case mode of
1380       Nothing -> do
1381                 pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1382                 return ('H' : (seperateBySemiColon pkg_lib_paths))
1383       Just s -> do
1384         allpkg <- getPreloadPackagesAnd dflags dep_packages
1385         putStrLn (unwords (map (packageIdString . packageConfigId) allpkg))
1386         return $ 'F':s ++ ';':(seperateBySemiColon (map (packageIdString . packageConfigId) allpkg))
1387
1388 mkExtraCObj :: DynFlags -> [String] -> IO FilePath
1389 mkExtraCObj dflags xs
1390  = do cFile <- newTempName dflags "c"
1391       oFile <- newTempName dflags "o"
1392       writeFile cFile $ unlines xs
1393       let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId
1394           (md_c_flags, _) = machdepCCOpts dflags
1395       SysTools.runCc dflags
1396                      ([Option        "-c",
1397                        FileOption "" cFile,
1398                        Option        "-o",
1399                        FileOption "" oFile] ++
1400                       map (FileOption "-I") (includeDirs rtsDetails) ++
1401                       map Option md_c_flags)
1402       return oFile
1403
1404 -- generates a Perl skript starting a parallel prg under PVM
1405 mk_pvm_wrapper_script :: String -> String -> String -> String
1406 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
1407  [
1408   "eval 'exec perl -S $0 ${1+\"$@\"}'",
1409   "  if $running_under_some_shell;",
1410   "# =!=!=!=!=!=!=!=!=!=!=!",
1411   "# This script is automatically generated: DO NOT EDIT!!!",
1412   "# Generated by Glasgow Haskell Compiler",
1413   "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
1414   "#",
1415   "$pvm_executable      = '" ++ pvm_executable ++ "';",
1416   "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
1417   "$SysMan = '" ++ sysMan ++ "';",
1418   "",
1419   {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
1420   "# first, some magical shortcuts to run "commands" on the binary",
1421   "# (which is hidden)",
1422   "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
1423   "    local($cmd) = $1;",
1424   "    system("$cmd $pvm_executable");",
1425   "    exit(0); # all done",
1426   "}", -}
1427   "",
1428   "# Now, run the real binary; process the args first",
1429   "$ENV{'PE'} = $pvm_executable_base;", --  ++ pvm_executable_base,
1430   "$debug = '';",
1431   "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
1432   "@nonPVM_args = ();",
1433   "$in_RTS_args = 0;",
1434   "",
1435   "args: while ($a = shift(@ARGV)) {",
1436   "    if ( $a eq '+RTS' ) {",
1437   "        $in_RTS_args = 1;",
1438   "    } elsif ( $a eq '-RTS' ) {",
1439   "        $in_RTS_args = 0;",
1440   "    }",
1441   "    if ( $a eq '-d' && $in_RTS_args ) {",
1442   "        $debug = '-';",
1443   "    } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
1444   "        $nprocessors = $1;",
1445   "    } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
1446   "        $nprocessors = $1;",
1447   "    } else {",
1448   "        push(@nonPVM_args, $a);",
1449   "    }",
1450   "}",
1451   "",
1452   "local($return_val) = 0;",
1453   "# Start the parallel execution by calling SysMan",
1454   "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
1455   "$return_val = $?;",
1456   "# ToDo: fix race condition moving files and flushing them!!",
1457   "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
1458   "exit($return_val);"
1459  ]
1460
1461 -----------------------------------------------------------------------------
1462 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
1463
1464 getHCFilePackages :: FilePath -> IO [PackageId]
1465 getHCFilePackages filename =
1466   Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
1467     l <- hGetLine h
1468     case l of
1469       '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
1470           return (map stringToPackageId (words rest))
1471       _other ->
1472           return []
1473
1474 -----------------------------------------------------------------------------
1475 -- Static linking, of .o files
1476
1477 -- The list of packages passed to link is the list of packages on
1478 -- which this program depends, as discovered by the compilation
1479 -- manager.  It is combined with the list of packages that the user
1480 -- specifies on the command line with -package flags.
1481 --
1482 -- In one-shot linking mode, we can't discover the package
1483 -- dependencies (because we haven't actually done any compilation or
1484 -- read any interface files), so the user must explicitly specify all
1485 -- the packages.
1486
1487 linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO ()
1488 linkBinary dflags o_files dep_packages = do
1489     let verb = getVerbFlag dflags
1490         output_fn = exeFileName dflags
1491
1492     -- get the full list of packages to link with, by combining the
1493     -- explicit packages with the auto packages and all of their
1494     -- dependencies, and eliminating duplicates.
1495
1496     pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1497     let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths)
1498 #ifdef elf_OBJ_FORMAT
1499         get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1500                                 | otherwise = ["-L" ++ l]
1501 #else
1502         get_pkg_lib_path_opts l = ["-L" ++ l]
1503 #endif
1504
1505     let lib_paths = libraryPaths dflags
1506     let lib_path_opts = map ("-L"++) lib_paths
1507
1508     -- The C "main" function is not in the rts but in a separate static
1509     -- library libHSrtsmain.a that sits next to the rts lib files. Assuming
1510     -- we're using a Haskell main function then we need to link it in.
1511     let no_hs_main = dopt Opt_NoHsMain dflags
1512     let main_lib | no_hs_main = []
1513                  | otherwise  = [ "-lHSrtsmain" ]
1514     rtsEnabledObj <- if dopt Opt_RtsOptsEnabled dflags
1515                      then do fn <- mkExtraCObj dflags
1516                                     ["#include \"Rts.h\"",
1517                                      "const rtsBool rtsOptsEnabled = rtsTrue;"]
1518                              return [fn]
1519                      else return []
1520     rtsOptsObj <- case rtsOpts dflags of
1521                   Just opts ->
1522                       do fn <- mkExtraCObj dflags
1523                                  -- We assume that the Haskell "show" does
1524                                  -- the right thing here
1525                                  ["char *ghc_rts_opts = " ++ show opts ++ ";"]
1526                          return [fn]
1527                   Nothing -> return []
1528
1529     pkg_link_opts <- getPackageLinkOpts dflags dep_packages
1530
1531 #ifdef darwin_TARGET_OS
1532     pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
1533     let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths
1534
1535     let framework_paths = frameworkPaths dflags
1536         framework_path_opts = map ("-F"++) framework_paths
1537
1538     pkg_frameworks <- getPackageFrameworks dflags dep_packages
1539     let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1540
1541     let frameworks = cmdlineFrameworks dflags
1542         framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ]
1543          -- reverse because they're added in reverse order from the cmd line
1544 #endif
1545         -- probably _stub.o files
1546     extra_ld_inputs <- readIORef v_Ld_inputs
1547
1548         -- opts from -optl-<blah> (including -l<blah> options)
1549     let extra_ld_opts = getOpts dflags opt_l
1550
1551     let ways = wayNames dflags
1552
1553     -- Here are some libs that need to be linked at the *end* of
1554     -- the command line, because they contain symbols that are referred to
1555     -- by the RTS.  We can't therefore use the ordinary way opts for these.
1556     let
1557         debug_opts | WayDebug `elem` ways = [
1558 #if defined(HAVE_LIBBFD)
1559                         "-lbfd", "-liberty"
1560 #endif
1561                          ]
1562                    | otherwise            = []
1563
1564     let
1565         thread_opts | WayThreaded `elem` ways = [
1566 #if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) && !defined(haiku_TARGET_OS)
1567                         "-lpthread"
1568 #endif
1569 #if defined(osf3_TARGET_OS)
1570                         , "-lexc"
1571 #endif
1572                         ]
1573                     | otherwise               = []
1574
1575     rc_objs <- maybeCreateManifest dflags output_fn
1576
1577     let (md_c_flags, _) = machdepCCOpts dflags
1578     SysTools.runLink dflags (
1579                        [ SysTools.Option verb
1580                        , SysTools.Option "-o"
1581                        , SysTools.FileOption "" output_fn
1582                        ]
1583                       ++ map SysTools.Option (
1584                          md_c_flags
1585
1586 #ifdef mingw32_TARGET_OS
1587                       -- Permit the linker to auto link _symbol to _imp_symbol.
1588                       -- This lets us link against DLLs without needing an "import library".
1589                       ++ ["-Wl,--enable-auto-import"]
1590 #endif
1591                       ++ o_files
1592                       ++ extra_ld_inputs
1593                       ++ lib_path_opts
1594                       ++ extra_ld_opts
1595                       ++ rc_objs
1596 #ifdef darwin_TARGET_OS
1597                       ++ framework_path_opts
1598                       ++ framework_opts
1599 #endif
1600                       ++ pkg_lib_path_opts
1601                       ++ main_lib
1602                       ++ rtsEnabledObj
1603                       ++ rtsOptsObj
1604                       ++ pkg_link_opts
1605 #ifdef darwin_TARGET_OS
1606                       ++ pkg_framework_path_opts
1607                       ++ pkg_framework_opts
1608 #endif
1609                       ++ debug_opts
1610                       ++ thread_opts
1611                     ))
1612
1613     -- parallel only: move binary to another dir -- HWL
1614     success <- runPhase_MoveBinary dflags output_fn dep_packages
1615     if success then return ()
1616                else ghcError (InstallationError ("cannot move binary"))
1617
1618
1619 exeFileName :: DynFlags -> FilePath
1620 exeFileName dflags
1621   | Just s <- outputFile dflags =
1622 #if defined(mingw32_HOST_OS)
1623       if null (takeExtension s)
1624         then s <.> "exe"
1625         else s
1626 #else
1627       s
1628 #endif
1629   | otherwise =
1630 #if defined(mingw32_HOST_OS)
1631         "main.exe"
1632 #else
1633         "a.out"
1634 #endif
1635
1636 maybeCreateManifest
1637    :: DynFlags
1638    -> FilePath                          -- filename of executable
1639    -> IO [FilePath]                     -- extra objects to embed, maybe
1640 #ifndef mingw32_TARGET_OS
1641 maybeCreateManifest _ _ = do
1642   return []
1643 #else
1644 maybeCreateManifest dflags exe_filename = do
1645   if not (dopt Opt_GenManifest dflags) then return [] else do
1646
1647   let manifest_filename = exe_filename <.> "manifest"
1648
1649   writeFile manifest_filename $
1650       "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
1651       "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
1652       "  <assemblyIdentity version=\"1.0.0.0\"\n"++
1653       "     processorArchitecture=\"X86\"\n"++
1654       "     name=\"" ++ dropExtension exe_filename ++ "\"\n"++
1655       "     type=\"win32\"/>\n\n"++
1656       "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
1657       "    <security>\n"++
1658       "      <requestedPrivileges>\n"++
1659       "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
1660       "        </requestedPrivileges>\n"++
1661       "       </security>\n"++
1662       "  </trustInfo>\n"++
1663       "</assembly>\n"
1664
1665   -- Windows will find the manifest file if it is named foo.exe.manifest.
1666   -- However, for extra robustness, and so that we can move the binary around,
1667   -- we can embed the manifest in the binary itself using windres:
1668   if not (dopt Opt_EmbedManifest dflags) then return [] else do
1669
1670   rc_filename <- newTempName dflags "rc"
1671   rc_obj_filename <- newTempName dflags (objectSuf dflags)
1672
1673   writeFile rc_filename $
1674       "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
1675         -- magic numbers :-)
1676         -- show is a bit hackish above, but we need to escape the
1677         -- backslashes in the path.
1678
1679   let wr_opts = getOpts dflags opt_windres
1680   runWindres dflags $ map SysTools.Option $
1681         ["--input="++rc_filename,
1682          "--output="++rc_obj_filename,
1683          "--output-format=coff"]
1684         ++ wr_opts
1685         -- no FileOptions here: windres doesn't like seeing
1686         -- backslashes, apparently
1687
1688   removeFile manifest_filename
1689
1690   return [rc_obj_filename]
1691 #endif
1692
1693
1694 linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
1695 linkDynLib dflags o_files dep_packages = do
1696     let verb = getVerbFlag dflags
1697     let o_file = outputFile dflags
1698
1699     -- We don't want to link our dynamic libs against the RTS package,
1700     -- because the RTS lib comes in several flavours and we want to be
1701     -- able to pick the flavour when a binary is linked.
1702     pkgs <- getPreloadPackagesAnd dflags dep_packages
1703
1704     -- On Windows we need to link the RTS import lib as Windows does
1705     -- not allow undefined symbols.
1706 #if !defined(mingw32_HOST_OS)
1707     let pkgs_no_rts = filter ((/= rtsPackageId) . packageConfigId) pkgs
1708 #else
1709     let pkgs_no_rts = pkgs
1710 #endif
1711     let pkg_lib_paths = collectLibraryPaths pkgs_no_rts
1712     let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1713 #ifdef elf_OBJ_FORMAT
1714         get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1715                                 | otherwise = ["-L" ++ l]
1716 #else
1717         get_pkg_lib_path_opts l = ["-L" ++ l]
1718 #endif
1719
1720     let lib_paths = libraryPaths dflags
1721     let lib_path_opts = map ("-L"++) lib_paths
1722
1723     let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts
1724
1725         -- probably _stub.o files
1726     extra_ld_inputs <- readIORef v_Ld_inputs
1727
1728     let (md_c_flags, _) = machdepCCOpts dflags
1729     let extra_ld_opts = getOpts dflags opt_l
1730 #if defined(mingw32_HOST_OS)
1731     -----------------------------------------------------------------------------
1732     -- Making a DLL
1733     -----------------------------------------------------------------------------
1734     let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
1735
1736     SysTools.runLink dflags
1737          ([ SysTools.Option verb
1738           , SysTools.Option "-o"
1739           , SysTools.FileOption "" output_fn
1740           , SysTools.Option "-shared"
1741           ] ++
1742           [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
1743           | dopt Opt_SharedImplib dflags
1744           ]
1745          ++ map (SysTools.FileOption "") o_files
1746          ++ map SysTools.Option (
1747             md_c_flags
1748
1749          -- Permit the linker to auto link _symbol to _imp_symbol
1750          -- This lets us link against DLLs without needing an "import library"
1751          ++ ["-Wl,--enable-auto-import"]
1752
1753          ++ extra_ld_inputs
1754          ++ lib_path_opts
1755          ++ extra_ld_opts
1756          ++ pkg_lib_path_opts
1757          ++ pkg_link_opts
1758         ))
1759 #elif defined(darwin_TARGET_OS)
1760     -----------------------------------------------------------------------------
1761     -- Making a darwin dylib
1762     -----------------------------------------------------------------------------
1763     -- About the options used for Darwin:
1764     -- -dynamiclib
1765     --   Apple's way of saying -shared
1766     -- -undefined dynamic_lookup:
1767     --   Without these options, we'd have to specify the correct dependencies
1768     --   for each of the dylibs. Note that we could (and should) do without this
1769     --   for all libraries except the RTS; all we need to do is to pass the
1770     --   correct HSfoo_dyn.dylib files to the link command.
1771     --   This feature requires Mac OS X 10.3 or later; there is a similar feature,
1772     --   -flat_namespace -undefined suppress, which works on earlier versions,
1773     --   but it has other disadvantages.
1774     -- -single_module
1775     --   Build the dynamic library as a single "module", i.e. no dynamic binding
1776     --   nonsense when referring to symbols from within the library. The NCG
1777     --   assumes that this option is specified (on i386, at least).
1778     -- -install_name
1779     --   Mac OS/X stores the path where a dynamic library is (to be) installed
1780     --   in the library itself.  It's called the "install name" of the library.
1781     --   Then any library or executable that links against it before it's
1782     --   installed will search for it in its ultimate install location.  By
1783     --   default we set the install name to the absolute path at build time, but
1784     --   it can be overridden by the -dylib-install-name option passed to ghc.
1785     --   Cabal does this.
1786     -----------------------------------------------------------------------------
1787
1788     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1789
1790     instName <- case dylibInstallName dflags of
1791         Just n -> return n
1792         Nothing -> do
1793             pwd <- getCurrentDirectory
1794             return $ pwd `combine` output_fn
1795     SysTools.runLink dflags
1796          ([ SysTools.Option verb
1797           , SysTools.Option "-dynamiclib"
1798           , SysTools.Option "-o"
1799           , SysTools.FileOption "" output_fn
1800           ]
1801          ++ map SysTools.Option (
1802             md_c_flags
1803          ++ o_files
1804          ++ [ "-undefined", "dynamic_lookup", "-single_module",
1805               "-Wl,-read_only_relocs,suppress", "-install_name", instName ]
1806          ++ extra_ld_inputs
1807          ++ lib_path_opts
1808          ++ extra_ld_opts
1809          ++ pkg_lib_path_opts
1810          ++ pkg_link_opts
1811         ))
1812 #else
1813     -----------------------------------------------------------------------------
1814     -- Making a DSO
1815     -----------------------------------------------------------------------------
1816
1817     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1818     let buildingRts = thisPackage dflags == rtsPackageId
1819     let bsymbolicFlag = if buildingRts
1820                         then -- -Bsymbolic breaks the way we implement
1821                              -- hooks in the RTS
1822                              []
1823                         else -- we need symbolic linking to resolve
1824                              -- non-PIC intra-package-relocations
1825                              ["-Wl,-Bsymbolic"]
1826
1827     SysTools.runLink dflags
1828          ([ SysTools.Option verb
1829           , SysTools.Option "-o"
1830           , SysTools.FileOption "" output_fn
1831           ]
1832          ++ map SysTools.Option (
1833             md_c_flags
1834          ++ o_files
1835          ++ [ "-shared" ]
1836          ++ bsymbolicFlag
1837          ++ [ "-Wl,-soname," ++ takeFileName output_fn ] -- set the library soname
1838          ++ extra_ld_inputs
1839          ++ lib_path_opts
1840          ++ extra_ld_opts
1841          ++ pkg_lib_path_opts
1842          ++ pkg_link_opts
1843         ))
1844 #endif
1845 -- -----------------------------------------------------------------------------
1846 -- Running CPP
1847
1848 doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO ()
1849 doCpp dflags raw include_cc_opts input_fn output_fn = do
1850     let hscpp_opts = getOpts dflags opt_P
1851     let cmdline_include_paths = includePaths dflags
1852
1853     pkg_include_dirs <- getPackageIncludePath dflags []
1854     let include_paths = foldr (\ x xs -> "-I" : x : xs) []
1855                           (cmdline_include_paths ++ pkg_include_dirs)
1856
1857     let verb = getVerbFlag dflags
1858
1859     let cc_opts
1860           | not include_cc_opts = []
1861           | otherwise           = (optc ++ md_c_flags)
1862                 where
1863                       optc = getOpts dflags opt_c
1864                       (md_c_flags, _) = machdepCCOpts dflags
1865
1866     let cpp_prog args | raw       = SysTools.runCpp dflags args
1867                       | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
1868
1869     let target_defs =
1870           [ "-D" ++ HOST_OS     ++ "_BUILD_OS=1",
1871             "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH=1",
1872             "-D" ++ TARGET_OS   ++ "_HOST_OS=1",
1873             "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ]
1874         -- remember, in code we *compile*, the HOST is the same our TARGET,
1875         -- and BUILD is the same as our HOST.
1876
1877     cpp_prog       ([SysTools.Option verb]
1878                     ++ map SysTools.Option include_paths
1879                     ++ map SysTools.Option hsSourceCppOpts
1880                     ++ map SysTools.Option target_defs
1881                     ++ map SysTools.Option hscpp_opts
1882                     ++ map SysTools.Option cc_opts
1883                     ++ [ SysTools.Option     "-x"
1884                        , SysTools.Option     "c"
1885                        , SysTools.Option     input_fn
1886         -- We hackily use Option instead of FileOption here, so that the file
1887         -- name is not back-slashed on Windows.  cpp is capable of
1888         -- dealing with / in filenames, so it works fine.  Furthermore
1889         -- if we put in backslashes, cpp outputs #line directives
1890         -- with *double* backslashes.   And that in turn means that
1891         -- our error messages get double backslashes in them.
1892         -- In due course we should arrange that the lexer deals
1893         -- with these \\ escapes properly.
1894                        , SysTools.Option     "-o"
1895                        , SysTools.FileOption "" output_fn
1896                        ])
1897
1898 cHaskell1Version :: String
1899 cHaskell1Version = "5" -- i.e., Haskell 98
1900
1901 hsSourceCppOpts :: [String]
1902 -- Default CPP defines in Haskell source
1903 hsSourceCppOpts =
1904         [ "-D__HASKELL1__="++cHaskell1Version
1905         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
1906         , "-D__HASKELL98__"
1907         , "-D__CONCURRENT_HASKELL__"
1908         ]
1909
1910
1911 -- -----------------------------------------------------------------------------
1912 -- Misc.
1913
1914 hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase
1915 hscNextPhase _ HsBootFile _        =  StopLn
1916 hscNextPhase dflags _ hsc_lang =
1917   case hsc_lang of
1918         HscC -> HCc
1919         HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle
1920                | otherwise -> As
1921         HscLlvm        -> LlvmOpt
1922         HscNothing     -> StopLn
1923         HscInterpreted -> StopLn
1924         _other         -> StopLn
1925
1926
1927 hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget
1928 hscMaybeAdjustTarget dflags stop _ current_hsc_lang
1929   = hsc_lang
1930   where
1931         keep_hc = dopt Opt_KeepHcFiles dflags
1932         hsc_lang
1933                 -- don't change the lang if we're interpreting
1934                  | current_hsc_lang == HscInterpreted = current_hsc_lang
1935
1936                 -- force -fvia-C if we are being asked for a .hc file
1937                  | HCc <- stop = HscC
1938                  | keep_hc     = HscC
1939                 -- otherwise, stick to the plan
1940                  | otherwise = current_hsc_lang
1941