compiler/main/DriverPipeline.hs

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