compiler/main/DriverPipeline.hs

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