compiler/main/DriverPipeline.hs

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