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         pkg_extra_cc_opts <- getPackageExtraCcOpts pkgs
 694
 695         split_objs <- readIORef v_Split_object_files
 696         let split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 697                       | otherwise         = [ ]
 698
 699         excessPrecision <- readIORef v_Excess_precision
 700
 701         -- force the C compiler to interpret this file as C when
 702         -- compiling .hc files, by adding the -x c option.
 703         let langopt
 704                 | cc_phase == HCc = [ SysTools.Option "-x", SysTools.Option "c"]
 705                 | otherwise       = [ ]
 706
 707         SysTools.runCc (langopt ++
 708                         [ SysTools.FileOption "" input_fn
 709                         , SysTools.Option "-o"
 710                         , SysTools.FileOption "" output_fn
 711                         ]
 712                        ++ map SysTools.Option (
 713                           md_c_flags
 714                        ++ (if cc_phase == HCc && mangle
 715                              then md_regd_c_flags
 716                              else [])
 717                        ++ [ verb, "-S", "-Wimplicit", "-O" ]
 718                        ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 719                        ++ cc_opts
 720                        ++ split_opt
 721                        ++ (if excessPrecision then [] else [ "-ffloat-store" ])
 722                        ++ include_paths
 723                        ++ pkg_extra_cc_opts
 724                        ))
 725
 726         return (Just next_phase, maybe_loc, output_fn)
 727
 728         -- ToDo: postprocess the output from gcc
 729
 730 -----------------------------------------------------------------------------
 731 -- Mangle phase
 732
 733 runPhase Mangle _basename _suff input_fn get_output_fn maybe_loc
 734    = do mangler_opts <- getOpts opt_m
 735         machdep_opts <- if (prefixMatch "i386" cTARGETPLATFORM)
 736                           then do n_regs <- dynFlag stolen_x86_regs
 737                                   return [ show n_regs ]
 738                           else return []
 739
 740         split <- readIORef v_Split_object_files
 741         let next_phase
 742                 | split = SplitMangle
 743                 | otherwise = As
 744         output_fn <- get_output_fn next_phase maybe_loc
 745
 746         SysTools.runMangle (map SysTools.Option mangler_opts
 747                           ++ [ SysTools.FileOption "" input_fn
 748                              , SysTools.FileOption "" output_fn
 749                              ]
 750                           ++ map SysTools.Option machdep_opts)
 751
 752         return (Just next_phase, maybe_loc, output_fn)
 753
 754 -----------------------------------------------------------------------------
 755 -- Splitting phase
 756
 757 runPhase SplitMangle _basename _suff input_fn get_output_fn maybe_loc
 758   = do  -- tmp_pfx is the prefix used for the split .s files
 759         -- We also use it as the file to contain the no. of split .s files (sigh)
 760         split_s_prefix <- SysTools.newTempName "split"
 761         let n_files_fn = split_s_prefix
 762
 763         SysTools.runSplit [ SysTools.FileOption "" input_fn
 764                           , SysTools.FileOption "" split_s_prefix
 765                           , SysTools.FileOption "" n_files_fn
 766                           ]
 767
 768         -- Save the number of split files for future references
 769         s <- readFile n_files_fn
 770         let n_files = read s :: Int
 771         writeIORef v_Split_info (split_s_prefix, n_files)
 772
 773         -- Remember to delete all these files
 774         addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s"
 775                         | n <- [1..n_files]]
 776
 777         return (Just SplitAs, maybe_loc, "**splitmangle**")
 778           -- we don't use the filename
 779
 780 -----------------------------------------------------------------------------
 781 -- As phase
 782
 783 runPhase As _basename _suff input_fn get_output_fn maybe_loc
 784   = do  as_opts               <- getOpts opt_a
 785         cmdline_include_paths <- readIORef v_Include_paths
 786
 787         output_fn <- get_output_fn Ln maybe_loc
 788
 789         -- we create directories for the object file, because it
 790         -- might be a hierarchical module.
 791         createDirectoryHierarchy (directoryOf output_fn)
 792
 793         SysTools.runAs (map SysTools.Option as_opts
 794                        ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
 795                        ++ [ SysTools.Option "-c"
 796                           , SysTools.FileOption "" input_fn
 797                           , SysTools.Option "-o"
 798                           , SysTools.FileOption "" output_fn
 799                           ])
 800
 801         return (Just Ln, maybe_loc, output_fn)
 802
 803
 804 runPhase SplitAs basename _suff _input_fn get_output_fn maybe_loc
 805   = do  as_opts <- getOpts opt_a
 806
 807         (split_s_prefix, n) <- readIORef v_Split_info
 808
 809         odir <- readIORef v_Output_dir
 810         let real_odir = case odir of
 811                                 Nothing -> basename ++ "_split"
 812                                 Just d  -> d
 813
 814         let assemble_file n
 815               = do  let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
 816                     let output_o = replaceFilenameDirectory
 817                                         (basename ++ "__" ++ show n ++ ".o")
 818                                          real_odir
 819                     real_o <- osuf_ify output_o
 820                     SysTools.runAs (map SysTools.Option as_opts ++
 821                                     [ SysTools.Option "-c"
 822                                     , SysTools.Option "-o"
 823                                     , SysTools.FileOption "" real_o
 824                                     , SysTools.FileOption "" input_s
 825                                     ])
 826
 827         mapM_ assemble_file [1..n]
 828
 829         output_fn <- get_output_fn Ln maybe_loc
 830         return (Just Ln, maybe_loc, output_fn)
 831
 832 #ifdef ILX
 833 -----------------------------------------------------------------------------
 834 -- Ilx2Il phase
 835 -- Run ilx2il over the ILX output, getting an IL file
 836
 837 runPhase Ilx2Il _basename _suff input_fn get_output_fn maybe_loc
 838   = do  ilx2il_opts <- getOpts opt_I
 839         SysTools.runIlx2il (map SysTools.Option ilx2il_opts
 840                            ++ [ SysTools.Option "--no-add-suffix-to-assembly",
 841                                 SysTools.Option "mscorlib",
 842                                 SysTools.Option "-o",
 843                                 SysTools.FileOption "" output_fn,
 844                                 SysTools.FileOption "" input_fn ])
 845         return True
 846
 847 -----------------------------------------------------------------------------
 848 -- Ilasm phase
 849 -- Run ilasm over the IL, getting a DLL
 850
 851 runPhase Ilasm _basename _suff input_fn get_output_fn maybe_loc
 852   = do  ilasm_opts <- getOpts opt_i
 853         SysTools.runIlasm (map SysTools.Option ilasm_opts
 854                            ++ [ SysTools.Option "/QUIET",
 855                                 SysTools.Option "/DLL",
 856                                 SysTools.FileOption "/OUT=" output_fn,
 857                                 SysTools.FileOption "" input_fn ])
 858         return True
 859
 860 #endif /* ILX */
 861
 862 -----------------------------------------------------------------------------
 863 -- MoveBinary sort-of-phase
 864 -- After having produced a binary, move it somewhere else and generate a
 865 -- wrapper script calling the binary. Currently, we need this only in
 866 -- a parallel way (i.e. in GUM), because PVM expects the binary in a
 867 -- central directory.
 868 -- This is called from staticLink below, after linking. I haven't made it
 869 -- a separate phase to minimise interfering with other modules, and
 870 -- we don't need the generality of a phase (MoveBinary is always
 871 -- done after linking and makes only sense in a parallel setup)   -- HWL
 872
 873 runPhase_MoveBinary input_fn
 874   = do
 875         sysMan   <- getSysMan
 876         pvm_root <- getEnv "PVM_ROOT"
 877         pvm_arch <- getEnv "PVM_ARCH"
 878         let
 879            pvm_executable_base = "=" ++ input_fn
 880            pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
 881         -- nuke old binary; maybe use configur'ed names for cp and rm?
 882         system ("rm -f " ++ pvm_executable)
 883         -- move the newly created binary into PVM land
 884         system ("cp -p " ++ input_fn ++ " " ++ pvm_executable)
 885         -- generate a wrapper script for running a parallel prg under PVM
 886         writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
 887         return True
 888
 889 -- generates a Perl skript starting a parallel prg under PVM
 890 mk_pvm_wrapper_script :: String -> String -> String -> String
 891 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
 892  [
 893   "eval 'exec perl -S $0 ${1+\"$@\"}'",
 894   "  if $running_under_some_shell;",
 895   "# =!=!=!=!=!=!=!=!=!=!=!",
 896   "# This script is automatically generated: DO NOT EDIT!!!",
 897   "# Generated by Glasgow Haskell Compiler",
 898   "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
 899   "#",
 900   "$pvm_executable      = '" ++ pvm_executable ++ "';",
 901   "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
 902   "$SysMan = '" ++ sysMan ++ "';",
 903   "",
 904   {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
 905   "# first, some magical shortcuts to run "commands" on the binary",
 906   "# (which is hidden)",
 907   "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
 908   "    local($cmd) = $1;",
 909   "    system("$cmd $pvm_executable");",
 910   "    exit(0); # all done",
 911   "}", -}
 912   "",
 913   "# Now, run the real binary; process the args first",
 914   "$ENV{'PE'} = $pvm_executable_base;", --  ++ pvm_executable_base,
 915   "$debug = '';",
 916   "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
 917   "@nonPVM_args = ();",
 918   "$in_RTS_args = 0;",
 919   "",
 920   "args: while ($a = shift(@ARGV)) {",
 921   "    if ( $a eq '+RTS' ) {",
 922   "     $in_RTS_args = 1;",
 923   "    } elsif ( $a eq '-RTS' ) {",
 924   "     $in_RTS_args = 0;",
 925   "    }",
 926   "    if ( $a eq '-d' && $in_RTS_args ) {",
 927   "     $debug = '-';",
 928   "    } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
 929   "     $nprocessors = $1;",
 930   "    } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
 931   "     $nprocessors = $1;",
 932   "    } else {",
 933   "     push(@nonPVM_args, $a);",
 934   "    }",
 935   "}",
 936   "",
 937   "local($return_val) = 0;",
 938   "# Start the parallel execution by calling SysMan",
 939   "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
 940   "$return_val = $?;",
 941   "# ToDo: fix race condition moving files and flushing them!!",
 942   "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
 943   "exit($return_val);"
 944  ]
 945
 946 -----------------------------------------------------------------------------
 947 -- Complain about non-dynamic flags in OPTIONS pragmas
 948
 949 checkProcessArgsResult flags basename suff
 950   = do when (notNull flags) (throwDyn (ProgramError (
 951           showSDoc (hang (text basename <> text ('.':suff) <> char ':')
 952                       4 (text "unknown flags in  {-# OPTIONS #-} pragma:" <+>
 953                           hsep (map text flags)))
 954         )))
 955
 956 -----------------------------------------------------------------------------
 957 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
 958
 959 getHCFilePackages :: FilePath -> IO [PackageName]
 960 getHCFilePackages filename =
 961   EXCEPTION.bracket (openFile filename ReadMode) hClose $ \h -> do
 962     l <- hGetLine h
 963     case l of
 964       '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
 965           return (map mkPackageName (words rest))
 966       _other ->
 967           return []
 968
 969 -----------------------------------------------------------------------------
 970 -- Static linking, of .o files
 971
 972 -- The list of packages passed to link is the list of packages on
 973 -- which this program depends, as discovered by the compilation
 974 -- manager.  It is combined with the list of packages that the user
 975 -- specifies on the command line with -package flags.
 976 --
 977 -- In one-shot linking mode, we can't discover the package
 978 -- dependencies (because we haven't actually done any compilation or
 979 -- read any interface files), so the user must explicitly specify all
 980 -- the packages.
 981
 982 staticLink :: [FilePath] -> [PackageName] -> IO ()
 983 staticLink o_files dep_packages = do
 984     verb       <- getVerbFlag
 985     static     <- readIORef v_Static
 986     no_hs_main <- readIORef v_NoHsMain
 987
 988     -- get the full list of packages to link with, by combining the
 989     -- explicit packages with the auto packages and all of their
 990     -- dependencies, and eliminating duplicates.
 991
 992     o_file <- readIORef v_Output_file
 993     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
 994
 995     pkg_lib_paths <- getPackageLibraryPath dep_packages
 996     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
 997
 998     lib_paths <- readIORef v_Library_paths
 999     let lib_path_opts = map ("-L"++) lib_paths
