compiler/main/DriverPipeline.hs

   1 {-# OPTIONS -fno-cse #-}
   2 -- -fno-cse is needed for GLOBAL_VAR's to behave properly
   3
   4 -----------------------------------------------------------------------------
   5 --
   6 -- GHC Driver
   7 --
   8 -- (c) The University of Glasgow 2005
   9 --
  10 -----------------------------------------------------------------------------
  11
  12 module DriverPipeline (
  13         -- Run a series of compilation steps in a pipeline, for a
  14         -- collection of source files.
  15    oneShot, compileFile,
  16
  17         -- Interfaces for the batch-mode driver
  18    linkBinary,
  19
  20         -- Interfaces for the compilation manager (interpreted/batch-mode)
  21    preprocess,
  22    compile, compile',
  23    link,
  24
  25   ) where
  26
  27 #include "HsVersions.h"
  28
  29 import Packages
  30 import HeaderInfo
  31 import DriverPhases
  32 import SysTools
  33 import HscMain
  34 import Finder
  35 import HscTypes
  36 import Outputable
  37 import Module
  38 import UniqFM           ( eltsUFM )
  39 import ErrUtils
  40 import DynFlags
  41 import StaticFlags      ( v_Ld_inputs, opt_PIC, opt_Static, WayName(..) )
  42 import Config
  43 import Panic
  44 import Util
  45 import StringBuffer     ( hGetStringBuffer )
  46 import BasicTypes       ( SuccessFlag(..) )
  47 import Maybes           ( expectJust )
  48 import ParserCoreUtils  ( getCoreModuleName )
  49 import SrcLoc
  50 import FastString
  51 import LlvmCodeGen      ( llvmFixupAsm )
  52 import MonadUtils
  53
  54 -- import Data.Either
  55 import Exception
  56 import Data.IORef       ( readIORef )
  57 -- import GHC.Exts              ( Int(..) )
  58 import System.Directory
  59 import System.FilePath
  60 import System.IO
  61 import System.IO.Error as IO
  62 import Control.Monad
  63 import Data.List        ( isSuffixOf )
  64 import Data.Maybe
  65 import System.Environment
  66
  67 -- ---------------------------------------------------------------------------
  68 -- Pre-process
  69
  70 -- | Just preprocess a file, put the result in a temp. file (used by the
  71 -- compilation manager during the summary phase).
  72 --
  73 -- We return the augmented DynFlags, because they contain the result
  74 -- of slurping in the OPTIONS pragmas
  75
  76 preprocess :: HscEnv
  77            -> (FilePath, Maybe Phase) -- ^ filename and starting phase
  78            -> IO (DynFlags, FilePath)
  79 preprocess hsc_env (filename, mb_phase) =
  80   ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
  81   runPipeline anyHsc hsc_env (filename, mb_phase)
  82         Nothing Temporary Nothing{-no ModLocation-}
  83
  84 -- ---------------------------------------------------------------------------
  85
  86 -- | Compile
  87 --
  88 -- Compile a single module, under the control of the compilation manager.
  89 --
  90 -- This is the interface between the compilation manager and the
  91 -- compiler proper (hsc), where we deal with tedious details like
  92 -- reading the OPTIONS pragma from the source file, converting the
  93 -- C or assembly that GHC produces into an object file, and compiling
  94 -- FFI stub files.
  95 --
  96 -- NB.  No old interface can also mean that the source has changed.
  97
  98 compile :: HscEnv
  99         -> ModSummary      -- ^ summary for module being compiled
 100         -> Int             -- ^ module N ...
 101         -> Int             -- ^ ... of M
 102         -> Maybe ModIface  -- ^ old interface, if we have one
 103         -> Maybe Linkable  -- ^ old linkable, if we have one
 104         -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful
 105
 106 compile = compile' (hscCompileNothing, hscCompileInteractive, hscCompileBatch)
 107
 108 compile' ::
 109            (Compiler (HscStatus, ModIface, ModDetails),
 110             Compiler (InteractiveStatus, ModIface, ModDetails),
 111             Compiler (HscStatus, ModIface, ModDetails))
 112         -> HscEnv
 113         -> ModSummary      -- ^ summary for module being compiled
 114         -> Int             -- ^ module N ...
 115         -> Int             -- ^ ... of M
 116         -> Maybe ModIface  -- ^ old interface, if we have one
 117         -> Maybe Linkable  -- ^ old linkable, if we have one
 118         -> IO HomeModInfo   -- ^ the complete HomeModInfo, if successful
 119
 120 compile' (nothingCompiler, interactiveCompiler, batchCompiler)
 121         hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
 122  = do
 123    let dflags0     = ms_hspp_opts summary
 124        this_mod    = ms_mod summary
 125        src_flavour = ms_hsc_src summary
 126        location    = ms_location summary
 127        input_fn    = expectJust "compile:hs" (ml_hs_file location)
 128        input_fnpp  = ms_hspp_file summary
 129
 130    debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp)
 131
 132    let basename = dropExtension input_fn
 133
 134   -- We add the directory in which the .hs files resides) to the import path.
 135   -- This is needed when we try to compile the .hc file later, if it
 136   -- imports a _stub.h file that we created here.
 137    let current_dir = case takeDirectory basename of
 138                      "" -> "." -- XXX Hack
 139                      d -> d
 140        old_paths   = includePaths dflags0
 141        dflags      = dflags0 { includePaths = current_dir : old_paths }
 142        hsc_env     = hsc_env0 {hsc_dflags = dflags}
 143
 144    -- Figure out what lang we're generating
 145    let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags)
 146    -- ... and what the next phase should be
 147    let next_phase = hscNextPhase dflags src_flavour hsc_lang
 148    -- ... and what file to generate the output into
 149    output_fn <- getOutputFilename next_phase
 150                         Temporary basename dflags next_phase (Just location)
 151
 152    let dflags' = dflags { hscTarget = hsc_lang,
 153                                 hscOutName = output_fn,
 154                                 extCoreName = basename ++ ".hcr" }
 155    let hsc_env' = hsc_env { hsc_dflags = dflags' }
 156
 157    -- -fforce-recomp should also work with --make
 158    let force_recomp = dopt Opt_ForceRecomp dflags
 159        source_unchanged = isJust maybe_old_linkable && not force_recomp
 160        object_filename = ml_obj_file location
 161
 162    let getStubLinkable False = return []
 163        getStubLinkable True
 164            = do stub_o <- compileStub hsc_env' this_mod location
 165                 return [ DotO stub_o ]
 166
 167        handleBatch HscNoRecomp
 168            = ASSERT (isJust maybe_old_linkable)
 169              return maybe_old_linkable
 170
 171        handleBatch (HscRecomp hasStub _)
 172            | isHsBoot src_flavour
 173                = do when (isObjectTarget hsc_lang) $ -- interpreted reaches here too
 174                        liftIO $ SysTools.touch dflags' "Touching object file"
 175                                    object_filename
 176                     return maybe_old_linkable
 177
 178            | otherwise
 179                = do stub_unlinked <- getStubLinkable hasStub
 180                     (hs_unlinked, unlinked_time) <-
 181                         case hsc_lang of
 182                           HscNothing
 183                             -> return ([], ms_hs_date summary)
 184                           -- We're in --make mode: finish the compilation pipeline.
 185                           _other
 186                             -> do _ <- runPipeline StopLn hsc_env' (output_fn,Nothing)
 187                                               (Just basename)
 188                                               Persistent
 189                                               (Just location)
 190                                   -- The object filename comes from the ModLocation
 191                                   o_time <- getModificationTime object_filename
 192                                   return ([DotO object_filename], o_time)
 193                     let linkable = LM unlinked_time this_mod
 194                                    (hs_unlinked ++ stub_unlinked)
 195                     return (Just linkable)
 196
 197        handleInterpreted HscNoRecomp
 198            = ASSERT (isJust maybe_old_linkable)
 199              return maybe_old_linkable
 200        handleInterpreted (HscRecomp _hasStub Nothing)
 201            = ASSERT (isHsBoot src_flavour)
 202              return maybe_old_linkable
 203        handleInterpreted (HscRecomp hasStub (Just (comp_bc, modBreaks)))
 204            = do stub_unlinked <- getStubLinkable hasStub
 205                 let hs_unlinked = [BCOs comp_bc modBreaks]
 206                     unlinked_time = ms_hs_date summary
 207                   -- Why do we use the timestamp of the source file here,
 208                   -- rather than the current time?  This works better in
 209                   -- the case where the local clock is out of sync
 210                   -- with the filesystem's clock.  It's just as accurate:
 211                   -- if the source is modified, then the linkable will
 212                   -- be out of date.
 213                 let linkable = LM unlinked_time this_mod
 214                                (hs_unlinked ++ stub_unlinked)
 215                 return (Just linkable)
 216
 217    let -- runCompiler :: Compiler result -> (result -> Maybe Linkable)
 218        --            -> m HomeModInfo
 219        runCompiler compiler handle
 220            = do (result, iface, details)
 221                     <- compiler hsc_env' summary source_unchanged mb_old_iface
 222                                 (Just (mod_index, nmods))
 223                 linkable <- handle result
 224                 return (HomeModInfo{ hm_details  = details,
 225                                      hm_iface    = iface,
 226                                      hm_linkable = linkable })
 227    -- run the compiler
 228    case hsc_lang of
 229       HscInterpreted -> runCompiler interactiveCompiler handleInterpreted
 230       HscNothing     -> runCompiler nothingCompiler     handleBatch
 231       _other         -> runCompiler batchCompiler       handleBatch
 232
 233 -----------------------------------------------------------------------------
 234 -- stub .h and .c files (for foreign export support)
 235
 236 -- The _stub.c file is derived from the haskell source file, possibly taking
 237 -- into account the -stubdir option.
 238 --
 239 -- Consequently, we derive the _stub.o filename from the haskell object
 240 -- filename.
 241 --
 242 -- This isn't necessarily the same as the object filename we
 243 -- would get if we just compiled the _stub.c file using the pipeline.
 244 -- For example:
 245 --
 246 --    ghc src/A.hs -odir obj
 247 --
 248 -- results in obj/A.o, and src/A_stub.c.  If we compile src/A_stub.c with
 249 -- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want
 250 -- obj/A_stub.o.
 251
 252 compileStub :: HscEnv -> Module -> ModLocation -> IO FilePath
 253 compileStub hsc_env mod location = do
 254         -- compile the _stub.c file w/ gcc
 255         let (stub_c,_,stub_o) = mkStubPaths (hsc_dflags hsc_env)
 256                                    (moduleName mod) location
 257
 258         _ <- runPipeline StopLn hsc_env (stub_c,Nothing)  Nothing
 259                 (SpecificFile stub_o) Nothing{-no ModLocation-}
 260
 261         return stub_o
 262
 263
 264 -- ---------------------------------------------------------------------------
 265 -- Link
 266
 267 link :: GhcLink                 -- interactive or batch
 268      -> DynFlags                -- dynamic flags
 269      -> Bool                    -- attempt linking in batch mode?
 270      -> HomePackageTable        -- what to link
 271      -> IO SuccessFlag
 272
 273 -- For the moment, in the batch linker, we don't bother to tell doLink
 274 -- which packages to link -- it just tries all that are available.
 275 -- batch_attempt_linking should only be *looked at* in batch mode.  It
 276 -- should only be True if the upsweep was successful and someone
 277 -- exports main, i.e., we have good reason to believe that linking
 278 -- will succeed.
 279
 280 #ifdef GHCI
 281 link LinkInMemory _ _ _
 282     = do -- Not Linking...(demand linker will do the job)
 283          return Succeeded
 284 #endif
 285
 286 link NoLink _ _ _
 287    = return Succeeded
 288
 289 link LinkBinary dflags batch_attempt_linking hpt
 290    = link' dflags batch_attempt_linking hpt
 291
 292 link LinkDynLib dflags batch_attempt_linking hpt
 293    = link' dflags batch_attempt_linking hpt
 294
 295 #ifndef GHCI
 296 -- warning suppression
 297 link other _ _ _ = panicBadLink other
 298 #endif
 299
 300 panicBadLink :: GhcLink -> a
 301 panicBadLink other = panic ("link: GHC not built to link this way: " ++
 302                             show other)
 303
 304 link' :: DynFlags                -- dynamic flags
 305       -> Bool                    -- attempt linking in batch mode?
 306       -> HomePackageTable        -- what to link
 307       -> IO SuccessFlag
 308
 309 link' dflags batch_attempt_linking hpt
 310    | batch_attempt_linking
 311    = do
 312         let
 313             home_mod_infos = eltsUFM hpt
 314
 315             -- the packages we depend on
 316             pkg_deps  = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos
 317
 318             -- the linkables to link
 319             linkables = map (expectJust "link".hm_linkable) home_mod_infos
 320
 321         debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
 322
 323         -- check for the -no-link flag
 324         if isNoLink (ghcLink dflags)
 325           then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).")
 326                   return Succeeded
 327           else do
 328
 329         let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
 330             obj_files = concatMap getOfiles linkables
 331
 332             exe_file = exeFileName dflags
 333
 334         linking_needed <- linkingNeeded dflags linkables pkg_deps
 335
 336         if not (dopt Opt_ForceRecomp dflags) && not linking_needed
 337            then do debugTraceMsg dflags 2 (text exe_file <+> ptext (sLit "is up to date, linking not required."))
 338                    return Succeeded
 339            else do
 340
 341         debugTraceMsg dflags 1 (ptext (sLit "Linking") <+> text exe_file
 342                                  <+> text "...")
 343
 344         -- Don't showPass in Batch mode; doLink will do that for us.
 345         let link = case ghcLink dflags of
 346                 LinkBinary  -> linkBinary
 347                 LinkDynLib  -> linkDynLib
 348                 other       -> panicBadLink other
 349         link dflags obj_files pkg_deps
 350
 351         debugTraceMsg dflags 3 (text "link: done")
 352
 353         -- linkBinary only returns if it succeeds
 354         return Succeeded
 355
 356    | otherwise
 357    = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$
 358                                 text "   Main.main not exported; not linking.")
 359         return Succeeded
 360
 361
 362 linkingNeeded :: DynFlags -> [Linkable] -> [PackageId] -> IO Bool
 363 linkingNeeded dflags linkables pkg_deps = do
 364         -- if the modification time on the executable is later than the
 365         -- modification times on all of the objects and libraries, then omit
 366         -- linking (unless the -fforce-recomp flag was given).
 367   let exe_file = exeFileName dflags
 368   e_exe_time <- IO.try $ getModificationTime exe_file
 369   case e_exe_time of
 370     Left _  -> return True
 371     Right t -> do
 372         -- first check object files and extra_ld_inputs
 373         extra_ld_inputs <- readIORef v_Ld_inputs
 374         e_extra_times <- mapM (IO.try . getModificationTime) extra_ld_inputs
 375         let (errs,extra_times) = splitEithers e_extra_times
 376         let obj_times =  map linkableTime linkables ++ extra_times
 377         if not (null errs) || any (t <) obj_times
 378             then return True
 379             else do
 380
 381         -- next, check libraries. XXX this only checks Haskell libraries,
 382         -- not extra_libraries or -l things from the command line.
 383         let pkg_map = pkgIdMap (pkgState dflags)
 384             pkg_hslibs  = [ (libraryDirs c, lib)
 385                           | Just c <- map (lookupPackage pkg_map) pkg_deps,
 386                             lib <- packageHsLibs dflags c ]
 387
 388         pkg_libfiles <- mapM (uncurry findHSLib) pkg_hslibs
 389         if any isNothing pkg_libfiles then return True else do
 390         e_lib_times <- mapM (IO.try . getModificationTime)
 391                           (catMaybes pkg_libfiles)
 392         let (lib_errs,lib_times) = splitEithers e_lib_times
 393         if not (null lib_errs) || any (t <) lib_times
 394            then return True
 395            else return False
 396
 397 findHSLib :: [String] -> String -> IO (Maybe FilePath)
 398 findHSLib dirs lib = do
 399   let batch_lib_file = "lib" ++ lib <.> "a"
 400   found <- filterM doesFileExist (map (</> batch_lib_file) dirs)
 401   case found of
 402     [] -> return Nothing
 403     (x:_) -> return (Just x)
 404
 405 -- -----------------------------------------------------------------------------
 406 -- Compile files in one-shot mode.
 407
 408 oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()
 409 oneShot hsc_env stop_phase srcs = do
 410   o_files <- mapM (compileFile hsc_env stop_phase) srcs
 411   doLink (hsc_dflags hsc_env) stop_phase o_files
 412
 413 compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
 414 compileFile hsc_env stop_phase (src, mb_phase) = do
 415    exists <- doesFileExist src
 416    when (not exists) $
 417         ghcError (CmdLineError ("does not exist: " ++ src))
 418
 419    let
 420         dflags = hsc_dflags hsc_env
 421         split     = dopt Opt_SplitObjs dflags
 422         mb_o_file = outputFile dflags
 423         ghc_link  = ghcLink dflags      -- Set by -c or -no-link
 424
 425         -- When linking, the -o argument refers to the linker's output.
 426         -- otherwise, we use it as the name for the pipeline's output.
 427         output
 428          | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
 429                 -- -o foo applies to linker
 430          | Just o_file <- mb_o_file = SpecificFile o_file
 431                 -- -o foo applies to the file we are compiling now
 432          | otherwise = Persistent
 433
 434         stop_phase' = case stop_phase of
 435                         As | split -> SplitAs
 436                         _          -> stop_phase
 437
 438    ( _, out_file) <- runPipeline stop_phase' hsc_env
 439                             (src, mb_phase) Nothing output
 440                             Nothing{-no ModLocation-}
 441    return out_file
 442
 443
 444 doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
 445 doLink dflags stop_phase o_files
 446   | not (isStopLn stop_phase)
 447   = return ()           -- We stopped before the linking phase
 448
 449   | otherwise
 450   = case ghcLink dflags of
 451         NoLink     -> return ()
 452         LinkBinary -> linkBinary dflags o_files []
 453         LinkDynLib -> linkDynLib dflags o_files []
 454         other      -> panicBadLink other
 455
 456
 457 -- ---------------------------------------------------------------------------
 458
 459 data PipelineOutput
 460   = Temporary
 461         -- ^ Output should be to a temporary file: we're going to
 462         -- run more compilation steps on this output later.
 463   | Persistent
 464         -- ^ We want a persistent file, i.e. a file in the current directory
 465         -- derived from the input filename, but with the appropriate extension.
 466         -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o.
 467   | SpecificFile FilePath
 468         -- ^ The output must go into the specified file.
 469
 470 -- | Run a compilation pipeline, consisting of multiple phases.
 471 --
 472 -- This is the interface to the compilation pipeline, which runs
 473 -- a series of compilation steps on a single source file, specifying
 474 -- at which stage to stop.
 475 --
 476 -- The DynFlags can be modified by phases in the pipeline (eg. by
 477 -- OPTIONS_GHC pragmas), and the changes affect later phases in the
 478 -- pipeline.
 479 runPipeline
 480   :: Phase                      -- ^ When to stop
 481   -> HscEnv                     -- ^ Compilation environment
 482   -> (FilePath,Maybe Phase)     -- ^ Input filename (and maybe -x suffix)
 483   -> Maybe FilePath             -- ^ original basename (if different from ^^^)
 484   -> PipelineOutput             -- ^ Output filename
 485   -> Maybe ModLocation          -- ^ A ModLocation, if this is a Haskell module
 486   -> IO (DynFlags, FilePath)     -- ^ (final flags, output filename)
 487
 488 runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc
 489   = do
 490   let dflags0 = hsc_dflags hsc_env0
 491       (input_basename, suffix) = splitExtension input_fn
 492       suffix' = drop 1 suffix -- strip off the .
 493       basename | Just b <- mb_basename = b
 494                | otherwise             = input_basename
 495
 496       -- Decide where dump files should go based on the pipeline output
 497       dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
 498       hsc_env = hsc_env0 {hsc_dflags = dflags}
 499
 500         -- If we were given a -x flag, then use that phase to start from
 501       start_phase = fromMaybe (startPhase suffix') mb_phase
 502
 503   -- We want to catch cases of "you can't get there from here" before
 504   -- we start the pipeline, because otherwise it will just run off the
 505   -- end.
 506   --
 507   -- There is a partial ordering on phases, where A < B iff A occurs
 508   -- before B in a normal compilation pipeline.
 509
 510   when (not (start_phase `happensBefore` stop_phase)) $
 511         ghcError (UsageError
 512                     ("cannot compile this file to desired target: "
 513                        ++ input_fn))
 514
 515   -- this is a function which will be used to calculate output file names
 516   -- as we go along (we partially apply it to some of its inputs here)
 517   let get_output_fn = getOutputFilename stop_phase output basename
 518
 519   -- Execute the pipeline...
 520   (dflags', output_fn, maybe_loc) <-
 521         pipeLoop hsc_env start_phase stop_phase input_fn
 522                  basename suffix' get_output_fn maybe_loc
 523
 524   -- Sometimes, a compilation phase doesn't actually generate any output
 525   -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
 526   -- stage, but we wanted to keep the output, then we have to explicitly
 527   -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
 528   -- further compilation stages can tell what the original filename was.
 529   case output of
 530     Temporary ->
 531         return (dflags', output_fn)
 532     _other ->
 533         do final_fn <- get_output_fn dflags' stop_phase maybe_loc
 534            when (final_fn /= output_fn) $ do
 535               let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'")
 536                   line_prag = Just ("{-# LINE 1 \"" ++ input_fn ++ "\" #-}\n")
 537               copyWithHeader dflags msg line_prag output_fn final_fn
 538            return (dflags', final_fn)
 539
 540
 541
 542 pipeLoop :: HscEnv -> Phase -> Phase
 543          -> FilePath  -> String -> Suffix
 544          -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
 545          -> Maybe ModLocation
 546          -> IO (DynFlags, FilePath, Maybe ModLocation)
 547
 548 pipeLoop hsc_env phase stop_phase
 549          input_fn orig_basename orig_suff
 550          orig_get_output_fn maybe_loc
 551
 552   | phase `eqPhase` stop_phase            -- All done
 553   = return (hsc_dflags hsc_env, input_fn, maybe_loc)
 554
 555   | not (phase `happensBefore` stop_phase)
 556         -- Something has gone wrong.  We'll try to cover all the cases when
 557         -- this could happen, so if we reach here it is a panic.
 558         -- eg. it might happen if the -C flag is used on a source file that
 559         -- has {-# OPTIONS -fasm #-}.
 560   = panic ("pipeLoop: at phase " ++ show phase ++
 561            " but I wanted to stop at phase " ++ show stop_phase)
 562
 563   | otherwise
 564   = do debugTraceMsg (hsc_dflags hsc_env) 4
 565                          (ptext (sLit "Running phase") <+> ppr phase)
 566        (next_phase, dflags', maybe_loc, output_fn)
 567           <- runPhase phase stop_phase hsc_env orig_basename
 568                       orig_suff input_fn orig_get_output_fn maybe_loc
 569        let hsc_env' = hsc_env {hsc_dflags = dflags'}
 570        pipeLoop hsc_env' next_phase stop_phase output_fn
 571                 orig_basename orig_suff orig_get_output_fn maybe_loc
 572
 573 getOutputFilename
 574   :: Phase -> PipelineOutput -> String
 575   -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
 576 getOutputFilename stop_phase output basename
 577  = func
 578  where
 579         func dflags next_phase maybe_location
 580            | is_last_phase, Persistent <- output     = persistent_fn
 581            | is_last_phase, SpecificFile f <- output = return f
 582            | keep_this_output                        = persistent_fn
 583            | otherwise                               = newTempName dflags suffix
 584            where
 585                 hcsuf      = hcSuf dflags
 586                 odir       = objectDir dflags
 587                 osuf       = objectSuf dflags
 588                 keep_hc    = dopt Opt_KeepHcFiles dflags
 589                 keep_raw_s = dopt Opt_KeepRawSFiles dflags
 590                 keep_s     = dopt Opt_KeepSFiles dflags
 591                 keep_bc    = dopt Opt_KeepLlvmFiles dflags
 592
 593                 myPhaseInputExt HCc    = hcsuf
 594                 myPhaseInputExt StopLn = osuf
 595                 myPhaseInputExt other  = phaseInputExt other
 596
 597                 is_last_phase = next_phase `eqPhase` stop_phase
 598
 599                 -- sometimes, we keep output from intermediate stages
 600                 keep_this_output =
 601                      case next_phase of
 602                              StopLn               -> True
 603                              Mangle  | keep_raw_s -> True
 604                              As      | keep_s     -> True
 605                              LlvmOpt | keep_bc    -> True
 606                              HCc     | keep_hc    -> True
 607                              _other               -> False
 608
 609                 suffix = myPhaseInputExt next_phase
 610
 611                 -- persistent object files get put in odir
 612                 persistent_fn
 613                    | StopLn <- next_phase = return odir_persistent
 614                    | otherwise            = return persistent
 615
 616                 persistent = basename <.> suffix
 617
 618                 odir_persistent
 619                    | Just loc <- maybe_location = ml_obj_file loc
 620                    | Just d <- odir = d </> persistent
 621                    | otherwise      = persistent
 622
 623
 624 -- -----------------------------------------------------------------------------
 625 -- | Each phase in the pipeline returns the next phase to execute, and the
 626 -- name of the file in which the output was placed.
 627 --
 628 -- We must do things dynamically this way, because we often don't know
 629 -- what the rest of the phases will be until part-way through the
 630 -- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
 631 -- of a source file can change the latter stages of the pipeline from
 632 -- taking the via-C route to using the native code generator.
 633 --
 634 runPhase :: Phase       -- ^ Do this phase first
 635          -> Phase       -- ^ Stop just before this phase
 636          -> HscEnv
 637          -> String      -- ^ basename of original input source
 638          -> String      -- ^ its extension
 639          -> FilePath    -- ^ name of file which contains the input to this phase.
 640          -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
 641                         -- ^ how to calculate the output filename
 642          -> Maybe ModLocation           -- ^ the ModLocation, if we have one
 643          -> IO (Phase,                   -- next phase
 644                 DynFlags,                -- new dynamic flags
 645                 Maybe ModLocation,       -- the ModLocation, if we have one
 646                 FilePath)                -- output filename
 647
 648         -- Invariant: the output filename always contains the output
 649         -- Interesting case: Hsc when there is no recompilation to do
 650         --                   Then the output filename is still a .o file
 651
 652 -------------------------------------------------------------------------------
 653 -- Unlit phase
 654
 655 runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 656   = do
 657        let dflags = hsc_dflags hsc_env
 658        output_fn <- get_output_fn dflags (Cpp sf) maybe_loc
 659
 660        let unlit_flags = getOpts dflags opt_L
 661            flags = map SysTools.Option unlit_flags ++
 662                    [ -- The -h option passes the file name for unlit to
 663                      -- put in a #line directive
 664                      SysTools.Option     "-h"
 665                      -- cpp interprets \b etc as escape sequences,
 666                      -- so we use / for filenames in pragmas
 667                    , SysTools.Option $ reslash Forwards $ normalise input_fn
 668                    , SysTools.FileOption "" input_fn
 669                    , SysTools.FileOption "" output_fn
 670                    ]
 671
 672        SysTools.runUnlit dflags flags
 673
 674        return (Cpp sf, dflags, maybe_loc, output_fn)
 675
 676 -------------------------------------------------------------------------------
 677 -- Cpp phase : (a) gets OPTIONS out of file
 678 --             (b) runs cpp if necessary
 679
 680 runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 681   = do let dflags0 = hsc_dflags hsc_env
 682        src_opts <- getOptionsFromFile dflags0 input_fn
 683        (dflags1, unhandled_flags, warns)
 684            <- parseDynamicNoPackageFlags dflags0 src_opts
 685        checkProcessArgsResult unhandled_flags
 686
 687        if not (xopt Opt_Cpp dflags1) then do
 688            -- we have to be careful to emit warnings only once.
 689            unless (dopt Opt_Pp dflags1) $ handleFlagWarnings dflags1 warns
 690
 691            -- no need to preprocess CPP, just pass input file along
 692            -- to the next phase of the pipeline.
 693            return (HsPp sf, dflags1, maybe_loc, input_fn)
 694         else do
 695             output_fn <- get_output_fn dflags1 (HsPp sf) maybe_loc
 696             doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn
 697             -- re-read the pragmas now that we've preprocessed the file
 698             -- See #2464,#3457
 699             src_opts <- getOptionsFromFile dflags0 output_fn
 700             (dflags2, unhandled_flags, warns)
 701                 <- parseDynamicNoPackageFlags dflags0 src_opts
 702             unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns
 703             -- the HsPp pass below will emit warnings
 704             checkProcessArgsResult unhandled_flags
 705
 706             return (HsPp sf, dflags2, maybe_loc, output_fn)
 707
 708 -------------------------------------------------------------------------------
 709 -- HsPp phase
 710
 711 runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
 712   = do let dflags = hsc_dflags hsc_env
 713        if not (dopt Opt_Pp dflags) then
 714            -- no need to preprocess, just pass input file along
 715            -- to the next phase of the pipeline.
 716           return (Hsc sf, dflags, maybe_loc, input_fn)
 717         else do
 718             let hspp_opts = getOpts dflags opt_F
 719             let orig_fn = basename <.> suff
 720             output_fn <- get_output_fn dflags (Hsc sf) maybe_loc
 721             SysTools.runPp dflags
 722                            ( [ SysTools.Option     orig_fn
 723                              , SysTools.Option     input_fn
 724                              , SysTools.FileOption "" output_fn
 725                              ] ++
 726                              map SysTools.Option hspp_opts
 727                            )
 728
 729             -- re-read pragmas now that we've parsed the file (see #3674)
 730             src_opts <- getOptionsFromFile dflags output_fn
 731             (dflags1, unhandled_flags, warns)
 732                 <- parseDynamicNoPackageFlags dflags src_opts
 733             handleFlagWarnings dflags1 warns
 734             checkProcessArgsResult unhandled_flags
 735
 736             return (Hsc sf, dflags1, maybe_loc, output_fn)
 737
 738 -----------------------------------------------------------------------------
 739 -- Hsc phase
 740
 741 -- Compilation of a single module, in "legacy" mode (_not_ under
 742 -- the direction of the compilation manager).
 743 runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _maybe_loc
 744  = do   -- normal Hsc mode, not mkdependHS
 745         let dflags0 = hsc_dflags hsc_env
 746
 747   -- we add the current directory (i.e. the directory in which
 748   -- the .hs files resides) to the include path, since this is
 749   -- what gcc does, and it's probably what you want.
 750         let current_dir = case takeDirectory basename of
 751                       "" -> "." -- XXX Hack
 752                       d -> d
 753
 754             paths = includePaths dflags0
 755             dflags = dflags0 { includePaths = current_dir : paths }
 756
 757   -- gather the imports and module name
 758         (hspp_buf,mod_name,imps,src_imps) <-
 759             case src_flavour of
 760                 ExtCoreFile -> do  -- no explicit imports in ExtCore input.
 761                     m <- getCoreModuleName input_fn
 762                     return (Nothing, mkModuleName m, [], [])
 763
 764                 _           -> do
 765                     buf <- hGetStringBuffer input_fn
 766                     (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
 767                     return (Just buf, mod_name, imps, src_imps)
 768
 769   -- Build a ModLocation to pass to hscMain.
 770   -- The source filename is rather irrelevant by now, but it's used
 771   -- by hscMain for messages.  hscMain also needs
 772   -- the .hi and .o filenames, and this is as good a way
 773   -- as any to generate them, and better than most. (e.g. takes
 774   -- into accout the -osuf flags)
 775         location1 <- mkHomeModLocation2 dflags mod_name basename suff
 776
 777   -- Boot-ify it if necessary
 778         let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
 779                       | otherwise            = location1
 780
 781
 782   -- Take -ohi into account if present
 783   -- This can't be done in mkHomeModuleLocation because
 784   -- it only applies to the module being compiles
 785         let ohi = outputHi dflags
 786             location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
 787                       | otherwise      = location2
 788
 789   -- Take -o into account if present
 790   -- Very like -ohi, but we must *only* do this if we aren't linking
 791   -- (If we're linking then the -o applies to the linked thing, not to
 792   -- the object file for one module.)
 793   -- Note the nasty duplication with the same computation in compileFile above
 794         let expl_o_file = outputFile dflags
 795             location4 | Just ofile <- expl_o_file
 796                       , isNoLink (ghcLink dflags)
 797                       = location3 { ml_obj_file = ofile }
 798                       | otherwise = location3
 799
 800             o_file = ml_obj_file location4      -- The real object file
 801
 802
 803   -- Figure out if the source has changed, for recompilation avoidance.
 804   --
 805   -- Setting source_unchanged to True means that M.o seems
 806   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 807   -- changed (which the compiler itself figures out).
 808   -- Setting source_unchanged to False tells the compiler that M.o is out of
 809   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 810         src_timestamp <- getModificationTime (basename <.> suff)
 811
 812         let force_recomp = dopt Opt_ForceRecomp dflags
 813             hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags)
 814         source_unchanged <-
 815           if force_recomp || not (isStopLn stop)
 816                 -- Set source_unchanged to False unconditionally if
 817                 --      (a) recompilation checker is off, or
 818                 --      (b) we aren't going all the way to .o file (e.g. ghc -S)
 819              then return False
 820                 -- Otherwise look at file modification dates
 821              else do o_file_exists <- doesFileExist o_file
 822                      if not o_file_exists
 823                         then return False       -- Need to recompile
 824                         else do t2 <- getModificationTime o_file
 825                                 if t2 > src_timestamp
 826                                   then return True
 827                                   else return False
 828
 829   -- get the DynFlags
 830         let next_phase = hscNextPhase dflags src_flavour hsc_lang
 831         output_fn  <- get_output_fn dflags next_phase (Just location4)
 832
 833         let dflags' = dflags { hscTarget = hsc_lang,
 834                                hscOutName = output_fn,
 835                                extCoreName = basename ++ ".hcr" }
 836
 837         let hsc_env' = hsc_env {hsc_dflags = dflags'}
 838
 839   -- Tell the finder cache about this module
 840         mod <- addHomeModuleToFinder hsc_env' mod_name location4
 841
 842   -- Make the ModSummary to hand to hscMain
 843         let
 844             mod_summary = ModSummary {  ms_mod       = mod,
 845                                         ms_hsc_src   = src_flavour,
 846                                         ms_hspp_file = input_fn,
 847                                         ms_hspp_opts = dflags,
 848                                         ms_hspp_buf  = hspp_buf,
 849                                         ms_location  = location4,
 850                                         ms_hs_date   = src_timestamp,
 851                                         ms_obj_date  = Nothing,
 852                                         ms_imps      = imps,
 853                                         ms_srcimps   = src_imps }
 854
 855   -- run the compiler!
 856         result <- hscCompileOneShot hsc_env'
 857                           mod_summary source_unchanged
 858                           Nothing       -- No iface
 859                           Nothing       -- No "module i of n" progress info
 860
 861         case result of
 862           HscNoRecomp
 863               -> do SysTools.touch dflags' "Touching object file" o_file
 864                     -- The .o file must have a later modification date
 865                     -- than the source file (else we wouldn't be in HscNoRecomp)
 866                     -- but we touch it anyway, to keep 'make' happy (we think).
 867                     return (StopLn, dflags', Just location4, o_file)
 868           (HscRecomp hasStub _)
 869               -> do when hasStub $
 870                          do stub_o <- compileStub hsc_env' mod location4
 871                             liftIO $ consIORef v_Ld_inputs stub_o
 872                     -- In the case of hs-boot files, generate a dummy .o-boot
 873                     -- stamp file for the benefit of Make
 874                     when (isHsBoot src_flavour) $
 875                       SysTools.touch dflags' "Touching object file" o_file
 876                     return (next_phase, dflags', Just location4, output_fn)
 877
 878 -----------------------------------------------------------------------------
 879 -- Cmm phase
 880
 881 runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 882   = do
 883        let dflags = hsc_dflags hsc_env
 884        output_fn <- get_output_fn dflags Cmm maybe_loc
 885        doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn
 886        return (Cmm, dflags, maybe_loc, output_fn)
 887
 888 runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc
 889   = do
 890         let dflags = hsc_dflags hsc_env
 891         let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
 892         let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
 893         output_fn <- get_output_fn dflags next_phase maybe_loc
 894
 895         let dflags' = dflags { hscTarget = hsc_lang,
 896                                hscOutName = output_fn,
 897                                extCoreName = basename ++ ".hcr" }
 898         let hsc_env' = hsc_env {hsc_dflags = dflags'}
 899
 900         hscCompileCmmFile hsc_env' input_fn
 901
 902         -- XXX: catch errors above and convert them into ghcError?  Original
 903         -- code was:
 904         --
 905         --when (not ok) $ ghcError (PhaseFailed "cmm" (ExitFailure 1))
 906
 907         return (next_phase, dflags, maybe_loc, output_fn)
 908
 909 -----------------------------------------------------------------------------
 910 -- Cc phase
 911
 912 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 913 -- way too many hacks, and I can't say I've ever used it anyway.
 914
 915 runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 916    | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc
 917    = do let dflags = hsc_dflags hsc_env
 918         let cc_opts = getOpts dflags opt_c
 919             hcc = cc_phase `eqPhase` HCc
 920
 921         let cmdline_include_paths = includePaths dflags
 922
 923         -- HC files have the dependent packages stamped into them
 924         pkgs <- if hcc then getHCFilePackages input_fn else return []
 925
 926         -- add package include paths even if we're just compiling .c
 927         -- files; this is the Value Add(TM) that using ghc instead of
 928         -- gcc gives you :)
 929         pkg_include_dirs <- getPackageIncludePath dflags pkgs
 930         let include_paths = foldr (\ x xs -> "-I" : x : xs) []
 931                               (cmdline_include_paths ++ pkg_include_dirs)
 932
 933         let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags
 934         gcc_extra_viac_flags <- getExtraViaCOpts dflags
 935         let pic_c_flags = picCCOpts dflags
 936
 937         let verb = getVerbFlag dflags
 938
 939         -- cc-options are not passed when compiling .hc files.  Our
 940         -- hc code doesn't not #include any header files anyway, so these
 941         -- options aren't necessary.
 942         pkg_extra_cc_opts <-
 943           if cc_phase `eqPhase` HCc
 944              then return []
 945              else getPackageExtraCcOpts dflags pkgs
 946
 947 #ifdef darwin_TARGET_OS
 948         pkg_framework_paths <- getPackageFrameworkPath dflags pkgs
 949         let cmdline_framework_paths = frameworkPaths dflags
 950         let framework_paths = map ("-F"++)
 951                         (cmdline_framework_paths ++ pkg_framework_paths)
 952 #endif
 953
 954         let split_objs = dopt Opt_SplitObjs dflags
 955             split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 956                       | otherwise         = [ ]
 957
 958         let cc_opt | optLevel dflags >= 2 = "-O2"
 959                    | otherwise            = "-O"
 960
 961         -- Decide next phase
 962
 963         let mangle = dopt Opt_DoAsmMangling dflags
 964             next_phase
 965                 | hcc && mangle     = Mangle
 966                 | otherwise         = As
 967         output_fn <- get_output_fn dflags next_phase maybe_loc
 968
 969         let
 970           more_hcc_opts =
 971 #if i386_TARGET_ARCH
 972                 -- on x86 the floating point regs have greater precision
 973                 -- than a double, which leads to unpredictable results.
 974                 -- By default, we turn this off with -ffloat-store unless
 975                 -- the user specified -fexcess-precision.
 976                 (if dopt Opt_ExcessPrecision dflags
 977                         then []
 978                         else [ "-ffloat-store" ]) ++
 979 #endif
 980
 981                 -- gcc's -fstrict-aliasing allows two accesses to memory
 982                 -- to be considered non-aliasing if they have different types.
 983                 -- This interacts badly with the C code we generate, which is
 984                 -- very weakly typed, being derived from C--.
 985                 ["-fno-strict-aliasing"]
 986
 987         SysTools.runCc dflags (
 988                 -- force the C compiler to interpret this file as C when
 989                 -- compiling .hc files, by adding the -x c option.
 990                 -- Also useful for plain .c files, just in case GHC saw a
 991                 -- -x c option.
 992                         [ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp
 993                                                 then SysTools.Option "c++"
 994                                                 else SysTools.Option "c"] ++
 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               "-Wl,-read_only_relocs,suppress", "-install_name", instName ]
1743          ++ extra_ld_inputs
1744          ++ lib_path_opts
1745          ++ extra_ld_opts
1746          ++ pkg_lib_path_opts
1747          ++ rtsEnabledObj
1748          ++ pkg_link_opts
1749         ))
1750 #else
1751     -----------------------------------------------------------------------------
1752     -- Making a DSO
1753     -----------------------------------------------------------------------------
1754
1755     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1756     let buildingRts = thisPackage dflags == rtsPackageId
1757     let bsymbolicFlag = if buildingRts
1758                         then -- -Bsymbolic breaks the way we implement
1759                              -- hooks in the RTS
1760                              []
1761                         else -- we need symbolic linking to resolve
1762                              -- non-PIC intra-package-relocations
1763                              ["-Wl,-Bsymbolic"]
1764
1765     SysTools.runLink dflags
1766          ([ SysTools.Option verb
1767           , SysTools.Option "-o"
1768           , SysTools.FileOption "" output_fn
1769           ]
1770          ++ map SysTools.Option (
1771             md_c_flags
1772          ++ o_files
1773          ++ [ "-shared" ]
1774          ++ bsymbolicFlag
1775          ++ [ "-Wl,-soname," ++ takeFileName output_fn ] -- set the library soname
1776          ++ extra_ld_inputs
1777          ++ lib_path_opts
1778          ++ extra_ld_opts
1779          ++ pkg_lib_path_opts
1780          ++ rtsEnabledObj
1781          ++ pkg_link_opts
1782         ))
1783 #endif
1784 -- -----------------------------------------------------------------------------
1785 -- Running CPP
1786
1787 doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO ()
1788 doCpp dflags raw include_cc_opts input_fn output_fn = do
1789     let hscpp_opts = getOpts dflags opt_P
1790     let cmdline_include_paths = includePaths dflags
1791
1792     pkg_include_dirs <- getPackageIncludePath dflags []
1793     let include_paths = foldr (\ x xs -> "-I" : x : xs) []
1794                           (cmdline_include_paths ++ pkg_include_dirs)
1795
1796     let verb = getVerbFlag dflags
1797
1798     let cc_opts
1799           | not include_cc_opts = []
1800           | otherwise           = (optc ++ md_c_flags)
1801                 where
1802                       optc = getOpts dflags opt_c
1803                       (md_c_flags, _) = machdepCCOpts dflags
1804
1805     let cpp_prog args | raw       = SysTools.runCpp dflags args
1806                       | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
1807
1808     let target_defs =
1809           [ "-D" ++ HOST_OS     ++ "_BUILD_OS=1",
1810             "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH=1",
1811             "-D" ++ TARGET_OS   ++ "_HOST_OS=1",
1812             "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ]
1813         -- remember, in code we *compile*, the HOST is the same our TARGET,
1814         -- and BUILD is the same as our HOST.
1815
1816     cpp_prog       ([SysTools.Option verb]
1817                     ++ map SysTools.Option include_paths
1818                     ++ map SysTools.Option hsSourceCppOpts
1819                     ++ map SysTools.Option target_defs
1820                     ++ map SysTools.Option hscpp_opts
1821                     ++ map SysTools.Option cc_opts
1822                     ++ [ SysTools.Option     "-x"
1823                        , SysTools.Option     "c"
1824                        , SysTools.Option     input_fn
1825         -- We hackily use Option instead of FileOption here, so that the file
1826         -- name is not back-slashed on Windows.  cpp is capable of
1827         -- dealing with / in filenames, so it works fine.  Furthermore
1828         -- if we put in backslashes, cpp outputs #line directives
1829         -- with *double* backslashes.   And that in turn means that
1830         -- our error messages get double backslashes in them.
1831         -- In due course we should arrange that the lexer deals
1832         -- with these \\ escapes properly.
1833                        , SysTools.Option     "-o"
1834                        , SysTools.FileOption "" output_fn
1835                        ])
1836
1837 hsSourceCppOpts :: [String]
1838 -- Default CPP defines in Haskell source
1839 hsSourceCppOpts =
1840         [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
1841
1842 -- ---------------------------------------------------------------------------
1843 -- join object files into a single relocatable object file, using ld -r
1844
1845 joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
1846 joinObjectFiles dflags o_files output_fn = do
1847   let ld_r args = SysTools.runLink dflags ([
1848                             SysTools.Option "-nostdlib",
1849                             SysTools.Option "-nodefaultlibs",
1850                             SysTools.Option "-Wl,-r",
1851                             SysTools.Option ld_x_flag,
1852                             SysTools.Option "-o",
1853                             SysTools.FileOption "" output_fn ]
1854                          ++ map SysTools.Option md_c_flags
1855                          ++ args)
1856       ld_x_flag | null cLD_X = ""
1857                 | otherwise  = "-Wl,-x"
1858
1859       (md_c_flags, _) = machdepCCOpts dflags
1860
1861   if cLdIsGNULd == "YES"
1862      then do
1863           script <- newTempName dflags "ldscript"
1864           writeFile script $ "INPUT(" ++ unwords o_files ++ ")"
1865           ld_r [SysTools.FileOption "" script]
1866      else do
1867           ld_r (map (SysTools.FileOption "") o_files)
1868
1869 -- -----------------------------------------------------------------------------
1870 -- Misc.
1871
1872 hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase
1873 hscNextPhase _ HsBootFile _        =  StopLn
1874 hscNextPhase dflags _ hsc_lang =
1875   case hsc_lang of
1876         HscC -> HCc
1877         HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle
1878                | otherwise -> As
1879         HscLlvm        -> LlvmOpt
1880         HscNothing     -> StopLn
1881         HscInterpreted -> StopLn
1882         _other         -> StopLn
1883
1884
1885 hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget
1886 hscMaybeAdjustTarget dflags stop _ current_hsc_lang
1887   = hsc_lang
1888   where
1889         keep_hc = dopt Opt_KeepHcFiles dflags
1890         hsc_lang
1891                 -- don't change the lang if we're interpreting
1892                  | current_hsc_lang == HscInterpreted = current_hsc_lang
1893
1894                 -- force -fvia-C if we are being asked for a .hc file
1895                  | HCc <- stop = HscC
1896                  | keep_hc     = HscC
1897                 -- otherwise, stick to the plan
1898                  | otherwise = current_hsc_lang
1899