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