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    odir       <- readIORef v_Output_dir
 385    osuf       <- readIORef v_Object_suf
 386    keep_hc    <- readIORef v_Keep_hc_files
 387 #ifdef ILX
 388    keep_il    <- readIORef v_Keep_il_files
 389    keep_ilx   <- readIORef v_Keep_ilx_files
 390 #endif
 391    keep_raw_s <- readIORef v_Keep_raw_s_files
 392    keep_s     <- readIORef v_Keep_s_files
 393    let
 394         myPhaseInputExt HCc | Just s <- hcsuf = s
 395         myPhaseInputExt Ln    = osuf
 396         myPhaseInputExt other = phaseInputExt other
 397
 398         func next_phase
 399                 | next_phase == stop_phase
 400                      = case maybe_output_filename of
 401                              Just file -> return file
 402                              Nothing
 403                                  | Ln <- next_phase -> return odir_persistent
 404                                  | keep_output      -> return persistent
 405                                  | otherwise        -> newTempName suffix
 406                         -- sometimes, we keep output from intermediate stages
 407                 | otherwise
 408                      = case next_phase of
 409                              Ln                  -> return odir_persistent
 410                              Mangle | keep_raw_s -> return persistent
 411                              As     | keep_s     -> return persistent
 412                              HCc    | keep_hc    -> return persistent
 413                              _other              -> newTempName suffix
 414            where
 415                 suffix = myPhaseInputExt next_phase
 416                 persistent = basename ++ '.':suffix
 417
 418                 odir_persistent
 419                    | Just d <- odir = replaceFilenameDirectory persistent d
 420                    | otherwise      = persistent
 421
 422    return func
 423
 424
 425 -- -----------------------------------------------------------------------------
 426 -- Each phase in the pipeline returns the next phase to execute, and the
 427 -- name of the file in which the output was placed.
 428 --
 429 -- We must do things dynamically this way, because we often don't know
 430 -- what the rest of the phases will be until part-way through the
 431 -- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
 432 -- of a source file can change the latter stages of the pipeline from
 433 -- taking the via-C route to using the native code generator.
 434
 435 runPhase :: Phase
 436           -> String     -- basename of original input source
 437           -> String     -- its extension
 438           -> FilePath   -- name of file which contains the input to this phase.
 439           -> (Phase -> IO FilePath)     -- how to calculate the output filename
 440           -> IO (Maybe Phase,   -- next phase
 441                  FilePath)      -- output filename
 442
 443 -------------------------------------------------------------------------------
 444 -- Unlit phase
 445
 446 runPhase Unlit _basename _suff input_fn get_output_fn
 447   = do unlit_flags <- getOpts opt_L
 448        -- The -h option passes the file name for unlit to put in a #line directive
 449        output_fn <- get_output_fn Cpp
 450
 451        SysTools.runUnlit (map SysTools.Option unlit_flags ++
 452                           [ SysTools.Option     "-h"
 453                           , SysTools.Option     input_fn
 454                           , SysTools.FileOption "" input_fn
 455                           , SysTools.FileOption "" output_fn
 456                           ])
 457
 458        return (Just Cpp, output_fn)
 459
 460 -------------------------------------------------------------------------------
 461 -- Cpp phase
 462
 463 runPhase Cpp basename suff input_fn get_output_fn
 464   = do src_opts <- getOptionsFromSource input_fn
 465        unhandled_flags <- processArgs dynamic_flags src_opts []
 466        checkProcessArgsResult unhandled_flags basename suff
 467
 468        do_cpp <- dynFlag cppFlag
 469        if not do_cpp then
 470            -- no need to preprocess CPP, just pass input file along
 471            -- to the next phase of the pipeline.
 472           return (Just HsPp, input_fn)
 473         else do
 474             hscpp_opts      <- getOpts opt_P
 475             hs_src_cpp_opts <- readIORef v_Hs_source_cpp_opts
 476
 477             cmdline_include_paths <- readIORef v_Include_paths
 478
 479             pkg_include_dirs <- getPackageIncludePath []
 480             let include_paths = foldr (\ x xs -> "-I" : x : xs) []
 481                                   (cmdline_include_paths ++ pkg_include_dirs)
 482
 483             verb <- getVerbFlag
 484             (md_c_flags, _) <- machdepCCOpts
 485
 486             output_fn <- get_output_fn HsPp
 487
 488             SysTools.runCpp ([SysTools.Option verb]
 489                             ++ map SysTools.Option include_paths
 490                             ++ map SysTools.Option hs_src_cpp_opts
 491                             ++ map SysTools.Option hscpp_opts
 492                             ++ map SysTools.Option md_c_flags
 493                             ++ [ SysTools.Option     "-x"
 494                                , SysTools.Option     "c"
 495                                , SysTools.Option     input_fn
 496         -- We hackily use Option instead of FileOption here, so that the file
 497         -- name is not back-slashed on Windows.  cpp is capable of
 498         -- dealing with / in filenames, so it works fine.  Furthermore
 499         -- if we put in backslashes, cpp outputs #line directives
 500         -- with *double* backslashes.   And that in turn means that
 501         -- our error messages get double backslashes in them.
 502         -- In due course we should arrange that the lexer deals
 503         -- with these \\ escapes properly.
 504                                , SysTools.Option     "-o"
 505                                , SysTools.FileOption "" output_fn
 506                                ])
 507
 508             return (Just HsPp, output_fn)
 509
 510 -------------------------------------------------------------------------------
 511 -- HsPp phase
 512
 513 runPhase HsPp basename suff input_fn get_output_fn
 514   = do do_pp   <- dynFlag ppFlag
 515        if not do_pp then
 516            -- no need to preprocess, just pass input file along
 517            -- to the next phase of the pipeline.
 518           return (Just Hsc, input_fn)
 519         else do
 520             hspp_opts      <- getOpts opt_F
 521             hs_src_pp_opts <- readIORef v_Hs_source_pp_opts
 522             let orig_fn = basename ++ '.':suff
 523             output_fn <- get_output_fn Hsc
 524             SysTools.runPp ( [ SysTools.Option     orig_fn
 525                              , SysTools.Option     input_fn
 526                              , SysTools.FileOption "" output_fn
 527                              ] ++
 528                              map SysTools.Option hs_src_pp_opts ++
 529                              map SysTools.Option hspp_opts
 530                            )
 531             return (Just Hsc, output_fn)
 532
 533 -----------------------------------------------------------------------------
 534 -- Hsc phase
 535
 536 -- Compilation of a single module, in "legacy" mode (_not_ under
 537 -- the direction of the compilation manager).
 538 runPhase Hsc basename suff input_fn get_output_fn = do
 539   todo <- readIORef v_GhcMode
 540   if todo == DoMkDependHS then do
 541        doMkDependHSPhase basename suff input_fn
 542        return (Nothing, input_fn)  -- Ln is a dummy stop phase
 543
 544    else do
 545       -- normal Hsc mode, not mkdependHS
 546
 547   -- we add the current directory (i.e. the directory in which
 548   -- the .hs files resides) to the import path, since this is
 549   -- what gcc does, and it's probably what you want.
 550         let current_dir = directoryOf basename
 551
 552         paths <- readIORef v_Include_paths
 553         writeIORef v_Include_paths (current_dir : paths)
 554
 555   -- gather the imports and module name
 556         (_,_,mod_name) <-
 557             if extcoreish_suffix suff
 558              then do
 559                -- no explicit imports in ExtCore input.
 560                m <- getCoreModuleName input_fn
 561                return ([], [], mkModuleName m)
 562              else
 563                getImportsFromFile input_fn
 564
 565   -- build a ModLocation to pass to hscMain.
 566         let (path,file) = splitFilenameDir basename
 567         (mod, location') <- mkHomeModLocation mod_name True path file suff
 568
 569   -- take -ohi into account if present
 570         ohi <- readIORef v_Output_hi
 571         let location | Just fn <- ohi = location'{ ml_hi_file = fn }
 572                      | otherwise      = location'
 573
 574   -- figure out if the source has changed, for recompilation avoidance.
 575   -- only do this if we're eventually going to generate a .o file.
 576   -- (ToDo: do when generating .hc files too?)
 577   --
 578   -- Setting source_unchanged to True means that M.o seems
 579   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 580   -- changed (which the compiler itself figures out).
 581   -- Setting source_unchanged to False tells the compiler that M.o is out of
 582   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 583         do_recomp   <- readIORef v_Recomp
 584         expl_o_file <- readIORef v_Output_file
 585
 586         let o_file -- if the -o option is given and IT IS THE OBJECT FILE FOR
 587                    -- THIS COMPILATION, then use that to determine if the
 588                    -- source is unchanged.
 589                 | Just x <- expl_o_file, todo == StopBefore Ln  =  x
 590                 | otherwise = ml_obj_file location
 591
 592         source_unchanged <-
 593           if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
 594              then return False
 595              else do t1 <- getModificationTime (basename ++ '.':suff)
 596                      o_file_exists <- doesFileExist o_file
 597                      if not o_file_exists
 598                         then return False       -- Need to recompile
 599                         else do t2 <- getModificationTime o_file
 600                                 if t2 > t1
 601                                   then return True
 602                                   else return False
 603
 604   -- get the DynFlags
 605         dyn_flags <- getDynFlags
 606         hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags)
 607         next_phase <- hscNextPhase hsc_lang
 608         output_fn <- get_output_fn next_phase
 609
 610         let dyn_flags' = dyn_flags { hscLang = hsc_lang,
 611                                      hscOutName = output_fn,
 612                                      hscStubCOutName = basename ++ "_stub.c",
 613                                      hscStubHOutName = basename ++ "_stub.h",
 614                                      extCoreName = basename ++ ".hcr" }
 615             hsc_env = HscEnv { hsc_mode = OneShot,
 616                                hsc_dflags = dyn_flags',
 617                                hsc_HPT    = emptyHomePackageTable }
 618
 619
 620   -- run the compiler!
 621         pcs <- initPersistentCompilerState
 622         result <- hscMain hsc_env pcs mod
 623                           location{ ml_hspp_file=Just input_fn }
 624                           source_unchanged
 625                           False
 626                           Nothing        -- no iface
 627
 628         case result of
 629
 630             HscFail pcs -> throwDyn (PhaseFailed "hsc" (ExitFailure 1))
 631
 632             HscNoRecomp pcs details iface -> do
 633                 SysTools.touch "Touching object file" o_file
 634                 return (Nothing, output_fn)
 635
 636             HscRecomp _pcs _details _iface stub_h_exists stub_c_exists
 637                       _maybe_interpreted_code -> do
 638
 639                 -- deal with stubs
 640                 maybe_stub_o <- compileStub dyn_flags' stub_c_exists
 641                 case maybe_stub_o of
 642                       Nothing -> return ()
 643                       Just stub_o -> add v_Ld_inputs stub_o
 644                 case hscLang dyn_flags of
 645                       HscNothing -> return (Nothing, output_fn)
 646                       _ -> return (Just next_phase, output_fn)
 647
 648 -----------------------------------------------------------------------------
 649 -- Cc phase
 650
 651 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 652 -- way too many hacks, and I can't say I've ever used it anyway.
 653
 654 runPhase cc_phase basename suff input_fn get_output_fn
 655    | cc_phase == Cc || cc_phase == HCc
 656    = do cc_opts <- getOpts opt_c
 657         cmdline_include_paths <- readIORef v_Include_paths
 658
 659         split  <- readIORef v_Split_object_files
 660         mangle <- readIORef v_Do_asm_mangling
 661
 662         let hcc = cc_phase == HCc
 663
 664             next_phase
 665                 | hcc && mangle     = Mangle
 666                 | otherwise         = As
 667
 668         output_fn <- get_output_fn next_phase
 669
 670         -- HC files have the dependent packages stamped into them
 671         pkgs <- if hcc then getHCFilePackages input_fn else return []
 672
 673         -- add package include paths even if we're just compiling .c
 674         -- files; this is the Value Add(TM) that using ghc instead of
 675         -- gcc gives you :)
 676         pkg_include_dirs <- getPackageIncludePath pkgs
 677         let include_paths = foldr (\ x xs -> "-I" : x : xs) []
 678                               (cmdline_include_paths ++ pkg_include_dirs)
 679
 680         mangle <- readIORef v_Do_asm_mangling
 681         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
 682
 683         verb <- getVerbFlag
 684
 685         o2 <- readIORef v_minus_o2_for_C
 686         let opt_flag | o2        = "-O2"
 687                      | otherwise = "-O"
 688
 689         pkg_extra_cc_opts <- getPackageExtraCcOpts pkgs
 690
 691         split_objs <- readIORef v_Split_object_files
 692         let split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 693                       | otherwise         = [ ]
 694
 695         excessPrecision <- readIORef v_Excess_precision
 696
 697         -- force the C compiler to interpret this file as C when
 698         -- compiling .hc files, by adding the -x c option.
 699         let langopt
 700                 | cc_phase == HCc = [ SysTools.Option "-x", SysTools.Option "c"]
 701                 | otherwise       = [ ]
 702
 703         SysTools.runCc (langopt ++
 704                         [ SysTools.FileOption "" input_fn
 705                         , SysTools.Option "-o"
 706                         , SysTools.FileOption "" output_fn
 707                         ]
 708                        ++ map SysTools.Option (
 709                           md_c_flags
 710                        ++ (if cc_phase == HCc && mangle
 711                              then md_regd_c_flags
 712                              else [])
 713                        ++ [ verb, "-S", "-Wimplicit", opt_flag ]
 714                        ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 715                        ++ cc_opts
 716                        ++ split_opt
 717                        ++ (if excessPrecision then [] else [ "-ffloat-store" ])
 718                        ++ include_paths
 719                        ++ pkg_extra_cc_opts
 720                        ))
 721
 722         return (Just next_phase, output_fn)
 723
 724         -- ToDo: postprocess the output from gcc
 725
 726 -----------------------------------------------------------------------------
 727 -- Mangle phase
 728
 729 runPhase Mangle _basename _suff input_fn get_output_fn
 730    = do mangler_opts <- getOpts opt_m
 731         machdep_opts <- if (prefixMatch "i386" cTARGETPLATFORM)
 732                           then do n_regs <- dynFlag stolen_x86_regs
 733                                   return [ show n_regs ]
 734                           else return []
 735
 736         split <- readIORef v_Split_object_files
 737         let next_phase
 738                 | split = SplitMangle
 739                 | otherwise = As
 740         output_fn <- get_output_fn next_phase
 741
 742         SysTools.runMangle (map SysTools.Option mangler_opts
 743                           ++ [ SysTools.FileOption "" input_fn
 744                              , SysTools.FileOption "" output_fn
 745                              ]
 746                           ++ map SysTools.Option machdep_opts)
 747
 748         return (Just next_phase, output_fn)
 749
 750 -----------------------------------------------------------------------------
 751 -- Splitting phase
 752
 753 runPhase SplitMangle _basename _suff input_fn get_output_fn
 754   = do  -- tmp_pfx is the prefix used for the split .s files
 755         -- We also use it as the file to contain the no. of split .s files (sigh)
 756         split_s_prefix <- SysTools.newTempName "split"
 757         let n_files_fn = split_s_prefix
 758
 759         SysTools.runSplit [ SysTools.FileOption "" input_fn
 760                           , SysTools.FileOption "" split_s_prefix
 761                           , SysTools.FileOption "" n_files_fn
 762                           ]
 763
 764         -- Save the number of split files for future references
 765         s <- readFile n_files_fn
 766         let n_files = read s :: Int
 767         writeIORef v_Split_info (split_s_prefix, n_files)
 768
 769         -- Remember to delete all these files
 770         addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s"
 771                         | n <- [1..n_files]]
 772
 773         return (Just SplitAs, "**splitmangle**")  -- we don't use the filename
 774
 775 -----------------------------------------------------------------------------
 776 -- As phase
 777
 778 runPhase As _basename _suff input_fn get_output_fn
 779   = do  as_opts               <- getOpts opt_a
 780         cmdline_include_paths <- readIORef v_Include_paths
 781
 782         output_fn <- get_output_fn Ln
 783
 784         SysTools.runAs (map SysTools.Option as_opts
 785                        ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
 786                        ++ [ SysTools.Option "-c"
 787                           , SysTools.FileOption "" input_fn
 788                           , SysTools.Option "-o"
 789                           , SysTools.FileOption "" output_fn
 790                           ])
 791
 792         return (Just Ln, output_fn)
 793
 794
 795 runPhase SplitAs basename _suff _input_fn get_output_fn
 796   = do  as_opts <- getOpts opt_a
 797
 798         (split_s_prefix, n) <- readIORef v_Split_info
 799
 800         odir <- readIORef v_Output_dir
 801         let real_odir = case odir of
 802                                 Nothing -> basename ++ "_split"
 803                                 Just d  -> d
 804
 805         let assemble_file n
 806               = do  let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
 807                     let output_o = replaceFilenameDirectory
 808                                         (basename ++ "__" ++ show n ++ ".o")
 809                                          real_odir
 810                     real_o <- osuf_ify output_o
 811                     SysTools.runAs (map SysTools.Option as_opts ++
 812                                     [ SysTools.Option "-c"
 813                                     , SysTools.Option "-o"
 814                                     , SysTools.FileOption "" real_o
 815                                     , SysTools.FileOption "" input_s
 816                                     ])
 817
 818         mapM_ assemble_file [1..n]
 819
 820         output_fn <- get_output_fn Ln
 821         return (Just Ln, output_fn)
 822
 823 #ifdef ILX
 824 -----------------------------------------------------------------------------
 825 -- Ilx2Il phase
 826 -- Run ilx2il over the ILX output, getting an IL file
 827
 828 runPhase Ilx2Il _basename _suff input_fn get_output_fn
 829   = do  ilx2il_opts <- getOpts opt_I
 830         SysTools.runIlx2il (map SysTools.Option ilx2il_opts
 831                            ++ [ SysTools.Option "--no-add-suffix-to-assembly",
 832                                 SysTools.Option "mscorlib",
 833                                 SysTools.Option "-o",
 834                                 SysTools.FileOption "" output_fn,
 835                                 SysTools.FileOption "" input_fn ])
 836         return True
 837
 838 -----------------------------------------------------------------------------
 839 -- Ilasm phase
 840 -- Run ilasm over the IL, getting a DLL
 841
 842 runPhase Ilasm _basename _suff input_fn get_output_fn
 843   = do  ilasm_opts <- getOpts opt_i
 844         SysTools.runIlasm (map SysTools.Option ilasm_opts
 845                            ++ [ SysTools.Option "/QUIET",
 846                                 SysTools.Option "/DLL",
 847                                 SysTools.FileOption "/OUT=" output_fn,
 848                                 SysTools.FileOption "" input_fn ])
 849         return True
 850
 851 #endif /* ILX */
 852
 853 -----------------------------------------------------------------------------
 854 -- MoveBinary sort-of-phase
 855 -- After having produced a binary, move it somewhere else and generate a
 856 -- wrapper script calling the binary. Currently, we need this only in
 857 -- a parallel way (i.e. in GUM), because PVM expects the binary in a
 858 -- central directory.
 859 -- This is called from staticLink below, after linking. I haven't made it
 860 -- a separate phase to minimise interfering with other modules, and
 861 -- we don't need the generality of a phase (MoveBinary is always
 862 -- done after linking and makes only sense in a parallel setup)   -- HWL
 863
 864 runPhase_MoveBinary input_fn
 865   = do
 866         sysMan   <- getSysMan
 867         pvm_root <- getEnv "PVM_ROOT"
 868         pvm_arch <- getEnv "PVM_ARCH"
 869         let
 870            pvm_executable_base = "=" ++ input_fn
 871            pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
 872         -- nuke old binary; maybe use configur'ed names for cp and rm?
 873         system ("rm -f " ++ pvm_executable)
 874         -- move the newly created binary into PVM land
 875         system ("cp -p " ++ input_fn ++ " " ++ pvm_executable)
 876         -- generate a wrapper script for running a parallel prg under PVM
 877         writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
 878         return True
 879
 880 -- generates a Perl skript starting a parallel prg under PVM
 881 mk_pvm_wrapper_script :: String -> String -> String -> String
 882 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
 883  [
 884   "eval 'exec perl -S $0 ${1+\"$@\"}'",
 885   "  if $running_under_some_shell;",
 886   "# =!=!=!=!=!=!=!=!=!=!=!",
 887   "# This script is automatically generated: DO NOT EDIT!!!",
 888   "# Generated by Glasgow Haskell Compiler",
 889   "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
 890   "#",
 891   "$pvm_executable      = '" ++ pvm_executable ++ "';",
 892   "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
 893   "$SysMan = '" ++ sysMan ++ "';",
 894   "",
 895   {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
 896   "# first, some magical shortcuts to run "commands" on the binary",
 897   "# (which is hidden)",
 898   "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
 899   "    local($cmd) = $1;",
 900   "    system("$cmd $pvm_executable");",
 901   "    exit(0); # all done",
 902   "}", -}
 903   "",
 904   "# Now, run the real binary; process the args first",
 905   "$ENV{'PE'} = $pvm_executable_base;", --  ++ pvm_executable_base,
 906   "$debug = '';",
 907   "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
 908   "@nonPVM_args = ();",
 909   "$in_RTS_args = 0;",
 910   "",
 911   "args: while ($a = shift(@ARGV)) {",
 912   "    if ( $a eq '+RTS' ) {",
 913   "     $in_RTS_args = 1;",
 914   "    } elsif ( $a eq '-RTS' ) {",
 915   "     $in_RTS_args = 0;",
 916   "    }",
 917   "    if ( $a eq '-d' && $in_RTS_args ) {",
 918   "     $debug = '-';",
 919   "    } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
 920   "     $nprocessors = $1;",
 921   "    } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
 922   "     $nprocessors = $1;",
 923   "    } else {",
 924   "     push(@nonPVM_args, $a);",
 925   "    }",
 926   "}",
 927   "",
 928   "local($return_val) = 0;",
 929   "# Start the parallel execution by calling SysMan",
 930   "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
 931   "$return_val = $?;",
 932   "# ToDo: fix race condition moving files and flushing them!!",
 933   "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
 934   "exit($return_val);"
 935  ]
 936
 937 -----------------------------------------------------------------------------
 938 -- Complain about non-dynamic flags in OPTIONS pragmas
 939
 940 checkProcessArgsResult flags basename suff
 941   = do when (notNull flags) (throwDyn (ProgramError (
 942           showSDoc (hang (text basename <> text ('.':suff) <> char ':')
 943                       4 (text "unknown flags in  {-# OPTIONS #-} pragma:" <+>
 944                           hsep (map text flags)))
 945         )))
 946
 947 -----------------------------------------------------------------------------
 948 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
 949
 950 getHCFilePackages :: FilePath -> IO [PackageName]
 951 getHCFilePackages filename =
 952   EXCEPTION.bracket (openFile filename ReadMode) hClose $ \h -> do
 953     l <- hGetLine h
 954     case l of
 955       '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
 956           return (map mkPackageName (words rest))
 957       _other ->
 958           return []
 959
 960 -----------------------------------------------------------------------------
 961 -- Static linking, of .o files
 962
 963 -- The list of packages passed to link is the list of packages on
 964 -- which this program depends, as discovered by the compilation
 965 -- manager.  It is combined with the list of packages that the user
 966 -- specifies on the command line with -package flags.
 967 --
 968 -- In one-shot linking mode, we can't discover the package
 969 -- dependencies (because we haven't actually done any compilation or
 970 -- read any interface files), so the user must explicitly specify all
 971 -- the packages.
 972
 973 staticLink :: [FilePath] -> [PackageName] -> IO ()
 974 staticLink o_files dep_packages = do
 975     verb       <- getVerbFlag
 976     static     <- readIORef v_Static
 977     no_hs_main <- readIORef v_NoHsMain
 978
 979     -- get the full list of packages to link with, by combining the
 980     -- explicit packages with the auto packages and all of their
 981     -- dependencies, and eliminating duplicates.
 982
 983     o_file <- readIORef v_Output_file
 984     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
 985
 986     pkg_lib_paths <- getPackageLibraryPath dep_packages
 987     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
 988
 989     lib_paths <- readIORef v_Library_paths
 990     let lib_path_opts = map ("-L"++) lib_paths
 991
 992     pkg_link_opts <- getPackageLinkOpts dep_packages
 993
 994 #ifdef darwin_TARGET_OS
 995     pkg_framework_paths <- getPackageFrameworkPath dep_packages
 996     let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths
 997
 998     framework_paths <- readIORef v_Framework_paths
 999     let framework_path_opts = map ("-F"++) framework_paths
