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