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