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