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