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