compiler/main/DriverPipeline.hs

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