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