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