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         -- cc-options are not passed when compiling .hc files.  Our
 856         -- hc code doesn't not #include any header files anyway, so these
 857         -- options aren't necessary.
 858         pkg_extra_cc_opts <-
 859           if cc_phase `eqPhase` HCc
 860              then return []
 861              else getPackageExtraCcOpts dflags pkgs
 862
 863 #ifdef darwin_TARGET_OS
 864         pkg_framework_paths <- getPackageFrameworkPath dflags pkgs
 865         let cmdline_framework_paths = frameworkPaths dflags
 866         let framework_paths = map ("-F"++)
 867                         (cmdline_framework_paths ++ pkg_framework_paths)
 868 #endif
 869
 870         let split_objs = dopt Opt_SplitObjs dflags
 871             split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 872                       | otherwise         = [ ]
 873
 874         let cc_opt | optLevel dflags >= 2 = "-O2"
 875                    | otherwise            = "-O"
 876
 877         -- Decide next phase
 878
 879         let mangle = dopt Opt_DoAsmMangling dflags
 880             next_phase
 881                 | hcc && mangle     = Mangle
 882                 | otherwise         = As
 883         output_fn <- get_output_fn dflags next_phase maybe_loc
 884
 885         let
 886           more_hcc_opts =
 887 #if i386_TARGET_ARCH
 888                 -- on x86 the floating point regs have greater precision
 889                 -- than a double, which leads to unpredictable results.
 890                 -- By default, we turn this off with -ffloat-store unless
 891                 -- the user specified -fexcess-precision.
 892                 (if dopt Opt_ExcessPrecision dflags
 893                         then []
 894                         else [ "-ffloat-store" ]) ++
 895 #endif
 896                 -- gcc's -fstrict-aliasing allows two accesses to memory
 897                 -- to be considered non-aliasing if they have different types.
 898                 -- This interacts badly with the C code we generate, which is
 899                 -- very weakly typed, being derived from C--.
 900                 ["-fno-strict-aliasing"]
 901
 902
 903
 904         SysTools.runCc dflags (
 905                 -- force the C compiler to interpret this file as C when
 906                 -- compiling .hc files, by adding the -x c option.
 907                 -- Also useful for plain .c files, just in case GHC saw a
 908                 -- -x c option.
 909                         [ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp
 910                                                 then SysTools.Option "c++" else SysTools.Option "c"] ++
 911                         [ SysTools.FileOption "" input_fn
 912                         , SysTools.Option "-o"
 913                         , SysTools.FileOption "" output_fn
 914                         ]
 915                        ++ map SysTools.Option (
 916                           md_c_flags
 917                        ++ pic_c_flags
 918 #ifdef sparc_TARGET_ARCH
 919         -- We only support SparcV9 and better because V8 lacks an atomic CAS
 920         -- instruction. Note that the user can still override this
 921         -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
 922         -- regardless of the ordering.
 923         --
 924         -- This is a temporary hack.
 925                        ++ ["-mcpu=v9"]
 926 #endif
 927                        ++ (if hcc && mangle
 928                              then md_regd_c_flags
 929                              else [])
 930                        ++ (if hcc
 931                              then if mangle
 932                                      then gcc_extra_viac_flags
 933                                      else filter (=="-fwrapv")
 934                                                 gcc_extra_viac_flags
 935                                 -- still want -fwrapv even for unreg'd
 936                              else [])
 937                        ++ (if hcc
 938                              then more_hcc_opts
 939                              else [])
 940                        ++ [ verb, "-S", "-Wimplicit", cc_opt ]
 941                        ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 942 #ifdef darwin_TARGET_OS
 943                        ++ framework_paths
 944 #endif
 945                        ++ cc_opts
 946                        ++ split_opt
 947                        ++ include_paths
 948                        ++ pkg_extra_cc_opts
 949                        ))
 950
 951         return (next_phase, dflags, maybe_loc, output_fn)
 952
 953         -- ToDo: postprocess the output from gcc
 954
 955 -----------------------------------------------------------------------------
 956 -- Mangle phase
 957
 958 runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 959    = do let dflags = hsc_dflags hsc_env
 960         let mangler_opts = getOpts dflags opt_m
 961
 962 #if i386_TARGET_ARCH
 963         machdep_opts <- return [ show (stolen_x86_regs dflags) ]
 964 #else
 965         machdep_opts <- return []
 966 #endif
 967
 968         let split = dopt Opt_SplitObjs dflags
 969             next_phase
 970                 | split = SplitMangle
 971                 | otherwise = As
 972         output_fn <- get_output_fn dflags next_phase maybe_loc
 973
 974         SysTools.runMangle dflags (map SysTools.Option mangler_opts
 975                           ++ [ SysTools.FileOption "" input_fn
 976                              , SysTools.FileOption "" output_fn
 977                              ]
 978                           ++ map SysTools.Option machdep_opts)
 979
 980         return (next_phase, dflags, maybe_loc, output_fn)
 981
 982 -----------------------------------------------------------------------------
 983 -- Splitting phase
 984
 985 runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc
 986   = do  -- tmp_pfx is the prefix used for the split .s files
 987         -- We also use it as the file to contain the no. of split .s files (sigh)
 988         let dflags = hsc_dflags hsc_env
 989         split_s_prefix <- SysTools.newTempName dflags "split"
 990         let n_files_fn = split_s_prefix
 991
 992         SysTools.runSplit dflags
 993                           [ SysTools.FileOption "" input_fn
 994                           , SysTools.FileOption "" split_s_prefix
 995                           , SysTools.FileOption "" n_files_fn
 996                           ]
 997
 998         -- Save the number of split files for future references
 999         s <- readFile n_files_fn
