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