compiler/main/DriverPipeline.hs

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