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