1000
1001     pkg_frameworks <- getPackageFrameworks dep_packages
1002     let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1003
1004     frameworks <- readIORef v_Cmdline_frameworks
1005     let framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ]
1006          -- reverse because they're added in reverse order from the cmd line
1007 #endif
1008
1009         -- probably _stub.o files
1010     extra_ld_inputs <- readIORef v_Ld_inputs
1011
1012         -- opts from -optl-<blah> (including -l<blah> options)
1013     extra_ld_opts <- getStaticOpts v_Opt_l
1014
1015     [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, basePackage]
1016
1017     let extra_os = if static || no_hs_main
1018                    then []
1019                    else [ head (library_dirs rts_pkg) ++ "/Main.dll_o",
1020                           head (library_dirs std_pkg) ++ "/PrelMain.dll_o" ]
1021
1022     (md_c_flags, _) <- machdepCCOpts
1023     SysTools.runLink ( [ SysTools.Option verb
1024                        , SysTools.Option "-o"
1025                        , SysTools.FileOption "" output_fn
1026                        ]
1027                       ++ map SysTools.Option (
1028                          md_c_flags
1029                       ++ o_files
1030                       ++ extra_os
1031                       ++ extra_ld_inputs
1032                       ++ lib_path_opts
1033                       ++ extra_ld_opts
1034 #ifdef darwin_TARGET_OS
1035                       ++ framework_path_opts
1036                       ++ framework_opts
1037 #endif
1038                       ++ pkg_lib_path_opts
1039                       ++ pkg_link_opts
1040 #ifdef darwin_TARGET_OS
1041                       ++ pkg_framework_path_opts
1042                       ++ pkg_framework_opts
1043 #endif
1044                       ++ if static && not no_hs_main then
1045                             [ "-u", prefixUnderscore "Main_zdmain_closure"]
1046                          else []))
1047
1048     -- parallel only: move binary to another dir -- HWL
1049     ways_ <- readIORef v_Ways
1050     when (WayPar `elem` ways_)
1051          (do success <- runPhase_MoveBinary output_fn
1052              if success then return ()
1053                         else throwDyn (InstallationError ("cannot move binary to PVM dir")))
1054
1055 -----------------------------------------------------------------------------
1056 -- Making a DLL (only for Win32)
1057
1058 doMkDLL :: [String] -> [PackageName] -> IO ()
1059 doMkDLL o_files dep_packages = do
1060     verb       <- getVerbFlag
1061     static     <- readIORef v_Static
1062     no_hs_main <- readIORef v_NoHsMain
1063
1064     o_file <- readIORef v_Output_file
1065     let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
1066
1067     pkg_lib_paths <- getPackageLibraryPath dep_packages
1068     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1069
1070     lib_paths <- readIORef v_Library_paths
1071     let lib_path_opts = map ("-L"++) lib_paths
1072
1073     pkg_link_opts <- getPackageLinkOpts dep_packages
1074
1075         -- probably _stub.o files
1076     extra_ld_inputs <- readIORef v_Ld_inputs
1077
1078         -- opts from -optdll-<blah>
1079     extra_ld_opts <- getStaticOpts v_Opt_dll
1080
1081     [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, basePackage]
1082
1083     let extra_os = if static || no_hs_main
1084                    then []
1085                    else [ head (library_dirs rts_pkg) ++ "/Main.dll_o",
1086                           head (library_dirs std_pkg) ++ "/PrelMain.dll_o" ]
1087
1088     (md_c_flags, _) <- machdepCCOpts
1089     SysTools.runMkDLL
1090          ([ SysTools.Option verb
1091           , SysTools.Option "-o"
1092           , SysTools.FileOption "" output_fn
1093           ]
1094          ++ map SysTools.Option (
1095             md_c_flags
1096          ++ o_files
1097          ++ extra_os
1098          ++ [ "--target=i386-mingw32" ]
1099          ++ extra_ld_inputs
1100          ++ lib_path_opts
1101          ++ extra_ld_opts
1102          ++ pkg_lib_path_opts
1103          ++ pkg_link_opts
1104          ++ (if "--def" `elem` (concatMap words extra_ld_opts)
1105                then [ "" ]
1106                else [ "--export-all" ])
1107         ))
1108
1109 -- -----------------------------------------------------------------------------
1110 -- Misc.
1111
1112 hscNextPhase :: HscLang -> IO Phase
1113 hscNextPhase hsc_lang = do
1114   split <- readIORef v_Split_object_files
1115   return (case hsc_lang of
1116                 HscC -> HCc
1117                 HscAsm | split -> SplitMangle
1118                        | otherwise -> As
1119                 HscNothing     -> HCc  -- dummy (no output will be generated)
1120                 HscInterpreted -> HCc  -- "" ""
1121                 _other         -> HCc  -- "" ""
1122         )
1123
1124 hscMaybeAdjustLang :: HscLang -> IO HscLang
1125 hscMaybeAdjustLang current_hsc_lang = do
1126   todo    <- readIORef v_GhcMode
1127   keep_hc <- readIORef v_Keep_hc_files
1128   let hsc_lang
1129         -- don't change the lang if we're interpreting
1130          | current_hsc_lang == HscInterpreted = current_hsc_lang
1131         -- force -fvia-C if we are being asked for a .hc file
1132          | todo == StopBefore HCc  || keep_hc = HscC
1133         -- force -fvia-C when profiling or ticky-ticky is on
1134          | opt_SccProfilingOn || opt_DoTickyProfiling = HscC
1135         -- otherwise, stick to the plan
1136          | otherwise = current_hsc_lang
1137   return hsc_lang