compiler/main/DriverPipeline.hs

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