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