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