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 = 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_s     = dopt Opt_KeepSFiles dflags
 589                 keep_bc    = dopt Opt_KeepLlvmFiles dflags
 590
 591                 myPhaseInputExt HCc    = hcsuf
 592                 myPhaseInputExt StopLn = osuf
 593                 myPhaseInputExt other  = phaseInputExt other
 594
 595                 is_last_phase = next_phase `eqPhase` stop_phase
 596
 597                 -- sometimes, we keep output from intermediate stages
 598                 keep_this_output =
 599                      case next_phase of
 600                              StopLn               -> True
 601                              As      | keep_s     -> True
 602                              LlvmOpt | keep_bc    -> True
 603                              HCc     | keep_hc    -> True
 604                              _other               -> False
 605
 606                 suffix = myPhaseInputExt next_phase
 607
 608                 -- persistent object files get put in odir
 609                 persistent_fn
 610                    | StopLn <- next_phase = return odir_persistent
 611                    | otherwise            = return persistent
 612
 613                 persistent = basename <.> suffix
 614
 615                 odir_persistent
 616                    | Just loc <- maybe_location = ml_obj_file loc
 617                    | Just d <- odir = d </> persistent
 618                    | otherwise      = persistent
 619
 620
 621 -- -----------------------------------------------------------------------------
 622 -- | Each phase in the pipeline returns the next phase to execute, and the
 623 -- name of the file in which the output was placed.
 624 --
 625 -- We must do things dynamically this way, because we often don't know
 626 -- what the rest of the phases will be until part-way through the
 627 -- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
 628 -- of a source file can change the latter stages of the pipeline from
 629 -- taking the via-C route to using the native code generator.
 630 --
 631 runPhase :: Phase       -- ^ Do this phase first
 632          -> Phase       -- ^ Stop just before this phase
 633          -> HscEnv
 634          -> String      -- ^ basename of original input source
 635          -> String      -- ^ its extension
 636          -> FilePath    -- ^ name of file which contains the input to this phase.
 637          -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
 638                         -- ^ how to calculate the output filename
 639          -> Maybe ModLocation           -- ^ the ModLocation, if we have one
 640          -> IO (Phase,                   -- next phase
 641                 DynFlags,                -- new dynamic flags
 642                 Maybe ModLocation,       -- the ModLocation, if we have one
 643                 FilePath)                -- output filename
 644
 645         -- Invariant: the output filename always contains the output
 646         -- Interesting case: Hsc when there is no recompilation to do
 647         --                   Then the output filename is still a .o file
 648
 649 -------------------------------------------------------------------------------
 650 -- Unlit phase
 651
 652 runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 653   = do
 654        let dflags = hsc_dflags hsc_env
 655        output_fn <- get_output_fn dflags (Cpp sf) maybe_loc
 656
 657        let unlit_flags = getOpts dflags opt_L
 658            flags = map SysTools.Option unlit_flags ++
 659                    [ -- The -h option passes the file name for unlit to
 660                      -- put in a #line directive
 661                      SysTools.Option     "-h"
 662                      -- cpp interprets \b etc as escape sequences,
 663                      -- so we use / for filenames in pragmas
 664                    , SysTools.Option $ reslash Forwards $ normalise input_fn
 665                    , SysTools.FileOption "" input_fn
 666                    , SysTools.FileOption "" output_fn
 667                    ]
 668
 669        SysTools.runUnlit dflags flags
 670
 671        return (Cpp sf, dflags, maybe_loc, output_fn)
 672
 673 -------------------------------------------------------------------------------
 674 -- Cpp phase : (a) gets OPTIONS out of file
 675 --             (b) runs cpp if necessary
 676
 677 runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 678   = do let dflags0 = hsc_dflags hsc_env
 679        src_opts <- getOptionsFromFile dflags0 input_fn
 680        (dflags1, unhandled_flags, warns)
 681            <- parseDynamicNoPackageFlags dflags0 src_opts
 682        checkProcessArgsResult unhandled_flags
 683
 684        if not (xopt Opt_Cpp dflags1) then do
 685            -- we have to be careful to emit warnings only once.
 686            unless (dopt Opt_Pp dflags1) $ handleFlagWarnings dflags1 warns
 687
 688            -- no need to preprocess CPP, just pass input file along
 689            -- to the next phase of the pipeline.
 690            return (HsPp sf, dflags1, maybe_loc, input_fn)
 691         else do
 692             output_fn <- get_output_fn dflags1 (HsPp sf) maybe_loc
 693             doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn
 694             -- re-read the pragmas now that we've preprocessed the file
 695             -- See #2464,#3457
 696             src_opts <- getOptionsFromFile dflags0 output_fn
 697             (dflags2, unhandled_flags, warns)
 698                 <- parseDynamicNoPackageFlags dflags0 src_opts
 699             unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns
 700             -- the HsPp pass below will emit warnings
 701             checkProcessArgsResult unhandled_flags
 702
 703             return (HsPp sf, dflags2, maybe_loc, output_fn)
 704
 705 -------------------------------------------------------------------------------
 706 -- HsPp phase
 707
 708 runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
 709   = do let dflags = hsc_dflags hsc_env
 710        if not (dopt Opt_Pp dflags) then
 711            -- no need to preprocess, just pass input file along
 712            -- to the next phase of the pipeline.
 713           return (Hsc sf, dflags, maybe_loc, input_fn)
 714         else do
 715             let hspp_opts = getOpts dflags opt_F
 716             let orig_fn = basename <.> suff
 717             output_fn <- get_output_fn dflags (Hsc sf) maybe_loc
 718             SysTools.runPp dflags
 719                            ( [ SysTools.Option     orig_fn
 720                              , SysTools.Option     input_fn
 721                              , SysTools.FileOption "" output_fn
 722                              ] ++
 723                              map SysTools.Option hspp_opts
 724                            )
 725
 726             -- re-read pragmas now that we've parsed the file (see #3674)
 727             src_opts <- getOptionsFromFile dflags output_fn
 728             (dflags1, unhandled_flags, warns)
 729                 <- parseDynamicNoPackageFlags dflags src_opts
 730             handleFlagWarnings dflags1 warns
 731             checkProcessArgsResult unhandled_flags
 732
 733             return (Hsc sf, dflags1, maybe_loc, output_fn)
 734
 735 -----------------------------------------------------------------------------
 736 -- Hsc phase
 737
 738 -- Compilation of a single module, in "legacy" mode (_not_ under
 739 -- the direction of the compilation manager).
 740 runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _maybe_loc
 741  = do   -- normal Hsc mode, not mkdependHS
 742         let dflags0 = hsc_dflags hsc_env
 743
 744   -- we add the current directory (i.e. the directory in which
 745   -- the .hs files resides) to the include path, since this is
 746   -- what gcc does, and it's probably what you want.
 747         let current_dir = case takeDirectory basename of
 748                       "" -> "." -- XXX Hack
 749                       d -> d
 750
 751             paths = includePaths dflags0
 752             dflags = dflags0 { includePaths = current_dir : paths }
 753
 754   -- gather the imports and module name
 755         (hspp_buf,mod_name,imps,src_imps) <-
 756             case src_flavour of
 757                 ExtCoreFile -> do  -- no explicit imports in ExtCore input.
 758                     m <- getCoreModuleName input_fn
 759                     return (Nothing, mkModuleName m, [], [])
 760
 761                 _           -> do
 762                     buf <- hGetStringBuffer input_fn
 763                     (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
 764                     return (Just buf, mod_name, imps, src_imps)
 765
 766   -- Build a ModLocation to pass to hscMain.
 767   -- The source filename is rather irrelevant by now, but it's used
 768   -- by hscMain for messages.  hscMain also needs
 769   -- the .hi and .o filenames, and this is as good a way
 770   -- as any to generate them, and better than most. (e.g. takes
 771   -- into accout the -osuf flags)
 772         location1 <- mkHomeModLocation2 dflags mod_name basename suff
 773
 774   -- Boot-ify it if necessary
 775         let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
 776                       | otherwise            = location1
 777
 778
 779   -- Take -ohi into account if present
 780   -- This can't be done in mkHomeModuleLocation because
 781   -- it only applies to the module being compiles
 782         let ohi = outputHi dflags
 783             location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
 784                       | otherwise      = location2
 785
 786   -- Take -o into account if present
 787   -- Very like -ohi, but we must *only* do this if we aren't linking
 788   -- (If we're linking then the -o applies to the linked thing, not to
 789   -- the object file for one module.)
 790   -- Note the nasty duplication with the same computation in compileFile above
 791         let expl_o_file = outputFile dflags
 792             location4 | Just ofile <- expl_o_file
 793                       , isNoLink (ghcLink dflags)
 794                       = location3 { ml_obj_file = ofile }
 795                       | otherwise = location3
 796
 797             o_file = ml_obj_file location4      -- The real object file
 798
 799
 800   -- Figure out if the source has changed, for recompilation avoidance.
 801   --
 802   -- Setting source_unchanged to True means that M.o seems
 803   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 804   -- changed (which the compiler itself figures out).
 805   -- Setting source_unchanged to False tells the compiler that M.o is out of
 806   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 807         src_timestamp <- getModificationTime (basename <.> suff)
 808
 809         let force_recomp = dopt Opt_ForceRecomp dflags
 810             hsc_lang = hscTarget dflags
 811         source_unchanged <-
 812           if force_recomp || not (isStopLn stop)
 813                 -- Set source_unchanged to False unconditionally if
 814                 --      (a) recompilation checker is off, or
 815                 --      (b) we aren't going all the way to .o file (e.g. ghc -S)
 816              then return False
 817                 -- Otherwise look at file modification dates
 818              else do o_file_exists <- doesFileExist o_file
 819                      if not o_file_exists
 820                         then return False       -- Need to recompile
 821                         else do t2 <- getModificationTime o_file
 822                                 if t2 > src_timestamp
 823                                   then return True
 824                                   else return False
 825
 826   -- get the DynFlags
 827         let next_phase = hscNextPhase dflags src_flavour hsc_lang
 828         output_fn  <- get_output_fn dflags next_phase (Just location4)
 829
 830         let dflags' = dflags { hscTarget = hsc_lang,
 831                                hscOutName = output_fn,
 832                                extCoreName = basename ++ ".hcr" }
 833
 834         let hsc_env' = hsc_env {hsc_dflags = dflags'}
 835
 836   -- Tell the finder cache about this module
 837         mod <- addHomeModuleToFinder hsc_env' mod_name location4
 838
 839   -- Make the ModSummary to hand to hscMain
 840         let
 841             mod_summary = ModSummary {  ms_mod       = mod,
 842                                         ms_hsc_src   = src_flavour,
 843                                         ms_hspp_file = input_fn,
 844                                         ms_hspp_opts = dflags,
 845                                         ms_hspp_buf  = hspp_buf,
 846                                         ms_location  = location4,
 847                                         ms_hs_date   = src_timestamp,
 848                                         ms_obj_date  = Nothing,
 849                                         ms_imps      = imps,
 850                                         ms_srcimps   = src_imps }
 851
 852   -- run the compiler!
 853         result <- hscCompileOneShot hsc_env'
 854                           mod_summary source_unchanged
 855                           Nothing       -- No iface
 856                           Nothing       -- No "module i of n" progress info
 857
 858         case result of
 859           HscNoRecomp
 860               -> do SysTools.touch dflags' "Touching object file" o_file
 861                     -- The .o file must have a later modification date
 862                     -- than the source file (else we wouldn't be in HscNoRecomp)
 863                     -- but we touch it anyway, to keep 'make' happy (we think).
 864                     return (StopLn, dflags', Just location4, o_file)
 865           (HscRecomp hasStub _)
 866               -> do when hasStub $
 867                          do stub_o <- compileStub hsc_env' mod location4
 868                             liftIO $ consIORef v_Ld_inputs stub_o
 869                     -- In the case of hs-boot files, generate a dummy .o-boot
 870                     -- stamp file for the benefit of Make
 871                     when (isHsBoot src_flavour) $
 872                       SysTools.touch dflags' "Touching object file" o_file
 873                     return (next_phase, dflags', Just location4, output_fn)
 874
 875 -----------------------------------------------------------------------------
 876 -- Cmm phase
 877
 878 runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 879   = do
 880        let dflags = hsc_dflags hsc_env
 881        output_fn <- get_output_fn dflags Cmm maybe_loc
 882        doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn
 883        return (Cmm, dflags, maybe_loc, output_fn)
 884
 885 runPhase Cmm _ hsc_env basename _ input_fn get_output_fn maybe_loc
 886   = do
 887         let dflags = hsc_dflags hsc_env
 888         let hsc_lang = hscTarget dflags
 889         let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
 890         output_fn <- get_output_fn dflags next_phase maybe_loc
 891
 892         let dflags' = dflags { hscTarget = hsc_lang,
 893                                hscOutName = output_fn,
 894                                extCoreName = basename ++ ".hcr" }
 895         let hsc_env' = hsc_env {hsc_dflags = dflags'}
 896
 897         hscCompileCmmFile hsc_env' input_fn
 898
 899         -- XXX: catch errors above and convert them into ghcError?  Original
 900         -- code was:
 901         --
 902         --when (not ok) $ ghcError (PhaseFailed "cmm" (ExitFailure 1))
 903
 904         return (next_phase, dflags, maybe_loc, output_fn)
 905
 906 -----------------------------------------------------------------------------
 907 -- Cc phase
 908
 909 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 910 -- way too many hacks, and I can't say I've ever used it anyway.
 911
 912 runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 913    | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc
 914    = do let dflags = hsc_dflags hsc_env
 915         let cc_opts = getOpts dflags opt_c
 916             hcc = cc_phase `eqPhase` HCc
 917
 918         let cmdline_include_paths = includePaths dflags
 919
 920         -- HC files have the dependent packages stamped into them
 921         pkgs <- if hcc then getHCFilePackages input_fn else return []
 922
 923         -- add package include paths even if we're just compiling .c
 924         -- files; this is the Value Add(TM) that using ghc instead of
 925         -- gcc gives you :)
 926         pkg_include_dirs <- getPackageIncludePath dflags pkgs
 927         let include_paths = foldr (\ x xs -> "-I" : x : xs) []
 928                               (cmdline_include_paths ++ pkg_include_dirs)
 929
 930         let md_c_flags = machdepCCOpts dflags
 931         gcc_extra_viac_flags <- getExtraViaCOpts dflags
 932         let pic_c_flags = picCCOpts dflags
 933
 934         let verb = getVerbFlag dflags
 935
 936         -- cc-options are not passed when compiling .hc files.  Our
 937         -- hc code doesn't not #include any header files anyway, so these
 938         -- options aren't necessary.
 939         pkg_extra_cc_opts <-
 940           if cc_phase `eqPhase` HCc
 941              then return []
 942              else getPackageExtraCcOpts dflags pkgs
 943
 944 #ifdef darwin_TARGET_OS
 945         pkg_framework_paths <- getPackageFrameworkPath dflags pkgs
 946         let cmdline_framework_paths = frameworkPaths dflags
 947         let framework_paths = map ("-F"++)
 948                         (cmdline_framework_paths ++ pkg_framework_paths)
 949 #endif
 950
 951         let split_objs = dopt Opt_SplitObjs dflags
 952             split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 953                       | otherwise         = [ ]
 954
 955         let cc_opt | optLevel dflags >= 2 = "-O2"
 956                    | otherwise            = "-O"
 957
 958         -- Decide next phase
 959
 960         let next_phase = As
 961         output_fn <- get_output_fn dflags next_phase maybe_loc
 962
 963         let
 964           more_hcc_opts =
 965 #if i386_TARGET_ARCH
 966                 -- on x86 the floating point regs have greater precision
 967                 -- than a double, which leads to unpredictable results.
 968                 -- By default, we turn this off with -ffloat-store unless
 969                 -- the user specified -fexcess-precision.
 970                 (if dopt Opt_ExcessPrecision dflags
 971                         then []
 972                         else [ "-ffloat-store" ]) ++
 973 #endif
 974
 975                 -- gcc's -fstrict-aliasing allows two accesses to memory
 976                 -- to be considered non-aliasing if they have different types.
 977                 -- This interacts badly with the C code we generate, which is
 978                 -- very weakly typed, being derived from C--.
 979                 ["-fno-strict-aliasing"]
 980
 981         SysTools.runCc dflags (
 982                 -- force the C compiler to interpret this file as C when
 983                 -- compiling .hc files, by adding the -x c option.
 984                 -- Also useful for plain .c files, just in case GHC saw a
 985                 -- -x c option.
 986                         [ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp
 987                                                 then SysTools.Option "c++"
 988                                                 else SysTools.Option "c"] ++
 989                         [ SysTools.FileOption "" input_fn
 990                         , SysTools.Option "-o"
 991                         , SysTools.FileOption "" output_fn
 992                         ]
 993                        ++ map SysTools.Option (
 994                           md_c_flags
 995                        ++ pic_c_flags
 996
 997 #if    defined(mingw32_TARGET_OS)
 998                 -- Stub files generated for foreign exports references the runIO_closure
 999                 -- and runNonIO_closure symbols, which are defined in the base package.
1000                 -- These symbols are imported into the stub.c file via RtsAPI.h, and the
1001                 -- way we do the import depends on whether we're currently compiling
1002                 -- the base package or not.
1003                        ++ (if thisPackage dflags == basePackageId
1004                                 then [ "-DCOMPILING_BASE_PACKAGE" ]
1005                                 else [])
1006 #endif
1007
1008 #ifdef sparc_TARGET_ARCH
1009         -- We only support SparcV9 and better because V8 lacks an atomic CAS
1010         -- instruction. Note that the user can still override this
1011         -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
1012         -- regardless of the ordering.
1013         --
1014         -- This is a temporary hack.
1015                        ++ ["-mcpu=v9"]
1016 #endif
1017                        ++ (if hcc
1018                              then gcc_extra_viac_flags ++ more_hcc_opts
1019                              else [])
1020                        ++ [ verb, "-S", "-Wimplicit", cc_opt ]
1021                        ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
1022 #ifdef darwin_TARGET_OS
1023                        ++ framework_paths
1024 #endif
1025                        ++ cc_opts
1026                        ++ split_opt
1027                        ++ include_paths
1028                        ++ pkg_extra_cc_opts
1029                        ))
1030
1031         return (next_phase, dflags, maybe_loc, output_fn)
1032
1033         -- ToDo: postprocess the output from gcc
1034
1035 -----------------------------------------------------------------------------
1036 -- Splitting phase
1037
1038 runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc
1039   = do  -- tmp_pfx is the prefix used for the split .s files
1040         -- We also use it as the file to contain the no. of split .s files (sigh)
1041         let dflags = hsc_dflags hsc_env
1042         split_s_prefix <- SysTools.newTempName dflags "split"
1043         let n_files_fn = split_s_prefix
1044
1045         SysTools.runSplit dflags
1046                           [ SysTools.FileOption "" input_fn
1047                           , SysTools.FileOption "" split_s_prefix
1048                           , SysTools.FileOption "" n_files_fn
1049                           ]
1050
1051         -- Save the number of split files for future references
1052         s <- readFile n_files_fn
1053         let n_files = read s :: Int
1054             dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) }
1055
1056         -- Remember to delete all these files
1057         addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s"
1058                                 | n <- [1..n_files]]
1059
1060         return (SplitAs, dflags', maybe_loc, "**splitmangle**")
1061           -- we don't use the filename
1062
1063 -----------------------------------------------------------------------------
1064 -- As phase
1065
1066 runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
1067   = do  let dflags = hsc_dflags hsc_env
1068         let as_opts =  getOpts dflags opt_a
1069         let cmdline_include_paths = includePaths dflags
1070
1071         output_fn <- get_output_fn dflags StopLn maybe_loc
1072
1073         -- we create directories for the object file, because it
1074         -- might be a hierarchical module.
1075         createDirectoryHierarchy (takeDirectory output_fn)
1076
1077         let md_c_flags = machdepCCOpts dflags
1078         SysTools.runAs dflags
1079                        (map SysTools.Option as_opts
1080                        ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
1081 #ifdef sparc_TARGET_ARCH
1082         -- We only support SparcV9 and better because V8 lacks an atomic CAS
1083         -- instruction so we have to make sure that the assembler accepts the
1084         -- instruction set. Note that the user can still override this
1085         -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1086         -- regardless of the ordering.
1087         --
1088         -- This is a temporary hack.
1089                        ++ [ SysTools.Option "-mcpu=v9" ]
1090 #endif
1091                        ++ [ SysTools.Option "-c"
1092                           , SysTools.FileOption "" input_fn
1093                           , SysTools.Option "-o"
1094                           , SysTools.FileOption "" output_fn
1095                           ]
1096                        ++ map SysTools.Option md_c_flags)
1097
1098         return (StopLn, dflags, maybe_loc, output_fn)
1099
1100
1101 runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc
1102   = do
1103         let dflags = hsc_dflags hsc_env
1104         output_fn <- get_output_fn dflags StopLn maybe_loc
1105
1106         let base_o = dropExtension output_fn
1107             osuf = objectSuf dflags
1108             split_odir  = base_o ++ "_" ++ osuf ++ "_split"
1109
1110         createDirectoryHierarchy split_odir
1111
1112         -- remove M_split/ *.o, because we're going to archive M_split/ *.o
1113         -- later and we don't want to pick up any old objects.
1114         fs <- getDirectoryContents split_odir
1115         mapM_ removeFile $ map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
1116
1117         let as_opts = getOpts dflags opt_a
1118
1119         let (split_s_prefix, n) = case splitInfo dflags of
1120                                   Nothing -> panic "No split info"
1121                                   Just x -> x
1122
1123         let split_s   n = split_s_prefix ++ "__" ++ show n <.> "s"
1124             split_obj n = split_odir </>
1125                           takeFileName base_o ++ "__" ++ show n <.> osuf
1126
1127         let md_c_flags = machdepCCOpts dflags
1128         let assemble_file n
1129               = SysTools.runAs dflags
1130                          (map SysTools.Option as_opts ++
1131 #ifdef sparc_TARGET_ARCH
1132         -- We only support SparcV9 and better because V8 lacks an atomic CAS
1133         -- instruction so we have to make sure that the assembler accepts the
1134         -- instruction set. Note that the user can still override this
1135         -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1136         -- regardless of the ordering.
1137         --
1138         -- This is a temporary hack.
1139                           [ SysTools.Option "-mcpu=v9" ] ++
1140 #endif
1141                           [ SysTools.Option "-c"
1142                           , SysTools.Option "-o"
1143                           , SysTools.FileOption "" (split_obj n)
1144                           , SysTools.FileOption "" (split_s n)
1145                           ]
1146                        ++ map SysTools.Option md_c_flags)
1147
1148         mapM_ assemble_file [1..n]
1149
1150         -- join them into a single .o file
1151         joinObjectFiles dflags (map split_obj [1..n]) output_fn
1152
1153         return (StopLn, dflags, maybe_loc, output_fn)
1154
1155 -----------------------------------------------------------------------------
1156 -- LlvmOpt phase
1157
1158 runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
1159   = do
1160     let dflags  = hsc_dflags hsc_env
1161     let lo_opts = getOpts dflags opt_lo
1162     let opt_lvl = max 0 (min 2 $ optLevel dflags)
1163     -- don't specify anything if user has specified commands. We do this for
1164     -- opt but not llc since opt is very specifically for optimisation passes
1165     -- only, so if the user is passing us extra options we assume they know
1166     -- what they are doing and don't get in the way.
1167     let optFlag = if null lo_opts
1168                      then [SysTools.Option (llvmOpts !! opt_lvl)]
1169                      else []
1170
1171     output_fn <- get_output_fn dflags LlvmLlc maybe_loc
1172
1173     SysTools.runLlvmOpt dflags
1174                ([ SysTools.FileOption "" input_fn,
1175                     SysTools.Option "-o",
1176                     SysTools.FileOption "" output_fn]
1177                 ++ optFlag
1178                 ++ map SysTools.Option lo_opts)
1179
1180     return (LlvmLlc, dflags, maybe_loc, output_fn)
1181   where
1182         -- we always (unless -optlo specified) run Opt since we rely on it to
1183         -- fix up some pretty big deficiencies in the code we generate
1184         llvmOpts = ["-mem2reg", "-O1", "-O2"]
1185
1186
1187 -----------------------------------------------------------------------------
1188 -- LlvmLlc phase
1189
1190 runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
1191   = do
1192     let dflags  = hsc_dflags hsc_env
1193     let lc_opts = getOpts dflags opt_lc
1194     let opt_lvl = max 0 (min 2 $ optLevel dflags)
1195 #if darwin_TARGET_OS
1196     let nphase = LlvmMangle
1197 #else
1198     let nphase = As
1199 #endif
1200     let rmodel | opt_PIC        = "pic"
1201                | not opt_Static = "dynamic-no-pic"
1202                | otherwise      = "static"
1203
1204     output_fn <- get_output_fn dflags nphase maybe_loc
1205
1206     SysTools.runLlvmLlc dflags
1207                 ([ SysTools.Option (llvmOpts !! opt_lvl),
1208                     SysTools.Option $ "-relocation-model=" ++ rmodel,
1209                     SysTools.FileOption "" input_fn,
1210                     SysTools.Option "-o", SysTools.FileOption "" output_fn]
1211                 ++ map SysTools.Option lc_opts)
1212
1213     return (nphase, dflags, maybe_loc, output_fn)
1214   where
1215 #if darwin_TARGET_OS
1216         llvmOpts = ["-O1", "-O2", "-O2"]
1217 #else
1218         llvmOpts = ["-O1", "-O2", "-O3"]
1219 #endif
1220
1221
1222 -----------------------------------------------------------------------------
1223 -- LlvmMangle phase
1224
1225 runPhase LlvmMangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
1226   = do
1227     let dflags = hsc_dflags hsc_env
1228     output_fn <- get_output_fn dflags As maybe_loc
1229     llvmFixupAsm input_fn output_fn
1230     return (As, dflags, maybe_loc, output_fn)
1231
1232
1233 -- warning suppression
1234 runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc =
1235    panic ("runPhase: don't know how to run phase " ++ show other)
1236 -----------------------------------------------------------------------------
1237 -- MoveBinary sort-of-phase
1238 -- After having produced a binary, move it somewhere else and generate a
1239 -- wrapper script calling the binary. Currently, we need this only in
1240 -- a parallel way (i.e. in GUM), because PVM expects the binary in a
1241 -- central directory.
1242 -- This is called from linkBinary below, after linking. I haven't made it
1243 -- a separate phase to minimise interfering with other modules, and
1244 -- we don't need the generality of a phase (MoveBinary is always
1245 -- done after linking and makes only sense in a parallel setup)   -- HWL
1246
1247 runPhase_MoveBinary :: DynFlags -> FilePath -> IO Bool
1248 runPhase_MoveBinary dflags input_fn
1249     | WayPar `elem` (wayNames dflags) && not opt_Static =
1250         panic ("Don't know how to combine PVM wrapper and dynamic wrapper")
1251     | WayPar `elem` (wayNames dflags) = do
1252         let sysMan = pgm_sysman dflags
1253         pvm_root <- getEnv "PVM_ROOT"
1254         pvm_arch <- getEnv "PVM_ARCH"
1255         let
1256            pvm_executable_base = "=" ++ input_fn
1257            pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
1258         -- nuke old binary; maybe use configur'ed names for cp and rm?
1259         _ <- tryIO (removeFile pvm_executable)
1260         -- move the newly created binary into PVM land
1261         copy dflags "copying PVM executable" input_fn pvm_executable
1262         -- generate a wrapper script for running a parallel prg under PVM
1263         writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
1264         return True
1265     | otherwise = return True
1266
1267 mkExtraCObj :: DynFlags -> [String] -> IO FilePath
1268 mkExtraCObj dflags xs
1269  = do cFile <- newTempName dflags "c"
1270       oFile <- newTempName dflags "o"
1271       writeFile cFile $ unlines xs
1272       let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId
1273           md_c_flags = machdepCCOpts dflags
1274       SysTools.runCc dflags
1275                      ([Option        "-c",
1276                        FileOption "" cFile,
1277                        Option        "-o",
1278                        FileOption "" oFile] ++
1279                       map (FileOption "-I") (includeDirs rtsDetails) ++
1280                       map Option md_c_flags)
1281       return oFile
1282
1283 mkRtsOptionsLevelObj :: DynFlags -> IO [FilePath]
1284 mkRtsOptionsLevelObj dflags
1285  = do let mkRtsEnabledObj val
1286               = do fn <- mkExtraCObj dflags
1287                              ["#include \"Rts.h\"",
1288                               "#include \"RtsOpts.h\"",
1289                               "const rtsOptsEnabledEnum rtsOptsEnabled = "
1290                                   ++ val ++ ";"]
1291                    return [fn]
1292       case rtsOptsEnabled dflags of
1293           RtsOptsNone     -> mkRtsEnabledObj "rtsOptsNone"
1294           RtsOptsSafeOnly -> return [] -- The default
1295           RtsOptsAll      -> mkRtsEnabledObj "rtsOptsAll"
1296
1297 -- generates a Perl skript starting a parallel prg under PVM
1298 mk_pvm_wrapper_script :: String -> String -> String -> String
1299 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
1300  [
1301   "eval 'exec perl -S $0 ${1+\"$@\"}'",
1302   "  if $running_under_some_shell;",
1303   "# =!=!=!=!=!=!=!=!=!=!=!",
1304   "# This script is automatically generated: DO NOT EDIT!!!",
1305   "# Generated by Glasgow Haskell Compiler",
1306   "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
1307   "#",
1308   "$pvm_executable      = '" ++ pvm_executable ++ "';",
1309   "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
1310   "$SysMan = '" ++ sysMan ++ "';",
1311   "",
1312   {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
1313   "# first, some magical shortcuts to run "commands" on the binary",
1314   "# (which is hidden)",
1315   "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
1316   "    local($cmd) = $1;",
1317   "    system("$cmd $pvm_executable");",
1318   "    exit(0); # all done",
1319   "}", -}
1320   "",
1321   "# Now, run the real binary; process the args first",
1322   "$ENV{'PE'} = $pvm_executable_base;", --  ++ pvm_executable_base,
1323   "$debug = '';",
1324   "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
1325   "@nonPVM_args = ();",
1326   "$in_RTS_args = 0;",
1327   "",
1328   "args: while ($a = shift(@ARGV)) {",
1329   "    if ( $a eq '+RTS' ) {",
1330   "        $in_RTS_args = 1;",
1331   "    } elsif ( $a eq '-RTS' ) {",
1332   "        $in_RTS_args = 0;",
1333   "    }",
1334   "    if ( $a eq '-d' && $in_RTS_args ) {",
1335   "        $debug = '-';",
1336   "    } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
1337   "        $nprocessors = $1;",
1338   "    } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
1339   "        $nprocessors = $1;",
1340   "    } else {",
1341   "        push(@nonPVM_args, $a);",
1342   "    }",
1343   "}",
1344   "",
1345   "local($return_val) = 0;",
1346   "# Start the parallel execution by calling SysMan",
1347   "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
1348   "$return_val = $?;",
1349   "# ToDo: fix race condition moving files and flushing them!!",
1350   "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
1351   "exit($return_val);"
1352  ]
1353
1354 -----------------------------------------------------------------------------
1355 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
1356
1357 getHCFilePackages :: FilePath -> IO [PackageId]
1358 getHCFilePackages filename =
1359   Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
1360     l <- hGetLine h
1361     case l of
1362       '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
1363           return (map stringToPackageId (words rest))
1364       _other ->
1365           return []
1366
1367 -----------------------------------------------------------------------------
1368 -- Static linking, of .o files
1369
1370 -- The list of packages passed to link is the list of packages on
1371 -- which this program depends, as discovered by the compilation
1372 -- manager.  It is combined with the list of packages that the user
1373 -- specifies on the command line with -package flags.
1374 --
1375 -- In one-shot linking mode, we can't discover the package
1376 -- dependencies (because we haven't actually done any compilation or
1377 -- read any interface files), so the user must explicitly specify all
1378 -- the packages.
1379
1380 linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO ()
1381 linkBinary dflags o_files dep_packages = do
1382     let verb = getVerbFlag dflags
1383         output_fn = exeFileName dflags
1384
1385     -- get the full list of packages to link with, by combining the
1386     -- explicit packages with the auto packages and all of their
1387     -- dependencies, and eliminating duplicates.
1388
1389     pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1390     let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths)
1391 #ifdef elf_OBJ_FORMAT
1392         get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1393                                 | otherwise = ["-L" ++ l]
1394 #else
1395         get_pkg_lib_path_opts l = ["-L" ++ l]
1396 #endif
1397
1398     let lib_paths = libraryPaths dflags
1399     let lib_path_opts = map ("-L"++) lib_paths
1400
1401     -- The C "main" function is not in the rts but in a separate static
1402     -- library libHSrtsmain.a that sits next to the rts lib files. Assuming
1403     -- we're using a Haskell main function then we need to link it in.
1404     let no_hs_main = dopt Opt_NoHsMain dflags
1405     let main_lib | no_hs_main = []
1406                  | otherwise  = [ "-lHSrtsmain" ]
1407     rtsEnabledObj <- mkRtsOptionsLevelObj dflags
1408     rtsOptsObj <- case rtsOpts dflags of
1409                   Just opts ->
1410                       do fn <- mkExtraCObj dflags
1411                                  -- We assume that the Haskell "show" does
1412                                  -- the right thing here
1413                                  ["char *ghc_rts_opts = " ++ show opts ++ ";"]
1414                          return [fn]
1415                   Nothing -> return []
1416
1417     pkg_link_opts <- getPackageLinkOpts dflags dep_packages
1418
1419 #ifdef darwin_TARGET_OS
1420     pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
1421     let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths
1422
1423     let framework_paths = frameworkPaths dflags
1424         framework_path_opts = map ("-F"++) framework_paths
1425
1426     pkg_frameworks <- getPackageFrameworks dflags dep_packages
1427     let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1428
1429     let frameworks = cmdlineFrameworks dflags
1430         framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ]
1431          -- reverse because they're added in reverse order from the cmd line
1432 #endif
1433         -- probably _stub.o files
1434     extra_ld_inputs <- readIORef v_Ld_inputs
1435
1436         -- opts from -optl-<blah> (including -l<blah> options)
1437     let extra_ld_opts = getOpts dflags opt_l
1438
1439     let ways = wayNames dflags
1440
1441     -- Here are some libs that need to be linked at the *end* of
1442     -- the command line, because they contain symbols that are referred to
1443     -- by the RTS.  We can't therefore use the ordinary way opts for these.
1444     let
1445         debug_opts | WayDebug `elem` ways = [
1446 #if defined(HAVE_LIBBFD)
1447                         "-lbfd", "-liberty"
1448 #endif
1449                          ]
1450                    | otherwise            = []
1451
1452     let
1453         thread_opts | WayThreaded `elem` ways = [
1454 #if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS) && !defined(openbsd_TARGET_OS) && !defined(haiku_TARGET_OS)
1455                         "-lpthread"
1456 #endif
1457 #if defined(osf3_TARGET_OS)
1458                         , "-lexc"
1459 #endif
1460                         ]
1461                     | otherwise               = []
1462
1463     rc_objs <- maybeCreateManifest dflags output_fn
1464
1465     let md_c_flags = machdepCCOpts dflags
1466     SysTools.runLink dflags (
1467                        [ SysTools.Option verb
1468                        , SysTools.Option "-o"
1469                        , SysTools.FileOption "" output_fn
1470                        ]
1471                       ++ map SysTools.Option (
1472                          md_c_flags
1473
1474 #ifdef mingw32_TARGET_OS
1475                       -- Permit the linker to auto link _symbol to _imp_symbol.
1476                       -- This lets us link against DLLs without needing an "import library".
1477                       ++ ["-Wl,--enable-auto-import"]
1478 #endif
1479                       ++ o_files
1480                       ++ extra_ld_inputs
1481                       ++ lib_path_opts
1482                       ++ extra_ld_opts
1483                       ++ rc_objs
1484 #ifdef darwin_TARGET_OS
1485                       ++ framework_path_opts
1486                       ++ framework_opts
1487 #endif
1488                       ++ pkg_lib_path_opts
1489                       ++ main_lib
1490                       ++ rtsEnabledObj
1491                       ++ rtsOptsObj
1492                       ++ pkg_link_opts
1493 #ifdef darwin_TARGET_OS
1494                       ++ pkg_framework_path_opts
1495                       ++ pkg_framework_opts
1496 #endif
1497                       ++ debug_opts
1498                       ++ thread_opts
1499                     ))
1500
1501     -- parallel only: move binary to another dir -- HWL
1502     success <- runPhase_MoveBinary dflags output_fn
1503     if success then return ()
1504                else ghcError (InstallationError ("cannot move binary"))
1505
1506
1507 exeFileName :: DynFlags -> FilePath
1508 exeFileName dflags
1509   | Just s <- outputFile dflags =
1510 #if defined(mingw32_HOST_OS)
1511       if null (takeExtension s)
1512         then s <.> "exe"
1513         else s
1514 #else
1515       s
1516 #endif
1517   | otherwise =
1518 #if defined(mingw32_HOST_OS)
1519         "main.exe"
1520 #else
1521         "a.out"
1522 #endif
1523
1524 maybeCreateManifest
1525    :: DynFlags
1526    -> FilePath                          -- filename of executable
1527    -> IO [FilePath]                     -- extra objects to embed, maybe
1528 #ifndef mingw32_TARGET_OS
1529 maybeCreateManifest _ _ = do
1530   return []
1531 #else
1532 maybeCreateManifest dflags exe_filename = do
1533   if not (dopt Opt_GenManifest dflags) then return [] else do
1534
1535   let manifest_filename = exe_filename <.> "manifest"
1536
1537   writeFile manifest_filename $
1538       "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
1539       "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
1540       "  <assemblyIdentity version=\"1.0.0.0\"\n"++
1541       "     processorArchitecture=\"X86\"\n"++
1542       "     name=\"" ++ dropExtension exe_filename ++ "\"\n"++
1543       "     type=\"win32\"/>\n\n"++
1544       "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
1545       "    <security>\n"++
1546       "      <requestedPrivileges>\n"++
1547       "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
1548       "        </requestedPrivileges>\n"++
1549       "       </security>\n"++
1550       "  </trustInfo>\n"++
1551       "</assembly>\n"
1552
1553   -- Windows will find the manifest file if it is named foo.exe.manifest.
1554   -- However, for extra robustness, and so that we can move the binary around,
1555   -- we can embed the manifest in the binary itself using windres:
1556   if not (dopt Opt_EmbedManifest dflags) then return [] else do
1557
1558   rc_filename <- newTempName dflags "rc"
1559   rc_obj_filename <- newTempName dflags (objectSuf dflags)
1560
1561   writeFile rc_filename $
1562       "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
1563         -- magic numbers :-)
1564         -- show is a bit hackish above, but we need to escape the
1565         -- backslashes in the path.
1566
1567   let wr_opts = getOpts dflags opt_windres
1568   runWindres dflags $ map SysTools.Option $
1569         ["--input="++rc_filename,
1570          "--output="++rc_obj_filename,
1571          "--output-format=coff"]
1572         ++ wr_opts
1573         -- no FileOptions here: windres doesn't like seeing
1574         -- backslashes, apparently
1575
1576   removeFile manifest_filename
1577
1578   return [rc_obj_filename]
1579 #endif
1580
1581
1582 linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
1583 linkDynLib dflags o_files dep_packages = do
1584     let verb = getVerbFlag dflags
1585     let o_file = outputFile dflags
1586
1587     pkgs <- getPreloadPackagesAnd dflags dep_packages
1588
1589     let pkg_lib_paths = collectLibraryPaths pkgs
1590     let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths
1591 #ifdef elf_OBJ_FORMAT
1592         get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1593                                 | otherwise = ["-L" ++ l]
1594 #else
1595         get_pkg_lib_path_opts l = ["-L" ++ l]
1596 #endif
1597
1598     let lib_paths = libraryPaths dflags
1599     let lib_path_opts = map ("-L"++) lib_paths
1600
1601     -- We don't want to link our dynamic libs against the RTS package,
1602     -- because the RTS lib comes in several flavours and we want to be
1603     -- able to pick the flavour when a binary is linked.
1604     -- On Windows we need to link the RTS import lib as Windows does
1605     -- not allow undefined symbols.
1606     -- The RTS library path is still added to the library search path
1607     -- above in case the RTS is being explicitly linked in (see #3807).
1608 #if !defined(mingw32_HOST_OS)
1609     let pkgs_no_rts = filter ((/= rtsPackageId) . packageConfigId) pkgs
1610 #else
1611     let pkgs_no_rts = pkgs
1612 #endif
1613     let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts
1614
1615         -- probably _stub.o files
1616     extra_ld_inputs <- readIORef v_Ld_inputs
1617
1618     let md_c_flags = machdepCCOpts dflags
1619     let extra_ld_opts = getOpts dflags opt_l
1620
1621     rtsEnabledObj <- mkRtsOptionsLevelObj dflags
1622
1623 #if defined(mingw32_HOST_OS)
1624     -----------------------------------------------------------------------------
1625     -- Making a DLL
1626     -----------------------------------------------------------------------------
1627     let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
1628
1629     SysTools.runLink dflags
1630          ([ SysTools.Option verb
1631           , SysTools.Option "-o"
1632           , SysTools.FileOption "" output_fn
1633           , SysTools.Option "-shared"
1634           ] ++
1635           [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
1636           | dopt Opt_SharedImplib dflags
1637           ]
1638          ++ map (SysTools.FileOption "") o_files
1639          ++ map SysTools.Option (
1640             md_c_flags
1641
1642          -- Permit the linker to auto link _symbol to _imp_symbol
1643          -- This lets us link against DLLs without needing an "import library"
1644          ++ ["-Wl,--enable-auto-import"]
1645
1646          ++ extra_ld_inputs
1647          ++ lib_path_opts
1648          ++ extra_ld_opts
1649          ++ pkg_lib_path_opts
1650          ++ rtsEnabledObj
1651          ++ pkg_link_opts
1652         ))
1653 #elif defined(darwin_TARGET_OS)
1654     -----------------------------------------------------------------------------
1655     -- Making a darwin dylib
1656     -----------------------------------------------------------------------------
1657     -- About the options used for Darwin:
1658     -- -dynamiclib
1659     --   Apple's way of saying -shared
1660     -- -undefined dynamic_lookup:
1661     --   Without these options, we'd have to specify the correct dependencies
1662     --   for each of the dylibs. Note that we could (and should) do without this
1663     --   for all libraries except the RTS; all we need to do is to pass the
1664     --   correct HSfoo_dyn.dylib files to the link command.
1665     --   This feature requires Mac OS X 10.3 or later; there is a similar feature,
1666     --   -flat_namespace -undefined suppress, which works on earlier versions,
1667     --   but it has other disadvantages.
1668     -- -single_module
1669     --   Build the dynamic library as a single "module", i.e. no dynamic binding
1670     --   nonsense when referring to symbols from within the library. The NCG
1671     --   assumes that this option is specified (on i386, at least).
1672     -- -install_name
1673     --   Mac OS/X stores the path where a dynamic library is (to be) installed
1674     --   in the library itself.  It's called the "install name" of the library.
1675     --   Then any library or executable that links against it before it's
1676     --   installed will search for it in its ultimate install location.  By
1677     --   default we set the install name to the absolute path at build time, but
1678     --   it can be overridden by the -dylib-install-name option passed to ghc.
1679     --   Cabal does this.
1680     -----------------------------------------------------------------------------
1681
1682     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1683
1684     instName <- case dylibInstallName dflags of
1685         Just n -> return n
1686         Nothing -> do
1687             pwd <- getCurrentDirectory
1688             return $ pwd `combine` output_fn
1689     SysTools.runLink dflags
1690          ([ SysTools.Option verb
1691           , SysTools.Option "-dynamiclib"
1692           , SysTools.Option "-o"
1693           , SysTools.FileOption "" output_fn
1694           ]
1695          ++ map SysTools.Option (
1696             md_c_flags
1697          ++ o_files
1698          ++ [ "-undefined", "dynamic_lookup", "-single_module",
1699 #if !defined(x86_64_TARGET_ARCH)
1700               "-Wl,-read_only_relocs,suppress",
1701 #endif
1702               "-install_name", instName ]
1703          ++ extra_ld_inputs
1704          ++ lib_path_opts
1705          ++ extra_ld_opts
1706          ++ pkg_lib_path_opts
1707          ++ rtsEnabledObj
1708          ++ pkg_link_opts
1709         ))
1710 #else
1711     -----------------------------------------------------------------------------
1712     -- Making a DSO
1713     -----------------------------------------------------------------------------
1714
1715     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1716     let buildingRts = thisPackage dflags == rtsPackageId
1717     let bsymbolicFlag = if buildingRts
1718                         then -- -Bsymbolic breaks the way we implement
1719                              -- hooks in the RTS
1720                              []
1721                         else -- we need symbolic linking to resolve
1722                              -- non-PIC intra-package-relocations
1723                              ["-Wl,-Bsymbolic"]
1724
1725     SysTools.runLink dflags
1726          ([ SysTools.Option verb
1727           , SysTools.Option "-o"
1728           , SysTools.FileOption "" output_fn
1729           ]
1730          ++ map SysTools.Option (
1731             md_c_flags
1732          ++ o_files
1733          ++ [ "-shared" ]
1734          ++ bsymbolicFlag
1735             -- Set the library soname. We use -h rather than -soname as
1736             -- Solaris 10 doesn't support the latter:
1737          ++ [ "-Wl,-h," ++ takeFileName output_fn ]
1738          ++ extra_ld_inputs
1739          ++ lib_path_opts
1740          ++ extra_ld_opts
1741          ++ pkg_lib_path_opts
1742          ++ rtsEnabledObj
1743          ++ pkg_link_opts
1744         ))
1745 #endif
1746 -- -----------------------------------------------------------------------------
1747 -- Running CPP
1748
1749 doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO ()
1750 doCpp dflags raw include_cc_opts input_fn output_fn = do
1751     let hscpp_opts = getOpts dflags opt_P
1752     let cmdline_include_paths = includePaths dflags
1753
1754     pkg_include_dirs <- getPackageIncludePath dflags []
1755     let include_paths = foldr (\ x xs -> "-I" : x : xs) []
1756                           (cmdline_include_paths ++ pkg_include_dirs)
1757
1758     let verb = getVerbFlag dflags
1759
1760     let cc_opts
1761           | not include_cc_opts = []
1762           | otherwise           = (optc ++ md_c_flags)
1763                 where
1764                       optc = getOpts dflags opt_c
1765                       md_c_flags = machdepCCOpts dflags
1766
1767     let cpp_prog args | raw       = SysTools.runCpp dflags args
1768                       | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
1769
1770     let target_defs =
1771           [ "-D" ++ HOST_OS     ++ "_BUILD_OS=1",
1772             "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH=1",
1773             "-D" ++ TARGET_OS   ++ "_HOST_OS=1",
1774             "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ]
1775         -- remember, in code we *compile*, the HOST is the same our TARGET,
1776         -- and BUILD is the same as our HOST.
1777
1778     cpp_prog       ([SysTools.Option verb]
1779                     ++ map SysTools.Option include_paths
1780                     ++ map SysTools.Option hsSourceCppOpts
1781                     ++ map SysTools.Option target_defs
1782                     ++ map SysTools.Option hscpp_opts
1783                     ++ map SysTools.Option cc_opts
1784                     ++ [ SysTools.Option     "-x"
1785                        , SysTools.Option     "c"
1786                        , SysTools.Option     input_fn
1787         -- We hackily use Option instead of FileOption here, so that the file
1788         -- name is not back-slashed on Windows.  cpp is capable of
1789         -- dealing with / in filenames, so it works fine.  Furthermore
1790         -- if we put in backslashes, cpp outputs #line directives
1791         -- with *double* backslashes.   And that in turn means that
1792         -- our error messages get double backslashes in them.
1793         -- In due course we should arrange that the lexer deals
1794         -- with these \\ escapes properly.
1795                        , SysTools.Option     "-o"
1796                        , SysTools.FileOption "" output_fn
1797                        ])
1798
1799 hsSourceCppOpts :: [String]
1800 -- Default CPP defines in Haskell source
1801 hsSourceCppOpts =
1802         [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
1803
1804 -- ---------------------------------------------------------------------------
1805 -- join object files into a single relocatable object file, using ld -r
1806
1807 joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO ()
1808 joinObjectFiles dflags o_files output_fn = do
1809   let ld_r args = SysTools.runLink dflags ([
1810                             SysTools.Option "-nostdlib",
1811                             SysTools.Option "-nodefaultlibs",
1812                             SysTools.Option "-Wl,-r",
1813                             SysTools.Option ld_x_flag,
1814                             SysTools.Option "-o",
1815                             SysTools.FileOption "" output_fn ]
1816                          ++ map SysTools.Option md_c_flags
1817                          ++ args)
1818       ld_x_flag | null cLD_X = ""
1819                 | otherwise  = "-Wl,-x"
1820
1821       md_c_flags = machdepCCOpts dflags
1822
1823   if cLdIsGNULd == "YES"
1824      then do
1825           script <- newTempName dflags "ldscript"
1826           writeFile script $ "INPUT(" ++ unwords o_files ++ ")"
1827           ld_r [SysTools.FileOption "" script]
1828      else do
1829           ld_r (map (SysTools.FileOption "") o_files)
1830
1831 -- -----------------------------------------------------------------------------
1832 -- Misc.
1833
1834 hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase
1835 hscNextPhase _ HsBootFile _        =  StopLn
1836 hscNextPhase dflags _ hsc_lang =
1837   case hsc_lang of
1838         HscC -> HCc
1839         HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle
1840                | otherwise -> As
1841         HscLlvm        -> LlvmOpt
1842         HscNothing     -> StopLn
1843         HscInterpreted -> StopLn
1844         _other         -> StopLn
1845