compiler/main/DriverPipeline.hs

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