compiler/main/DriverPipeline.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- GHC Driver
   4 --
   5 -- (c) The University of Glasgow 2005
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module DriverPipeline (
  10         -- Run a series of compilation steps in a pipeline, for a
  11         -- collection of source files.
  12    oneShot, compileFile,
  13
  14         -- Interfaces for the batch-mode driver
  15    linkBinary,
  16
  17         -- Interfaces for the compilation manager (interpreted/batch-mode)
  18    preprocess,
  19    compile, CompResult(..),
  20    link,
  21
  22   ) where
  23
  24 #include "HsVersions.h"
  25
  26 import Packages
  27 import HeaderInfo
  28 import DriverPhases
  29 import SysTools
  30 import HscMain
  31 import Finder
  32 import HscTypes
  33 import Outputable
  34 import Module
  35 import UniqFM           ( eltsUFM )
  36 import ErrUtils
  37 import DynFlags
  38 import StaticFlags      ( v_Ld_inputs, opt_Static, opt_HardwireLibPaths, WayName(..) )
  39 import Config
  40 import Panic
  41 import Util
  42 import StringBuffer     ( hGetStringBuffer )
  43 import BasicTypes       ( SuccessFlag(..) )
  44 import Maybes           ( expectJust )
  45 import ParserCoreUtils  ( getCoreModuleName )
  46 import SrcLoc           ( unLoc )
  47 import SrcLoc           ( Located(..) )
  48
  49 import Control.Exception as Exception
  50 import Data.IORef       ( readIORef, writeIORef, IORef )
  51 import GHC.Exts         ( Int(..) )
  52 import System.Directory
  53 import System.IO
  54 import SYSTEM_IO_ERROR as IO
  55 import Control.Monad
  56 import Data.List        ( isSuffixOf )
  57 import Data.Maybe
  58 import System.Exit
  59 import System.Environment
  60
  61 -- ---------------------------------------------------------------------------
  62 -- Pre-process
  63
  64 -- Just preprocess a file, put the result in a temp. file (used by the
  65 -- compilation manager during the summary phase).
  66 --
  67 -- We return the augmented DynFlags, because they contain the result
  68 -- of slurping in the OPTIONS pragmas
  69
  70 preprocess :: DynFlags -> (FilePath, Maybe Phase) -> IO (DynFlags, FilePath)
  71 preprocess dflags (filename, mb_phase) =
  72   ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
  73   runPipeline anyHsc dflags (filename, mb_phase)
  74         Nothing Temporary Nothing{-no ModLocation-}
  75
  76 -- ---------------------------------------------------------------------------
  77 -- Compile
  78
  79 -- Compile a single module, under the control of the compilation manager.
  80 --
  81 -- This is the interface between the compilation manager and the
  82 -- compiler proper (hsc), where we deal with tedious details like
  83 -- reading the OPTIONS pragma from the source file, and passing the
  84 -- output of hsc through the C compiler.
  85
  86 -- NB.  No old interface can also mean that the source has changed.
  87
  88 compile :: HscEnv
  89         -> ModSummary
  90         -> Maybe Linkable       -- Just linkable <=> source unchanged
  91         -> Maybe ModIface       -- Old interface, if available
  92         -> Int -> Int
  93         -> IO CompResult
  94
  95 data CompResult
  96    = CompOK   ModDetails        -- New details
  97               ModIface          -- New iface
  98               (Maybe Linkable)  -- a Maybe, for the same reasons as hm_linkable
  99
 100    | CompErrs
 101
 102
 103 compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do
 104
 105    let dflags0     = ms_hspp_opts mod_summary
 106        this_mod    = ms_mod mod_summary
 107        src_flavour = ms_hsc_src mod_summary
 108
 109        have_object
 110                | Just l <- maybe_old_linkable, isObjectLinkable l = True
 111                | otherwise = False
 112
 113    -- FIXME: We need to know whether or not we're recompiling the file. Move this to HscMain?
 114    --showPass dflags0 ("Compiling " ++ showModMsg have_object mod_summary)
 115
 116    let location   = ms_location mod_summary
 117    let input_fn   = expectJust "compile:hs" (ml_hs_file location)
 118    let input_fnpp = ms_hspp_file mod_summary
 119
 120    debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp)
 121
 122    let (basename, _) = splitFilename input_fn
 123
 124   -- We add the directory in which the .hs files resides) to the import path.
 125   -- This is needed when we try to compile the .hc file later, if it
 126   -- imports a _stub.h file that we created here.
 127    let current_dir = directoryOf basename
 128        old_paths   = includePaths dflags0
 129        dflags      = dflags0 { includePaths = current_dir : old_paths }
 130
 131    -- Figure out what lang we're generating
 132    let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags)
 133    -- ... and what the next phase should be
 134    let next_phase = hscNextPhase dflags src_flavour hsc_lang
 135    -- ... and what file to generate the output into
 136    output_fn <- getOutputFilename next_phase
 137                         Temporary basename dflags next_phase (Just location)
 138
 139    let dflags' = dflags { hscTarget = hsc_lang,
 140                                 hscOutName = output_fn,
 141                                 extCoreName = basename ++ ".hcr" }
 142
 143    -- -no-recomp should also work with --make
 144    let force_recomp = dopt Opt_ForceRecomp dflags
 145        source_unchanged = isJust maybe_old_linkable && not force_recomp
 146        hsc_env' = hsc_env { hsc_dflags = dflags' }
 147        object_filename = ml_obj_file location
 148
 149    let getStubLinkable False = return []
 150        getStubLinkable True
 151            = do stub_o <- compileStub dflags' this_mod location
 152                 return [ DotO stub_o ]
 153
 154        handleBatch (HscNoRecomp, iface, details)
 155            = ASSERT (isJust maybe_old_linkable)
 156              return (CompOK details iface maybe_old_linkable)
 157        handleBatch (HscRecomp hasStub, iface, details)
 158            | isHsBoot src_flavour
 159                = do SysTools.touch dflags' "Touching object file"
 160                                    object_filename
 161                     return (CompOK details iface Nothing)
 162            | otherwise
 163                = do stub_unlinked <- getStubLinkable hasStub
 164                     (hs_unlinked, unlinked_time) <-
 165                         case hsc_lang of
 166                           HscNothing
 167                             -> return ([], ms_hs_date mod_summary)
 168                           -- We're in --make mode: finish the compilation pipeline.
 169                           _other
 170                             -> do runPipeline StopLn dflags (output_fn,Nothing)
 171                                               (Just basename)
 172                                               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)  Nothing
 242                 (SpecificFile stub_o) Nothing{-no ModLocation-}
 243
 244         return stub_o
 245
 246
 247 -- ---------------------------------------------------------------------------
 248 -- Link
 249
 250 link :: GhcLink                 -- 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 LinkInMemory dflags batch_attempt_linking hpt
 265     = do -- Not Linking...(demand linker will do the job)
 266          return Succeeded
 267 #endif
 268
 269 link NoLink dflags batch_attempt_linking hpt
 270    = return Succeeded
 271
 272 link LinkBinary 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                 LinkBinary  -> linkBinary
 317                 LinkDynLib  -> linkDynLib
 318         link dflags obj_files pkg_deps
 319
 320         debugTraceMsg dflags 3 (text "link: done")
 321
 322         -- linkBinary 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 -- Compile files in one-shot mode.
 332
 333 oneShot :: DynFlags -> Phase -> [(String, Maybe Phase)] -> IO ()
 334 oneShot dflags stop_phase srcs = do
 335   o_files <- mapM (compileFile dflags stop_phase) srcs
 336   doLink dflags stop_phase o_files
 337
 338 compileFile :: DynFlags -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
 339 compileFile dflags stop_phase (src, mb_phase) = do
 340    exists <- doesFileExist src
 341    when (not exists) $
 342         throwDyn (CmdLineError ("does not exist: " ++ src))
 343
 344    let
 345         split     = dopt Opt_SplitObjs dflags
 346         mb_o_file = outputFile dflags
 347         ghc_link  = ghcLink dflags      -- Set by -c or -no-link
 348
 349         -- When linking, the -o argument refers to the linker's output.
 350         -- otherwise, we use it as the name for the pipeline's output.
 351         output
 352          | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
 353                 -- -o foo applies to linker
 354          | Just o_file <- mb_o_file = SpecificFile o_file
 355                 -- -o foo applies to the file we are compiling now
 356          | otherwise = Persistent
 357
 358         stop_phase' = case stop_phase of
 359                         As | split -> SplitAs
 360                         other      -> stop_phase
 361
 362    (_, out_file) <- runPipeline stop_phase' dflags
 363                           (src, mb_phase) Nothing output
 364                           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         LinkBinary -> linkBinary dflags o_files link_pkgs
 377         LinkDynLib -> linkDynLib dflags o_files []
 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   -> Maybe FilePath             -- original basename (if different from ^^^)
 411   -> PipelineOutput             -- Output filename
 412   -> Maybe ModLocation          -- A ModLocation, if this is a Haskell module
 413   -> IO (DynFlags, FilePath)    -- (final flags, output filename)
 414
 415 runPipeline stop_phase dflags0 (input_fn, mb_phase) mb_basename output maybe_loc
 416   = do
 417   let
 418       (input_basename, suffix) = splitFilename input_fn
 419       basename | Just b <- mb_basename = b
 420                | otherwise             = input_basename
 421
 422       -- Decide where dump files should go based on the pipeline output
 423       dflags = dflags0 { dumpPrefix = Just (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,imps,src_imps) <-
 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                             ; (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn
 654                             ; return (Just buf, mod_name, imps, src_imps) }
 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      = imps,
 742                                         ms_srcimps   = src_imps }
 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         gcc_extra_viac_flags <- getExtraViaCOpts dflags
 818         let pic_c_flags = picCCOpts dflags
 819
 820         let verb = getVerbFlag dflags
 821
 822         pkg_extra_cc_opts <- getPackageExtraCcOpts dflags pkgs
 823
 824         let split_objs = dopt Opt_SplitObjs dflags
 825             split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 826                       | otherwise         = [ ]
 827
 828         let excessPrecision = dopt Opt_ExcessPrecision dflags
 829
 830         let cc_opt | optLevel dflags >= 2 = "-O2"
 831                    | otherwise            = "-O"
 832
 833         -- Decide next phase
 834
 835         let mangle = dopt Opt_DoAsmMangling dflags
 836             next_phase
 837                 | hcc && mangle     = Mangle
 838                 | otherwise         = As
 839         output_fn <- get_output_fn dflags next_phase maybe_loc
 840
 841         let
 842           more_hcc_opts =
 843 #if i386_TARGET_ARCH
 844                 -- on x86 the floating point regs have greater precision
 845                 -- than a double, which leads to unpredictable results.
 846                 -- By default, we turn this off with -ffloat-store unless
 847                 -- the user specified -fexcess-precision.
 848                 (if excessPrecision then [] else [ "-ffloat-store" ]) ++
 849 #endif
 850                 -- gcc's -fstrict-aliasing allows two accesses to memory
 851                 -- to be considered non-aliasing if they have different types.
 852                 -- This interacts badly with the C code we generate, which is
 853                 -- very weakly typed, being derived from C--.
 854                 ["-fno-strict-aliasing"]
 855
 856
 857
 858         SysTools.runCc dflags (
 859                 -- force the C compiler to interpret this file as C when
 860                 -- compiling .hc files, by adding the -x c option.
 861                 -- Also useful for plain .c files, just in case GHC saw a
 862                 -- -x c option.
 863                         [ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp
 864                                                 then SysTools.Option "c++" else SysTools.Option "c"] ++
 865                         [ SysTools.FileOption "" input_fn
 866                         , SysTools.Option "-o"
 867                         , SysTools.FileOption "" output_fn
 868                         ]
 869                        ++ map SysTools.Option (
 870                           md_c_flags
 871                        ++ pic_c_flags
 872 #ifdef sparc_TARGET_ARCH
 873         -- We only support SparcV9 and better because V8 lacks an atomic CAS
 874         -- instruction. Note that the user can still override this
 875         -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
 876         -- regardless of the ordering.
 877         --
 878         -- This is a temporary hack.
 879                        ++ ["-mcpu=v9"]
 880 #endif
 881                        ++ (if hcc && mangle
 882                              then md_regd_c_flags
 883                              else [])
 884                        ++ (if hcc
 885                              then if mangle
 886                                      then gcc_extra_viac_flags
 887                                      else filter (=="-fwrapv")
 888                                                 gcc_extra_viac_flags
 889                                 -- still want -fwrapv even for unreg'd
 890                              else [])
 891                        ++ (if hcc
 892                              then more_hcc_opts
 893                              else [])
 894                        ++ [ verb, "-S", "-Wimplicit", cc_opt ]
 895                        ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 896                        ++ cc_opts
 897                        ++ split_opt
 898                        ++ include_paths
 899                        ++ pkg_extra_cc_opts
 900                        ))
 901
 902         return (next_phase, dflags, maybe_loc, output_fn)
 903
 904         -- ToDo: postprocess the output from gcc
 905
 906 -----------------------------------------------------------------------------
 907 -- Mangle phase
 908
 909 runPhase Mangle stop dflags _basename _suff input_fn get_output_fn maybe_loc
 910    = do let mangler_opts = getOpts dflags opt_m
 911
 912 #if i386_TARGET_ARCH
 913         machdep_opts <- return [ show (stolen_x86_regs dflags) ]
 914 #else
 915         machdep_opts <- return []
 916 #endif
 917
 918         let split = dopt Opt_SplitObjs dflags
 919             next_phase
 920                 | split = SplitMangle
 921                 | otherwise = As
 922         output_fn <- get_output_fn dflags next_phase maybe_loc
 923
 924         SysTools.runMangle dflags (map SysTools.Option mangler_opts
 925                           ++ [ SysTools.FileOption "" input_fn
 926                              , SysTools.FileOption "" output_fn
 927                              ]
 928                           ++ map SysTools.Option machdep_opts)
 929
 930         return (next_phase, dflags, maybe_loc, output_fn)
 931
 932 -----------------------------------------------------------------------------
 933 -- Splitting phase
 934
 935 runPhase SplitMangle stop dflags _basename _suff input_fn get_output_fn maybe_loc
 936   = do  -- tmp_pfx is the prefix used for the split .s files
 937         -- We also use it as the file to contain the no. of split .s files (sigh)
 938         split_s_prefix <- SysTools.newTempName dflags "split"
 939         let n_files_fn = split_s_prefix
 940
 941         SysTools.runSplit dflags
 942                           [ SysTools.FileOption "" input_fn
 943                           , SysTools.FileOption "" split_s_prefix
 944                           , SysTools.FileOption "" n_files_fn
 945                           ]
 946
 947         -- Save the number of split files for future references
 948         s <- readFile n_files_fn
 949         let n_files = read s :: Int
 950         writeIORef v_Split_info (split_s_prefix, n_files)
 951
 952         -- Remember to delete all these files
 953         addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s"
 954                         | n <- [1..n_files]]
 955
 956         return (SplitAs, dflags, maybe_loc, "**splitmangle**")
 957           -- we don't use the filename
 958
 959 -----------------------------------------------------------------------------
 960 -- As phase
 961
 962 runPhase As stop dflags _basename _suff input_fn get_output_fn maybe_loc
 963   = do  let as_opts =  getOpts dflags opt_a
 964         let cmdline_include_paths = includePaths dflags
 965
 966         output_fn <- get_output_fn dflags StopLn maybe_loc
 967
 968         -- we create directories for the object file, because it
 969         -- might be a hierarchical module.
 970         createDirectoryHierarchy (directoryOf output_fn)
 971
 972         SysTools.runAs dflags
 973                        (map SysTools.Option as_opts
 974                        ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
 975 #ifdef sparc_TARGET_ARCH
 976         -- We only support SparcV9 and better because V8 lacks an atomic CAS
 977         -- instruction so we have to make sure that the assembler accepts the
 978         -- instruction set. Note that the user can still override this
 979         -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
 980         -- regardless of the ordering.
 981         --
 982         -- This is a temporary hack.
 983                        ++ [ SysTools.Option "-mcpu=v9" ]
 984 #endif
 985                        ++ [ SysTools.Option "-c"
 986                           , SysTools.FileOption "" input_fn
 987                           , SysTools.Option "-o"
 988                           , SysTools.FileOption "" output_fn
 989                           ])
 990
 991         return (StopLn, dflags, maybe_loc, output_fn)
 992
 993
 994 runPhase SplitAs stop dflags basename _suff _input_fn get_output_fn maybe_loc
 995   = do
 996         output_fn <- get_output_fn dflags StopLn maybe_loc
 997
 998         let (base_o, _) = splitFilename output_fn
 999             split_odir  = base_o ++ "_split"
