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                        object_dir = directoryOf object_filename
 195
 196                    -- create the object dir if it doesn't exist
 197                    createDirectoryHierarchy object_dir
 198
 199                    runPipeline (StopBefore Ln) ""
 200                         True Nothing output_fn (Just location)
 201                         -- the object filename comes from the ModLocation
 202
 203                    o_time <- getModificationTime object_filename
 204                    return ([DotO object_filename], o_time)
 205
 206            let linkable = LM unlinked_time mod_name
 207                              (hs_unlinked ++ stub_unlinked)
 208
 209            return (CompOK pcs details iface (Just linkable))
 210
 211 -----------------------------------------------------------------------------
 212 -- stub .h and .c files (for foreign export support)
 213
 214 compileStub dflags stub_c_exists
 215   | not stub_c_exists = return Nothing
 216   | stub_c_exists = do
 217         -- compile the _stub.c file w/ gcc
 218         let stub_c = hscStubCOutName dflags
 219         stub_o <- runPipeline (StopBefore Ln) "stub-compile"
 220                         True{-persistent output-}
 221                         Nothing{-no specific output file-}
 222                         stub_c
 223                         Nothing{-no ModLocation-}
 224         return (Just stub_o)
 225
 226
 227 -- ---------------------------------------------------------------------------
 228 -- Link
 229
 230 link :: GhciMode                -- interactive or batch
 231      -> DynFlags                -- dynamic flags
 232      -> Bool                    -- attempt linking in batch mode?
 233      -> HomePackageTable        -- what to link
 234      -> IO SuccessFlag
 235
 236 -- For the moment, in the batch linker, we don't bother to tell doLink
 237 -- which packages to link -- it just tries all that are available.
 238 -- batch_attempt_linking should only be *looked at* in batch mode.  It
 239 -- should only be True if the upsweep was successful and someone
 240 -- exports main, i.e., we have good reason to believe that linking
 241 -- will succeed.
 242
 243 #ifdef GHCI
 244 link Interactive dflags batch_attempt_linking hpt
 245     = do -- Not Linking...(demand linker will do the job)
 246          return Succeeded
 247 #endif
 248
 249 link Batch dflags batch_attempt_linking hpt
 250    | batch_attempt_linking
 251    = do
 252         let
 253             home_mod_infos = moduleEnvElts hpt
 254
 255             -- the packages we depend on
 256             pkg_deps  = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos
 257
 258             -- the linkables to link
 259             linkables = map hm_linkable home_mod_infos
 260
 261         when (verb >= 3) $ do
 262              hPutStrLn stderr "link: linkables are ..."
 263              hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
 264
 265         -- check for the -no-link flag
 266         omit_linking <- readIORef v_NoLink
 267         if omit_linking
 268           then do when (verb >= 3) $
 269                     hPutStrLn stderr "link(batch): linking omitted (-no-link flag given)."
 270                   return Succeeded
 271           else do
 272
 273         when (verb >= 1) $
 274              hPutStrLn stderr "Linking ..."
 275
 276         let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
 277             obj_files = concatMap getOfiles linkables
 278
 279         -- Don't showPass in Batch mode; doLink will do that for us.
 280         staticLink obj_files pkg_deps
 281
 282         when (verb >= 3) (hPutStrLn stderr "link: done")
 283
 284         -- staticLink only returns if it succeeds
 285         return Succeeded
 286
 287    | otherwise
 288    = do when (verb >= 3) $ do
 289             hPutStrLn stderr "link(batch): upsweep (partially) failed OR"
 290             hPutStrLn stderr "   Main.main not exported; not linking."
 291         return Succeeded
 292    where
 293       verb = verbosity dflags
 294
 295 -- ---------------------------------------------------------------------------
 296 -- Run a compilation pipeline, consisting of multiple phases.
 297
 298 runPipeline
 299   :: GhcMode            -- when to stop
 300   -> String             -- "stop after" flag
 301   -> Bool               -- final output is persistent?
 302   -> Maybe FilePath     -- where to put the output, optionally
 303   -> FilePath           -- input filename
 304   -> Maybe ModLocation  -- a ModLocation for this module, if we have one
 305   -> IO FilePath        -- output filename
 306
 307 runPipeline todo stop_flag keep_output maybe_output_filename input_fn maybe_loc
 308   = do
 309   split <- readIORef v_Split_object_files
 310   let (basename, suffix) = splitFilename input_fn
 311       start_phase = startPhase suffix
 312
 313       stop_phase = case todo of
 314                         StopBefore As | split -> SplitAs
 315                         StopBefore phase      -> phase
 316                         DoMkDependHS          -> Ln
 317                         DoLink                -> Ln
 318                         DoMkDLL               -> Ln
 319
 320   -- We want to catch cases of "you can't get there from here" before
 321   -- we start the pipeline, because otherwise it will just run off the
 322   -- end.
 323   --
 324   -- There is a partial ordering on phases, where A < B iff A occurs
 325   -- before B in a normal compilation pipeline.
 326   --
 327   when (not (start_phase `happensBefore` stop_phase)) $
 328         throwDyn (UsageError
 329                     ("flag `" ++ stop_flag
 330                      ++ "' is incompatible with source file `"
 331                      ++ input_fn ++ "'"))
 332
 333   -- generate a function which will be used to calculate output file names
 334   -- as we go along.
 335   get_output_fn <- genOutputFilenameFunc keep_output maybe_output_filename
 336                         stop_phase basename
 337
 338   -- and execute the pipeline...
 339   (output_fn, maybe_loc) <-
 340         pipeLoop start_phase stop_phase input_fn basename suffix
 341                  get_output_fn maybe_loc
 342
 343   -- sometimes, a compilation phase doesn't actually generate any output
 344   -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
 345   -- stage, but we wanted to keep the output, then we have to explicitly
 346   -- copy the file.
 347   if keep_output
 348         then do final_fn <- get_output_fn stop_phase maybe_loc
 349                 when (final_fn /= output_fn) $
 350                   copy ("Copying `" ++ output_fn ++ "' to `" ++ final_fn
 351                         ++ "'") output_fn final_fn
 352                 return final_fn
 353         else
 354              return output_fn
 355
 356
 357 pipeLoop :: Phase -> Phase -> FilePath -> String -> Suffix
 358   -> (Phase -> Maybe ModLocation -> IO FilePath)
 359   -> Maybe ModLocation -> IO (FilePath, Maybe ModLocation)
 360
 361 pipeLoop phase stop_phase input_fn orig_basename orig_suff
 362         get_output_fn maybe_loc
 363
 364   | phase == stop_phase  =  return (input_fn, maybe_loc)  -- all done
 365
 366   | not (phase `happensBefore` stop_phase)  =
 367         -- Something has gone wrong.  We'll try to cover all the cases when
 368         -- this could happen, so if we reach here it is a panic.
 369         -- eg. it might happen if the -C flag is used on a source file that
 370         -- has {-# OPTIONS -fasm #-}.
 371         panic ("pipeLoop: at phase " ++ show phase ++
 372                 " but I wanted to stop at phase " ++ show stop_phase)
 373
 374   | otherwise = do
 375         maybe_next_phase <- runPhase phase orig_basename orig_suff input_fn
 376                                 get_output_fn maybe_loc
 377         case maybe_next_phase of
 378           (Nothing, maybe_loc, output_fn) -> do
 379                 -- we stopped early, but return the *final* filename
 380                 -- (it presumably already exists)
 381                 final_fn <- get_output_fn stop_phase maybe_loc
 382                 return (final_fn, maybe_loc)
 383           (Just next_phase, maybe_loc, output_fn) ->
 384                 pipeLoop next_phase stop_phase output_fn
 385                         orig_basename orig_suff get_output_fn maybe_loc
 386
 387
 388 genOutputFilenameFunc :: Bool -> Maybe FilePath -> Phase -> String
 389   -> IO (Phase{-next phase-} -> Maybe ModLocation -> IO FilePath)
 390 genOutputFilenameFunc keep_output maybe_output_filename stop_phase basename
 391  = do
 392    hcsuf      <- readIORef v_HC_suf
 393    odir       <- readIORef v_Output_dir
 394    osuf       <- readIORef v_Object_suf
 395    keep_hc    <- readIORef v_Keep_hc_files
 396 #ifdef ILX
 397    keep_il    <- readIORef v_Keep_il_files
 398    keep_ilx   <- readIORef v_Keep_ilx_files
 399 #endif
 400    keep_raw_s <- readIORef v_Keep_raw_s_files
 401    keep_s     <- readIORef v_Keep_s_files
 402    let
 403         myPhaseInputExt HCc | Just s <- hcsuf = s
 404         myPhaseInputExt Ln    = osuf
 405         myPhaseInputExt other = phaseInputExt other
 406
 407         func next_phase maybe_location
 408                 | next_phase == stop_phase
 409                      = case maybe_output_filename of
 410                              Just file -> return file
 411                              Nothing
 412                                  | Ln <- next_phase -> return odir_persistent
 413                                  | keep_output      -> return persistent
 414                                  | otherwise        -> newTempName suffix
 415                         -- sometimes, we keep output from intermediate stages
 416                 | otherwise
 417                      = case next_phase of
 418                              Ln                  -> return odir_persistent
 419                              Mangle | keep_raw_s -> return persistent
 420                              As     | keep_s     -> return persistent
 421                              HCc    | keep_hc    -> return persistent
 422                              _other              -> newTempName suffix
 423            where
 424                 suffix = myPhaseInputExt next_phase
 425                 persistent = basename ++ '.':suffix
 426
 427                 odir_persistent
 428                    | Just loc <- maybe_location = ml_obj_file loc
 429                    | Just d <- odir = replaceFilenameDirectory persistent d
 430                    | otherwise      = persistent
 431
 432    return func
 433
 434
 435 -- -----------------------------------------------------------------------------
 436 -- Each phase in the pipeline returns the next phase to execute, and the
 437 -- name of the file in which the output was placed.
 438 --
 439 -- We must do things dynamically this way, because we often don't know
 440 -- what the rest of the phases will be until part-way through the
 441 -- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
 442 -- of a source file can change the latter stages of the pipeline from
 443 -- taking the via-C route to using the native code generator.
 444
 445 runPhase :: Phase
 446           -> String     -- basename of original input source
 447           -> String     -- its extension
 448           -> FilePath   -- name of file which contains the input to this phase.
 449           -> (Phase -> Maybe ModLocation -> IO FilePath)
 450                         -- how to calculate the output filename
 451           -> Maybe ModLocation          -- the ModLocation, if we have one
 452           -> IO (Maybe Phase,           -- next phase
 453                  Maybe ModLocation,     -- the ModLocation, if we have one
 454                  FilePath)              -- output filename
 455
 456 -------------------------------------------------------------------------------
 457 -- Unlit phase
 458
 459 runPhase Unlit _basename _suff input_fn get_output_fn maybe_loc
 460   = do unlit_flags <- getOpts opt_L
 461        -- The -h option passes the file name for unlit to put in a #line directive
 462        output_fn <- get_output_fn Cpp maybe_loc
 463
 464        SysTools.runUnlit (map SysTools.Option unlit_flags ++
 465                           [ SysTools.Option     "-h"
 466                           , SysTools.Option     input_fn
 467                           , SysTools.FileOption "" input_fn
 468                           , SysTools.FileOption "" output_fn
 469                           ])
 470
 471        return (Just Cpp, maybe_loc, output_fn)
 472
 473 -------------------------------------------------------------------------------
 474 -- Cpp phase
 475
 476 runPhase Cpp basename suff input_fn get_output_fn maybe_loc
 477   = do src_opts <- getOptionsFromSource input_fn
 478        unhandled_flags <- processArgs dynamic_flags src_opts []
 479        checkProcessArgsResult unhandled_flags basename suff
 480
 481        do_cpp <- dynFlag cppFlag
 482        if not do_cpp then
 483            -- no need to preprocess CPP, just pass input file along
 484            -- to the next phase of the pipeline.
 485           return (Just HsPp, maybe_loc, input_fn)
 486         else do
 487             hscpp_opts      <- getOpts opt_P
 488             hs_src_cpp_opts <- readIORef v_Hs_source_cpp_opts
 489
 490             cmdline_include_paths <- readIORef v_Include_paths
 491
 492             pkg_include_dirs <- getPackageIncludePath []
 493             let include_paths = foldr (\ x xs -> "-I" : x : xs) []
 494                                   (cmdline_include_paths ++ pkg_include_dirs)
 495
 496             verb <- getVerbFlag
 497             (md_c_flags, _) <- machdepCCOpts
 498
 499             output_fn <- get_output_fn HsPp maybe_loc
 500
 501             SysTools.runCpp ([SysTools.Option verb]
 502                             ++ map SysTools.Option include_paths
 503                             ++ map SysTools.Option hs_src_cpp_opts
 504                             ++ map SysTools.Option hscpp_opts
 505                             ++ map SysTools.Option md_c_flags
 506                             ++ [ SysTools.Option     "-x"
 507                                , SysTools.Option     "c"
 508                                , SysTools.Option     input_fn
 509         -- We hackily use Option instead of FileOption here, so that the file
 510         -- name is not back-slashed on Windows.  cpp is capable of
 511         -- dealing with / in filenames, so it works fine.  Furthermore
 512         -- if we put in backslashes, cpp outputs #line directives
 513         -- with *double* backslashes.   And that in turn means that
 514         -- our error messages get double backslashes in them.
 515         -- In due course we should arrange that the lexer deals
 516         -- with these \\ escapes properly.
 517                                , SysTools.Option     "-o"
 518                                , SysTools.FileOption "" output_fn
 519                                ])
 520
 521             return (Just HsPp, maybe_loc, output_fn)
 522
 523 -------------------------------------------------------------------------------
 524 -- HsPp phase
 525
 526 runPhase HsPp basename suff input_fn get_output_fn maybe_loc
 527   = do do_pp   <- dynFlag ppFlag
 528        if not do_pp then
 529            -- no need to preprocess, just pass input file along
 530            -- to the next phase of the pipeline.
 531           return (Just Hsc, maybe_loc, input_fn)
 532         else do
 533             hspp_opts      <- getOpts opt_F
 534             hs_src_pp_opts <- readIORef v_Hs_source_pp_opts
 535             let orig_fn = basename ++ '.':suff
 536             output_fn <- get_output_fn Hsc maybe_loc
 537             SysTools.runPp ( [ SysTools.Option     orig_fn
 538                              , SysTools.Option     input_fn
 539                              , SysTools.FileOption "" output_fn
 540                              ] ++
 541                              map SysTools.Option hs_src_pp_opts ++
 542                              map SysTools.Option hspp_opts
 543                            )
 544             return (Just Hsc, maybe_loc, output_fn)
 545
 546 -----------------------------------------------------------------------------
 547 -- Hsc phase
 548
 549 -- Compilation of a single module, in "legacy" mode (_not_ under
 550 -- the direction of the compilation manager).
 551 runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do
 552   todo <- readIORef v_GhcMode
 553   if todo == DoMkDependHS then do
 554        locn <- doMkDependHSPhase basename suff input_fn
 555        return (Nothing, Just locn, input_fn)  -- Ln is a dummy stop phase
 556
 557    else do
 558       -- normal Hsc mode, not mkdependHS
 559
 560   -- we add the current directory (i.e. the directory in which
 561   -- the .hs files resides) to the import path, since this is
 562   -- what gcc does, and it's probably what you want.
 563         let current_dir = directoryOf basename
 564
 565         paths <- readIORef v_Include_paths
 566         writeIORef v_Include_paths (current_dir : paths)
 567
 568   -- gather the imports and module name
 569         (_,_,mod_name) <-
 570             if extcoreish_suffix suff
 571              then do
 572                -- no explicit imports in ExtCore input.
 573                m <- getCoreModuleName input_fn
 574                return ([], [], mkModuleName m)
 575              else
 576                getImportsFromFile input_fn
 577
 578   -- build a ModLocation to pass to hscMain.
 579         (mod, location') <- mkHomeModLocation mod_name (basename ++ '.':suff)
 580
 581   -- take -ohi into account if present
 582         ohi <- readIORef v_Output_hi
 583         let location | Just fn <- ohi = location'{ ml_hi_file = fn }
 584                      | otherwise      = location'
 585
 586   -- figure out if the source has changed, for recompilation avoidance.
 587   -- only do this if we're eventually going to generate a .o file.
 588   -- (ToDo: do when generating .hc files too?)
 589   --
 590   -- Setting source_unchanged to True means that M.o seems
 591   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 592   -- changed (which the compiler itself figures out).
 593   -- Setting source_unchanged to False tells the compiler that M.o is out of
 594   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 595         do_recomp   <- readIORef v_Recomp
 596         expl_o_file <- readIORef v_Output_file
 597
 598         let o_file -- if the -o option is given and IT IS THE OBJECT FILE FOR
 599                    -- THIS COMPILATION, then use that to determine if the
 600                    -- source is unchanged.
 601                 | Just x <- expl_o_file, todo == StopBefore Ln  =  x
 602                 | otherwise = ml_obj_file location
 603
 604         source_unchanged <-
 605           if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
 606              then return False
 607              else do t1 <- getModificationTime (basename ++ '.':suff)
 608                      o_file_exists <- doesFileExist o_file
 609                      if not o_file_exists
 610                         then return False       -- Need to recompile
 611                         else do t2 <- getModificationTime o_file
 612                                 if t2 > t1
 613                                   then return True
 614                                   else return False
 615
 616   -- get the DynFlags
 617         dyn_flags <- getDynFlags
 618         hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags)
 619         next_phase <- hscNextPhase hsc_lang
 620         output_fn <- get_output_fn next_phase (Just location)
 621
 622         let dyn_flags' = dyn_flags { hscLang = hsc_lang,
 623                                      hscOutName = output_fn,
 624                                      hscStubCOutName = basename ++ "_stub.c",
 625                                      hscStubHOutName = basename ++ "_stub.h",
 626                                      extCoreName = basename ++ ".hcr" }
 627             hsc_env = HscEnv { hsc_mode = OneShot,
 628                                hsc_dflags = dyn_flags',
 629                                hsc_HPT    = emptyHomePackageTable }
 630
 631
 632   -- run the compiler!
 633         pcs <- initPersistentCompilerState
 634         result <- hscMain hsc_env pcs mod
 635                           location{ ml_hspp_file=Just input_fn }
 636                           source_unchanged
 637                           False
 638                           Nothing        -- no iface
 639
 640         case result of
 641
 642             HscFail pcs -> throwDyn (PhaseFailed "hsc" (ExitFailure 1))
 643
 644             HscNoRecomp pcs details iface -> do
 645                 SysTools.touch "Touching object file" o_file
 646                 return (Nothing, Just location, output_fn)
 647
 648             HscRecomp _pcs _details _iface stub_h_exists stub_c_exists
 649                       _maybe_interpreted_code -> do
 650
 651                 -- deal with stubs
 652                 maybe_stub_o <- compileStub dyn_flags' stub_c_exists
 653                 case maybe_stub_o of
 654                       Nothing -> return ()
 655                       Just stub_o -> add v_Ld_inputs stub_o
 656                 case hscLang dyn_flags of
 657                       HscNothing -> return (Nothing, Just location, output_fn)
 658                       _ -> return (Just next_phase, Just location, output_fn)
 659
 660 -----------------------------------------------------------------------------
 661 -- Cc phase
 662
 663 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 664 -- way too many hacks, and I can't say I've ever used it anyway.
 665
 666 runPhase cc_phase basename suff input_fn get_output_fn maybe_loc
 667    | cc_phase == Cc || cc_phase == HCc
 668    = do cc_opts <- getOpts opt_c
 669         cmdline_include_paths <- readIORef v_Include_paths
 670
 671         split  <- readIORef v_Split_object_files
 672         mangle <- readIORef v_Do_asm_mangling
 673
 674         let hcc = cc_phase == HCc
 675
 676             next_phase
 677                 | hcc && mangle     = Mangle
 678                 | otherwise         = As
 679
 680         output_fn <- get_output_fn next_phase maybe_loc
 681
 682         -- HC files have the dependent packages stamped into them
 683         pkgs <- if hcc then getHCFilePackages input_fn else return []
 684
 685         -- add package include paths even if we're just compiling .c
 686         -- files; this is the Value Add(TM) that using ghc instead of
 687         -- gcc gives you :)
 688         pkg_include_dirs <- getPackageIncludePath pkgs
 689         let include_paths = foldr (\ x xs -> "-I" : x : xs) []
 690                               (cmdline_include_paths ++ pkg_include_dirs)
 691
 692         mangle <- readIORef v_Do_asm_mangling
 693         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
 694
 695         verb <- getVerbFlag
 696
 697         o2 <- readIORef v_minus_o2_for_C
 698         let opt_flag | o2        = "-O2"
 699                      | otherwise = "-O"
 700
 701         pkg_extra_cc_opts <- getPackageExtraCcOpts pkgs
 702
 703         split_objs <- readIORef v_Split_object_files
 704         let split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 705                       | otherwise         = [ ]
 706
 707         excessPrecision <- readIORef v_Excess_precision
 708
 709         -- force the C compiler to interpret this file as C when
 710         -- compiling .hc files, by adding the -x c option.
 711         let langopt
 712                 | cc_phase == HCc = [ SysTools.Option "-x", SysTools.Option "c"]
 713                 | otherwise       = [ ]
 714
 715         SysTools.runCc (langopt ++
 716                         [ SysTools.FileOption "" input_fn
 717                         , SysTools.Option "-o"
 718                         , SysTools.FileOption "" output_fn
 719                         ]
 720                        ++ map SysTools.Option (
 721                           md_c_flags
 722                        ++ (if cc_phase == HCc && mangle
 723                              then md_regd_c_flags
 724                              else [])
 725                        ++ [ verb, "-S", "-Wimplicit", opt_flag ]
 726                        ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 727                        ++ cc_opts
 728                        ++ split_opt
 729                        ++ (if excessPrecision then [] else [ "-ffloat-store" ])
 730                        ++ include_paths
 731                        ++ pkg_extra_cc_opts
 732                        ))
 733
 734         return (Just next_phase, maybe_loc, output_fn)
 735
 736         -- ToDo: postprocess the output from gcc
 737
 738 -----------------------------------------------------------------------------
 739 -- Mangle phase
 740
 741 runPhase Mangle _basename _suff input_fn get_output_fn maybe_loc
 742    = do mangler_opts <- getOpts opt_m
 743         machdep_opts <- if (prefixMatch "i386" cTARGETPLATFORM)
 744                           then do n_regs <- dynFlag stolen_x86_regs
 745                                   return [ show n_regs ]
 746                           else return []
 747
 748         split <- readIORef v_Split_object_files
 749         let next_phase
 750                 | split = SplitMangle
 751                 | otherwise = As
 752         output_fn <- get_output_fn next_phase maybe_loc
 753
 754         SysTools.runMangle (map SysTools.Option mangler_opts
 755                           ++ [ SysTools.FileOption "" input_fn
 756                              , SysTools.FileOption "" output_fn
 757                              ]
 758                           ++ map SysTools.Option machdep_opts)
 759
 760         return (Just next_phase, maybe_loc, output_fn)
 761
 762 -----------------------------------------------------------------------------
 763 -- Splitting phase
 764
 765 runPhase SplitMangle _basename _suff input_fn get_output_fn maybe_loc
 766   = do  -- tmp_pfx is the prefix used for the split .s files
 767         -- We also use it as the file to contain the no. of split .s files (sigh)
 768         split_s_prefix <- SysTools.newTempName "split"
 769         let n_files_fn = split_s_prefix
 770
 771         SysTools.runSplit [ SysTools.FileOption "" input_fn
 772                           , SysTools.FileOption "" split_s_prefix
 773                           , SysTools.FileOption "" n_files_fn
 774                           ]
 775
 776         -- Save the number of split files for future references
 777         s <- readFile n_files_fn
 778         let n_files = read s :: Int
 779         writeIORef v_Split_info (split_s_prefix, n_files)
 780
 781         -- Remember to delete all these files
 782         addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s"
 783                         | n <- [1..n_files]]
 784
 785         return (Just SplitAs, maybe_loc, "**splitmangle**")
 786           -- we don't use the filename
 787
 788 -----------------------------------------------------------------------------
 789 -- As phase
 790
 791 runPhase As _basename _suff input_fn get_output_fn maybe_loc
 792   = do  as_opts               <- getOpts opt_a
 793         cmdline_include_paths <- readIORef v_Include_paths
 794
 795         output_fn <- get_output_fn Ln maybe_loc
 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                       ++ if static && not no_hs_main then
