compiler/main/DriverPipeline.hs

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