compiler/main/DriverPipeline.hs

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