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