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    genPipeline, runPipeline, pipeLoop, 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
  68 -- Just preprocess a file, put the result in a temp. file (used by the
  69 -- compilation manager during the summary phase).
  70
  71 preprocess :: FilePath -> IO FilePath
  72 preprocess filename =
  73   ASSERT(haskellish_src_file filename)
  74   do restoreDynFlags    -- Restore to state of last save
  75      let fInfo = (filename, getFileSuffix filename)
  76      pipeline <- genPipeline (StopBefore Hsc) ("preprocess") False
  77                              defaultHscLang fInfo
  78      (fn,_)   <- runPipeline pipeline fInfo
  79                              False{-no linking-} False{-no -o flag-}
  80      return fn
  81
  82 -----------------------------------------------------------------------------
  83 --                      Compile
  84 -----------------------------------------------------------------------------
  85
  86 -- Compile a single module, under the control of the compilation manager.
  87 --
  88 -- This is the interface between the compilation manager and the
  89 -- compiler proper (hsc), where we deal with tedious details like
  90 -- reading the OPTIONS pragma from the source file, and passing the
  91 -- output of hsc through the C compiler.
  92
  93 -- The driver sits between 'compile' and 'hscMain', translating calls
  94 -- to the former into calls to the latter, and results from the latter
  95 -- into results from the former.  It does things like preprocessing
  96 -- the .hs file if necessary, and compiling up the .stub_c files to
  97 -- generate Linkables.
  98
  99 -- NB.  No old interface can also mean that the source has changed.
 100
 101 compile :: GhciMode                -- distinguish batch from interactive
 102         -> Module
 103         -> ModLocation
 104         -> Bool                    -- True <=> source unchanged
 105         -> Bool                    -- True <=> have object
 106         -> Maybe ModIface          -- old interface, if available
 107         -> HomePackageTable        -- For home-module stuff
 108         -> PersistentCompilerState -- persistent compiler state
 109         -> IO CompResult
 110
 111 data CompResult
 112    = CompOK   PersistentCompilerState   -- Updated PCS
 113               ModDetails                -- New details
 114               ModIface                  -- New iface
 115               (Maybe Linkable)  -- New code; Nothing => compilation was not reqd
 116                                 --                      (old code is still valid)
 117
 118    | CompErrs PersistentCompilerState   -- Updated PCS
 119
 120
 121 compile ghci_mode this_mod location
 122         source_unchanged have_object
 123         old_iface hpt pcs = do
 124
 125    dyn_flags <- restoreDynFlags         -- Restore to the state of the last save
 126
 127
 128    showPass dyn_flags
 129         (showSDoc (text "Compiling" <+> ppr this_mod))
 130
 131    let verb       = verbosity dyn_flags
 132    let input_fn   = expectJust "compile:hs" (ml_hs_file location)
 133    let input_fnpp = expectJust "compile:hspp" (ml_hspp_file location)
 134    let mod_name   = moduleName this_mod
 135
 136    when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp))
 137
 138    opts <- getOptionsFromSource input_fnpp
 139    processArgs dynamic_flags opts []
 140    dyn_flags <- getDynFlags
 141
 142    let hsc_lang      = hscLang dyn_flags
 143        (basename, _) = splitFilename input_fn
 144
 145    keep_hc <- readIORef v_Keep_hc_files
 146 #ifdef ILX
 147    keep_il <- readIORef v_Keep_il_files
 148 #endif
 149    keep_s  <- readIORef v_Keep_s_files
 150
 151    output_fn <-
 152         case hsc_lang of
 153            HscAsm  | keep_s    -> return (basename ++ '.':phaseInputExt As)
 154                    | otherwise -> newTempName (phaseInputExt As)
 155            HscC    | keep_hc   -> return (basename ++ '.':phaseInputExt HCc)
 156                    | otherwise -> newTempName (phaseInputExt HCc)
 157            HscJava             -> newTempName "java" -- ToDo
 158 #ifdef ILX
 159            HscILX  | keep_il   -> return (basename ++ '.':phaseInputExt Ilasm)
 160                    | otherwise -> newTempName (phaseInputExt Ilx2Il)
 161 #endif
 162            HscInterpreted      -> return (error "no output file")
 163            HscNothing          -> return (error "no output file")
 164
 165    let dyn_flags' = dyn_flags { hscOutName = output_fn,
 166                                 hscStubCOutName = basename ++ "_stub.c",
 167                                 hscStubHOutName = basename ++ "_stub.h",
 168                                 extCoreName = basename ++ ".hcr" }
 169
 170    -- figure out which header files to #include in a generated .hc file
 171    c_includes <- getPackageCIncludes
 172    cmdline_includes <- dynFlag cmdlineHcIncludes -- -#include options
 173
 174    let cc_injects = unlines (map mk_include
 175                                  (c_includes ++ reverse cmdline_includes))
 176        mk_include h_file =
 177         case h_file of
 178            '"':_{-"-} -> "#include "++h_file
 179            '<':_      -> "#include "++h_file
 180            _          -> "#include \""++h_file++"\""
 181
 182    writeIORef v_HCHeader cc_injects
 183
 184    -- -no-recomp should also work with --make
 185    do_recomp <- readIORef v_Recomp
 186    let source_unchanged' = source_unchanged && do_recomp
 187        hsc_env = HscEnv { hsc_mode = ghci_mode,
 188                           hsc_dflags = dyn_flags',
 189                           hsc_HPT    = hpt }
 190
 191    -- run the compiler
 192    hsc_result <- hscMain hsc_env pcs this_mod location
 193                          source_unchanged' have_object old_iface
 194
 195    case hsc_result of
 196       HscFail pcs -> return (CompErrs pcs)
 197
 198       HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing)
 199
 200       HscRecomp pcs details iface
 201         stub_h_exists stub_c_exists maybe_interpreted_code -> do
 202            let
 203            maybe_stub_o <- compileStub dyn_flags' stub_c_exists
 204            let stub_unlinked = case maybe_stub_o of
 205                                   Nothing -> []
 206                                   Just stub_o -> [ DotO stub_o ]
 207
 208            (hs_unlinked, unlinked_time) <-
 209              case hsc_lang of
 210
 211                 -- in interpreted mode, just return the compiled code
 212                 -- as our "unlinked" object.
 213                 HscInterpreted ->
 214                     case maybe_interpreted_code of
 215 #ifdef GHCI
 216                        Just comp_bc -> do tm <- getClockTime
 217                                           return ([BCOs comp_bc], tm)
 218 #endif
 219                        Nothing -> panic "compile: no interpreted code"
 220
 221                 -- we're in batch mode: finish the compilation pipeline.
 222                 _other -> do pipe <- genPipeline (StopBefore Ln) "" True
 223                                         hsc_lang (output_fn, getFileSuffix output_fn)
 224                              -- runPipeline takes input_fn so it can split off
 225                              -- the base name and use it as the base of
 226                              -- the output object file.
 227                              let (basename, suffix) = splitFilename input_fn
 228                              (o_file,_) <-
 229                                  pipeLoop pipe (output_fn, getFileSuffix output_fn)
 230                                                False False
 231                                                basename suffix
 232                              o_time <- getModificationTime o_file
 233                              return ([DotO o_file], o_time)
 234
 235            let linkable = LM unlinked_time mod_name
 236                              (hs_unlinked ++ stub_unlinked)
 237
 238            return (CompOK pcs details iface (Just linkable))
 239
 240 -----------------------------------------------------------------------------
 241 -- stub .h and .c files (for foreign export support)
 242
 243 compileStub dflags stub_c_exists
 244   | not stub_c_exists = return Nothing
 245   | stub_c_exists = do
 246         -- compile the _stub.c file w/ gcc
 247         let stub_c = hscStubCOutName dflags
 248         pipeline   <- genPipeline (StopBefore Ln) "" True defaultHscLang (stub_c,"c")
 249         (stub_o,_) <- runPipeline pipeline (stub_c,"c") False{-no linking-}
 250                                   False{-no -o option-}
 251         return (Just stub_o)
 252
 253
 254 -----------------------------------------------------------------------------
 255 --                      Link
 256 -----------------------------------------------------------------------------
 257
 258 link :: GhciMode                -- interactive or batch
 259      -> DynFlags                -- dynamic flags
 260      -> Bool                    -- attempt linking in batch mode?
 261      -> [Linkable]
 262      -> IO SuccessFlag
 263
 264 -- For the moment, in the batch linker, we don't bother to tell doLink
 265 -- which packages to link -- it just tries all that are available.
 266 -- batch_attempt_linking should only be *looked at* in batch mode.  It
 267 -- should only be True if the upsweep was successful and someone
 268 -- exports main, i.e., we have good reason to believe that linking
 269 -- will succeed.
 270
 271 -- There will be (ToDo: are) two lists passed to link.  These
 272 -- correspond to
 273 --
 274 --      1. The list of all linkables in the current home package.  This is
 275 --         used by the batch linker to link the program, and by the interactive
 276 --         linker to decide which modules from the previous link it can
 277 --         throw away.
 278 --      2. The list of modules on which we just called "compile".  This list
 279 --         is used by the interactive linker to decide which modules need
 280 --         to be actually linked this time around (or unlinked and re-linked
 281 --         if the module was recompiled).
 282
 283 link mode dflags batch_attempt_linking linkables
 284    = do let verb = verbosity dflags
 285         when (verb >= 3) $ do
 286              hPutStrLn stderr "link: linkables are ..."
 287              hPutStrLn stderr (showSDoc (vcat (map ppr linkables)))
 288
 289         res <- link' mode dflags batch_attempt_linking linkables
 290
 291         when (verb >= 3) (hPutStrLn stderr "link: done")
 292
 293         return res
 294
 295 #ifdef GHCI
 296 link' Interactive dflags batch_attempt_linking linkables
 297     = do showPass dflags "Not Linking...(demand linker will do the job)"
 298          -- linkModules dflags linkables
 299          return Succeeded
 300 #endif
 301
 302 link' Batch dflags batch_attempt_linking linkables
 303    | batch_attempt_linking
 304    = do when (verb >= 1) $
 305              hPutStrLn stderr "ghc: linking ..."
 306
 307         -- Don't showPass in Batch mode; doLink will do that for us.
 308         staticLink (concatMap getOfiles linkables)
 309
 310         -- staticLink only returns if it succeeds
 311         return Succeeded
 312
 313    | otherwise
 314    = do when (verb >= 3) $ do
 315             hPutStrLn stderr "link(batch): upsweep (partially) failed OR"
 316             hPutStrLn stderr "   Main.main not exported; not linking."
 317         return Succeeded
 318    where
 319       verb = verbosity dflags
 320       getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
 321
 322
 323
 324 -----------------------------------------------------------------------------
 325 --                      genPipeline: Pipeline construction
 326 -----------------------------------------------------------------------------
 327
 328 -- Herein is all the magic about which phases to run in which order, whether
 329 -- the intermediate files should be in TMPDIR or in the current directory,
 330 -- what the suffix of the intermediate files should be, etc.
 331
 332 -- The following compilation pipeline algorithm is fairly hacky.  A
 333 -- better way to do this would be to express the whole compilation as a
 334 -- data flow DAG, where the nodes are the intermediate files and the
 335 -- edges are the compilation phases.  This framework would also work
 336 -- nicely if a haskell dependency generator was included in the
 337 -- driver.
 338
 339 -- It would also deal much more cleanly with compilation phases that
 340 -- generate multiple intermediates, (eg. hsc generates .hc, .hi, and
 341 -- possibly stub files), where some of the output files need to be
 342 -- processed further (eg. the stub files need to be compiled by the C
 343 -- compiler).
 344
 345 -- A cool thing to do would then be to execute the data flow graph
 346 -- concurrently, automatically taking advantage of extra processors on
 347 -- the host machine.  For example, when compiling two Haskell files
 348 -- where one depends on the other, the data flow graph would determine
 349 -- that the C compiler from the first compilation can be overlapped
 350 -- with the hsc compilation for the second file.
 351
 352 data IntermediateFileType
 353   = Temporary
 354   | Persistent
 355   deriving (Eq, Show)
 356
 357 genPipeline
 358    :: GhcMode            -- when to stop
 359    -> String             -- "stop after" flag (for error messages)
 360    -> Bool               -- True => output is persistent
 361    -> HscLang            -- preferred output language for hsc
 362    -> (FilePath, String) -- original filename & its suffix
 363    -> IO [              -- list of phases to run for this file
 364              (Phase,
 365               IntermediateFileType,  -- keep the output from this phase?
 366               String)                -- output file suffix
 367          ]
 368
 369 genPipeline todo stop_flag persistent_output lang (filename,suffix)
 370  = do
 371    split      <- readIORef v_Split_object_files
 372    mangle     <- readIORef v_Do_asm_mangling
 373    keep_hc    <- readIORef v_Keep_hc_files
 374 #ifdef ILX
 375    keep_il    <- readIORef v_Keep_il_files
 376    keep_ilx   <- readIORef v_Keep_ilx_files
 377 #endif
 378    keep_raw_s <- readIORef v_Keep_raw_s_files
 379    keep_s     <- readIORef v_Keep_s_files
 380    osuf       <- readIORef v_Object_suf
 381    hcsuf      <- readIORef v_HC_suf
 382
 383    let
 384    ----------- -----  ----   ---   --   --  -  -  -
 385     start = startPhase suffix
 386
 387       -- special case for mkdependHS: .hspp files go through MkDependHS
 388     start_phase | todo == DoMkDependHS && start == Hsc  = MkDependHS
 389                 | otherwise = start
 390
 391     haskellish = haskellish_suffix suffix
 392     cish = cish_suffix suffix
 393
 394        -- for a .hc file we need to force lang to HscC
 395     real_lang | start_phase == HCc || start_phase == Mangle = HscC
 396               | otherwise                                   = lang
 397
 398    let
 399    ----------- -----  ----   ---   --   --  -  -  -
 400     pipeline = preprocess ++ compile
 401
 402     preprocess
 403         | haskellish = [ Unlit, Cpp, HsPp ]
 404         | otherwise  = [ ]
 405
 406     compile
 407       | todo == DoMkDependHS = [ MkDependHS ]
 408
 409       | cish = [ Cc, As ]
 410
 411       | haskellish =
 412        case real_lang of
 413         HscC    | split && mangle -> [ Hsc, HCc, Mangle, SplitMangle, SplitAs ]
 414                 | mangle          -> [ Hsc, HCc, Mangle, As ]
 415                 | split           -> not_valid
 416                 | otherwise       -> [ Hsc, HCc, As ]
 417
 418         HscAsm  | split           -> [ Hsc, SplitMangle, SplitAs ]
 419                 | otherwise       -> [ Hsc, As ]
 420
 421         HscJava | split           -> not_valid
 422                 | otherwise       -> error "not implemented: compiling via Java"
 423 #ifdef ILX
 424         HscILX  | split           -> not_valid
 425                 | otherwise       -> [ Hsc, Ilx2Il, Ilasm ]
 426 #endif
 427         HscNothing                -> [ Hsc, HCc ] -- HCc is a dummy stop phase
 428
 429       | otherwise = [ ]  -- just pass this file through to the linker
 430
 431         -- ToDo: this is somewhat cryptic
 432     not_valid = throwDyn (UsageError ("invalid option combination"))
 433
 434     stop_phase = case todo of
 435                         StopBefore As | split -> SplitAs
 436 #ifdef ILX
 437                                       | real_lang == HscILX -> Ilasm
 438 #endif
 439                         StopBefore phase      -> phase
 440                         DoMkDependHS          -> Ln
 441                         DoLink                -> Ln
 442                         DoMkDLL               -> Ln
 443    ----------- -----  ----   ---   --   --  -  -  -
 444
 445         -- this shouldn't happen.
 446    when (start_phase /= Ln && start_phase `notElem` pipeline)
 447         (throwDyn (CmdLineError ("can't find starting phase for "
 448                                  ++ filename)))
 449         -- if we can't find the phase we're supposed to stop before,
 450         -- something has gone wrong.  This test carefully avoids the
 451         -- case where we aren't supposed to do any compilation, because the file
 452         -- is already in linkable form (for example).
 453 --   hPutStrLn stderr (show ((start_phase `elem` pipeline,stop_phase /= Ln,stop_phase `notElem` pipeline), start_phase, stop_phase, pipeline,todo))
 454 --   hFlush stderr
 455    when (start_phase `elem` pipeline &&
 456          (stop_phase /= Ln && stop_phase `notElem` pipeline))
 457         (do
 458           throwDyn (UsageError
 459                     ("flag `" ++ stop_flag
 460                      ++ "' is incompatible with source file `"
 461                      ++ filename ++ "'" ++ show pipeline ++ show stop_phase)))
 462    let
 463         -- .o and .hc suffixes can be overriden by command-line options:
 464       myPhaseInputExt Ln  | Just s <- osuf  = s
 465       myPhaseInputExt HCc | Just s <- hcsuf = s
 466       myPhaseInputExt other                 = phaseInputExt other
 467
 468       annotatePipeline
 469          :: [Phase]             -- raw pipeline
 470          -> Phase               -- phase to stop before
 471          -> [(Phase, IntermediateFileType, String{-file extension-})]
 472       annotatePipeline []     _    = []
 473       annotatePipeline (Ln:_) _    = []
 474       annotatePipeline (phase:next_phase:ps) stop =
 475           (phase, keep_this_output, myPhaseInputExt next_phase)
 476              : annotatePipeline (next_phase:ps) stop
 477           where
 478                 keep_this_output
 479                      | next_phase == stop
 480                      = if persistent_output then Persistent else Temporary
 481                      | otherwise
 482                      = case next_phase of
 483                              Ln -> Persistent
 484                              Mangle | keep_raw_s -> Persistent
 485                              As     | keep_s     -> Persistent
 486                              HCc    | keep_hc    -> Persistent
 487 #ifdef ILX
 488                              Ilx2Il | keep_ilx   -> Persistent
 489                              Ilasm  | keep_il    -> Persistent
 490 #endif
 491                              _other              -> Temporary
 492
 493         -- add information about output files to the pipeline
 494         -- the suffix on an output file is determined by the next phase
 495         -- in the pipeline, so we add linking to the end of the pipeline
 496         -- to force the output from the final phase to be a .o file.
 497
 498       annotated_pipeline = annotatePipeline (pipeline ++ [Ln]) stop_phase
 499
 500       phase_ne p (p1,_,_) = (p1 /= p)
 501    ----------- -----  ----   ---   --   --  -  -  -
 502
 503    return (
 504      takeWhile (phase_ne stop_phase ) $
 505      dropWhile (phase_ne start_phase) $
 506      annotated_pipeline
 507     )
 508
 509
 510 runPipeline
 511   :: [ (Phase, IntermediateFileType, String) ] -- phases to run
 512   -> (String,String)            -- input file
 513   -> Bool                       -- doing linking afterward?
 514   -> Bool                       -- take into account -o when generating output?
 515   -> IO (String, String)        -- return final filename
 516
 517 runPipeline pipeline (input_fn,suffix) do_linking use_ofile
 518   = pipeLoop pipeline (input_fn,suffix) do_linking use_ofile basename suffix
 519   where (basename, _) = splitFilename input_fn
 520
 521 pipeLoop [] input_fn _ _ _ _ = return input_fn
 522 pipeLoop (all_phases@((phase, keep, o_suffix):phases))
 523         (input_fn,real_suff) do_linking use_ofile orig_basename orig_suffix
 524   = do
 525
 526      output_fn <- outputFileName (null phases) keep o_suffix
 527
 528      mbCarryOn <- run_phase phase orig_basename orig_suffix
 529                             input_fn output_fn
 530         -- sometimes we bail out early, eg. when the compiler's recompilation
 531         -- checker has determined that recompilation isn't necessary.
 532      case mbCarryOn of
 533        Nothing -> do
 534               let (_,keep,final_suffix) = last all_phases
 535               ofile <- outputFileName True keep final_suffix
 536               return (ofile, final_suffix)
 537           -- carry on ...
 538        Just fn -> do
 539                 {-
 540                   Check to see whether we've reached the end of the
 541                   pipeline, but did so with an ineffective last stage.
 542                   (i.e., it returned the input_fn as the output filename).
 543
 544                   If we did and the output is persistent, copy the contents
 545                   of input_fn into the file where the pipeline's output is
 546                   expected to end up.
 547                 -}
 548               atEnd <- finalStage (null phases)
 549               when (atEnd && fn == input_fn)
 550                    (copy "Saving away compilation pipeline's output"
 551                          input_fn
 552                          output_fn)
 553               {-
 554                Notice that in order to keep the invariant that we can
 555                determine a compilation pipeline's 'start phase' just
 556                by looking at the input filename, the input filename
 557                to the next stage/phase is associated here with the suffix
 558                of the output file, *even* if it does not have that
 559                suffix in reality.
 560
 561                Why is this important? Because we may run a compilation
 562                pipeline in stages (cf. Main.main.compileFile's two stages),
 563                so when generating the next stage we need to be precise
 564                about what kind of file (=> suffix) is given as input.
 565
 566                [Not having to generate a pipeline in stages seems like
 567                 the right way to go, but I've punted on this for now --sof]
 568
 569               -}
 570               pipeLoop phases (fn, o_suffix) do_linking use_ofile
 571                         orig_basename orig_suffix
 572   where
 573      finalStage lastPhase = do
 574        o_file <- readIORef v_Output_file
 575        return (lastPhase && not do_linking && use_ofile && isJust o_file)
 576
 577      outputFileName last_phase keep suffix
 578         = do o_file <- readIORef v_Output_file
 579              atEnd  <- finalStage last_phase
 580              if atEnd
 581                then case o_file of
 582                        Just s  -> return s
 583                        Nothing -> error "outputFileName"
 584                else if keep == Persistent
 585                            then odir_ify (orig_basename ++ '.':suffix)
 586                            else newTempName suffix
 587
 588 run_phase :: Phase
 589           -> String                -- basename of original input source
 590           -> String                -- its extension
 591           -> FilePath              -- name of file which contains the input to this phase.
 592           -> FilePath              -- where to stick the result.
 593           -> IO (Maybe FilePath)
 594                   -- Nothing => stop the compilation pipeline
 595                   -- Just fn => the result of this phase can be found in 'fn'
 596                   --            (this can either be 'input_fn' or 'output_fn').
 597 -------------------------------------------------------------------------------
 598 -- Unlit phase
 599
 600 run_phase Unlit _basename _suff input_fn output_fn
 601   = do unlit_flags <- getOpts opt_L
 602        -- The -h option passes the file name for unlit to put in a #line directive
 603        SysTools.runUnlit (map SysTools.Option unlit_flags ++
 604                           [ SysTools.Option     "-h"
 605                           , SysTools.Option     input_fn
 606                           , SysTools.FileOption "" input_fn
 607                           , SysTools.FileOption "" output_fn
 608                           ])
 609        return (Just output_fn)
 610
 611 -------------------------------------------------------------------------------
 612 -- Cpp phase
 613
 614 run_phase Cpp basename suff input_fn output_fn
 615   = do src_opts <- getOptionsFromSource input_fn
 616        unhandled_flags <- processArgs dynamic_flags src_opts []
 617        checkProcessArgsResult unhandled_flags basename suff
 618
 619        do_cpp <- dynFlag cppFlag
 620        if not do_cpp then
 621            -- no need to preprocess CPP, just pass input file along
 622            -- to the next phase of the pipeline.
 623           return (Just input_fn)
 624         else do
 625             hscpp_opts      <- getOpts opt_P
 626             hs_src_cpp_opts <- readIORef v_Hs_source_cpp_opts
 627
 628             cmdline_include_paths <- readIORef v_Include_paths
 629             pkg_include_dirs <- getPackageIncludePath
 630             let include_paths = foldr (\ x xs -> "-I" : x : xs) []
 631                                   (cmdline_include_paths ++ pkg_include_dirs)
 632
 633             verb <- getVerbFlag
 634             (md_c_flags, _) <- machdepCCOpts
 635
 636             SysTools.runCpp ([SysTools.Option verb]
 637                             ++ map SysTools.Option include_paths
 638                             ++ map SysTools.Option hs_src_cpp_opts
 639                             ++ map SysTools.Option hscpp_opts
 640                             ++ map SysTools.Option md_c_flags
 641                             ++ [ SysTools.Option     "-x"
 642                                , SysTools.Option     "c"
 643                                , SysTools.Option     input_fn
 644         -- We hackily use Option instead of FileOption here, so that the file
 645         -- name is not back-slashed on Windows.  cpp is capable of
 646         -- dealing with / in filenames, so it works fine.  Furthermore
 647         -- if we put in backslashes, cpp outputs #line directives
 648         -- with *double* backslashes.   And that in turn means that
 649         -- our error messages get double backslashes in them.
 650         -- In due course we should arrange that the lexer deals
 651         -- with these \\ escapes properly.
 652                                , SysTools.Option     "-o"
 653                                , SysTools.FileOption "" output_fn
 654                                ])
 655             return (Just output_fn)
 656
 657 -------------------------------------------------------------------------------
 658 -- HsPp phase
 659
 660 run_phase HsPp basename suff input_fn output_fn
 661   = do let orig_fn = basename ++ '.':suff
 662        do_pp   <- dynFlag ppFlag
 663        if not do_pp then
 664            -- no need to preprocess, just pass input file along
 665            -- to the next phase of the pipeline.
 666           return (Just input_fn)
 667         else do
 668             hspp_opts      <- getOpts opt_F
 669             hs_src_pp_opts <- readIORef v_Hs_source_pp_opts
 670             SysTools.runPp ( [ SysTools.Option     orig_fn
 671                              , SysTools.Option     input_fn
 672                              , SysTools.FileOption "" output_fn
 673                              ] ++
 674                              map SysTools.Option hs_src_pp_opts ++
 675                              map SysTools.Option hspp_opts
 676                            )
 677             return (Just output_fn)
 678
 679 -----------------------------------------------------------------------------
 680 -- MkDependHS phase
 681
 682 run_phase MkDependHS basename suff input_fn output_fn
 683  = do src <- readFile input_fn
 684       let (import_sources, import_normals, _) = getImports src
 685       let orig_fn = basename ++ '.':suff
 686       deps_sources <- mapM (findDependency True  orig_fn) import_sources
 687       deps_normals <- mapM (findDependency False orig_fn) import_normals
 688       let deps = deps_sources ++ deps_normals
 689
 690       osuf_opt <- readIORef v_Object_suf
 691       let osuf = case osuf_opt of
 692                    Nothing -> phaseInputExt Ln
 693                    Just s  -> s
 694
 695       extra_suffixes <- readIORef v_Dep_suffixes
 696       let suffixes = osuf : map (++ ('_':osuf)) extra_suffixes
 697           ofiles = map (\suf -> basename ++ '.':suf) suffixes
 698
 699       objs <- mapM odir_ify ofiles
 700
 701         -- Handle for file that accumulates dependencies
 702       hdl <- readIORef v_Dep_tmp_hdl
 703
 704         -- std dependency of the object(s) on the source file
 705       hPutStrLn hdl (unwords (map escapeSpaces objs) ++ " : " ++
 706                      escapeSpaces (basename ++ '.':suff))
 707
 708       let genDep (dep, False {- not an hi file -}) =
 709              hPutStrLn hdl (unwords (map escapeSpaces objs) ++ " : " ++
 710                             escapeSpaces dep)
 711           genDep (dep, True  {- is an hi file -}) = do
 712              hisuf <- readIORef v_Hi_suf
 713              let dep_base = remove_suffix '.' dep
 714                  deps = (dep_base ++ hisuf)
 715                         : map (\suf -> dep_base ++ suf ++ '_':hisuf) extra_suffixes
 716                   -- length objs should be == length deps
 717              sequence_ (zipWith (\o d -> hPutStrLn hdl (escapeSpaces o ++ " : " ++ escapeSpaces d)) objs deps)
 718
 719       sequence_ (map genDep [ d | Just d <- deps ])
 720       return (Just output_fn)
 721
 722 -- add the lines to dep_makefile:
 723            -- always:
 724                    -- this.o : this.hs
 725
 726            -- if the dependency is on something other than a .hi file:
 727                    -- this.o this.p_o ... : dep
 728            -- otherwise
 729                    -- if the import is {-# SOURCE #-}
 730                            -- this.o this.p_o ... : dep.hi-boot[-$vers]
 731
 732                    -- else
 733                            -- this.o ...   : dep.hi
 734                            -- this.p_o ... : dep.p_hi
 735                            -- ...
 736
 737            -- (where .o is $osuf, and the other suffixes come from
 738            -- the cmdline -s options).
 739
 740
 741 -----------------------------------------------------------------------------
 742 -- Hsc phase
 743
 744 -- Compilation of a single module, in "legacy" mode (_not_ under
 745 -- the direction of the compilation manager).
 746 run_phase Hsc basename suff input_fn output_fn
 747   = do
 748
 749   -- we add the current directory (i.e. the directory in which
 750   -- the .hs files resides) to the import path, since this is
 751   -- what gcc does, and it's probably what you want.
 752         let current_dir = getdir basename
 753
 754         paths <- readIORef v_Include_paths
 755         writeIORef v_Include_paths (current_dir : paths)
 756
 757   -- figure out which header files to #include in a generated .hc file
 758         c_includes <- getPackageCIncludes
 759         cmdline_includes <- dynFlag cmdlineHcIncludes -- -#include options
 760
 761         let cc_injects = unlines (map mk_include
 762                                  (c_includes ++ reverse cmdline_includes))
 763             mk_include h_file =
 764                 case h_file of
 765                    '"':_{-"-} -> "#include "++h_file
 766                    '<':_      -> "#include "++h_file
 767                    _          -> "#include \""++h_file++"\""
 768
 769         writeIORef v_HCHeader cc_injects
 770
 771   -- gather the imports and module name
 772         (srcimps,imps,mod_name) <-
 773             if extcoreish_suffix suff
 774              then do
 775                -- no explicit imports in ExtCore input.
 776                m <- getCoreModuleName input_fn
 777                return ([], [], mkModuleName m)
 778              else
 779                getImportsFromFile input_fn
 780
 781   -- build a ModLocation to pass to hscMain.
 782         (mod, location')
 783            <- mkHomeModuleLocn mod_name basename (basename ++ '.':suff)
 784
 785   -- take -ohi into account if present
 786         ohi <- readIORef v_Output_hi
 787         let location | Just fn <- ohi = location'{ ml_hi_file = fn }
 788                      | otherwise      = location'
 789
 790   -- figure out if the source has changed, for recompilation avoidance.
 791   -- only do this if we're eventually going to generate a .o file.
 792   -- (ToDo: do when generating .hc files too?)
 793   --
 794   -- Setting source_unchanged to True means that M.o seems
 795   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 796   -- changed (which the compiler itself figures out).
 797   -- Setting source_unchanged to False tells the compiler that M.o is out of
 798   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 799         do_recomp   <- readIORef v_Recomp
 800         todo        <- readIORef v_GhcMode
 801         expl_o_file <- readIORef v_Output_file
 802
 803         let o_file -- if the -o option is given and IT IS THE OBJECT FILE FOR
 804                    -- THIS COMPILATION, then use that to determine if the
 805                    -- source is unchanged.
 806                 | Just x <- expl_o_file, todo == StopBefore Ln  =  x
 807                 | otherwise = expectJust "source_unchanged" (ml_obj_file location)
 808
 809         source_unchanged <-
 810           if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
 811              then return False
 812              else do t1 <- getModificationTime (basename ++ '.':suff)
 813                      o_file_exists <- doesFileExist o_file
 814                      if not o_file_exists
 815                         then return False       -- Need to recompile
 816                         else do t2 <- getModificationTime o_file
 817                                 if t2 > t1
 818                                   then return True
 819                                   else return False
 820
 821   -- get the DynFlags
 822         dyn_flags <- getDynFlags
 823
 824         let dyn_flags' = dyn_flags { hscOutName = output_fn,
 825                                      hscStubCOutName = basename ++ "_stub.c",
 826                                      hscStubHOutName = basename ++ "_stub.h",
 827                                      extCoreName = basename ++ ".hcr" }
 828             hsc_env = HscEnv { hsc_mode = OneShot,
 829                                hsc_dflags = dyn_flags',
 830                                hsc_HPT    = emptyHomePackageTable }
 831
 832
 833   -- run the compiler!
 834         pcs <- initPersistentCompilerState
 835         result <- hscMain hsc_env pcs mod
 836                           location{ ml_hspp_file=Just input_fn }
 837                           source_unchanged
 838                           False
 839                           Nothing        -- no iface
 840
 841         case result of {
 842
 843             HscFail pcs -> throwDyn (PhaseFailed "hsc" (ExitFailure 1));
 844
 845             HscNoRecomp pcs details iface -> do { SysTools.touch "Touching object file" o_file
 846                                                 ; return Nothing } ;
 847
 848             HscRecomp pcs details iface stub_h_exists stub_c_exists
 849                       _maybe_interpreted_code -> do
 850
 851                             -- deal with stubs
 852                             maybe_stub_o <- compileStub dyn_flags' stub_c_exists
 853                             case maybe_stub_o of
 854                               Nothing -> return ()
 855                               Just stub_o -> add v_Ld_inputs stub_o
 856                             case hscLang dyn_flags of
 857                               HscNothing -> return Nothing
 858                               _ -> return (Just output_fn)
 859     }
 860
 861 -----------------------------------------------------------------------------
 862 -- Cc phase
 863
 864 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 865 -- way too many hacks, and I can't say I've ever used it anyway.
 866
 867 run_phase cc_phase basename suff input_fn output_fn
 868    | cc_phase == Cc || cc_phase == HCc
 869    = do cc_opts              <- getOpts opt_c
 870         cmdline_include_paths <- readIORef v_Include_paths
 871
 872         let hcc = cc_phase == HCc
 873
 874                 -- add package include paths even if we're just compiling
 875                 -- .c files; this is the Value Add(TM) that using
 876                 -- ghc instead of gcc gives you :)
 877         pkg_include_dirs <- getPackageIncludePath
 878         let include_paths = foldr (\ x xs -> "-I" : x : xs) []
 879                               (cmdline_include_paths ++ pkg_include_dirs)
 880
 881         mangle <- readIORef v_Do_asm_mangling
 882         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
 883
 884         verb <- getVerbFlag
 885
 886         o2 <- readIORef v_minus_o2_for_C
 887         let opt_flag | o2        = "-O2"
 888                      | otherwise = "-O"
 889
 890         pkg_extra_cc_opts <- getPackageExtraCcOpts
 891
 892         split_objs <- readIORef v_Split_object_files
 893         let split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 894                       | otherwise         = [ ]
 895
 896         excessPrecision <- readIORef v_Excess_precision
 897
 898         -- force the C compiler to interpret this file as C when
 899         -- compiling .hc files, by adding the -x c option.
 900         let langopt
 901                 | cc_phase == HCc = [ SysTools.Option "-x", SysTools.Option "c"]
 902                 | otherwise       = [ ]
 903
 904         SysTools.runCc (langopt ++
 905                         [ SysTools.FileOption "" input_fn
 906                         , SysTools.Option "-o"
 907                         , SysTools.FileOption "" output_fn
 908                         ]
 909                        ++ map SysTools.Option (
 910                           md_c_flags
 911                        ++ (if cc_phase == HCc && mangle
 912                              then md_regd_c_flags
 913                              else [])
 914                        ++ [ verb, "-S", "-Wimplicit", opt_flag ]
 915                        ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 916                        ++ cc_opts
 917                        ++ split_opt
 918                        ++ (if excessPrecision then [] else [ "-ffloat-store" ])
 919                        ++ include_paths
 920                        ++ pkg_extra_cc_opts
 921                        ))
 922         return (Just output_fn)
 923
 924         -- ToDo: postprocess the output from gcc
 925
 926 -----------------------------------------------------------------------------
 927 -- Mangle phase
 928
 929 run_phase Mangle _basename _suff input_fn output_fn
 930   = do mangler_opts <- getOpts opt_m
 931        machdep_opts <- if (prefixMatch "i386" cTARGETPLATFORM)
 932                        then do n_regs <- dynFlag stolen_x86_regs
 933                                return [ show n_regs ]
 934                        else return []
 935
 936        SysTools.runMangle (map SysTools.Option mangler_opts
 937                           ++ [ SysTools.FileOption "" input_fn
 938                              , SysTools.FileOption "" output_fn
 939                              ]
 940                           ++ map SysTools.Option machdep_opts)
 941        return (Just output_fn)
 942
 943 -----------------------------------------------------------------------------
 944 -- Splitting phase
 945
 946 run_phase SplitMangle _basename _suff input_fn output_fn
 947   = do  -- tmp_pfx is the prefix used for the split .s files
 948         -- We also use it as the file to contain the no. of split .s files (sigh)
 949         split_s_prefix <- SysTools.newTempName "split"
 950         let n_files_fn = split_s_prefix
 951
 952         SysTools.runSplit [ SysTools.FileOption "" input_fn
 953                           , SysTools.FileOption "" split_s_prefix
 954                           , SysTools.FileOption "" n_files_fn
 955                           ]
 956
 957         -- Save the number of split files for future references
 958         s <- readFile n_files_fn
 959         let n_files = read s :: Int
 960         writeIORef v_Split_info (split_s_prefix, n_files)
 961
 962         -- Remember to delete all these files
 963         addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s"
 964                         | n <- [1..n_files]]
 965
 966         return (Just output_fn)
 967
 968 -----------------------------------------------------------------------------
 969 -- As phase
 970
 971 run_phase As _basename _suff input_fn output_fn
 972   = do  as_opts               <- getOpts opt_a
 973         cmdline_include_paths <- readIORef v_Include_paths
 974
 975         SysTools.runAs (map SysTools.Option as_opts
 976                        ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
 977                        ++ [ SysTools.Option "-c"
 978                           , SysTools.FileOption "" input_fn
 979                           , SysTools.Option "-o"
 980                           , SysTools.FileOption "" output_fn
 981                           ])
 982         return (Just output_fn)
 983
 984 run_phase SplitAs basename _suff _input_fn output_fn
 985   = do  as_opts <- getOpts opt_a
 986
 987         (split_s_prefix, n) <- readIORef v_Split_info
 988
 989         odir <- readIORef v_Output_dir
 990         let real_odir = case odir of
 991                                 Nothing -> basename ++ "_split"
 992                                 Just d  -> d
 993
 994         let assemble_file n
 995               = do  let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
 996                     let output_o = newdir real_odir
 997                                         (basename ++ "__" ++ show n ++ ".o")
 998                     real_o <- osuf_ify output_o
 999                     SysTools.runAs (map SysTools.Option as_opts ++
1000                                     [ SysTools.Option "-c"
1001                                     , SysTools.Option "-o"
1002                                     , SysTools.FileOption "" real_o
1003                                     , SysTools.FileOption "" input_s
1004                                     ])
1005
1006         mapM_ assemble_file [1..n]
1007         return (Just output_fn)
1008
1009 #ifdef ILX
1010 -----------------------------------------------------------------------------
1011 -- Ilx2Il phase
1012 -- Run ilx2il over the ILX output, getting an IL file
1013
1014 run_phase Ilx2Il _basename _suff input_fn output_fn
1015   = do  ilx2il_opts <- getOpts opt_I
1016         SysTools.runIlx2il (map SysTools.Option ilx2il_opts
1017                            ++ [ SysTools.Option "--no-add-suffix-to-assembly",
1018                                 SysTools.Option "mscorlib",
1019                                 SysTools.Option "-o",
1020                                 SysTools.FileOption "" output_fn,
1021                                 SysTools.FileOption "" input_fn ])
1022         return (Just output_fn)
1023
1024 -----------------------------------------------------------------------------
1025 -- Ilasm phase
1026 -- Run ilasm over the IL, getting a DLL
1027
1028 run_phase Ilasm _basename _suff input_fn output_fn
1029   = do  ilasm_opts <- getOpts opt_i
1030         SysTools.runIlasm (map SysTools.Option ilasm_opts
1031                            ++ [ SysTools.Option "/QUIET",
1032                                 SysTools.Option "/DLL",
1033                                 SysTools.FileOption "/OUT=" output_fn,
1034                                 SysTools.FileOption "" input_fn ])
1035         return (Just output_fn)
1036
1037 #endif -- ILX
1038
1039 -----------------------------------------------------------------------------
1040 -- MoveBinary sort-of-phase
1041 -- After having produced a binary, move it somewhere else and generate a
1042 -- wrapper script calling the binary. Currently, we need this only in
1043 -- a parallel way (i.e. in GUM), because PVM expects the binary in a
1044 -- central directory.
1045 -- This is called from staticLink below, after linking. I haven't made it
1046 -- a separate phase to minimise interfering with other modules, and
1047 -- we don't need the generality of a phase (MoveBinary is always
1048 -- done after linking and makes only sense in a parallel setup)   -- HWL
1049
1050 run_phase_MoveBinary input_fn
1051   = do
1052         sysMan   <- getSysMan
1053         pvm_root <- getEnv "PVM_ROOT"
1054         pvm_arch <- getEnv "PVM_ARCH"
1055         let
1056            pvm_executable_base = "=" ++ input_fn
1057            pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
1058         -- nuke old binary; maybe use configur'ed names for cp and rm?
1059         system ("rm -f " ++ pvm_executable)
1060         -- move the newly created binary into PVM land
1061         system ("cp -p " ++ input_fn ++ " " ++ pvm_executable)
1062         -- generate a wrapper script for running a parallel prg under PVM
1063         writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
1064         return True
1065
1066 -- generates a Perl skript starting a parallel prg under PVM
1067 mk_pvm_wrapper_script :: String -> String -> String -> String
1068 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
1069  [
1070   "eval 'exec perl -S $0 ${1+\"$@\"}'",
1071   "  if $running_under_some_shell;",
1072   "# =!=!=!=!=!=!=!=!=!=!=!",
1073   "# This script is automatically generated: DO NOT EDIT!!!",
1074   "# Generated by Glasgow Haskell Compiler",
1075   "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
1076   "#",
1077   "$pvm_executable      = '" ++ pvm_executable ++ "';",
1078   "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
1079   "$SysMan = '" ++ sysMan ++ "';",
1080   "",
1081   {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
1082   "# first, some magical shortcuts to run "commands" on the binary",
1083   "# (which is hidden)",
1084   "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
1085   "    local($cmd) = $1;",
1086   "    system("$cmd $pvm_executable");",
1087   "    exit(0); # all done",
1088   "}", -}
1089   "",
1090   "# Now, run the real binary; process the args first",
1091   "$ENV{'PE'} = $pvm_executable_base;", --  ++ pvm_executable_base,
1092   "$debug = '';",
1093   "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
1094   "@nonPVM_args = ();",
1095   "$in_RTS_args = 0;",
1096   "",
1097   "args: while ($a = shift(@ARGV)) {",
1098   "    if ( $a eq '+RTS' ) {",
1099   "     $in_RTS_args = 1;",
1100   "    } elsif ( $a eq '-RTS' ) {",
1101   "     $in_RTS_args = 0;",
1102   "    }",
1103   "    if ( $a eq '-d' && $in_RTS_args ) {",
1104   "     $debug = '-';",
1105   "    } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
1106   "     $nprocessors = $1;",
1107   "    } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
1108   "     $nprocessors = $1;",
1109   "    } else {",
1110   "     push(@nonPVM_args, $a);",
1111   "    }",
1112   "}",
1113   "",
1114   "local($return_val) = 0;",
1115   "# Start the parallel execution by calling SysMan",
1116   "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
1117   "$return_val = $?;",
1118   "# ToDo: fix race condition moving files and flushing them!!",
1119   "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
1120   "exit($return_val);"
1121  ]
1122
1123 -----------------------------------------------------------------------------
1124 -- Complain about non-dynamic flags in OPTIONS pragmas
1125
1126 checkProcessArgsResult flags basename suff
1127   = do when (notNull flags) (throwDyn (ProgramError (
1128            basename ++ "." ++ suff
1129            ++ ": static flags are not allowed in {-# OPTIONS #-} pragmas:\n\t"
1130            ++ unwords flags)) (ExitFailure 1))
1131
1132 -----------------------------------------------------------------------------
1133 -- Static linking, of .o files
1134
1135 staticLink :: [String] -> IO ()
1136 staticLink o_files = do
1137     verb       <- getVerbFlag
1138     static     <- readIORef v_Static
1139     no_hs_main <- readIORef v_NoHsMain
1140
1141     o_file <- readIORef v_Output_file
1142     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1143
1144     pkg_lib_paths <- getPackageLibraryPath
1145     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1146
1147     lib_paths <- readIORef v_Library_paths
1148     let lib_path_opts = map ("-L"++) lib_paths
1149
1150     pkg_libs <- getPackageLibraries
1151     let imp          = if static then "" else "_imp"
1152         pkg_lib_opts = map (\lib -> "-l" ++ lib ++ imp) pkg_libs
1153
1154     libs <- readIORef v_Cmdline_libraries
1155     let lib_opts = map ("-l"++) (reverse libs)
1156          -- reverse because they're added in reverse order from the cmd line
1157
1158 #ifdef darwin_TARGET_OS
1159     pkg_framework_paths <- getPackageFrameworkPath
1160     let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths
1161
1162     framework_paths <- readIORef v_Framework_paths
1163     let framework_path_opts = map ("-F"++) framework_paths
1164
1165     pkg_frameworks <- getPackageFrameworks
1166     let pkg_framework_opts = map ("-framework " ++) pkg_frameworks
1167
1168     frameworks <- readIORef v_Cmdline_frameworks
1169     let framework_opts = map ("-framework "++) (reverse frameworks)
1170          -- reverse because they're added in reverse order from the cmd line
1171 #endif
1172
1173     pkg_extra_ld_opts <- getPackageExtraLdOpts
1174
1175         -- probably _stub.o files
1176     extra_ld_inputs <- readIORef v_Ld_inputs
1177
1178         -- opts from -optl-<blah>
1179     extra_ld_opts <- getStaticOpts v_Opt_l
1180
1181     [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, preludePackage]
1182
1183     let extra_os = if static || no_hs_main
1184                    then []
1185                    else [ head (library_dirs rts_pkg) ++ "/Main.dll_o",
1186                           head (library_dirs std_pkg) ++ "/PrelMain.dll_o" ]
1187
1188     (md_c_flags, _) <- machdepCCOpts
1189     SysTools.runLink ( [ SysTools.Option verb
1190                        , SysTools.Option "-o"
1191                        , SysTools.FileOption "" output_fn
1192                        ]
1193                       ++ map SysTools.Option (
1194                          md_c_flags
1195                       ++ o_files
1196                       ++ extra_os
1197                       ++ extra_ld_inputs
1198                       ++ lib_path_opts
1199                       ++ lib_opts
1200 #ifdef darwin_TARGET_OS
1201                       ++ framework_path_opts
1202                       ++ framework_opts
1203 #endif
1204                       ++ pkg_lib_path_opts
1205                       ++ pkg_lib_opts
1206 #ifdef darwin_TARGET_OS
1207                       ++ pkg_framework_path_opts
1208                       ++ pkg_framework_opts
1209 #endif
1210                       ++ pkg_extra_ld_opts
1211                       ++ extra_ld_opts
1212                       ++ if static && not no_hs_main then
1213                             [ "-u", prefixUnderscore "Main_zdmain_closure"]
1214                          else []))
1215
1216     -- parallel only: move binary to another dir -- HWL
1217     ways_ <- readIORef v_Ways
1218     when (WayPar `elem` ways_)
1219          (do success <- run_phase_MoveBinary output_fn
1220              if success then return ()
1221                         else throwDyn (InstallationError ("cannot move binary to PVM dir")))
1222
1223 -----------------------------------------------------------------------------
1224 -- Making a DLL (only for Win32)
1225
1226 doMkDLL :: [String] -> IO ()
1227 doMkDLL o_files = do
1228     verb       <- getVerbFlag
1229     static     <- readIORef v_Static
1230     no_hs_main <- readIORef v_NoHsMain
1231
1232     o_file <- readIORef v_Output_file
1233     let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
1234
1235     pkg_lib_paths <- getPackageLibraryPath
1236     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1237
1238     lib_paths <- readIORef v_Library_paths
1239     let lib_path_opts = map ("-L"++) lib_paths
1240
1241     pkg_libs <- getPackageLibraries
1242     let imp = if static then "" else "_imp"
1243         pkg_lib_opts = map (\lib -> "-l" ++ lib ++ imp) pkg_libs
1244
1245     libs <- readIORef v_Cmdline_libraries
1246     let lib_opts = map ("-l"++) (reverse libs)
1247          -- reverse because they're added in reverse order from the cmd line
1248
1249     pkg_extra_ld_opts <- getPackageExtraLdOpts
1250
1251         -- probably _stub.o files
1252     extra_ld_inputs <- readIORef v_Ld_inputs
1253
1254         -- opts from -optdll-<blah>
1255     extra_ld_opts <- getStaticOpts v_Opt_dll
1256
1257     [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, stdPackage]
1258
1259     let extra_os = if static || no_hs_main
1260                    then []
1261                    else [ head (library_dirs rts_pkg) ++ "/Main.dll_o",
1262                           head (library_dirs std_pkg) ++ "/PrelMain.dll_o" ]
1263
1264     (md_c_flags, _) <- machdepCCOpts
1265     SysTools.runMkDLL
1266          ([ SysTools.Option verb
1267           , SysTools.Option "-o"
1268           , SysTools.FileOption "" output_fn
1269           ]
1270          ++ map SysTools.Option (
1271             md_c_flags
1272          ++ o_files
1273          ++ extra_os
1274          ++ [ "--target=i386-mingw32" ]
1275          ++ extra_ld_inputs
1276          ++ lib_path_opts
1277          ++ lib_opts
1278          ++ pkg_lib_path_opts
1279          ++ pkg_lib_opts
1280          ++ pkg_extra_ld_opts
1281          ++ (if "--def" `elem` (concatMap words extra_ld_opts)
1282                then [ "" ]
1283                else [ "--export-all" ])
1284          ++ extra_ld_opts
1285         ))