1000
1001     pkg_link_opts <- getPackageLinkOpts dep_packages
1002
1003 #ifdef darwin_TARGET_OS
1004     pkg_framework_paths <- getPackageFrameworkPath dep_packages
1005     let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths
1006
1007     framework_paths <- readIORef v_Framework_paths
1008     let framework_path_opts = map ("-F"++) framework_paths
1009
1010     pkg_frameworks <- getPackageFrameworks dep_packages
1011     let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1012
1013     frameworks <- readIORef v_Cmdline_frameworks
1014     let framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ]
1015          -- reverse because they're added in reverse order from the cmd line
1016 #endif
1017
1018         -- probably _stub.o files
1019     extra_ld_inputs <- readIORef v_Ld_inputs
1020
1021         -- opts from -optl-<blah> (including -l<blah> options)
1022     extra_ld_opts <- getStaticOpts v_Opt_l
1023
1024     [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, basePackage]
1025
1026     let extra_os = if static || no_hs_main
1027                    then []
1028                    else [ head (library_dirs rts_pkg) ++ "/Main.dll_o",
1029                           head (library_dirs std_pkg) ++ "/PrelMain.dll_o" ]
1030
1031     (md_c_flags, _) <- machdepCCOpts
1032     SysTools.runLink ( [ SysTools.Option verb
1033                        , SysTools.Option "-o"
1034                        , SysTools.FileOption "" output_fn
1035                        ]
1036                       ++ map SysTools.Option (
1037                          md_c_flags
1038                       ++ o_files
1039                       ++ extra_os
1040                       ++ extra_ld_inputs
1041                       ++ lib_path_opts
1042                       ++ extra_ld_opts
1043 #ifdef darwin_TARGET_OS
1044                       ++ framework_path_opts
1045                       ++ framework_opts
1046 #endif
1047                       ++ pkg_lib_path_opts
1048                       ++ pkg_link_opts
1049 #ifdef darwin_TARGET_OS
1050                       ++ pkg_framework_path_opts
1051                       ++ pkg_framework_opts
1052 #endif
1053                     ))
1054
1055     -- parallel only: move binary to another dir -- HWL
1056     ways_ <- readIORef v_Ways
1057     when (WayPar `elem` ways_)
1058          (do success <- runPhase_MoveBinary output_fn
1059              if success then return ()
1060                         else throwDyn (InstallationError ("cannot move binary to PVM dir")))
1061
1062 -----------------------------------------------------------------------------
1063 -- Making a DLL (only for Win32)
1064
1065 doMkDLL :: [String] -> [PackageName] -> IO ()
1066 doMkDLL o_files dep_packages = do
1067     verb       <- getVerbFlag
1068     static     <- readIORef v_Static
1069     no_hs_main <- readIORef v_NoHsMain
1070
1071     o_file <- readIORef v_Output_file
1072     let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
1073
1074     pkg_lib_paths <- getPackageLibraryPath dep_packages
1075     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1076
1077     lib_paths <- readIORef v_Library_paths
1078     let lib_path_opts = map ("-L"++) lib_paths
1079
1080     pkg_link_opts <- getPackageLinkOpts dep_packages
1081
1082         -- probably _stub.o files
1083     extra_ld_inputs <- readIORef v_Ld_inputs
1084
1085         -- opts from -optdll-<blah>
1086     extra_ld_opts <- getStaticOpts v_Opt_dll
1087
1088     [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, basePackage]
1089
1090     let extra_os = if static || no_hs_main
1091                    then []
1092                    else [ head (library_dirs rts_pkg) ++ "/Main.dll_o",
1093                           head (library_dirs std_pkg) ++ "/PrelMain.dll_o" ]
1094
1095     (md_c_flags, _) <- machdepCCOpts
1096     SysTools.runMkDLL
1097          ([ SysTools.Option verb
1098           , SysTools.Option "-o"
1099           , SysTools.FileOption "" output_fn
1100           ]
1101          ++ map SysTools.Option (
1102             md_c_flags
1103          ++ o_files
1104          ++ extra_os
1105          ++ [ "--target=i386-mingw32" ]
1106          ++ extra_ld_inputs
1107          ++ lib_path_opts
1108          ++ extra_ld_opts
1109          ++ pkg_lib_path_opts
1110          ++ pkg_link_opts
1111          ++ (if "--def" `elem` (concatMap words extra_ld_opts)
1112                then [ "" ]
1113                else [ "--export-all" ])
1114         ))
1115
1116 -- -----------------------------------------------------------------------------
1117 -- Misc.
1118
1119 hscNextPhase :: HscLang -> IO Phase
1120 hscNextPhase hsc_lang = do
1121   split <- readIORef v_Split_object_files
1122   return (case hsc_lang of
1123                 HscC -> HCc
1124                 HscAsm | split -> SplitMangle
1125                        | otherwise -> As
1126                 HscNothing     -> HCc  -- dummy (no output will be generated)
1127                 HscInterpreted -> HCc  -- "" ""
1128                 _other         -> HCc  -- "" ""
1129         )
1130
1131 hscMaybeAdjustLang :: HscLang -> IO HscLang
1132 hscMaybeAdjustLang current_hsc_lang = do
1133   todo    <- readIORef v_GhcMode
1134   keep_hc <- readIORef v_Keep_hc_files
1135   let hsc_lang
1136         -- don't change the lang if we're interpreting
1137          | current_hsc_lang == HscInterpreted = current_hsc_lang
1138         -- force -fvia-C if we are being asked for a .hc file
1139          | todo == StopBefore HCc  || keep_hc = HscC
1140         -- force -fvia-C when profiling or ticky-ticky is on
1141          | opt_SccProfilingOn || opt_DoTickyProfiling = HscC
1142         -- otherwise, stick to the plan
1143          | otherwise = current_hsc_lang
1144   return hsc_lang