compiler/main/DriverPipeline.hs

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