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