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