ghc/compiler/main/DriverPipeline.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- GHC Driver
   4 --
   5 -- (c) The University of Glasgow 2002
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 #include "../includes/config.h"
  10
  11 module DriverPipeline (
  12
  13         -- Interfaces for the batch-mode driver
  14    runPipeline, staticLink,
  15
  16         -- Interfaces for the compilation manager (interpreted/batch-mode)
  17    preprocess,
  18    compile, CompResult(..),
  19    link,
  20
  21         -- DLL building
  22    doMkDLL
  23   ) where
  24
  25 #include "HsVersions.h"
  26
  27 import Packages
  28 import GetImports
  29 import DriverState
  30 import DriverUtil
  31 import DriverMkDepend
  32 import DriverPhases
  33 import DriverFlags
  34 import SysTools         ( newTempName, addFilesToClean, getSysMan, copy )
  35 import qualified SysTools
  36 import HscMain
  37 import Finder
  38 import HscTypes
  39 import Outputable
  40 import Module
  41 import ErrUtils
  42 import CmdLineOpts
  43 import Config
  44 import Panic
  45 import Util
  46 import BasicTypes       ( SuccessFlag(..) )
  47 import Maybes           ( expectJust )
  48
  49 import ParserCoreUtils ( getCoreModuleName )
  50
  51 import EXCEPTION
  52 import DATA_IOREF       ( readIORef, writeIORef )
  53
  54 #ifdef GHCI
  55 import Time             ( getClockTime )
  56 #endif
  57 import Directory
  58 import System
  59 import IO
  60 import Monad
  61 import Maybe
  62
  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 preprocess :: FilePath -> IO FilePath
  71 preprocess filename =
  72   ASSERT(haskellish_src_file filename)
  73   do restoreDynFlags    -- Restore to state of last save
  74      runPipeline (StopBefore Hsc) ("preprocess")
  75         False{-temporary output file-}
  76         Nothing{-no specific output file-}
  77         filename
  78         Nothing{-no ModLocation-}
  79
  80 -- ---------------------------------------------------------------------------
  81 -- Compile
  82
  83 -- Compile a single module, under the control of the compilation manager.
  84 --
  85 -- This is the interface between the compilation manager and the
  86 -- compiler proper (hsc), where we deal with tedious details like
  87 -- reading the OPTIONS pragma from the source file, and passing the
  88 -- output of hsc through the C compiler.
  89
  90 -- The driver sits between 'compile' and 'hscMain', translating calls
  91 -- to the former into calls to the latter, and results from the latter
  92 -- into results from the former.  It does things like preprocessing
  93 -- the .hs file if necessary, and compiling up the .stub_c files to
  94 -- generate Linkables.
  95
  96 -- NB.  No old interface can also mean that the source has changed.
  97
  98 compile :: GhciMode                -- distinguish batch from interactive
  99         -> Module
 100         -> ModLocation
 101         -> Bool                    -- True <=> source unchanged
 102         -> Bool                    -- True <=> have object
 103         -> Maybe ModIface          -- old interface, if available
 104         -> HomePackageTable        -- For home-module stuff
 105         -> PersistentCompilerState -- persistent compiler state
 106         -> IO CompResult
 107
 108 data CompResult
 109    = CompOK   PersistentCompilerState   -- Updated PCS
 110               ModDetails                -- New details
 111               ModIface                  -- New iface
 112               (Maybe Linkable)  -- New code; Nothing => compilation was not reqd
 113                                 --                      (old code is still valid)
 114
 115    | CompErrs PersistentCompilerState   -- Updated PCS
 116
 117
 118 compile ghci_mode this_mod location
 119         source_unchanged have_object
 120         old_iface hpt pcs = do
 121
 122    dyn_flags <- restoreDynFlags         -- Restore to the state of the last save
 123
 124    showPass dyn_flags
 125         (showSDoc (text "Compiling" <+> ppr this_mod))
 126
 127    let verb       = verbosity dyn_flags
 128    let input_fn   = expectJust "compile:hs" (ml_hs_file location)
 129    let input_fnpp = expectJust "compile:hspp" (ml_hspp_file location)
 130    let mod_name   = moduleName this_mod
 131
 132    when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp))
 133
 134    opts <- getOptionsFromSource input_fnpp
 135    processArgs dynamic_flags opts []
 136    dyn_flags <- getDynFlags
 137
 138    let (basename, _) = splitFilename input_fn
 139
 140    -- figure out what lang we're generating
 141    hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags)
 142    -- figure out what the next phase should be
 143    next_phase <- hscNextPhase hsc_lang
 144    -- figure out what file to generate the output into
 145    get_output_fn <- genOutputFilenameFunc False Nothing next_phase basename
 146    output_fn <- get_output_fn next_phase (Just location)
 147
 148    let dyn_flags' = dyn_flags { hscLang = hsc_lang,
 149                                 hscOutName = output_fn,
 150                                 hscStubCOutName = basename ++ "_stub.c",
 151                                 hscStubHOutName = basename ++ "_stub.h",
 152                                 extCoreName = basename ++ ".hcr" }
 153
 154    -- -no-recomp should also work with --make
 155    do_recomp <- readIORef v_Recomp
 156    let source_unchanged' = source_unchanged && do_recomp
 157        hsc_env = HscEnv { hsc_mode = ghci_mode,
 158                           hsc_dflags = dyn_flags',
 159                           hsc_HPT    = hpt }
 160
 161    -- run the compiler
 162    hsc_result <- hscMain hsc_env pcs this_mod location
 163                          source_unchanged' have_object old_iface
 164
 165    case hsc_result of
 166       HscFail pcs -> return (CompErrs pcs)
 167
 168       HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing)
 169
 170       HscRecomp pcs details iface
 171         stub_h_exists stub_c_exists maybe_interpreted_code -> do
 172            let
 173            maybe_stub_o <- compileStub dyn_flags' 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 -> do tm <- getClockTime
 187                                           return ([BCOs comp_bc], tm)
 188 #endif
 189                        Nothing -> panic "compile: no interpreted code"
 190
 191                 -- we're in batch mode: finish the compilation pipeline.
 192                 _other -> do
 193                    let object_filename = ml_obj_file location
 194
 195                    runPipeline (StopBefore Ln) ""
 196                         True Nothing output_fn (Just location)
 197                         -- the object filename comes from the ModLocation
 198
 199                    o_time <- getModificationTime object_filename
 200                    return ([DotO object_filename], o_time)
 201
 202            let linkable = LM unlinked_time mod_name
 203                              (hs_unlinked ++ stub_unlinked)
 204
 205            return (CompOK pcs details iface (Just linkable))
 206
 207 -----------------------------------------------------------------------------
 208 -- stub .h and .c files (for foreign export support)
 209
 210 compileStub dflags stub_c_exists
 211   | not stub_c_exists = return Nothing
 212   | stub_c_exists = do
 213         -- compile the _stub.c file w/ gcc
 214         let stub_c = hscStubCOutName dflags
 215         stub_o <- runPipeline (StopBefore Ln) "stub-compile"
 216                         True{-persistent output-}
 217                         Nothing{-no specific output file-}
 218                         stub_c
 219                         Nothing{-no ModLocation-}
 220         return (Just stub_o)
 221
 222
 223 -- ---------------------------------------------------------------------------
 224 -- Link
 225
 226 link :: GhciMode                -- interactive or batch
 227      -> DynFlags                -- dynamic flags
 228      -> Bool                    -- attempt linking in batch mode?
 229      -> HomePackageTable        -- what to link
 230      -> IO SuccessFlag
 231
 232 -- For the moment, in the batch linker, we don't bother to tell doLink
 233 -- which packages to link -- it just tries all that are available.
 234 -- batch_attempt_linking should only be *looked at* in batch mode.  It
 235 -- should only be True if the upsweep was successful and someone
 236 -- exports main, i.e., we have good reason to believe that linking
 237 -- will succeed.
 238
 239 #ifdef GHCI
 240 link Interactive dflags batch_attempt_linking hpt
 241     = do -- Not Linking...(demand linker will do the job)
 242          return Succeeded
 243 #endif
 244
 245 link Batch dflags batch_attempt_linking hpt
 246    | batch_attempt_linking
 247    = do
 248         let
 249             home_mod_infos = moduleEnvElts hpt
 250
 251             -- the packages we depend on
 252             pkg_deps  = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos
 253
 254             -- the linkables to link
 255             linkables = map hm_linkable home_mod_infos
 256
 257         when (verb >= 3) $ do
 258              hPutStrLn stderr "link: linkables are ..."
 259              hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
 260
 261         -- check for the -no-link flag
 262         omit_linking <- readIORef v_NoLink
 263         if omit_linking
 264           then do when (verb >= 3) $
 265                     hPutStrLn stderr "link(batch): linking omitted (-no-link flag given)."
 266                   return Succeeded
 267           else do
 268
 269         when (verb >= 1) $
 270              hPutStrLn stderr "Linking ..."
 271
 272         let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
 273             obj_files = concatMap getOfiles linkables
 274
 275         -- Don't showPass in Batch mode; doLink will do that for us.
 276         staticLink obj_files pkg_deps
 277
 278         when (verb >= 3) (hPutStrLn stderr "link: done")
 279
 280         -- staticLink only returns if it succeeds
 281         return Succeeded
 282
 283    | otherwise
 284    = do when (verb >= 3) $ do
 285             hPutStrLn stderr "link(batch): upsweep (partially) failed OR"
 286             hPutStrLn stderr "   Main.main not exported; not linking."
 287         return Succeeded
 288    where
 289       verb = verbosity dflags
 290
 291 -- ---------------------------------------------------------------------------
 292 -- Run a compilation pipeline, consisting of multiple phases.
 293
 294 runPipeline
 295   :: GhcMode            -- when to stop
 296   -> String             -- "stop after" flag
 297   -> Bool               -- final output is persistent?
 298   -> Maybe FilePath     -- where to put the output, optionally
 299   -> FilePath           -- input filename
 300   -> Maybe ModLocation  -- a ModLocation for this module, if we have one
 301   -> IO FilePath        -- output filename
 302
 303 runPipeline todo stop_flag keep_output maybe_output_filename input_fn maybe_loc
 304   = do
 305   split <- readIORef v_Split_object_files
 306   let (basename, suffix) = splitFilename input_fn
 307       start_phase = startPhase suffix
 308
 309       stop_phase = case todo of
 310                         StopBefore As | split -> SplitAs
 311                         StopBefore phase      -> phase
 312                         DoMkDependHS          -> Ln
 313                         DoLink                -> Ln
 314                         DoMkDLL               -> Ln
 315
 316   -- We want to catch cases of "you can't get there from here" before
 317   -- we start the pipeline, because otherwise it will just run off the
 318   -- end.
 319   --
 320   -- There is a partial ordering on phases, where A < B iff A occurs
 321   -- before B in a normal compilation pipeline.
 322   --
 323   when (not (start_phase `happensBefore` stop_phase)) $
 324         throwDyn (UsageError
 325                     ("flag `" ++ stop_flag
 326                      ++ "' is incompatible with source file `"
 327                      ++ input_fn ++ "'"))
 328
 329   -- generate a function which will be used to calculate output file names
 330   -- as we go along.
 331   get_output_fn <- genOutputFilenameFunc keep_output maybe_output_filename
 332                         stop_phase basename
 333
 334   -- and execute the pipeline...
 335   (output_fn, maybe_loc) <-
 336         pipeLoop start_phase stop_phase input_fn basename suffix
 337                  get_output_fn maybe_loc
 338
 339   -- sometimes, a compilation phase doesn't actually generate any output
 340   -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
 341   -- stage, but we wanted to keep the output, then we have to explicitly
 342   -- copy the file.
 343   if keep_output
 344         then do final_fn <- get_output_fn stop_phase maybe_loc
 345                 when (final_fn /= output_fn) $
 346                   copy ("Copying `" ++ output_fn ++ "' to `" ++ final_fn
 347                         ++ "'") output_fn final_fn
 348                 return final_fn
 349         else
 350              return output_fn
 351
 352
 353 pipeLoop :: Phase -> Phase -> FilePath -> String -> Suffix
 354   -> (Phase -> Maybe ModLocation -> IO FilePath)
 355   -> Maybe ModLocation -> IO (FilePath, Maybe ModLocation)
 356
 357 pipeLoop phase stop_phase input_fn orig_basename orig_suff
 358         get_output_fn maybe_loc
 359
 360   | phase == stop_phase  =  return (input_fn, maybe_loc)  -- all done
 361
 362   | not (phase `happensBefore` stop_phase)  =
 363         -- Something has gone wrong.  We'll try to cover all the cases when
 364         -- this could happen, so if we reach here it is a panic.
 365         -- eg. it might happen if the -C flag is used on a source file that
 366         -- has {-# OPTIONS -fasm #-}.
 367         panic ("pipeLoop: at phase " ++ show phase ++
 368                 " but I wanted to stop at phase " ++ show stop_phase)
 369
 370   | otherwise = do
 371         maybe_next_phase <- runPhase phase orig_basename orig_suff input_fn
 372                                 get_output_fn maybe_loc
 373         case maybe_next_phase of
 374           (Nothing, maybe_loc, output_fn) -> do
 375                 -- we stopped early, but return the *final* filename
 376                 -- (it presumably already exists)
 377                 final_fn <- get_output_fn stop_phase maybe_loc
 378                 return (final_fn, maybe_loc)
 379           (Just next_phase, maybe_loc, output_fn) ->
 380                 pipeLoop next_phase stop_phase output_fn
 381                         orig_basename orig_suff get_output_fn maybe_loc
 382
 383
 384 genOutputFilenameFunc :: Bool -> Maybe FilePath -> Phase -> String
 385   -> IO (Phase{-next phase-} -> Maybe ModLocation -> IO FilePath)
 386 genOutputFilenameFunc keep_output maybe_output_filename stop_phase basename
 387  = do
 388    hcsuf      <- readIORef v_HC_suf
 389    odir       <- readIORef v_Output_dir
 390    osuf       <- readIORef v_Object_suf
 391    keep_hc    <- readIORef v_Keep_hc_files
 392 #ifdef ILX
 393    keep_il    <- readIORef v_Keep_il_files
 394    keep_ilx   <- readIORef v_Keep_ilx_files
 395 #endif
 396    keep_raw_s <- readIORef v_Keep_raw_s_files
 397    keep_s     <- readIORef v_Keep_s_files
 398    let
 399         myPhaseInputExt HCc | Just s <- hcsuf = s
 400         myPhaseInputExt Ln    = osuf
 401         myPhaseInputExt other = phaseInputExt other
 402
 403         func next_phase maybe_location
 404                 | next_phase == stop_phase
 405                      = case maybe_output_filename of
 406                              Just file -> return file
 407                              Nothing
 408                                  | Ln <- next_phase -> return odir_persistent
 409                                  | keep_output      -> return persistent
 410                                  | otherwise        -> newTempName suffix
 411                         -- sometimes, we keep output from intermediate stages
 412                 | otherwise
 413                      = case next_phase of
 414                              Ln                  -> return odir_persistent
 415                              Mangle | keep_raw_s -> return persistent
 416                              As     | keep_s     -> return persistent
 417                              HCc    | keep_hc    -> return persistent
 418                              _other              -> newTempName suffix
 419            where
 420                 suffix = myPhaseInputExt next_phase
 421                 persistent = basename ++ '.':suffix
 422
 423                 odir_persistent
 424                    | Just loc <- maybe_location = ml_obj_file loc
 425                    | Just d <- odir = replaceFilenameDirectory persistent d
 426                    | otherwise      = persistent
 427
 428    return func
 429
 430
 431 -- -----------------------------------------------------------------------------
 432 -- Each phase in the pipeline returns the next phase to execute, and the
 433 -- name of the file in which the output was placed.
 434 --
 435 -- We must do things dynamically this way, because we often don't know
 436 -- what the rest of the phases will be until part-way through the
 437 -- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
 438 -- of a source file can change the latter stages of the pipeline from
 439 -- taking the via-C route to using the native code generator.
 440
 441 runPhase :: Phase
 442           -> String     -- basename of original input source
 443           -> String     -- its extension
 444           -> FilePath   -- name of file which contains the input to this phase.
 445           -> (Phase -> Maybe ModLocation -> IO FilePath)
 446                         -- how to calculate the output filename
 447           -> Maybe ModLocation          -- the ModLocation, if we have one
 448           -> IO (Maybe Phase,           -- next phase
 449                  Maybe ModLocation,     -- the ModLocation, if we have one
 450                  FilePath)              -- output filename
 451
 452 -------------------------------------------------------------------------------
 453 -- Unlit phase
 454
 455 runPhase Unlit _basename _suff input_fn get_output_fn maybe_loc
 456   = do unlit_flags <- getOpts opt_L
 457        -- The -h option passes the file name for unlit to put in a #line directive
 458        output_fn <- get_output_fn Cpp maybe_loc
 459
 460        SysTools.runUnlit (map SysTools.Option unlit_flags ++
 461                           [ SysTools.Option     "-h"
 462                           , SysTools.Option     input_fn
 463                           , SysTools.FileOption "" input_fn
 464                           , SysTools.FileOption "" output_fn
 465                           ])
 466
 467        return (Just Cpp, maybe_loc, output_fn)
 468
 469 -------------------------------------------------------------------------------
 470 -- Cpp phase
 471
 472 runPhase Cpp basename suff input_fn get_output_fn maybe_loc
 473   = do src_opts <- getOptionsFromSource input_fn
 474        unhandled_flags <- processArgs dynamic_flags src_opts []
 475        checkProcessArgsResult unhandled_flags basename suff
 476
 477        do_cpp <- dynFlag cppFlag
 478        if not do_cpp then
 479            -- no need to preprocess CPP, just pass input file along
 480            -- to the next phase of the pipeline.
 481           return (Just HsPp, maybe_loc, input_fn)
 482         else do
 483             hscpp_opts      <- getOpts opt_P
 484             hs_src_cpp_opts <- readIORef v_Hs_source_cpp_opts
 485
 486             cmdline_include_paths <- readIORef v_Include_paths
 487
 488             pkg_include_dirs <- getPackageIncludePath []
 489             let include_paths = foldr (\ x xs -> "-I" : x : xs) []
 490                                   (cmdline_include_paths ++ pkg_include_dirs)
 491
 492             verb <- getVerbFlag
 493             (md_c_flags, _) <- machdepCCOpts
 494
 495             output_fn <- get_output_fn HsPp maybe_loc
 496
 497             SysTools.runCpp ([SysTools.Option verb]
 498                             ++ map SysTools.Option include_paths
 499                             ++ map SysTools.Option hs_src_cpp_opts
 500                             ++ map SysTools.Option hscpp_opts
 501                             ++ map SysTools.Option md_c_flags
 502                             ++ [ SysTools.Option     "-x"
 503                                , SysTools.Option     "c"
 504                                , SysTools.Option     input_fn
 505         -- We hackily use Option instead of FileOption here, so that the file
 506         -- name is not back-slashed on Windows.  cpp is capable of
 507         -- dealing with / in filenames, so it works fine.  Furthermore
 508         -- if we put in backslashes, cpp outputs #line directives
 509         -- with *double* backslashes.   And that in turn means that
 510         -- our error messages get double backslashes in them.
 511         -- In due course we should arrange that the lexer deals
 512         -- with these \\ escapes properly.
 513                                , SysTools.Option     "-o"
 514                                , SysTools.FileOption "" output_fn
 515                                ])
 516
 517             return (Just HsPp, maybe_loc, output_fn)
 518
 519 -------------------------------------------------------------------------------
 520 -- HsPp phase
 521
 522 runPhase HsPp basename suff input_fn get_output_fn maybe_loc
 523   = do do_pp   <- dynFlag ppFlag
 524        if not do_pp then
 525            -- no need to preprocess, just pass input file along
 526            -- to the next phase of the pipeline.
 527           return (Just Hsc, maybe_loc, input_fn)
 528         else do
 529             hspp_opts      <- getOpts opt_F
 530             hs_src_pp_opts <- readIORef v_Hs_source_pp_opts
 531             let orig_fn = basename ++ '.':suff
 532             output_fn <- get_output_fn Hsc maybe_loc
 533             SysTools.runPp ( [ SysTools.Option     orig_fn
 534                              , SysTools.Option     input_fn
 535                              , SysTools.FileOption "" output_fn
 536                              ] ++
 537                              map SysTools.Option hs_src_pp_opts ++
 538                              map SysTools.Option hspp_opts
 539                            )
 540             return (Just Hsc, maybe_loc, output_fn)
 541
 542 -----------------------------------------------------------------------------
 543 -- Hsc phase
 544
 545 -- Compilation of a single module, in "legacy" mode (_not_ under
 546 -- the direction of the compilation manager).
 547 runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do
 548   todo <- readIORef v_GhcMode
 549   if todo == DoMkDependHS then do
 550        locn <- doMkDependHSPhase basename suff input_fn
 551        return (Nothing, Just locn, input_fn)  -- Ln is a dummy stop phase
 552
 553    else do
 554       -- normal Hsc mode, not mkdependHS
 555
 556   -- we add the current directory (i.e. the directory in which
 557   -- the .hs files resides) to the import path, since this is
 558   -- what gcc does, and it's probably what you want.
 559         let current_dir = directoryOf basename
 560
 561         paths <- readIORef v_Include_paths
 562         writeIORef v_Include_paths (current_dir : paths)
 563
 564   -- gather the imports and module name
 565         (_,_,mod_name) <-
 566             if extcoreish_suffix suff
 567              then do
 568                -- no explicit imports in ExtCore input.
 569                m <- getCoreModuleName input_fn
 570                return ([], [], mkModuleName m)
 571              else
 572                getImportsFromFile input_fn
 573
 574   -- build a ModLocation to pass to hscMain.
 575         (mod, location') <- mkHomeModLocation mod_name (basename ++ '.':suff)
 576
 577   -- take -ohi into account if present
 578         ohi <- readIORef v_Output_hi
 579         let location | Just fn <- ohi = location'{ ml_hi_file = fn }
 580                      | otherwise      = location'
 581
 582   -- figure out if the source has changed, for recompilation avoidance.
 583   -- only do this if we're eventually going to generate a .o file.
 584   -- (ToDo: do when generating .hc files too?)
 585   --
 586   -- Setting source_unchanged to True means that M.o seems
 587   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 588   -- changed (which the compiler itself figures out).
 589   -- Setting source_unchanged to False tells the compiler that M.o is out of
 590   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 591         do_recomp   <- readIORef v_Recomp
 592         expl_o_file <- readIORef v_Output_file
 593
 594         let o_file -- if the -o option is given and IT IS THE OBJECT FILE FOR
 595                    -- THIS COMPILATION, then use that to determine if the
 596                    -- source is unchanged.
 597                 | Just x <- expl_o_file, todo == StopBefore Ln  =  x
 598                 | otherwise = ml_obj_file location
 599
 600         source_unchanged <-
 601           if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
 602              then return False
 603              else do t1 <- getModificationTime (basename ++ '.':suff)
 604                      o_file_exists <- doesFileExist o_file
 605                      if not o_file_exists
 606                         then return False       -- Need to recompile
 607                         else do t2 <- getModificationTime o_file
 608                                 if t2 > t1
 609                                   then return True
 610                                   else return False
 611
 612   -- get the DynFlags
 613         dyn_flags <- getDynFlags
 614         hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags)
 615         next_phase <- hscNextPhase hsc_lang
 616         output_fn <- get_output_fn next_phase (Just location)
 617
 618         let dyn_flags' = dyn_flags { hscLang = hsc_lang,
 619                                      hscOutName = output_fn,
 620                                      hscStubCOutName = basename ++ "_stub.c",
 621                                      hscStubHOutName = basename ++ "_stub.h",
 622                                      extCoreName = basename ++ ".hcr" }
 623             hsc_env = HscEnv { hsc_mode = OneShot,
 624                                hsc_dflags = dyn_flags',
 625                                hsc_HPT    = emptyHomePackageTable }
 626
 627
 628   -- run the compiler!
 629         pcs <- initPersistentCompilerState
 630         result <- hscMain hsc_env pcs mod
 631                           location{ ml_hspp_file=Just input_fn }
 632                           source_unchanged
 633                           False
 634                           Nothing        -- no iface
 635
 636         case result of
 637
 638             HscFail pcs -> throwDyn (PhaseFailed "hsc" (ExitFailure 1))
 639
 640             HscNoRecomp pcs details iface -> do
 641                 SysTools.touch "Touching object file" o_file
 642                 return (Nothing, Just location, output_fn)
 643
 644             HscRecomp _pcs _details _iface stub_h_exists stub_c_exists
 645                       _maybe_interpreted_code -> do
 646
 647                 -- deal with stubs
 648                 maybe_stub_o <- compileStub dyn_flags' stub_c_exists
 649                 case maybe_stub_o of
 650                       Nothing -> return ()
 651                       Just stub_o -> add v_Ld_inputs stub_o
 652                 case hscLang dyn_flags of
 653                       HscNothing -> return (Nothing, Just location, output_fn)
 654                       _ -> return (Just next_phase, Just location, output_fn)
 655
 656 -----------------------------------------------------------------------------
 657 -- Cc phase
 658
 659 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 660 -- way too many hacks, and I can't say I've ever used it anyway.
 661
 662 runPhase cc_phase basename suff input_fn get_output_fn maybe_loc
 663    | cc_phase == Cc || cc_phase == HCc
 664    = do cc_opts <- getOpts opt_c
 665         cmdline_include_paths <- readIORef v_Include_paths
 666
 667         split  <- readIORef v_Split_object_files
 668         mangle <- readIORef v_Do_asm_mangling
 669
 670         let hcc = cc_phase == HCc
 671
 672             next_phase
 673                 | hcc && mangle     = Mangle
 674                 | otherwise         = As
 675
 676         output_fn <- get_output_fn next_phase maybe_loc
 677
 678         -- HC files have the dependent packages stamped into them
 679         pkgs <- if hcc then getHCFilePackages input_fn else return []
 680
 681         -- add package include paths even if we're just compiling .c
 682         -- files; this is the Value Add(TM) that using ghc instead of
 683         -- gcc gives you :)
 684         pkg_include_dirs <- getPackageIncludePath pkgs
 685         let include_paths = foldr (\ x xs -> "-I" : x : xs) []
 686                               (cmdline_include_paths ++ pkg_include_dirs)
 687
 688         mangle <- readIORef v_Do_asm_mangling
 689         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
 690
 691         verb <- getVerbFlag
 692
 693         o2 <- readIORef v_minus_o2_for_C
 694         let opt_flag | o2        = "-O2"
 695                      | otherwise = "-O"
 696
 697         pkg_extra_cc_opts <- getPackageExtraCcOpts pkgs
 698
 699         split_objs <- readIORef v_Split_object_files
 700         let split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 701                       | otherwise         = [ ]
 702
 703         excessPrecision <- readIORef v_Excess_precision
 704
 705         -- force the C compiler to interpret this file as C when
 706         -- compiling .hc files, by adding the -x c option.
 707         let langopt
 708                 | cc_phase == HCc = [ SysTools.Option "-x", SysTools.Option "c"]
 709                 | otherwise       = [ ]
 710
 711         SysTools.runCc (langopt ++
 712                         [ SysTools.FileOption "" input_fn
 713                         , SysTools.Option "-o"
 714                         , SysTools.FileOption "" output_fn
 715                         ]
 716                        ++ map SysTools.Option (
 717                           md_c_flags
 718                        ++ (if cc_phase == HCc && mangle
 719                              then md_regd_c_flags
 720                              else [])
 721                        ++ [ verb, "-S", "-Wimplicit", opt_flag ]
 722                        ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 723                        ++ cc_opts
 724                        ++ split_opt
 725                        ++ (if excessPrecision then [] else [ "-ffloat-store" ])
 726                        ++ include_paths
 727                        ++ pkg_extra_cc_opts
 728                        ))
 729
 730         return (Just next_phase, maybe_loc, output_fn)
 731
 732         -- ToDo: postprocess the output from gcc
 733
 734 -----------------------------------------------------------------------------
 735 -- Mangle phase
 736
 737 runPhase Mangle _basename _suff input_fn get_output_fn maybe_loc
 738    = do mangler_opts <- getOpts opt_m
 739         machdep_opts <- if (prefixMatch "i386" cTARGETPLATFORM)
 740                           then do n_regs <- dynFlag stolen_x86_regs
 741                                   return [ show n_regs ]
 742                           else return []
 743
 744         split <- readIORef v_Split_object_files
 745         let next_phase
 746                 | split = SplitMangle
 747                 | otherwise = As
 748         output_fn <- get_output_fn next_phase maybe_loc
 749
 750         SysTools.runMangle (map SysTools.Option mangler_opts
 751                           ++ [ SysTools.FileOption "" input_fn
 752                              , SysTools.FileOption "" output_fn
 753                              ]
 754                           ++ map SysTools.Option machdep_opts)
 755
 756         return (Just next_phase, maybe_loc, output_fn)
 757
 758 -----------------------------------------------------------------------------
 759 -- Splitting phase
 760
 761 runPhase SplitMangle _basename _suff input_fn get_output_fn maybe_loc
 762   = do  -- tmp_pfx is the prefix used for the split .s files
 763         -- We also use it as the file to contain the no. of split .s files (sigh)
 764         split_s_prefix <- SysTools.newTempName "split"
 765         let n_files_fn = split_s_prefix
 766
 767         SysTools.runSplit [ SysTools.FileOption "" input_fn
 768                           , SysTools.FileOption "" split_s_prefix
 769                           , SysTools.FileOption "" n_files_fn
 770                           ]
 771
 772         -- Save the number of split files for future references
 773         s <- readFile n_files_fn
 774         let n_files = read s :: Int
 775         writeIORef v_Split_info (split_s_prefix, n_files)
 776
 777         -- Remember to delete all these files
 778         addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s"
 779                         | n <- [1..n_files]]
 780
 781         return (Just SplitAs, maybe_loc, "**splitmangle**")
 782           -- we don't use the filename
 783
 784 -----------------------------------------------------------------------------
 785 -- As phase
 786
 787 runPhase As _basename _suff input_fn get_output_fn maybe_loc
 788   = do  as_opts               <- getOpts opt_a
 789         cmdline_include_paths <- readIORef v_Include_paths
 790
 791         output_fn <- get_output_fn Ln maybe_loc
 792
 793         -- we create directories for the object file, because it
 794         -- might be a hierarchical module.
 795         createDirectoryHierarchy (directoryOf output_fn)
 796
 797         SysTools.runAs (map SysTools.Option as_opts
 798                        ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
 799                        ++ [ SysTools.Option "-c"
 800                           , SysTools.FileOption "" input_fn
 801                           , SysTools.Option "-o"
 802                           , SysTools.FileOption "" output_fn
 803                           ])
 804
 805         return (Just Ln, maybe_loc, output_fn)
 806
 807
 808 runPhase SplitAs basename _suff _input_fn get_output_fn maybe_loc
 809   = do  as_opts <- getOpts opt_a
 810
 811         (split_s_prefix, n) <- readIORef v_Split_info
 812
 813         odir <- readIORef v_Output_dir
 814         let real_odir = case odir of
 815                                 Nothing -> basename ++ "_split"
 816                                 Just d  -> d
 817
 818         let assemble_file n
 819               = do  let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
 820                     let output_o = replaceFilenameDirectory
 821                                         (basename ++ "__" ++ show n ++ ".o")
 822                                          real_odir
 823                     real_o <- osuf_ify output_o
 824                     SysTools.runAs (map SysTools.Option as_opts ++
 825                                     [ SysTools.Option "-c"
 826                                     , SysTools.Option "-o"
 827                                     , SysTools.FileOption "" real_o
 828                                     , SysTools.FileOption "" input_s
 829                                     ])
 830
 831         mapM_ assemble_file [1..n]
 832
 833         output_fn <- get_output_fn Ln maybe_loc
 834         return (Just Ln, maybe_loc, output_fn)
 835
 836 #ifdef ILX
 837 -----------------------------------------------------------------------------
 838 -- Ilx2Il phase
 839 -- Run ilx2il over the ILX output, getting an IL file
 840
 841 runPhase Ilx2Il _basename _suff input_fn get_output_fn maybe_loc
 842   = do  ilx2il_opts <- getOpts opt_I
 843         SysTools.runIlx2il (map SysTools.Option ilx2il_opts
 844                            ++ [ SysTools.Option "--no-add-suffix-to-assembly",
 845                                 SysTools.Option "mscorlib",
 846                                 SysTools.Option "-o",
 847                                 SysTools.FileOption "" output_fn,
 848                                 SysTools.FileOption "" input_fn ])
 849         return True
 850
 851 -----------------------------------------------------------------------------
 852 -- Ilasm phase
 853 -- Run ilasm over the IL, getting a DLL
 854
 855 runPhase Ilasm _basename _suff input_fn get_output_fn maybe_loc
 856   = do  ilasm_opts <- getOpts opt_i
 857         SysTools.runIlasm (map SysTools.Option ilasm_opts
 858                            ++ [ SysTools.Option "/QUIET",
 859                                 SysTools.Option "/DLL",
 860                                 SysTools.FileOption "/OUT=" output_fn,
 861                                 SysTools.FileOption "" input_fn ])
 862         return True
 863
 864 #endif /* ILX */
 865
 866 -----------------------------------------------------------------------------
 867 -- MoveBinary sort-of-phase
 868 -- After having produced a binary, move it somewhere else and generate a
 869 -- wrapper script calling the binary. Currently, we need this only in
 870 -- a parallel way (i.e. in GUM), because PVM expects the binary in a
 871 -- central directory.
 872 -- This is called from staticLink below, after linking. I haven't made it
 873 -- a separate phase to minimise interfering with other modules, and
 874 -- we don't need the generality of a phase (MoveBinary is always
 875 -- done after linking and makes only sense in a parallel setup)   -- HWL
 876
 877 runPhase_MoveBinary input_fn
 878   = do
 879         sysMan   <- getSysMan
 880         pvm_root <- getEnv "PVM_ROOT"
 881         pvm_arch <- getEnv "PVM_ARCH"
 882         let
 883            pvm_executable_base = "=" ++ input_fn
 884            pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
 885         -- nuke old binary; maybe use configur'ed names for cp and rm?
 886         system ("rm -f " ++ pvm_executable)
 887         -- move the newly created binary into PVM land
 888         system ("cp -p " ++ input_fn ++ " " ++ pvm_executable)
 889         -- generate a wrapper script for running a parallel prg under PVM
 890         writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
 891         return True
 892
 893 -- generates a Perl skript starting a parallel prg under PVM
 894 mk_pvm_wrapper_script :: String -> String -> String -> String
 895 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
 896  [
 897   "eval 'exec perl -S $0 ${1+\"$@\"}'",
 898   "  if $running_under_some_shell;",
 899   "# =!=!=!=!=!=!=!=!=!=!=!",
 900   "# This script is automatically generated: DO NOT EDIT!!!",
 901   "# Generated by Glasgow Haskell Compiler",
 902   "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
 903   "#",
 904   "$pvm_executable      = '" ++ pvm_executable ++ "';",
 905   "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
 906   "$SysMan = '" ++ sysMan ++ "';",
 907   "",
 908   {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
 909   "# first, some magical shortcuts to run "commands" on the binary",
 910   "# (which is hidden)",
 911   "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
 912   "    local($cmd) = $1;",
 913   "    system("$cmd $pvm_executable");",
 914   "    exit(0); # all done",
 915   "}", -}
 916   "",
 917   "# Now, run the real binary; process the args first",
 918   "$ENV{'PE'} = $pvm_executable_base;", --  ++ pvm_executable_base,
 919   "$debug = '';",
 920   "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
 921   "@nonPVM_args = ();",
 922   "$in_RTS_args = 0;",
 923   "",
 924   "args: while ($a = shift(@ARGV)) {",
 925   "    if ( $a eq '+RTS' ) {",
 926   "     $in_RTS_args = 1;",
 927   "    } elsif ( $a eq '-RTS' ) {",
 928   "     $in_RTS_args = 0;",
 929   "    }",
 930   "    if ( $a eq '-d' && $in_RTS_args ) {",
 931   "     $debug = '-';",
 932   "    } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
 933   "     $nprocessors = $1;",
 934   "    } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
 935   "     $nprocessors = $1;",
 936   "    } else {",
 937   "     push(@nonPVM_args, $a);",
 938   "    }",
 939   "}",
 940   "",
 941   "local($return_val) = 0;",
 942   "# Start the parallel execution by calling SysMan",
 943   "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
 944   "$return_val = $?;",
 945   "# ToDo: fix race condition moving files and flushing them!!",
 946   "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
 947   "exit($return_val);"
 948  ]
 949
 950 -----------------------------------------------------------------------------
 951 -- Complain about non-dynamic flags in OPTIONS pragmas
 952
 953 checkProcessArgsResult flags basename suff
 954   = do when (notNull flags) (throwDyn (ProgramError (
 955           showSDoc (hang (text basename <> text ('.':suff) <> char ':')
 956                       4 (text "unknown flags in  {-# OPTIONS #-} pragma:" <+>
 957                           hsep (map text flags)))
 958         )))
 959
 960 -----------------------------------------------------------------------------
 961 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
 962
 963 getHCFilePackages :: FilePath -> IO [PackageName]
 964 getHCFilePackages filename =
 965   EXCEPTION.bracket (openFile filename ReadMode) hClose $ \h -> do
 966     l <- hGetLine h
 967     case l of
 968       '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
 969           return (map mkPackageName (words rest))
 970       _other ->
 971           return []
 972
 973 -----------------------------------------------------------------------------
 974 -- Static linking, of .o files
 975
 976 -- The list of packages passed to link is the list of packages on
 977 -- which this program depends, as discovered by the compilation
 978 -- manager.  It is combined with the list of packages that the user
 979 -- specifies on the command line with -package flags.
 980 --
 981 -- In one-shot linking mode, we can't discover the package
 982 -- dependencies (because we haven't actually done any compilation or
 983 -- read any interface files), so the user must explicitly specify all
 984 -- the packages.
 985
 986 staticLink :: [FilePath] -> [PackageName] -> IO ()
 987 staticLink o_files dep_packages = do
 988     verb       <- getVerbFlag
 989     static     <- readIORef v_Static
 990     no_hs_main <- readIORef v_NoHsMain
 991
 992     -- get the full list of packages to link with, by combining the
 993     -- explicit packages with the auto packages and all of their
 994     -- dependencies, and eliminating duplicates.
 995
 996     o_file <- readIORef v_Output_file
 997     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
 998
 999     pkg_lib_paths <- getPackageLibraryPath dep_packages
