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