compiler/main/DriverPipeline.hs

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