compiler/main/DriverPipeline.hs

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