1058                             [ "-u", prefixUnderscore "Main_zdmain_closure"]
1059                          else []))
1060
1061     -- parallel only: move binary to another dir -- HWL
1062     ways_ <- readIORef v_Ways
1063     when (WayPar `elem` ways_)
1064          (do success <- runPhase_MoveBinary output_fn
1065              if success then return ()
1066                         else throwDyn (InstallationError ("cannot move binary to PVM dir")))
1067
1068 -----------------------------------------------------------------------------
1069 -- Making a DLL (only for Win32)
1070
1071 doMkDLL :: [String] -> [PackageName] -> IO ()
1072 doMkDLL o_files dep_packages = do
1073     verb       <- getVerbFlag
1074     static     <- readIORef v_Static
1075     no_hs_main <- readIORef v_NoHsMain
1076
1077     o_file <- readIORef v_Output_file
1078     let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
1079
1080     pkg_lib_paths <- getPackageLibraryPath dep_packages
1081     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1082
1083     lib_paths <- readIORef v_Library_paths
1084     let lib_path_opts = map ("-L"++) lib_paths
1085
1086     pkg_link_opts <- getPackageLinkOpts dep_packages
1087
1088         -- probably _stub.o files
1089     extra_ld_inputs <- readIORef v_Ld_inputs
1090
1091         -- opts from -optdll-<blah>
1092     extra_ld_opts <- getStaticOpts v_Opt_dll
1093
1094     [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, basePackage]
1095
1096     let extra_os = if static || no_hs_main
1097                    then []
1098                    else [ head (library_dirs rts_pkg) ++ "/Main.dll_o",
1099                           head (library_dirs std_pkg) ++ "/PrelMain.dll_o" ]
1100
1101     (md_c_flags, _) <- machdepCCOpts
1102     SysTools.runMkDLL
1103          ([ SysTools.Option verb
1104           , SysTools.Option "-o"
1105           , SysTools.FileOption "" output_fn
1106           ]
1107          ++ map SysTools.Option (
1108             md_c_flags
1109          ++ o_files
1110          ++ extra_os
1111          ++ [ "--target=i386-mingw32" ]
1112          ++ extra_ld_inputs
1113          ++ lib_path_opts
1114          ++ extra_ld_opts
1115          ++ pkg_lib_path_opts
1116          ++ pkg_link_opts
1117          ++ (if "--def" `elem` (concatMap words extra_ld_opts)
1118                then [ "" ]
1119                else [ "--export-all" ])
1120         ))
1121
1122 -- -----------------------------------------------------------------------------
1123 -- Misc.
1124
1125 hscNextPhase :: HscLang -> IO Phase
1126 hscNextPhase hsc_lang = do
1127   split <- readIORef v_Split_object_files
1128   return (case hsc_lang of
1129                 HscC -> HCc
1130                 HscAsm | split -> SplitMangle
1131                        | otherwise -> As
1132                 HscNothing     -> HCc  -- dummy (no output will be generated)
1133                 HscInterpreted -> HCc  -- "" ""
1134                 _other         -> HCc  -- "" ""
1135         )
1136
1137 hscMaybeAdjustLang :: HscLang -> IO HscLang
1138 hscMaybeAdjustLang current_hsc_lang = do
1139   todo    <- readIORef v_GhcMode
1140   keep_hc <- readIORef v_Keep_hc_files
1141   let hsc_lang
1142         -- don't change the lang if we're interpreting
1143          | current_hsc_lang == HscInterpreted = current_hsc_lang
1144         -- force -fvia-C if we are being asked for a .hc file
1145          | todo == StopBefore HCc  || keep_hc = HscC
1146         -- force -fvia-C when profiling or ticky-ticky is on
1147          | opt_SccProfilingOn || opt_DoTickyProfiling = HscC
1148         -- otherwise, stick to the plan
1149          | otherwise = current_hsc_lang
1150   return hsc_lang