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