compiler/main/DriverPipeline.hs

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