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