1000     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1001
1002     lib_paths <- readIORef v_Library_paths
1003     let lib_path_opts = map ("-L"++) lib_paths
1004
1005     pkg_link_opts <- getPackageLinkOpts dep_packages
1006
1007 #ifdef darwin_TARGET_OS
1008     pkg_framework_paths <- getPackageFrameworkPath dep_packages
1009     let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths
1010
1011     framework_paths <- readIORef v_Framework_paths
1012     let framework_path_opts = map ("-F"++) framework_paths
1013
1014     pkg_frameworks <- getPackageFrameworks dep_packages
1015     let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1016
1017     frameworks <- readIORef v_Cmdline_frameworks
1018     let framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ]
1019          -- reverse because they're added in reverse order from the cmd line
1020 #endif
1021
1022         -- probably _stub.o files
1023     extra_ld_inputs <- readIORef v_Ld_inputs
1024
1025         -- opts from -optl-<blah> (including -l<blah> options)
1026     extra_ld_opts <- getStaticOpts v_Opt_l
1027
1028     [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, basePackage]
1029
1030     let extra_os = if static || no_hs_main
1031                    then []
1032                    else [ head (library_dirs rts_pkg) ++ "/Main.dll_o",
1033                           head (library_dirs std_pkg) ++ "/PrelMain.dll_o" ]
1034
1035     (md_c_flags, _) <- machdepCCOpts
1036     SysTools.runLink ( [ SysTools.Option verb
1037                        , SysTools.Option "-o"
1038                        , SysTools.FileOption "" output_fn
1039                        ]
1040                       ++ map SysTools.Option (
1041                          md_c_flags
1042                       ++ o_files
1043                       ++ extra_os
1044                       ++ extra_ld_inputs
1045                       ++ lib_path_opts
1046                       ++ extra_ld_opts
1047 #ifdef darwin_TARGET_OS
1048                       ++ framework_path_opts
1049                       ++ framework_opts
1050 #endif
1051                       ++ pkg_lib_path_opts
1052                       ++ pkg_link_opts
1053 #ifdef darwin_TARGET_OS
1054                       ++ pkg_framework_path_opts
1055                       ++ pkg_framework_opts
1056 #endif
1057                     ))
1058
1059     -- parallel only: move binary to another dir -- HWL
1060     ways_ <- readIORef v_Ways
1061     when (WayPar `elem` ways_)
1062          (do success <- runPhase_MoveBinary output_fn
1063              if success then return ()
1064                         else throwDyn (InstallationError ("cannot move binary to PVM dir")))
1065
1066 -----------------------------------------------------------------------------
1067 -- Making a DLL (only for Win32)
1068
1069 doMkDLL :: [String] -> [PackageName] -> IO ()
1070 doMkDLL o_files dep_packages = do
1071     verb       <- getVerbFlag
1072     static     <- readIORef v_Static
1073     no_hs_main <- readIORef v_NoHsMain
1074
1075     o_file <- readIORef v_Output_file
1076     let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
1077
1078     pkg_lib_paths <- getPackageLibraryPath dep_packages
1079     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1080
1081     lib_paths <- readIORef v_Library_paths
1082     let lib_path_opts = map ("-L"++) lib_paths
1083
1084     pkg_link_opts <- getPackageLinkOpts dep_packages
1085
1086         -- probably _stub.o files
1087     extra_ld_inputs <- readIORef v_Ld_inputs
1088
1089         -- opts from -optdll-<blah>
1090     extra_ld_opts <- getStaticOpts v_Opt_dll
1091
1092     [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, basePackage]
1093
1094     let extra_os = if static || no_hs_main
1095                    then []
1096                    else [ head (library_dirs rts_pkg) ++ "/Main.dll_o",
1097                           head (library_dirs std_pkg) ++ "/PrelMain.dll_o" ]
1098
1099     (md_c_flags, _) <- machdepCCOpts
1100     SysTools.runMkDLL
1101          ([ SysTools.Option verb
1102           , SysTools.Option "-o"
1103           , SysTools.FileOption "" output_fn
1104           ]
1105          ++ map SysTools.Option (
1106             md_c_flags
1107          ++ o_files
1108          ++ extra_os
1109          ++ [ "--target=i386-mingw32" ]
1110          ++ extra_ld_inputs
1111          ++ lib_path_opts
1112          ++ extra_ld_opts
1113          ++ pkg_lib_path_opts
1114          ++ pkg_link_opts
1115          ++ (if "--def" `elem` (concatMap words extra_ld_opts)
1116                then [ "" ]
1117                else [ "--export-all" ])
1118         ))
1119
1120 -- -----------------------------------------------------------------------------
1121 -- Misc.
1122
1123 hscNextPhase :: HscLang -> IO Phase
1124 hscNextPhase hsc_lang = do
1125   split <- readIORef v_Split_object_files
1126   return (case hsc_lang of
1127                 HscC -> HCc
1128                 HscAsm | split -> SplitMangle
1129                        | otherwise -> As
1130                 HscNothing     -> HCc  -- dummy (no output will be generated)
1131                 HscInterpreted -> HCc  -- "" ""
1132                 _other         -> HCc  -- "" ""
1133         )
1134
1135 hscMaybeAdjustLang :: HscLang -> IO HscLang
1136 hscMaybeAdjustLang current_hsc_lang = do
1137   todo    <- readIORef v_GhcMode
1138   keep_hc <- readIORef v_Keep_hc_files
1139   let hsc_lang
1140         -- don't change the lang if we're interpreting
1141          | current_hsc_lang == HscInterpreted = current_hsc_lang
1142         -- force -fvia-C if we are being asked for a .hc file
1143          | todo == StopBefore HCc  || keep_hc = HscC
1144         -- force -fvia-C when profiling or ticky-ticky is on
1145          | opt_SccProfilingOn || opt_DoTickyProfiling = HscC
1146         -- otherwise, stick to the plan
1147          | otherwise = current_hsc_lang
1148   return hsc_lang