1000             osuf = objectSuf dflags
1001
1002         createDirectoryHierarchy split_odir
1003
1004         -- remove M_split/ *.o, because we're going to archive M_split/ *.o
1005         -- later and we don't want to pick up any old objects.
1006         fs <- getDirectoryContents split_odir
1007         mapM_ removeFile $ map (split_odir `joinFileName`)
1008                          $ filter (osuf `isSuffixOf`) fs
1009
1010         let as_opts = getOpts dflags opt_a
1011
1012         (split_s_prefix, n) <- readIORef v_Split_info
1013
1014         let split_s   n = split_s_prefix ++ "__" ++ show n `joinFileExt` "s"
1015             split_obj n = split_odir `joinFileName`
1016                                 filenameOf base_o ++ "__" ++ show n
1017                                         `joinFileExt` osuf
1018
1019         let assemble_file n
1020               = SysTools.runAs dflags
1021                          (map SysTools.Option as_opts ++
1022                          [ SysTools.Option "-c"
1023                          , SysTools.Option "-o"
1024                          , SysTools.FileOption "" (split_obj n)
1025                          , SysTools.FileOption "" (split_s n)
1026                          ])
1027
1028         mapM_ assemble_file [1..n]
1029
1030         -- and join the split objects into a single object file:
1031         let ld_r args = SysTools.runLink dflags ([
1032                                 SysTools.Option "-nostdlib",
1033                                 SysTools.Option "-nodefaultlibs",
1034                                 SysTools.Option "-Wl,-r",
1035                                 SysTools.Option ld_x_flag,
1036                                 SysTools.Option "-o",
1037                                 SysTools.FileOption "" output_fn ] ++ args)
1038             ld_x_flag | null cLD_X = ""
1039                       | otherwise  = "-Wl,-x"
1040
1041         if cLdIsGNULd == "YES"
1042             then do
1043                   let script = split_odir `joinFileName` "ld.script"
1044                   writeFile script $
1045                       "INPUT(" ++ unwords (map split_obj [1..n]) ++ ")"
1046                   ld_r [SysTools.FileOption "" script]
1047             else do
1048                   ld_r (map (SysTools.FileOption "" . split_obj) [1..n])
1049
1050         return (StopLn, dflags, maybe_loc, output_fn)
1051
1052
1053 -----------------------------------------------------------------------------
1054 -- MoveBinary sort-of-phase
1055 -- After having produced a binary, move it somewhere else and generate a
1056 -- wrapper script calling the binary. Currently, we need this only in
1057 -- a parallel way (i.e. in GUM), because PVM expects the binary in a
1058 -- central directory.
1059 -- This is called from linkBinary below, after linking. I haven't made it
1060 -- a separate phase to minimise interfering with other modules, and
1061 -- we don't need the generality of a phase (MoveBinary is always
1062 -- done after linking and makes only sense in a parallel setup)   -- HWL
1063
1064 runPhase_MoveBinary dflags input_fn
1065   = do
1066         let sysMan = pgm_sysman dflags
1067         pvm_root <- getEnv "PVM_ROOT"
1068         pvm_arch <- getEnv "PVM_ARCH"
1069         let
1070            pvm_executable_base = "=" ++ input_fn
1071            pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
1072         -- nuke old binary; maybe use configur'ed names for cp and rm?
1073         Panic.try (removeFile pvm_executable)
1074         -- move the newly created binary into PVM land
1075         copy dflags "copying PVM executable" input_fn pvm_executable
1076         -- generate a wrapper script for running a parallel prg under PVM
1077         writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
1078         return True
1079
1080 -- generates a Perl skript starting a parallel prg under PVM
1081 mk_pvm_wrapper_script :: String -> String -> String -> String
1082 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
1083  [
1084   "eval 'exec perl -S $0 ${1+\"$@\"}'",
1085   "  if $running_under_some_shell;",
1086   "# =!=!=!=!=!=!=!=!=!=!=!",
1087   "# This script is automatically generated: DO NOT EDIT!!!",
1088   "# Generated by Glasgow Haskell Compiler",
1089   "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
1090   "#",
1091   "$pvm_executable      = '" ++ pvm_executable ++ "';",
1092   "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
1093   "$SysMan = '" ++ sysMan ++ "';",
1094   "",
1095   {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
1096   "# first, some magical shortcuts to run "commands" on the binary",
1097   "# (which is hidden)",
1098   "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
1099   "    local($cmd) = $1;",
1100   "    system("$cmd $pvm_executable");",
1101   "    exit(0); # all done",
1102   "}", -}
1103   "",
1104   "# Now, run the real binary; process the args first",
1105   "$ENV{'PE'} = $pvm_executable_base;", --  ++ pvm_executable_base,
1106   "$debug = '';",
1107   "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
1108   "@nonPVM_args = ();",
1109   "$in_RTS_args = 0;",
1110   "",
1111   "args: while ($a = shift(@ARGV)) {",
1112   "    if ( $a eq '+RTS' ) {",
1113   "        $in_RTS_args = 1;",
1114   "    } elsif ( $a eq '-RTS' ) {",
1115   "        $in_RTS_args = 0;",
1116   "    }",
1117   "    if ( $a eq '-d' && $in_RTS_args ) {",
1118   "        $debug = '-';",
1119   "    } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
1120   "        $nprocessors = $1;",
1121   "    } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
1122   "        $nprocessors = $1;",
1123   "    } else {",
1124   "        push(@nonPVM_args, $a);",
1125   "    }",
1126   "}",
1127   "",
1128   "local($return_val) = 0;",
1129   "# Start the parallel execution by calling SysMan",
1130   "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
1131   "$return_val = $?;",
1132   "# ToDo: fix race condition moving files and flushing them!!",
1133   "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
1134   "exit($return_val);"
1135  ]
1136
1137 -----------------------------------------------------------------------------
1138 -- Complain about non-dynamic flags in OPTIONS pragmas
1139
1140 checkProcessArgsResult flags filename
1141   = do when (notNull flags) (throwDyn (ProgramError (
1142           showSDoc (hang (text filename <> char ':')
1143                       4 (text "unknown flags in  {-# OPTIONS #-} pragma:" <+>
1144                           hsep (map text flags)))
1145         )))
1146
1147 -----------------------------------------------------------------------------
1148 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
1149
1150 getHCFilePackages :: FilePath -> IO [PackageId]
1151 getHCFilePackages filename =
1152   Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
1153     l <- hGetLine h
1154     case l of
1155       '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
1156           return (map stringToPackageId (words rest))
1157       _other ->
1158           return []
1159
1160 -----------------------------------------------------------------------------
1161 -- Static linking, of .o files
1162
1163 -- The list of packages passed to link is the list of packages on
1164 -- which this program depends, as discovered by the compilation
1165 -- manager.  It is combined with the list of packages that the user
1166 -- specifies on the command line with -package flags.
1167 --
1168 -- In one-shot linking mode, we can't discover the package
1169 -- dependencies (because we haven't actually done any compilation or
1170 -- read any interface files), so the user must explicitly specify all
1171 -- the packages.
1172
1173 linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO ()
1174 linkBinary dflags o_files dep_packages = do
1175     let verb = getVerbFlag dflags
1176         output_fn = exeFileName dflags
1177
1178     -- get the full list of packages to link with, by combining the
1179     -- explicit packages with the auto packages and all of their
1180     -- dependencies, and eliminating duplicates.
1181
1182     pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1183     let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths)
1184         get_pkg_lib_path_opts l | opt_HardwireLibPaths && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1185                                 | otherwise = ["-L" ++ l]
1186
1187     let lib_paths = libraryPaths dflags
1188     let lib_path_opts = map ("-L"++) lib_paths
1189
1190     pkg_link_opts <- getPackageLinkOpts dflags dep_packages
1191
1192 #ifdef darwin_TARGET_OS
1193     pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
1194     let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths
1195
1196     let framework_paths = frameworkPaths dflags
1197         framework_path_opts = map ("-F"++) framework_paths
1198
1199     pkg_frameworks <- getPackageFrameworks dflags dep_packages
1200     let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1201
1202     let frameworks = cmdlineFrameworks dflags
1203         framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ]
1204          -- reverse because they're added in reverse order from the cmd line
1205 #endif
1206
1207         -- probably _stub.o files
1208     extra_ld_inputs <- readIORef v_Ld_inputs
1209
1210         -- opts from -optl-<blah> (including -l<blah> options)
1211     let extra_ld_opts = getOpts dflags opt_l
1212
1213     let ways = wayNames dflags
1214
1215     -- Here are some libs that need to be linked at the *end* of
1216     -- the command line, because they contain symbols that are referred to
1217     -- by the RTS.  We can't therefore use the ordinary way opts for these.
1218     let
1219         debug_opts | WayDebug `elem` ways = [
1220 #if defined(HAVE_LIBBFD)
1221                         "-lbfd", "-liberty"
1222 #endif
1223                          ]
1224                    | otherwise            = []
1225
1226     let
1227         thread_opts | WayThreaded `elem` ways = [
1228 #if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS)
1229                         "-lpthread"
1230 #endif
1231 #if defined(osf3_TARGET_OS)
1232                         , "-lexc"
1233 #endif
1234                         ]
1235                     | otherwise               = []
1236
1237     rc_objs <- maybeCreateManifest dflags output_fn
1238
1239     let (md_c_flags, _) = machdepCCOpts dflags
1240     SysTools.runLink dflags (
1241                        [ SysTools.Option verb
1242                        , SysTools.Option "-o"
1243                        , SysTools.FileOption "" output_fn
1244                        ]
1245                       ++ map SysTools.Option (
1246                          md_c_flags
1247                       ++ o_files
1248                       ++ extra_ld_inputs
1249                       ++ lib_path_opts
1250                       ++ extra_ld_opts
1251                       ++ rc_objs
1252 #ifdef darwin_TARGET_OS
1253                       ++ framework_path_opts
1254                       ++ framework_opts
1255 #endif
1256                       ++ pkg_lib_path_opts
1257                       ++ pkg_link_opts
1258 #ifdef darwin_TARGET_OS
1259                       ++ pkg_framework_path_opts
1260                       ++ pkg_framework_opts
1261 #endif
1262                       ++ debug_opts
1263                       ++ thread_opts
1264                     ))
1265
1266     -- parallel only: move binary to another dir -- HWL
1267     when (WayPar `elem` ways)
1268          (do success <- runPhase_MoveBinary dflags output_fn
1269              if success then return ()
1270                         else throwDyn (InstallationError ("cannot move binary to PVM dir")))
1271
1272
1273 exeFileName :: DynFlags -> FilePath
1274 exeFileName dflags
1275   | Just s <- outputFile dflags =
1276 #if defined(mingw32_HOST_OS)
1277       if null (suffixOf s)
1278         then s `joinFileExt` "exe"
1279         else s
1280 #else
1281       s
1282 #endif
1283   | otherwise =
1284 #if defined(mingw32_HOST_OS)
1285         "main.exe"
1286 #else
1287         "a.out"
1288 #endif
1289
1290 maybeCreateManifest
1291    :: DynFlags
1292    -> FilePath                          -- filename of executable
1293    -> IO [FilePath]                     -- extra objects to embed, maybe
1294 maybeCreateManifest dflags exe_filename = do
1295 #ifndef mingw32_TARGET_OS
1296   return []
1297 #else
1298   if not (dopt Opt_GenManifest dflags) then return [] else do
1299
1300   let manifest_filename = exe_filename `joinFileExt` "manifest"
1301
1302   writeFile manifest_filename $
1303       "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
1304       "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
1305       "  <assemblyIdentity version=\"1.0.0.0\"\n"++
1306       "     processorArchitecture=\"X86\"\n"++
1307       "     name=\"" ++ basenameOf exe_filename ++ "\"\n"++
1308       "     type=\"win32\"/>\n\n"++
1309       "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
1310       "    <security>\n"++
1311       "      <requestedPrivileges>\n"++
1312       "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
1313       "        </requestedPrivileges>\n"++
1314       "       </security>\n"++
1315       "  </trustInfo>\n"++
1316       "</assembly>\n"
1317
1318   -- Windows will fine the manifest file if it is named foo.exe.manifest.
1319   -- However, for extra robustness, and so that we can move the binary around,
1320   -- we can embed the manifest in the binary itself using windres:
1321   if not (dopt Opt_EmbedManifest dflags) then return [] else do
1322
1323   rc_filename <- newTempName dflags "rc"
1324   rc_obj_filename <- newTempName dflags (objectSuf dflags)
1325
1326   writeFile rc_filename $
1327       "1 24 MOVEABLE PURE \"" ++ manifest_filename ++ "\"\n"
1328         -- magic numbers :-)
1329
1330   let wr_opts = getOpts dflags opt_windres
1331   runWindres dflags $ map SysTools.Option $
1332         ["--input="++rc_filename,
1333          "--output="++rc_obj_filename,
1334          "--output-format=coff"]
1335         ++ wr_opts
1336         -- no FileOptions here: windres doesn't like seeing
1337         -- backslashes, apparently
1338
1339   return [rc_obj_filename]
1340 #endif
1341
1342
1343 linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
1344 linkDynLib dflags o_files dep_packages = do
1345     let verb = getVerbFlag dflags
1346     let static = opt_Static
1347     let no_hs_main = dopt Opt_NoHsMain dflags
1348     let o_file = outputFile dflags
1349
1350     pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1351     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1352
1353     let lib_paths = libraryPaths dflags
1354     let lib_path_opts = map ("-L"++) lib_paths
1355
1356     pkg_link_opts <- getPackageLinkOpts dflags dep_packages
1357
1358         -- probably _stub.o files
1359     extra_ld_inputs <- readIORef v_Ld_inputs
1360
1361     let (md_c_flags, _) = machdepCCOpts dflags
1362     let extra_ld_opts = getOpts dflags opt_l
1363 #if defined(mingw32_HOST_OS)
1364     -----------------------------------------------------------------------------
1365     -- Making a DLL
1366     -----------------------------------------------------------------------------
1367     let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
1368
1369     SysTools.runLink dflags
1370          ([ SysTools.Option verb
1371           , SysTools.Option "-o"
1372           , SysTools.FileOption "" output_fn
1373           , SysTools.Option "-shared"
1374           , SysTools.Option "-Wl,--export-all-symbols"
1375           , SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
1376           ]
1377          ++ map (SysTools.FileOption "") o_files
1378          ++ map SysTools.Option (
1379             md_c_flags
1380          ++ extra_ld_inputs
1381          ++ lib_path_opts
1382          ++ extra_ld_opts
1383          ++ pkg_lib_path_opts
1384          ++ pkg_link_opts
1385         ))
1386 #elif defined(darwin_TARGET_OS)
1387     -----------------------------------------------------------------------------
1388     -- Making a darwin dylib
1389     -----------------------------------------------------------------------------
1390     -- About the options used for Darwin:
1391     -- -dynamiclib
1392     --   Apple's way of saying -shared
1393     -- -undefined dynamic_lookup:
1394     --   Without these options, we'd have to specify the correct dependencies
1395     --   for each of the dylibs. Note that we could (and should) do without this
1396     --   for all libraries except the RTS; all we need to do is to pass the
1397     --   correct HSfoo_dyn.dylib files to the link command.
1398     --   This feature requires Mac OS X 10.3 or later; there is a similar feature,
1399     --   -flat_namespace -undefined suppress, which works on earlier versions,
1400     --   but it has other disadvantages.
1401     -- -single_module
1402     --   Build the dynamic library as a single "module", i.e. no dynamic binding
1403     --   nonsense when referring to symbols from within the library. The NCG
1404     --   assumes that this option is specified (on i386, at least).
1405     -- -Wl,-macosx_version_min -Wl,10.3
1406     --   Tell the linker its safe to assume that the library will run on 10.3 or
1407     --   later, so that it will not complain about the use of the option
1408     --   -undefined dynamic_lookup above.
1409     -- -install_name
1410     --   Causes the dynamic linker to ignore the DYLD_LIBRARY_PATH when loading
1411     --   this lib and instead look for it at its absolute path.
1412     --   When installing the .dylibs (see target.mk), we'll change that path to
1413     --   point to the place they are installed. Therefore, we won't have to set
1414     --   up DYLD_LIBRARY_PATH specifically for ghc.
1415     -----------------------------------------------------------------------------
1416
1417     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1418
1419     pwd <- getCurrentDirectory
1420     SysTools.runLink dflags
1421          ([ SysTools.Option verb
1422           , SysTools.Option "-dynamiclib"
1423           , SysTools.Option "-o"
1424           , SysTools.FileOption "" output_fn
1425           ]
1426          ++ map SysTools.Option (
1427             md_c_flags
1428          ++ o_files
1429          ++ [ "-undefined", "dynamic_lookup", "-single_module", "-Wl,-macosx_version_min","-Wl,10.3", "-install_name " ++ (pwd `joinFileName` output_fn) ]
1430          ++ extra_ld_inputs
1431          ++ lib_path_opts
1432          ++ extra_ld_opts
1433          ++ pkg_lib_path_opts
1434          ++ pkg_link_opts
1435         ))
1436 #else
1437     -----------------------------------------------------------------------------
1438     -- Making a DSO
1439     -----------------------------------------------------------------------------
1440
1441     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1442
1443     SysTools.runLink dflags
1444          ([ SysTools.Option verb
1445           , SysTools.Option "-o"
1446           , SysTools.FileOption "" output_fn
1447           ]
1448          ++ map SysTools.Option (
1449             md_c_flags
1450          ++ o_files
1451          ++ [ "-shared", "-Wl,-Bsymbolic" ] -- we need symbolic linking to resolve non-PIC intra-package-relocations
1452          ++ extra_ld_inputs
1453          ++ lib_path_opts
1454          ++ extra_ld_opts
1455          ++ pkg_lib_path_opts
1456          ++ pkg_link_opts
1457         ))
1458 #endif
1459 -- -----------------------------------------------------------------------------
1460 -- Running CPP
1461
1462 doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO ()
1463 doCpp dflags raw include_cc_opts input_fn output_fn = do
1464     let hscpp_opts = getOpts dflags opt_P
1465     let cmdline_include_paths = includePaths dflags
1466
1467     pkg_include_dirs <- getPackageIncludePath dflags []
1468     let include_paths = foldr (\ x xs -> "-I" : x : xs) []
1469                           (cmdline_include_paths ++ pkg_include_dirs)
1470
1471     let verb = getVerbFlag dflags
1472
1473     let cc_opts
1474           | not include_cc_opts = []
1475           | otherwise           = (optc ++ md_c_flags)
1476                 where
1477                       optc = getOpts dflags opt_c
1478                       (md_c_flags, _) = machdepCCOpts dflags
1479
1480     let cpp_prog args | raw       = SysTools.runCpp dflags args
1481                       | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
1482
1483     let target_defs =
1484           [ "-D" ++ HOST_OS     ++ "_BUILD_OS=1",
1485             "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH=1",
1486             "-D" ++ TARGET_OS   ++ "_HOST_OS=1",
1487             "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ]
1488         -- remember, in code we *compile*, the HOST is the same our TARGET,
1489         -- and BUILD is the same as our HOST.
1490
1491     cpp_prog       ([SysTools.Option verb]
1492                     ++ map SysTools.Option include_paths
1493                     ++ map SysTools.Option hsSourceCppOpts
1494                     ++ map SysTools.Option hscpp_opts
1495                     ++ map SysTools.Option cc_opts
1496                     ++ map SysTools.Option target_defs
1497                     ++ [ SysTools.Option     "-x"
1498                        , SysTools.Option     "c"
1499                        , SysTools.Option     input_fn
1500         -- We hackily use Option instead of FileOption here, so that the file
1501         -- name is not back-slashed on Windows.  cpp is capable of
1502         -- dealing with / in filenames, so it works fine.  Furthermore
1503         -- if we put in backslashes, cpp outputs #line directives
1504         -- with *double* backslashes.   And that in turn means that
1505         -- our error messages get double backslashes in them.
1506         -- In due course we should arrange that the lexer deals
1507         -- with these \\ escapes properly.
1508                        , SysTools.Option     "-o"
1509                        , SysTools.FileOption "" output_fn
1510                        ])
1511
1512 cHaskell1Version = "5" -- i.e., Haskell 98
1513
1514 -- Default CPP defines in Haskell source
1515 hsSourceCppOpts =
1516         [ "-D__HASKELL1__="++cHaskell1Version
1517         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
1518         , "-D__HASKELL98__"
1519         , "-D__CONCURRENT_HASKELL__"
1520         ]
1521
1522
1523 -- -----------------------------------------------------------------------------
1524 -- Misc.
1525
1526 hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase
1527 hscNextPhase dflags HsBootFile hsc_lang  =  StopLn
1528 hscNextPhase dflags other hsc_lang =
1529   case hsc_lang of
1530         HscC -> HCc
1531         HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle
1532                | otherwise -> As
1533         HscNothing     -> StopLn
1534         HscInterpreted -> StopLn
1535         _other         -> StopLn
1536
1537
1538 hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget
1539 hscMaybeAdjustTarget dflags stop other current_hsc_lang
1540   = hsc_lang
1541   where
1542         keep_hc = dopt Opt_KeepHcFiles dflags
1543         hsc_lang
1544                 -- don't change the lang if we're interpreting
1545                  | current_hsc_lang == HscInterpreted = current_hsc_lang
1546
1547                 -- force -fvia-C if we are being asked for a .hc file
1548                  | HCc <- stop = HscC
1549                  | keep_hc     = HscC
1550                 -- otherwise, stick to the plan
1551                  | otherwise = current_hsc_lang
1552
1553 GLOBAL_VAR(v_Split_info, ("",0), (String,Int))
1554         -- The split prefix and number of files