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