1000         let n_files = read s :: Int
1001         writeIORef v_Split_info (split_s_prefix, n_files)
1002
1003         -- Remember to delete all these files
1004         addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s"
1005                         | n <- [1..n_files]]
1006
1007         return (SplitAs, dflags, maybe_loc, "**splitmangle**")
1008           -- we don't use the filename
1009
1010 -----------------------------------------------------------------------------
1011 -- As phase
1012
1013 runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
1014   = do  let dflags = hsc_dflags hsc_env
1015         let as_opts =  getOpts dflags opt_a
1016         let cmdline_include_paths = includePaths dflags
1017
1018         output_fn <- get_output_fn dflags StopLn maybe_loc
1019
1020         -- we create directories for the object file, because it
1021         -- might be a hierarchical module.
1022         createDirectoryHierarchy (takeDirectory output_fn)
1023
1024         SysTools.runAs dflags
1025                        (map SysTools.Option as_opts
1026                        ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
1027 #ifdef sparc_TARGET_ARCH
1028         -- We only support SparcV9 and better because V8 lacks an atomic CAS
1029         -- instruction so we have to make sure that the assembler accepts the
1030         -- instruction set. Note that the user can still override this
1031         -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1032         -- regardless of the ordering.
1033         --
1034         -- This is a temporary hack.
1035                        ++ [ SysTools.Option "-mcpu=v9" ]
1036 #endif
1037                        ++ [ SysTools.Option "-c"
1038                           , SysTools.FileOption "" input_fn
1039                           , SysTools.Option "-o"
1040                           , SysTools.FileOption "" output_fn
1041                           ])
1042
1043         return (StopLn, dflags, maybe_loc, output_fn)
1044
1045
1046 runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc
1047   = do
1048         let dflags = hsc_dflags hsc_env
1049         output_fn <- get_output_fn dflags StopLn maybe_loc
1050
1051         let base_o = dropExtension output_fn
1052             split_odir  = base_o ++ "_split"
1053             osuf = objectSuf dflags
1054
1055         createDirectoryHierarchy split_odir
1056
1057         -- remove M_split/ *.o, because we're going to archive M_split/ *.o
1058         -- later and we don't want to pick up any old objects.
1059         fs <- getDirectoryContents split_odir
1060         mapM_ removeFile $ map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
1061
1062         let as_opts = getOpts dflags opt_a
1063
1064         (split_s_prefix, n) <- readIORef v_Split_info
1065
1066         let split_s   n = split_s_prefix ++ "__" ++ show n <.> "s"
1067             split_obj n = split_odir </>
1068                           takeFileName base_o ++ "__" ++ show n <.> osuf
1069
1070         let assemble_file n
1071               = SysTools.runAs dflags
1072                          (map SysTools.Option as_opts ++
1073                           [ SysTools.Option "-c"
1074                           , SysTools.Option "-o"
1075                           , SysTools.FileOption "" (split_obj n)
1076                           , SysTools.FileOption "" (split_s n)
1077                           ])
1078
1079         mapM_ assemble_file [1..n]
1080
1081         -- and join the split objects into a single object file:
1082         let ld_r args = SysTools.runLink dflags ([
1083                             SysTools.Option "-nostdlib",
1084                             SysTools.Option "-nodefaultlibs",
1085                             SysTools.Option "-Wl,-r",
1086                             SysTools.Option ld_x_flag,
1087                             SysTools.Option "-o",
1088                             SysTools.FileOption "" output_fn ] ++ args)
1089             ld_x_flag | null cLD_X = ""
1090                       | otherwise  = "-Wl,-x"
1091
1092         if cLdIsGNULd == "YES"
1093             then do
1094                   let script = split_odir </> "ld.script"
1095                   writeFile script $
1096                       "INPUT(" ++ unwords (map split_obj [1..n]) ++ ")"
1097                   ld_r [SysTools.FileOption "" script]
1098             else do
1099                   ld_r (map (SysTools.FileOption "" . split_obj) [1..n])
1100
1101         return (StopLn, dflags, maybe_loc, output_fn)
1102
1103 -- warning suppression
1104 runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc =
1105    panic ("runPhase: don't know how to run phase " ++ show other)
1106 -----------------------------------------------------------------------------
1107 -- MoveBinary sort-of-phase
1108 -- After having produced a binary, move it somewhere else and generate a
1109 -- wrapper script calling the binary. Currently, we need this only in
1110 -- a parallel way (i.e. in GUM), because PVM expects the binary in a
1111 -- central directory.
1112 -- This is called from linkBinary below, after linking. I haven't made it
1113 -- a separate phase to minimise interfering with other modules, and
1114 -- we don't need the generality of a phase (MoveBinary is always
1115 -- done after linking and makes only sense in a parallel setup)   -- HWL
1116
1117 runPhase_MoveBinary :: DynFlags -> FilePath -> [PackageId] -> IO Bool
1118 runPhase_MoveBinary dflags input_fn dep_packages
1119     | WayPar `elem` (wayNames dflags) && not opt_Static =
1120         panic ("Don't know how to combine PVM wrapper and dynamic wrapper")
1121     | WayPar `elem` (wayNames dflags) = do
1122         let sysMan = pgm_sysman dflags
1123         pvm_root <- getEnv "PVM_ROOT"
1124         pvm_arch <- getEnv "PVM_ARCH"
1125         let
1126            pvm_executable_base = "=" ++ input_fn
1127            pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
1128         -- nuke old binary; maybe use configur'ed names for cp and rm?
1129         tryIO (removeFile pvm_executable)
1130         -- move the newly created binary into PVM land
1131         copy dflags "copying PVM executable" input_fn pvm_executable
1132         -- generate a wrapper script for running a parallel prg under PVM
1133         writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
1134         return True
1135     | not opt_Static =
1136         case (dynLibLoader dflags) of
1137           Wrapped wrapmode ->
1138               do
1139                 let (o_base, o_ext) = splitExtension input_fn
1140                 let wrapped_executable | o_ext == "exe" = (o_base ++ "_real") <.> o_ext
1141                                        | otherwise = input_fn ++ "_real"
1142                 behaviour <- wrapper_behaviour dflags wrapmode dep_packages
1143
1144                 -- THINKME isn't this possible to do a bit nicer?
1145                 let behaviour' = concatMap (\x -> if x=='\\' then "\\\\" else [x]) behaviour
1146                 renameFile input_fn wrapped_executable
1147                 let rtsDetails = (getPackageDetails (pkgState dflags) rtsPackageId);
1148                 SysTools.runCc dflags
1149                   ([ SysTools.FileOption "" ((head (libraryDirs rtsDetails)) ++ "/dyn-wrapper.c")
1150                    , SysTools.Option ("-DBEHAVIOUR=\"" ++ behaviour' ++ "\"")
1151                    , SysTools.Option "-o"
1152                    , SysTools.FileOption "" input_fn
1153                    ] ++ map (SysTools.FileOption "-I") (includeDirs rtsDetails))
1154                 return True
1155           _ -> return True
1156     | otherwise = return True
1157
1158 wrapper_behaviour :: DynFlags -> Maybe [Char] -> [PackageId] -> IO [Char]
1159 wrapper_behaviour dflags mode dep_packages =
1160     let seperateBySemiColon strs = tail $ concatMap (';':) strs
1161     in case mode of
1162       Nothing -> do
1163                 pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1164                 return ('H' : (seperateBySemiColon pkg_lib_paths))
1165       Just s -> do
1166         allpkg <- getPreloadPackagesAnd dflags dep_packages
1167         putStrLn (unwords (map (packageIdString . packageConfigId) allpkg))
1168         return $ 'F':s ++ ';':(seperateBySemiColon (map (packageIdString . packageConfigId) allpkg))
1169
1170 -- generates a Perl skript starting a parallel prg under PVM
1171 mk_pvm_wrapper_script :: String -> String -> String -> String
1172 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
1173  [
1174   "eval 'exec perl -S $0 ${1+\"$@\"}'",
1175   "  if $running_under_some_shell;",
1176   "# =!=!=!=!=!=!=!=!=!=!=!",
1177   "# This script is automatically generated: DO NOT EDIT!!!",
1178   "# Generated by Glasgow Haskell Compiler",
1179   "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
1180   "#",
1181   "$pvm_executable      = '" ++ pvm_executable ++ "';",
1182   "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
1183   "$SysMan = '" ++ sysMan ++ "';",
1184   "",
1185   {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
1186   "# first, some magical shortcuts to run "commands" on the binary",
1187   "# (which is hidden)",
1188   "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
1189   "    local($cmd) = $1;",
1190   "    system("$cmd $pvm_executable");",
1191   "    exit(0); # all done",
1192   "}", -}
1193   "",
1194   "# Now, run the real binary; process the args first",
1195   "$ENV{'PE'} = $pvm_executable_base;", --  ++ pvm_executable_base,
1196   "$debug = '';",
1197   "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
1198   "@nonPVM_args = ();",
1199   "$in_RTS_args = 0;",
1200   "",
1201   "args: while ($a = shift(@ARGV)) {",
1202   "    if ( $a eq '+RTS' ) {",
1203   "        $in_RTS_args = 1;",
1204   "    } elsif ( $a eq '-RTS' ) {",
1205   "        $in_RTS_args = 0;",
1206   "    }",
1207   "    if ( $a eq '-d' && $in_RTS_args ) {",
1208   "        $debug = '-';",
1209   "    } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
1210   "        $nprocessors = $1;",
1211   "    } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
1212   "        $nprocessors = $1;",
1213   "    } else {",
1214   "        push(@nonPVM_args, $a);",
1215   "    }",
1216   "}",
1217   "",
1218   "local($return_val) = 0;",
1219   "# Start the parallel execution by calling SysMan",
1220   "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
1221   "$return_val = $?;",
1222   "# ToDo: fix race condition moving files and flushing them!!",
1223   "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
1224   "exit($return_val);"
1225  ]
1226
1227 -----------------------------------------------------------------------------
1228 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
1229
1230 getHCFilePackages :: FilePath -> IO [PackageId]
1231 getHCFilePackages filename =
1232   Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
1233     l <- hGetLine h
1234     case l of
1235       '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
1236           return (map stringToPackageId (words rest))
1237       _other ->
1238           return []
1239
1240 -----------------------------------------------------------------------------
1241 -- Static linking, of .o files
1242
1243 -- The list of packages passed to link is the list of packages on
1244 -- which this program depends, as discovered by the compilation
1245 -- manager.  It is combined with the list of packages that the user
1246 -- specifies on the command line with -package flags.
1247 --
1248 -- In one-shot linking mode, we can't discover the package
1249 -- dependencies (because we haven't actually done any compilation or
1250 -- read any interface files), so the user must explicitly specify all
1251 -- the packages.
1252
1253 linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO ()
1254 linkBinary dflags o_files dep_packages = do
1255     let verb = getVerbFlag dflags
1256         output_fn = exeFileName dflags
1257
1258     -- get the full list of packages to link with, by combining the
1259     -- explicit packages with the auto packages and all of their
1260     -- dependencies, and eliminating duplicates.
1261
1262     pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1263     let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths)
1264 #ifdef linux_TARGET_OS
1265         get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1266                                 | otherwise = ["-L" ++ l]
1267 #else
1268         get_pkg_lib_path_opts l = ["-L" ++ l]
1269 #endif
1270
1271     let lib_paths = libraryPaths dflags
1272     let lib_path_opts = map ("-L"++) lib_paths
1273
1274     pkg_link_opts <- getPackageLinkOpts dflags dep_packages
1275
1276 #ifdef darwin_TARGET_OS
1277     pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
1278     let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths
1279
1280     let framework_paths = frameworkPaths dflags
1281         framework_path_opts = map ("-F"++) framework_paths
1282
1283     pkg_frameworks <- getPackageFrameworks dflags dep_packages
1284     let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1285
1286     let frameworks = cmdlineFrameworks dflags
1287         framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ]
1288          -- reverse because they're added in reverse order from the cmd line
1289 #endif
1290 #ifdef mingw32_TARGET_OS
1291     let dynMain = if not opt_Static then
1292                       (head (libraryDirs (getPackageDetails (pkgState dflags) rtsPackageId))) ++ "/Main.dyn_o"
1293                   else
1294                       ""
1295 #endif
1296         -- probably _stub.o files
1297     extra_ld_inputs <- readIORef v_Ld_inputs
1298
1299         -- opts from -optl-<blah> (including -l<blah> options)
1300     let extra_ld_opts = getOpts dflags opt_l
1301
1302     let ways = wayNames dflags
1303
1304     -- Here are some libs that need to be linked at the *end* of
1305     -- the command line, because they contain symbols that are referred to
1306     -- by the RTS.  We can't therefore use the ordinary way opts for these.
1307     let
1308         debug_opts | WayDebug `elem` ways = [
1309 #if defined(HAVE_LIBBFD)
1310                         "-lbfd", "-liberty"
1311 #endif
1312                          ]
1313                    | otherwise            = []
1314
1315     let
1316         thread_opts | WayThreaded `elem` ways = [
1317 #if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS)
1318                         "-lpthread"
1319 #endif
1320 #if defined(osf3_TARGET_OS)
1321                         , "-lexc"
1322 #endif
1323                         ]
1324                     | otherwise               = []
1325
1326     rc_objs <- maybeCreateManifest dflags output_fn
1327
1328     let (md_c_flags, _) = machdepCCOpts dflags
1329     SysTools.runLink dflags (
1330                        [ SysTools.Option verb
1331                        , SysTools.Option "-o"
1332                        , SysTools.FileOption "" output_fn
1333                        ]
1334                       ++ map SysTools.Option (
1335                          md_c_flags
1336                       ++ o_files
1337 #ifdef mingw32_TARGET_OS
1338                       ++ [dynMain]
1339 #endif
1340                       ++ extra_ld_inputs
1341                       ++ lib_path_opts
1342                       ++ extra_ld_opts
1343                       ++ rc_objs
1344 #ifdef darwin_TARGET_OS
1345                       ++ framework_path_opts
1346                       ++ framework_opts
1347 #endif
1348                       ++ pkg_lib_path_opts
1349                       ++ pkg_link_opts
1350 #ifdef darwin_TARGET_OS
1351                       ++ pkg_framework_path_opts
1352                       ++ pkg_framework_opts
1353 #endif
1354                       ++ debug_opts
1355                       ++ thread_opts
1356                     ))
1357
1358     -- parallel only: move binary to another dir -- HWL
1359     success <- runPhase_MoveBinary dflags output_fn dep_packages
1360     if success then return ()
1361                else ghcError (InstallationError ("cannot move binary"))
1362
1363
1364 exeFileName :: DynFlags -> FilePath
1365 exeFileName dflags
1366   | Just s <- outputFile dflags =
1367 #if defined(mingw32_HOST_OS)
1368       if null (takeExtension s)
1369         then s <.> "exe"
1370         else s
1371 #else
1372       s
1373 #endif
1374   | otherwise =
1375 #if defined(mingw32_HOST_OS)
1376         "main.exe"
1377 #else
1378         "a.out"
1379 #endif
1380
1381 maybeCreateManifest
1382    :: DynFlags
1383    -> FilePath                          -- filename of executable
1384    -> IO [FilePath]                     -- extra objects to embed, maybe
1385 #ifndef mingw32_TARGET_OS
1386 maybeCreateManifest _ _ = do
1387   return []
1388 #else
1389 maybeCreateManifest dflags exe_filename = do
1390   if not (dopt Opt_GenManifest dflags) then return [] else do
1391
1392   let manifest_filename = exe_filename <.> "manifest"
1393
1394   writeFile manifest_filename $
1395       "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
1396       "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
1397       "  <assemblyIdentity version=\"1.0.0.0\"\n"++
1398       "     processorArchitecture=\"X86\"\n"++
1399       "     name=\"" ++ dropExtension exe_filename ++ "\"\n"++
1400       "     type=\"win32\"/>\n\n"++
1401       "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
1402       "    <security>\n"++
1403       "      <requestedPrivileges>\n"++
1404       "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
1405       "        </requestedPrivileges>\n"++
1406       "       </security>\n"++
1407       "  </trustInfo>\n"++
1408       "</assembly>\n"
1409
1410   -- Windows will find the manifest file if it is named foo.exe.manifest.
1411   -- However, for extra robustness, and so that we can move the binary around,
1412   -- we can embed the manifest in the binary itself using windres:
1413   if not (dopt Opt_EmbedManifest dflags) then return [] else do
1414
1415   rc_filename <- newTempName dflags "rc"
1416   rc_obj_filename <- newTempName dflags (objectSuf dflags)
1417
1418   writeFile rc_filename $
1419       "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
1420         -- magic numbers :-)
1421         -- show is a bit hackish above, but we need to escape the
1422         -- backslashes in the path.
1423
1424   let wr_opts = getOpts dflags opt_windres
1425   runWindres dflags $ map SysTools.Option $
1426         ["--input="++rc_filename,
1427          "--output="++rc_obj_filename,
1428          "--output-format=coff"]
1429         ++ wr_opts
1430         -- no FileOptions here: windres doesn't like seeing
1431         -- backslashes, apparently
1432
1433   return [rc_obj_filename]
1434 #endif
1435
1436
1437 linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
1438 linkDynLib dflags o_files dep_packages = do
1439     let verb = getVerbFlag dflags
1440     let o_file = outputFile dflags
1441
1442     -- We don't want to link our dynamic libs against the RTS package,
1443     -- because the RTS lib comes in several flavours and we want to be
1444     -- able to pick the flavour when a binary is linked.
1445     pkgs <- getPreloadPackagesAnd dflags dep_packages
1446     let pkgs_no_rts = filter ((/= rtsPackageId) . packageConfigId) pkgs
1447
1448     let pkg_lib_paths = collectLibraryPaths pkgs_no_rts
1449     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1450
1451     let lib_paths = libraryPaths dflags
1452     let lib_path_opts = map ("-L"++) lib_paths
1453
1454     let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts
1455
1456         -- probably _stub.o files
1457     extra_ld_inputs <- readIORef v_Ld_inputs
1458
1459     let (md_c_flags, _) = machdepCCOpts dflags
1460     let extra_ld_opts = getOpts dflags opt_l
1461 #if defined(mingw32_HOST_OS)
1462     -----------------------------------------------------------------------------
1463     -- Making a DLL
1464     -----------------------------------------------------------------------------
1465     let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
1466
1467     SysTools.runLink dflags
1468          ([ SysTools.Option verb
1469           , SysTools.Option "-o"
1470           , SysTools.FileOption "" output_fn
1471           , SysTools.Option "-shared"
1472           , SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
1473           ]
1474          ++ map (SysTools.FileOption "") o_files
1475          ++ map SysTools.Option (
1476             md_c_flags
1477          ++ extra_ld_inputs
1478          ++ lib_path_opts
1479          ++ extra_ld_opts
1480          ++ pkg_lib_path_opts
1481          ++ pkg_link_opts
1482         ))
1483 #elif defined(darwin_TARGET_OS)
1484     -----------------------------------------------------------------------------
1485     -- Making a darwin dylib
1486     -----------------------------------------------------------------------------
1487     -- About the options used for Darwin:
1488     -- -dynamiclib
1489     --   Apple's way of saying -shared
1490     -- -undefined dynamic_lookup:
1491     --   Without these options, we'd have to specify the correct dependencies
1492     --   for each of the dylibs. Note that we could (and should) do without this
1493     --   for all libraries except the RTS; all we need to do is to pass the
1494     --   correct HSfoo_dyn.dylib files to the link command.
1495     --   This feature requires Mac OS X 10.3 or later; there is a similar feature,
1496     --   -flat_namespace -undefined suppress, which works on earlier versions,
1497     --   but it has other disadvantages.
1498     -- -single_module
1499     --   Build the dynamic library as a single "module", i.e. no dynamic binding
1500     --   nonsense when referring to symbols from within the library. The NCG
1501     --   assumes that this option is specified (on i386, at least).
1502     -- -Wl,-macosx_version_min -Wl,10.3
1503     --   Tell the linker its safe to assume that the library will run on 10.3 or
1504     --   later, so that it will not complain about the use of the option
1505     --   -undefined dynamic_lookup above.
1506     -- -install_name
1507     --   Causes the dynamic linker to ignore the DYLD_LIBRARY_PATH when loading
1508     --   this lib and instead look for it at its absolute path.
1509     --   When installing the .dylibs (see target.mk), we'll change that path to
1510     --   point to the place they are installed. Therefore, we won't have to set
1511     --   up DYLD_LIBRARY_PATH specifically for ghc.
1512     -----------------------------------------------------------------------------
1513
1514     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1515
1516     pwd <- getCurrentDirectory
1517     SysTools.runLink dflags
1518          ([ SysTools.Option verb
1519           , SysTools.Option "-dynamiclib"
1520           , SysTools.Option "-o"
1521           , SysTools.FileOption "" output_fn
1522           ]
1523          ++ map SysTools.Option (
1524             md_c_flags
1525          ++ o_files
1526          ++ [ "-undefined", "dynamic_lookup", "-single_module", "-Wl,-macosx_version_min","-Wl,10.3", "-install_name " ++ (pwd </> output_fn) ]
1527          ++ extra_ld_inputs
1528          ++ lib_path_opts
1529          ++ extra_ld_opts
1530          ++ pkg_lib_path_opts
1531          ++ pkg_link_opts
1532         ))
1533 #else
1534     -----------------------------------------------------------------------------
1535     -- Making a DSO
1536     -----------------------------------------------------------------------------
1537
1538     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1539
1540     SysTools.runLink dflags
1541          ([ SysTools.Option verb
1542           , SysTools.Option "-o"
1543           , SysTools.FileOption "" output_fn
1544           ]
1545          ++ map SysTools.Option (
1546             md_c_flags
1547          ++ o_files
1548          ++ [ "-shared", "-Wl,-Bsymbolic" ] -- we need symbolic linking to resolve non-PIC intra-package-relocations
1549          ++ extra_ld_inputs
1550          ++ lib_path_opts
1551          ++ extra_ld_opts
1552          ++ pkg_lib_path_opts
1553          ++ pkg_link_opts
1554         ))
1555 #endif
1556 -- -----------------------------------------------------------------------------
1557 -- Running CPP
1558
1559 doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO ()
1560 doCpp dflags raw include_cc_opts input_fn output_fn = do
1561     let hscpp_opts = getOpts dflags opt_P
1562     let cmdline_include_paths = includePaths dflags
1563
1564     pkg_include_dirs <- getPackageIncludePath dflags []
1565     let include_paths = foldr (\ x xs -> "-I" : x : xs) []
1566                           (cmdline_include_paths ++ pkg_include_dirs)
1567
1568     let verb = getVerbFlag dflags
1569
1570     let cc_opts
1571           | not include_cc_opts = []
1572           | otherwise           = (optc ++ md_c_flags)
1573                 where
1574                       optc = getOpts dflags opt_c
1575                       (md_c_flags, _) = machdepCCOpts dflags
1576
1577     let cpp_prog args | raw       = SysTools.runCpp dflags args
1578                       | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
1579
1580     let target_defs =
1581           [ "-D" ++ HOST_OS     ++ "_BUILD_OS=1",
1582             "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH=1",
1583             "-D" ++ TARGET_OS   ++ "_HOST_OS=1",
1584             "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ]
1585         -- remember, in code we *compile*, the HOST is the same our TARGET,
1586         -- and BUILD is the same as our HOST.
1587
1588     cpp_prog       ([SysTools.Option verb]
1589                     ++ map SysTools.Option include_paths
1590                     ++ map SysTools.Option hsSourceCppOpts
1591                     ++ map SysTools.Option hscpp_opts
1592                     ++ map SysTools.Option cc_opts
1593                     ++ map SysTools.Option target_defs
1594                     ++ [ SysTools.Option     "-x"
1595                        , SysTools.Option     "c"
1596                        , SysTools.Option     input_fn
1597         -- We hackily use Option instead of FileOption here, so that the file
1598         -- name is not back-slashed on Windows.  cpp is capable of
1599         -- dealing with / in filenames, so it works fine.  Furthermore
1600         -- if we put in backslashes, cpp outputs #line directives
1601         -- with *double* backslashes.   And that in turn means that
1602         -- our error messages get double backslashes in them.
1603         -- In due course we should arrange that the lexer deals
1604         -- with these \\ escapes properly.
1605                        , SysTools.Option     "-o"
1606                        , SysTools.FileOption "" output_fn
1607                        ])
1608
1609 cHaskell1Version :: String
1610 cHaskell1Version = "5" -- i.e., Haskell 98
1611
1612 hsSourceCppOpts :: [String]
1613 -- Default CPP defines in Haskell source
1614 hsSourceCppOpts =
1615         [ "-D__HASKELL1__="++cHaskell1Version
1616         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
1617         , "-D__HASKELL98__"
1618         , "-D__CONCURRENT_HASKELL__"
1619         ]
1620
1621
1622 -- -----------------------------------------------------------------------------
1623 -- Misc.
1624
1625 hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase
1626 hscNextPhase _ HsBootFile _        =  StopLn
1627 hscNextPhase dflags _ hsc_lang =
1628   case hsc_lang of
1629         HscC -> HCc
1630         HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle
1631                | otherwise -> As
1632         HscNothing     -> StopLn
1633         HscInterpreted -> StopLn
1634         _other         -> StopLn
1635
1636
1637 hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget
1638 hscMaybeAdjustTarget dflags stop _ current_hsc_lang
1639   = hsc_lang
1640   where
1641         keep_hc = dopt Opt_KeepHcFiles dflags
1642         hsc_lang
1643                 -- don't change the lang if we're interpreting
1644                  | current_hsc_lang == HscInterpreted = current_hsc_lang
1645
1646                 -- force -fvia-C if we are being asked for a .hc file
1647                  | HCc <- stop = HscC
1648                  | keep_hc     = HscC
1649                 -- otherwise, stick to the plan
1650                  | otherwise = current_hsc_lang
1651
1652 GLOBAL_VAR(v_Split_info, ("",0), (String,Int))
1653         -- The split prefix and number of files