compiler/main/DriverPipeline.hs

   1 -----------------------------------------------------------------------------
   2 --
   3 -- GHC Driver
   4 --
   5 -- (c) The University of Glasgow 2005
   6 --
   7 -----------------------------------------------------------------------------
   8
   9 module DriverPipeline (
  10         -- Run a series of compilation steps in a pipeline, for a
  11         -- collection of source files.
  12    oneShot, compileFile,
  13
  14         -- Interfaces for the batch-mode driver
  15    linkBinary,
  16
  17         -- Interfaces for the compilation manager (interpreted/batch-mode)
  18    preprocess,
  19    compile,
  20    link,
  21
  22   ) where
  23
  24 #include "HsVersions.h"
  25
  26 import Packages
  27 import HeaderInfo
  28 import DriverPhases
  29 import SysTools
  30 import HscMain
  31 import Finder
  32 import HscTypes
  33 import Outputable
  34 import Module
  35 import LazyUniqFM               ( eltsUFM )
  36 import ErrUtils
  37 import DynFlags
  38 import StaticFlags      ( v_Ld_inputs, opt_Static, WayName(..) )
  39 import Config
  40 import Panic
  41 import Util
  42 import StringBuffer     ( hGetStringBuffer )
  43 import BasicTypes       ( SuccessFlag(..) )
  44 import Maybes           ( expectJust )
  45 import ParserCoreUtils  ( getCoreModuleName )
  46 import SrcLoc           ( unLoc )
  47 import SrcLoc           ( Located(..) )
  48 import FastString
  49
  50 import Control.Exception as Exception
  51 import Data.IORef       ( readIORef, writeIORef, IORef )
  52 import GHC.Exts         ( Int(..) )
  53 import System.Directory
  54 import System.FilePath
  55 import System.IO
  56 import SYSTEM_IO_ERROR as IO
  57 import Control.Monad
  58 import Data.List        ( isSuffixOf )
  59 import Data.Maybe
  60 import System.Exit
  61 import System.Environment
  62
  63 -- ---------------------------------------------------------------------------
  64 -- Pre-process
  65
  66 -- Just preprocess a file, put the result in a temp. file (used by the
  67 -- compilation manager during the summary phase).
  68 --
  69 -- We return the augmented DynFlags, because they contain the result
  70 -- of slurping in the OPTIONS pragmas
  71
  72 preprocess :: HscEnv -> (FilePath, Maybe Phase) -> IO (DynFlags, FilePath)
  73 preprocess hsc_env (filename, mb_phase) =
  74   ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
  75   runPipeline anyHsc hsc_env (filename, mb_phase)
  76         Nothing Temporary Nothing{-no ModLocation-}
  77
  78 -- ---------------------------------------------------------------------------
  79 -- Compile
  80
  81 -- Compile a single module, under the control of the compilation manager.
  82 --
  83 -- This is the interface between the compilation manager and the
  84 -- compiler proper (hsc), where we deal with tedious details like
  85 -- reading the OPTIONS pragma from the source file, and passing the
  86 -- output of hsc through the C compiler.
  87
  88 -- NB.  No old interface can also mean that the source has changed.
  89
  90 compile :: HscEnv
  91         -> ModSummary                   -- summary for module being compiled
  92         -> Int -> Int                   -- module N of M
  93         -> Maybe ModIface               -- old interface, if we have one
  94         -> Maybe Linkable               -- old linkable, if we have one
  95         -> IO (Maybe HomeModInfo)       -- the complete HomeModInfo, if successful
  96
  97 compile hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable
  98  = do
  99    let dflags0     = ms_hspp_opts summary
 100        this_mod    = ms_mod summary
 101        src_flavour = ms_hsc_src summary
 102        location    = ms_location summary
 103        input_fn    = expectJust "compile:hs" (ml_hs_file location)
 104        input_fnpp  = ms_hspp_file summary
 105
 106    debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp)
 107
 108    let basename = dropExtension input_fn
 109
 110   -- We add the directory in which the .hs files resides) to the import path.
 111   -- This is needed when we try to compile the .hc file later, if it
 112   -- imports a _stub.h file that we created here.
 113    let current_dir = case takeDirectory basename of
 114                      "" -> "." -- XXX Hack
 115                      d -> d
 116        old_paths   = includePaths dflags0
 117        dflags      = dflags0 { includePaths = current_dir : old_paths }
 118        hsc_env     = hsc_env0 {hsc_dflags = dflags}
 119
 120    -- Figure out what lang we're generating
 121    let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags)
 122    -- ... and what the next phase should be
 123    let next_phase = hscNextPhase dflags src_flavour hsc_lang
 124    -- ... and what file to generate the output into
 125    output_fn <- getOutputFilename next_phase
 126                         Temporary basename dflags next_phase (Just location)
 127
 128    let dflags' = dflags { hscTarget = hsc_lang,
 129                                 hscOutName = output_fn,
 130                                 extCoreName = basename ++ ".hcr" }
 131    let hsc_env' = hsc_env { hsc_dflags = dflags' }
 132
 133    -- -no-recomp should also work with --make
 134    let force_recomp = dopt Opt_ForceRecomp dflags
 135        source_unchanged = isJust maybe_old_linkable && not force_recomp
 136        object_filename = ml_obj_file location
 137
 138    let getStubLinkable False = return []
 139        getStubLinkable True
 140            = do stub_o <- compileStub hsc_env' this_mod location
 141                 return [ DotO stub_o ]
 142
 143        handleBatch HscNoRecomp
 144            = ASSERT (isJust maybe_old_linkable)
 145              return maybe_old_linkable
 146
 147        handleBatch (HscRecomp hasStub)
 148            | isHsBoot src_flavour
 149                = do when (isObjectTarget hsc_lang) $ -- interpreted reaches here too
 150                        SysTools.touch dflags' "Touching object file"
 151                                    object_filename
 152                     return maybe_old_linkable
 153
 154            | otherwise
 155                = do stub_unlinked <- getStubLinkable hasStub
 156                     (hs_unlinked, unlinked_time) <-
 157                         case hsc_lang of
 158                           HscNothing
 159                             -> return ([], ms_hs_date summary)
 160                           -- We're in --make mode: finish the compilation pipeline.
 161                           _other
 162                             -> do runPipeline StopLn hsc_env' (output_fn,Nothing)
 163                                               (Just basename)
 164                                               Persistent
 165                                               (Just location)
 166                                   -- The object filename comes from the ModLocation
 167                                   o_time <- getModificationTime object_filename
 168                                   return ([DotO object_filename], o_time)
 169                     let linkable = LM unlinked_time this_mod
 170                                    (hs_unlinked ++ stub_unlinked)
 171                     return (Just linkable)
 172
 173        handleInterpreted InteractiveNoRecomp
 174            = ASSERT (isJust maybe_old_linkable)
 175              return maybe_old_linkable
 176        handleInterpreted (InteractiveRecomp hasStub comp_bc modBreaks)
 177            = do stub_unlinked <- getStubLinkable hasStub
 178                 let hs_unlinked = [BCOs comp_bc modBreaks]
 179                     unlinked_time = ms_hs_date summary
 180                   -- Why do we use the timestamp of the source file here,
 181                   -- rather than the current time?  This works better in
 182                   -- the case where the local clock is out of sync
 183                   -- with the filesystem's clock.  It's just as accurate:
 184                   -- if the source is modified, then the linkable will
 185                   -- be out of date.
 186                 let linkable = LM unlinked_time this_mod
 187                                (hs_unlinked ++ stub_unlinked)
 188                 return (Just linkable)
 189
 190    let -- runCompiler :: Compiler result -> (result -> Maybe Linkable)
 191        --            -> IO (Maybe HomeModInfo)
 192        runCompiler compiler handle
 193            = do mbResult <- compiler hsc_env' summary source_unchanged mb_old_iface
 194                                      (Just (mod_index, nmods))
 195                 case mbResult of
 196                   Nothing -> return Nothing
 197                   Just (result, iface, details) -> do
 198                         linkable <- handle result
 199                         return (Just HomeModInfo{ hm_details  = details,
 200                                                   hm_iface    = iface,
 201                                                   hm_linkable = linkable })
 202    -- run the compiler
 203    case hsc_lang of
 204       HscInterpreted
 205         | isHsBoot src_flavour ->
 206                 runCompiler hscCompileNothing handleBatch
 207         | otherwise ->
 208                 runCompiler hscCompileInteractive handleInterpreted
 209       HscNothing ->
 210                 runCompiler hscCompileNothing handleBatch
 211       _other ->
 212                 runCompiler hscCompileBatch handleBatch
 213
 214 -----------------------------------------------------------------------------
 215 -- stub .h and .c files (for foreign export support)
 216
 217 -- The _stub.c file is derived from the haskell source file, possibly taking
 218 -- into account the -stubdir option.
 219 --
 220 -- Consequently, we derive the _stub.o filename from the haskell object
 221 -- filename.
 222 --
 223 -- This isn't necessarily the same as the object filename we
 224 -- would get if we just compiled the _stub.c file using the pipeline.
 225 -- For example:
 226 --
 227 --    ghc src/A.hs -odir obj
 228 --
 229 -- results in obj/A.o, and src/A_stub.c.  If we compile src/A_stub.c with
 230 -- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want
 231 -- obj/A_stub.o.
 232
 233 compileStub :: HscEnv -> Module -> ModLocation -> IO FilePath
 234 compileStub hsc_env mod location = do
 235         let (o_base, o_ext) = splitExtension (ml_obj_file location)
 236             stub_o = (o_base ++ "_stub") <.> o_ext
 237
 238         -- compile the _stub.c file w/ gcc
 239         let (stub_c,_,_) = mkStubPaths (hsc_dflags hsc_env) (moduleName mod) location
 240         runPipeline StopLn hsc_env (stub_c,Nothing)  Nothing
 241                 (SpecificFile stub_o) Nothing{-no ModLocation-}
 242
 243         return stub_o
 244
 245
 246 -- ---------------------------------------------------------------------------
 247 -- Link
 248
 249 link :: GhcLink                 -- interactive or batch
 250      -> DynFlags                -- dynamic flags
 251      -> Bool                    -- attempt linking in batch mode?
 252      -> HomePackageTable        -- what to link
 253      -> IO SuccessFlag
 254
 255 -- For the moment, in the batch linker, we don't bother to tell doLink
 256 -- which packages to link -- it just tries all that are available.
 257 -- batch_attempt_linking should only be *looked at* in batch mode.  It
 258 -- should only be True if the upsweep was successful and someone
 259 -- exports main, i.e., we have good reason to believe that linking
 260 -- will succeed.
 261
 262 #ifdef GHCI
 263 link LinkInMemory _ _ _
 264     = do -- Not Linking...(demand linker will do the job)
 265          return Succeeded
 266 #endif
 267
 268 link NoLink _ _ _
 269    = return Succeeded
 270
 271 link LinkBinary dflags batch_attempt_linking hpt
 272    | batch_attempt_linking
 273    = do
 274         let
 275             home_mod_infos = eltsUFM hpt
 276
 277             -- the packages we depend on
 278             pkg_deps  = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos
 279
 280             -- the linkables to link
 281             linkables = map (expectJust "link".hm_linkable) home_mod_infos
 282
 283         debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
 284
 285         -- check for the -no-link flag
 286         if isNoLink (ghcLink dflags)
 287           then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).")
 288                   return Succeeded
 289           else do
 290
 291         let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
 292             obj_files = concatMap getOfiles linkables
 293
 294             exe_file = exeFileName dflags
 295
 296         -- if the modification time on the executable is later than the
 297         -- modification times on all of the objects, then omit linking
 298         -- (unless the -no-recomp flag was given).
 299         e_exe_time <- IO.try $ getModificationTime exe_file
 300         extra_ld_inputs <- readIORef v_Ld_inputs
 301         extra_times <- mapM (IO.try . getModificationTime) extra_ld_inputs
 302         let other_times = map linkableTime linkables
 303                        ++ [ t' | Right t' <- extra_times ]
 304             linking_needed = case e_exe_time of
 305                                Left _  -> True
 306                                Right t -> any (t <) other_times
 307
 308         if not (dopt Opt_ForceRecomp dflags) && not linking_needed
 309            then do debugTraceMsg dflags 2 (text exe_file <+> ptext (sLit "is up to date, linking not required."))
 310                    return Succeeded
 311            else do
 312
 313         debugTraceMsg dflags 1 (ptext (sLit "Linking") <+> text exe_file
 314                                  <+> text "...")
 315
 316         -- Don't showPass in Batch mode; doLink will do that for us.
 317         let link = case ghcLink dflags of
 318                 LinkBinary  -> linkBinary
 319                 LinkDynLib  -> linkDynLib
 320                 other       -> panicBadLink other
 321         link dflags obj_files pkg_deps
 322
 323         debugTraceMsg dflags 3 (text "link: done")
 324
 325         -- linkBinary only returns if it succeeds
 326         return Succeeded
 327
 328    | otherwise
 329    = do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$
 330                                 text "   Main.main not exported; not linking.")
 331         return Succeeded
 332
 333 -- warning suppression
 334 link other _ _ _ = panicBadLink other
 335
 336 panicBadLink :: GhcLink -> a
 337 panicBadLink other = panic ("link: GHC not built to link this way: " ++
 338                             show other)
 339 -- -----------------------------------------------------------------------------
 340 -- Compile files in one-shot mode.
 341
 342 oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO ()
 343 oneShot hsc_env stop_phase srcs = do
 344   o_files <- mapM (compileFile hsc_env stop_phase) srcs
 345   doLink (hsc_dflags hsc_env) stop_phase o_files
 346
 347 compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath
 348 compileFile hsc_env stop_phase (src, mb_phase) = do
 349    exists <- doesFileExist src
 350    when (not exists) $
 351         throwDyn (CmdLineError ("does not exist: " ++ src))
 352
 353    let
 354         dflags = hsc_dflags hsc_env
 355         split     = dopt Opt_SplitObjs dflags
 356         mb_o_file = outputFile dflags
 357         ghc_link  = ghcLink dflags      -- Set by -c or -no-link
 358
 359         -- When linking, the -o argument refers to the linker's output.
 360         -- otherwise, we use it as the name for the pipeline's output.
 361         output
 362          | StopLn <- stop_phase, not (isNoLink ghc_link) = Persistent
 363                 -- -o foo applies to linker
 364          | Just o_file <- mb_o_file = SpecificFile o_file
 365                 -- -o foo applies to the file we are compiling now
 366          | otherwise = Persistent
 367
 368         stop_phase' = case stop_phase of
 369                         As | split -> SplitAs
 370                         _          -> stop_phase
 371
 372    (_, out_file) <- runPipeline stop_phase' hsc_env
 373                           (src, mb_phase) Nothing output
 374                           Nothing{-no ModLocation-}
 375    return out_file
 376
 377
 378 doLink :: DynFlags -> Phase -> [FilePath] -> IO ()
 379 doLink dflags stop_phase o_files
 380   | not (isStopLn stop_phase)
 381   = return ()           -- We stopped before the linking phase
 382
 383   | otherwise
 384   = case ghcLink dflags of
 385         NoLink     -> return ()
 386         LinkBinary -> linkBinary dflags o_files link_pkgs
 387         LinkDynLib -> linkDynLib dflags o_files []
 388         other      -> panicBadLink other
 389   where
 390    -- Always link in the haskell98 package for static linking.  Other
 391    -- packages have to be specified via the -package flag.
 392     link_pkgs = [haskell98PackageId]
 393
 394
 395 -- ---------------------------------------------------------------------------
 396 -- Run a compilation pipeline, consisting of multiple phases.
 397
 398 -- This is the interface to the compilation pipeline, which runs
 399 -- a series of compilation steps on a single source file, specifying
 400 -- at which stage to stop.
 401
 402 -- The DynFlags can be modified by phases in the pipeline (eg. by
 403 -- GHC_OPTIONS pragmas), and the changes affect later phases in the
 404 -- pipeline.
 405
 406 data PipelineOutput
 407   = Temporary
 408         -- output should be to a temporary file: we're going to
 409         -- run more compilation steps on this output later
 410   | Persistent
 411         -- we want a persistent file, i.e. a file in the current directory
 412         -- derived from the input filename, but with the appropriate extension.
 413         -- eg. in "ghc -c Foo.hs" the output goes into ./Foo.o.
 414   | SpecificFile FilePath
 415         -- the output must go into the specified file.
 416
 417 runPipeline
 418   :: Phase                      -- When to stop
 419   -> HscEnv                     -- Compilation environment
 420   -> (FilePath,Maybe Phase)     -- Input filename (and maybe -x suffix)
 421   -> Maybe FilePath             -- original basename (if different from ^^^)
 422   -> PipelineOutput             -- Output filename
 423   -> Maybe ModLocation          -- A ModLocation, if this is a Haskell module
 424   -> IO (DynFlags, FilePath)    -- (final flags, output filename)
 425
 426 runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc
 427   = do
 428   let dflags0 = hsc_dflags hsc_env0
 429       (input_basename, suffix) = splitExtension input_fn
 430       suffix' = drop 1 suffix -- strip off the .
 431       basename | Just b <- mb_basename = b
 432                | otherwise             = input_basename
 433
 434       -- Decide where dump files should go based on the pipeline output
 435       dflags = dflags0 { dumpPrefix = Just (basename ++ ".") }
 436       hsc_env = hsc_env0 {hsc_dflags = dflags}
 437
 438         -- If we were given a -x flag, then use that phase to start from
 439       start_phase = fromMaybe (startPhase suffix') mb_phase
 440
 441   -- We want to catch cases of "you can't get there from here" before
 442   -- we start the pipeline, because otherwise it will just run off the
 443   -- end.
 444   --
 445   -- There is a partial ordering on phases, where A < B iff A occurs
 446   -- before B in a normal compilation pipeline.
 447
 448   when (not (start_phase `happensBefore` stop_phase)) $
 449         throwDyn (UsageError
 450                     ("cannot compile this file to desired target: "
 451                        ++ input_fn))
 452
 453   -- this is a function which will be used to calculate output file names
 454   -- as we go along (we partially apply it to some of its inputs here)
 455   let get_output_fn = getOutputFilename stop_phase output basename
 456
 457   -- Execute the pipeline...
 458   (dflags', output_fn, maybe_loc) <-
 459         pipeLoop hsc_env start_phase stop_phase input_fn
 460                  basename suffix' get_output_fn maybe_loc
 461
 462   -- Sometimes, a compilation phase doesn't actually generate any output
 463   -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
 464   -- stage, but we wanted to keep the output, then we have to explicitly
 465   -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
 466   -- further compilation stages can tell what the original filename was.
 467   case output of
 468     Temporary ->
 469         return (dflags', output_fn)
 470     _other ->
 471         do final_fn <- get_output_fn dflags' stop_phase maybe_loc
 472            when (final_fn /= output_fn) $ do
 473               let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'")
 474                   line_prag = Just ("{-# LINE 1 \"" ++ input_fn ++ "\" #-}\n")
 475               copyWithHeader dflags msg line_prag output_fn final_fn
 476            return (dflags', final_fn)
 477
 478
 479
 480 pipeLoop :: HscEnv -> Phase -> Phase
 481          -> FilePath  -> String -> Suffix
 482          -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
 483          -> Maybe ModLocation
 484          -> IO (DynFlags, FilePath, Maybe ModLocation)
 485
 486 pipeLoop hsc_env phase stop_phase
 487          input_fn orig_basename orig_suff
 488          orig_get_output_fn maybe_loc
 489
 490   | phase `eqPhase` stop_phase            -- All done
 491   = return (hsc_dflags hsc_env, input_fn, maybe_loc)
 492
 493   | not (phase `happensBefore` stop_phase)
 494         -- Something has gone wrong.  We'll try to cover all the cases when
 495         -- this could happen, so if we reach here it is a panic.
 496         -- eg. it might happen if the -C flag is used on a source file that
 497         -- has {-# OPTIONS -fasm #-}.
 498   = panic ("pipeLoop: at phase " ++ show phase ++
 499            " but I wanted to stop at phase " ++ show stop_phase)
 500
 501   | otherwise
 502   = do (next_phase, dflags', maybe_loc, output_fn)
 503           <- runPhase phase stop_phase hsc_env orig_basename
 504                       orig_suff input_fn orig_get_output_fn maybe_loc
 505        let hsc_env' = hsc_env {hsc_dflags = dflags'}
 506        pipeLoop hsc_env' next_phase stop_phase output_fn
 507                 orig_basename orig_suff orig_get_output_fn maybe_loc
 508
 509 getOutputFilename
 510   :: Phase -> PipelineOutput -> String
 511   -> DynFlags -> Phase{-next phase-} -> Maybe ModLocation -> IO FilePath
 512 getOutputFilename stop_phase output basename
 513  = func
 514  where
 515         func dflags next_phase maybe_location
 516            | is_last_phase, Persistent <- output     = persistent_fn
 517            | is_last_phase, SpecificFile f <- output = return f
 518            | keep_this_output                        = persistent_fn
 519            | otherwise                               = newTempName dflags suffix
 520            where
 521                 hcsuf      = hcSuf dflags
 522                 odir       = objectDir dflags
 523                 osuf       = objectSuf dflags
 524                 keep_hc    = dopt Opt_KeepHcFiles dflags
 525                 keep_raw_s = dopt Opt_KeepRawSFiles dflags
 526                 keep_s     = dopt Opt_KeepSFiles dflags
 527
 528                 myPhaseInputExt HCc    = hcsuf
 529                 myPhaseInputExt StopLn = osuf
 530                 myPhaseInputExt other  = phaseInputExt other
 531
 532                 is_last_phase = next_phase `eqPhase` stop_phase
 533
 534                 -- sometimes, we keep output from intermediate stages
 535                 keep_this_output =
 536                      case next_phase of
 537                              StopLn              -> True
 538                              Mangle | keep_raw_s -> True
 539                              As     | keep_s     -> True
 540                              HCc    | keep_hc    -> True
 541                              _other              -> False
 542
 543                 suffix = myPhaseInputExt next_phase
 544
 545                 -- persistent object files get put in odir
 546                 persistent_fn
 547                    | StopLn <- next_phase = return odir_persistent
 548                    | otherwise            = return persistent
 549
 550                 persistent = basename <.> suffix
 551
 552                 odir_persistent
 553                    | Just loc <- maybe_location = ml_obj_file loc
 554                    | Just d <- odir = d </> persistent
 555                    | otherwise      = persistent
 556
 557
 558 -- -----------------------------------------------------------------------------
 559 -- Each phase in the pipeline returns the next phase to execute, and the
 560 -- name of the file in which the output was placed.
 561 --
 562 -- We must do things dynamically this way, because we often don't know
 563 -- what the rest of the phases will be until part-way through the
 564 -- compilation: for example, an {-# OPTIONS -fasm #-} at the beginning
 565 -- of a source file can change the latter stages of the pipeline from
 566 -- taking the via-C route to using the native code generator.
 567
 568 runPhase :: Phase       -- Do this phase first
 569          -> Phase       -- Stop just before this phase
 570          -> HscEnv
 571          -> String      -- basename of original input source
 572          -> String      -- its extension
 573          -> FilePath    -- name of file which contains the input to this phase.
 574          -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath)
 575                         -- how to calculate the output filename
 576          -> Maybe ModLocation           -- the ModLocation, if we have one
 577          -> IO (Phase,                  -- next phase
 578                 DynFlags,               -- new dynamic flags
 579                 Maybe ModLocation,      -- the ModLocation, if we have one
 580                 FilePath)               -- output filename
 581
 582         -- Invariant: the output filename always contains the output
 583         -- Interesting case: Hsc when there is no recompilation to do
 584         --                   Then the output filename is still a .o file
 585
 586 -------------------------------------------------------------------------------
 587 -- Unlit phase
 588
 589 runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 590   = do
 591        let dflags = hsc_dflags hsc_env
 592        output_fn <- get_output_fn dflags (Cpp sf) maybe_loc
 593
 594        let unlit_flags = getOpts dflags opt_L
 595            flags = map SysTools.Option unlit_flags ++
 596                    [ -- The -h option passes the file name for unlit to
 597                      -- put in a #line directive
 598                      SysTools.Option     "-h"
 599                      -- cpp interprets \b etc as escape sequences,
 600                      -- so we use / for filenames in pragmas
 601                    , SysTools.Option $ reslash Forwards $ normalise input_fn
 602                    , SysTools.FileOption "" input_fn
 603                    , SysTools.FileOption "" output_fn
 604                    ]
 605
 606        SysTools.runUnlit dflags flags
 607
 608        return (Cpp sf, dflags, maybe_loc, output_fn)
 609
 610 -------------------------------------------------------------------------------
 611 -- Cpp phase : (a) gets OPTIONS out of file
 612 --             (b) runs cpp if necessary
 613
 614 runPhase (Cpp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
 615   = do let dflags0 = hsc_dflags hsc_env
 616        src_opts <- getOptionsFromFile dflags0 input_fn
 617        (dflags, unhandled_flags, warns) <- parseDynamicFlags dflags0 (map unLoc src_opts)
 618        handleFlagWarnings dflags warns
 619        checkProcessArgsResult unhandled_flags (basename <.> suff)
 620
 621        if not (dopt Opt_Cpp dflags) then
 622            -- no need to preprocess CPP, just pass input file along
 623            -- to the next phase of the pipeline.
 624           return (HsPp sf, dflags, maybe_loc, input_fn)
 625         else do
 626             output_fn <- get_output_fn dflags (HsPp sf) maybe_loc
 627             doCpp dflags True{-raw-} False{-no CC opts-} input_fn output_fn
 628             return (HsPp sf, dflags, maybe_loc, output_fn)
 629
 630 -------------------------------------------------------------------------------
 631 -- HsPp phase
 632
 633 runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
 634   = do let dflags = hsc_dflags hsc_env
 635        if not (dopt Opt_Pp dflags) then
 636            -- no need to preprocess, just pass input file along
 637            -- to the next phase of the pipeline.
 638           return (Hsc sf, dflags, maybe_loc, input_fn)
 639         else do
 640             let hspp_opts = getOpts dflags opt_F
 641             let orig_fn = basename <.> suff
 642             output_fn <- get_output_fn dflags (Hsc sf) maybe_loc
 643             SysTools.runPp dflags
 644                            ( [ SysTools.Option     orig_fn
 645                              , SysTools.Option     input_fn
 646                              , SysTools.FileOption "" output_fn
 647                              ] ++
 648                              map SysTools.Option hspp_opts
 649                            )
 650             return (Hsc sf, dflags, maybe_loc, output_fn)
 651
 652 -----------------------------------------------------------------------------
 653 -- Hsc phase
 654
 655 -- Compilation of a single module, in "legacy" mode (_not_ under
 656 -- the direction of the compilation manager).
 657 runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _maybe_loc
 658  = do   -- normal Hsc mode, not mkdependHS
 659         let dflags0 = hsc_dflags hsc_env
 660
 661   -- we add the current directory (i.e. the directory in which
 662   -- the .hs files resides) to the include path, since this is
 663   -- what gcc does, and it's probably what you want.
 664         let current_dir = case takeDirectory basename of
 665                       "" -> "." -- XXX Hack
 666                       d -> d
 667
 668             paths = includePaths dflags0
 669             dflags = dflags0 { includePaths = current_dir : paths }
 670
 671   -- gather the imports and module name
 672         (hspp_buf,mod_name,imps,src_imps) <-
 673             case src_flavour of
 674                 ExtCoreFile -> do {  -- no explicit imports in ExtCore input.
 675                                   ; m <- getCoreModuleName input_fn
 676                                   ; return (Nothing, mkModuleName m, [], []) }
 677
 678                 _           -> do { buf <- hGetStringBuffer input_fn
 679                             ; (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
 680                             ; return (Just buf, mod_name, imps, src_imps) }
 681
 682   -- Build a ModLocation to pass to hscMain.
 683   -- The source filename is rather irrelevant by now, but it's used
 684   -- by hscMain for messages.  hscMain also needs
 685   -- the .hi and .o filenames, and this is as good a way
 686   -- as any to generate them, and better than most. (e.g. takes
 687   -- into accout the -osuf flags)
 688         location1 <- mkHomeModLocation2 dflags mod_name basename suff
 689
 690   -- Boot-ify it if necessary
 691         let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
 692                       | otherwise            = location1
 693
 694
 695   -- Take -ohi into account if present
 696   -- This can't be done in mkHomeModuleLocation because
 697   -- it only applies to the module being compiles
 698         let ohi = outputHi dflags
 699             location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
 700                       | otherwise      = location2
 701
 702   -- Take -o into account if present
 703   -- Very like -ohi, but we must *only* do this if we aren't linking
 704   -- (If we're linking then the -o applies to the linked thing, not to
 705   -- the object file for one module.)
 706   -- Note the nasty duplication with the same computation in compileFile above
 707         let expl_o_file = outputFile dflags
 708             location4 | Just ofile <- expl_o_file
 709                       , isNoLink (ghcLink dflags)
 710                       = location3 { ml_obj_file = ofile }
 711                       | otherwise = location3
 712
 713             o_file = ml_obj_file location4      -- The real object file
 714
 715
 716   -- Figure out if the source has changed, for recompilation avoidance.
 717   --
 718   -- Setting source_unchanged to True means that M.o seems
 719   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 720   -- changed (which the compiler itself figures out).
 721   -- Setting source_unchanged to False tells the compiler that M.o is out of
 722   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 723         src_timestamp <- getModificationTime (basename <.> suff)
 724
 725         let force_recomp = dopt Opt_ForceRecomp dflags
 726         source_unchanged <-
 727           if force_recomp || not (isStopLn stop)
 728                 -- Set source_unchanged to False unconditionally if
 729                 --      (a) recompilation checker is off, or
 730                 --      (b) we aren't going all the way to .o file (e.g. ghc -S)
 731              then return False
 732                 -- Otherwise look at file modification dates
 733              else do o_file_exists <- doesFileExist o_file
 734                      if not o_file_exists
 735                         then return False       -- Need to recompile
 736                         else do t2 <- getModificationTime o_file
 737                                 if t2 > src_timestamp
 738                                   then return True
 739                                   else return False
 740
 741   -- get the DynFlags
 742         let hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags)
 743         let next_phase = hscNextPhase dflags src_flavour hsc_lang
 744         output_fn  <- get_output_fn dflags next_phase (Just location4)
 745
 746         let dflags' = dflags { hscTarget = hsc_lang,
 747                                hscOutName = output_fn,
 748                                extCoreName = basename ++ ".hcr" }
 749
 750         let hsc_env' = hsc_env {hsc_dflags = dflags'}
 751
 752   -- Tell the finder cache about this module
 753         mod <- addHomeModuleToFinder hsc_env' mod_name location4
 754
 755   -- Make the ModSummary to hand to hscMain
 756         let
 757             mod_summary = ModSummary {  ms_mod       = mod,
 758                                         ms_hsc_src   = src_flavour,
 759                                         ms_hspp_file = input_fn,
 760                                         ms_hspp_opts = dflags,
 761                                         ms_hspp_buf  = hspp_buf,
 762                                         ms_location  = location4,
 763                                         ms_hs_date   = src_timestamp,
 764                                         ms_obj_date  = Nothing,
 765                                         ms_imps      = imps,
 766                                         ms_srcimps   = src_imps }
 767
 768   -- run the compiler!
 769         mbResult <- hscCompileOneShot hsc_env'
 770                           mod_summary source_unchanged
 771                           Nothing       -- No iface
 772                           Nothing       -- No "module i of n" progress info
 773
 774         case mbResult of
 775           Nothing -> throwDyn (PhaseFailed "hsc" (ExitFailure 1))
 776           Just HscNoRecomp
 777               -> do SysTools.touch dflags' "Touching object file" o_file
 778                     -- The .o file must have a later modification date
 779                     -- than the source file (else we wouldn't be in HscNoRecomp)
 780                     -- but we touch it anyway, to keep 'make' happy (we think).
 781                     return (StopLn, dflags', Just location4, o_file)
 782           Just (HscRecomp hasStub)
 783               -> do when hasStub $
 784                          do stub_o <- compileStub hsc_env' mod location4
 785                             consIORef v_Ld_inputs stub_o
 786                     -- In the case of hs-boot files, generate a dummy .o-boot
 787                     -- stamp file for the benefit of Make
 788                     when (isHsBoot src_flavour) $
 789                       SysTools.touch dflags' "Touching object file" o_file
 790                     return (next_phase, dflags', Just location4, output_fn)
 791
 792 -----------------------------------------------------------------------------
 793 -- Cmm phase
 794
 795 runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 796   = do
 797        let dflags = hsc_dflags hsc_env
 798        output_fn <- get_output_fn dflags Cmm maybe_loc
 799        doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn
 800        return (Cmm, dflags, maybe_loc, output_fn)
 801
 802 runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc
 803   = do
 804         let dflags = hsc_dflags hsc_env
 805         let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
 806         let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
 807         output_fn <- get_output_fn dflags next_phase maybe_loc
 808
 809         let dflags' = dflags { hscTarget = hsc_lang,
 810                                hscOutName = output_fn,
 811                                extCoreName = basename ++ ".hcr" }
 812         let hsc_env' = hsc_env {hsc_dflags = dflags'}
 813
 814         ok <- hscCmmFile hsc_env' input_fn
 815
 816         when (not ok) $ throwDyn (PhaseFailed "cmm" (ExitFailure 1))
 817
 818         return (next_phase, dflags, maybe_loc, output_fn)
 819
 820 -----------------------------------------------------------------------------
 821 -- Cc phase
 822
 823 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 824 -- way too many hacks, and I can't say I've ever used it anyway.
 825
 826 runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 827    | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc
 828    = do let dflags = hsc_dflags hsc_env
 829         let cc_opts = getOpts dflags opt_c
 830             hcc = cc_phase `eqPhase` HCc
 831
 832         let cmdline_include_paths = includePaths dflags
 833
 834         -- HC files have the dependent packages stamped into them
 835         pkgs <- if hcc then getHCFilePackages input_fn else return []
 836
 837         -- add package include paths even if we're just compiling .c
 838         -- files; this is the Value Add(TM) that using ghc instead of
 839         -- gcc gives you :)
 840         pkg_include_dirs <- getPackageIncludePath dflags pkgs
 841         let include_paths = foldr (\ x xs -> "-I" : x : xs) []
 842                               (cmdline_include_paths ++ pkg_include_dirs)
 843
 844         let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags
 845         gcc_extra_viac_flags <- getExtraViaCOpts dflags
 846         let pic_c_flags = picCCOpts dflags
 847
 848         let verb = getVerbFlag dflags
 849
 850         pkg_extra_cc_opts <- getPackageExtraCcOpts dflags pkgs
 851
 852 #ifdef darwin_TARGET_OS
 853         pkg_framework_paths <- getPackageFrameworkPath dflags pkgs
 854         let cmdline_framework_paths = frameworkPaths dflags
 855         let framework_paths = map ("-F"++)
 856                         (cmdline_framework_paths ++ pkg_framework_paths)
 857 #endif
 858
 859         let split_objs = dopt Opt_SplitObjs dflags
 860             split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 861                       | otherwise         = [ ]
 862
 863         let cc_opt | optLevel dflags >= 2 = "-O2"
 864                    | otherwise            = "-O"
 865
 866         -- Decide next phase
 867
 868         let mangle = dopt Opt_DoAsmMangling dflags
 869             next_phase
 870                 | hcc && mangle     = Mangle
 871                 | otherwise         = As
 872         output_fn <- get_output_fn dflags next_phase maybe_loc
 873
 874         let
 875           more_hcc_opts =
 876 #if i386_TARGET_ARCH
 877                 -- on x86 the floating point regs have greater precision
 878                 -- than a double, which leads to unpredictable results.
 879                 -- By default, we turn this off with -ffloat-store unless
 880                 -- the user specified -fexcess-precision.
 881                 (if dopt Opt_ExcessPrecision dflags
 882                         then []
 883                         else [ "-ffloat-store" ]) ++
 884 #endif
 885                 -- gcc's -fstrict-aliasing allows two accesses to memory
 886                 -- to be considered non-aliasing if they have different types.
 887                 -- This interacts badly with the C code we generate, which is
 888                 -- very weakly typed, being derived from C--.
 889                 ["-fno-strict-aliasing"]
 890
 891
 892
 893         SysTools.runCc dflags (
 894                 -- force the C compiler to interpret this file as C when
 895                 -- compiling .hc files, by adding the -x c option.
 896                 -- Also useful for plain .c files, just in case GHC saw a
 897                 -- -x c option.
 898                         [ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp
 899                                                 then SysTools.Option "c++" else SysTools.Option "c"] ++
 900                         [ SysTools.FileOption "" input_fn
 901                         , SysTools.Option "-o"
 902                         , SysTools.FileOption "" output_fn
 903                         ]
 904                        ++ map SysTools.Option (
 905                           md_c_flags
 906                        ++ pic_c_flags
 907 #ifdef sparc_TARGET_ARCH
 908         -- We only support SparcV9 and better because V8 lacks an atomic CAS
 909         -- instruction. Note that the user can still override this
 910         -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
 911         -- regardless of the ordering.
 912         --
 913         -- This is a temporary hack.
 914                        ++ ["-mcpu=v9"]
 915 #endif
 916                        ++ (if hcc && mangle
 917                              then md_regd_c_flags
 918                              else [])
 919                        ++ (if hcc
 920                              then if mangle
 921                                      then gcc_extra_viac_flags
 922                                      else filter (=="-fwrapv")
 923                                                 gcc_extra_viac_flags
 924                                 -- still want -fwrapv even for unreg'd
 925                              else [])
 926                        ++ (if hcc
 927                              then more_hcc_opts
 928                              else [])
 929                        ++ [ verb, "-S", "-Wimplicit", cc_opt ]
 930                        ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 931 #ifdef darwin_TARGET_OS
 932                        ++ framework_paths
 933 #endif
 934                        ++ cc_opts
 935                        ++ split_opt
 936                        ++ include_paths
 937                        ++ pkg_extra_cc_opts
 938                        ))
 939
 940         return (next_phase, dflags, maybe_loc, output_fn)
 941
 942         -- ToDo: postprocess the output from gcc
 943
 944 -----------------------------------------------------------------------------
 945 -- Mangle phase
 946
 947 runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 948    = do let dflags = hsc_dflags hsc_env
 949         let mangler_opts = getOpts dflags opt_m
 950
 951 #if i386_TARGET_ARCH
 952         machdep_opts <- return [ show (stolen_x86_regs dflags) ]
 953 #else
 954         machdep_opts <- return []
 955 #endif
 956
 957         let split = dopt Opt_SplitObjs dflags
 958             next_phase
 959                 | split = SplitMangle
 960                 | otherwise = As
 961         output_fn <- get_output_fn dflags next_phase maybe_loc
 962
 963         SysTools.runMangle dflags (map SysTools.Option mangler_opts
 964                           ++ [ SysTools.FileOption "" input_fn
 965                              , SysTools.FileOption "" output_fn
 966                              ]
 967                           ++ map SysTools.Option machdep_opts)
 968
 969         return (next_phase, dflags, maybe_loc, output_fn)
 970
 971 -----------------------------------------------------------------------------
 972 -- Splitting phase
 973
 974 runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc
 975   = do  -- tmp_pfx is the prefix used for the split .s files
 976         -- We also use it as the file to contain the no. of split .s files (sigh)
 977         let dflags = hsc_dflags hsc_env
 978         split_s_prefix <- SysTools.newTempName dflags "split"
 979         let n_files_fn = split_s_prefix
 980
 981         SysTools.runSplit dflags
 982                           [ SysTools.FileOption "" input_fn
 983                           , SysTools.FileOption "" split_s_prefix
 984                           , SysTools.FileOption "" n_files_fn
 985                           ]
 986
 987         -- Save the number of split files for future references
 988         s <- readFile n_files_fn
 989         let n_files = read s :: Int
 990         writeIORef v_Split_info (split_s_prefix, n_files)
 991
 992         -- Remember to delete all these files
 993         addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s"
 994                         | n <- [1..n_files]]
 995
 996         return (SplitAs, dflags, maybe_loc, "**splitmangle**")
 997           -- we don't use the filename
 998
 999 -----------------------------------------------------------------------------
1000 -- As phase
1001
1002 runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
1003   = do  let dflags = hsc_dflags hsc_env
1004         let as_opts =  getOpts dflags opt_a
1005         let cmdline_include_paths = includePaths dflags
1006
1007         output_fn <- get_output_fn dflags StopLn maybe_loc
1008
1009         -- we create directories for the object file, because it
1010         -- might be a hierarchical module.
1011         createDirectoryHierarchy (takeDirectory output_fn)
1012
1013         SysTools.runAs dflags
1014                        (map SysTools.Option as_opts
1015                        ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
1016 #ifdef sparc_TARGET_ARCH
1017         -- We only support SparcV9 and better because V8 lacks an atomic CAS
1018         -- instruction so we have to make sure that the assembler accepts the
1019         -- instruction set. Note that the user can still override this
1020         -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1021         -- regardless of the ordering.
1022         --
1023         -- This is a temporary hack.
1024                        ++ [ SysTools.Option "-mcpu=v9" ]
1025 #endif
1026                        ++ [ SysTools.Option "-c"
1027                           , SysTools.FileOption "" input_fn
1028                           , SysTools.Option "-o"
1029                           , SysTools.FileOption "" output_fn
1030                           ])
1031
1032         return (StopLn, dflags, maybe_loc, output_fn)
1033
1034
1035 runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc
1036   = do
1037         let dflags = hsc_dflags hsc_env
1038         output_fn <- get_output_fn dflags StopLn maybe_loc
1039
1040         let base_o = dropExtension output_fn
1041             split_odir  = base_o ++ "_split"
1042             osuf = objectSuf dflags
1043
1044         createDirectoryHierarchy split_odir
1045
1046         -- remove M_split/ *.o, because we're going to archive M_split/ *.o
1047         -- later and we don't want to pick up any old objects.
1048         fs <- getDirectoryContents split_odir
1049         mapM_ removeFile $ map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
1050
1051         let as_opts = getOpts dflags opt_a
1052
1053         (split_s_prefix, n) <- readIORef v_Split_info
1054
1055         let split_s   n = split_s_prefix ++ "__" ++ show n <.> "s"
1056             split_obj n = split_odir </>
1057                           takeFileName base_o ++ "__" ++ show n <.> osuf
1058
1059         let assemble_file n
1060               = SysTools.runAs dflags
1061                          (map SysTools.Option as_opts ++
1062                           [ SysTools.Option "-c"
1063                           , SysTools.Option "-o"
1064                           , SysTools.FileOption "" (split_obj n)
1065                           , SysTools.FileOption "" (split_s n)
1066                           ])
1067
1068         mapM_ assemble_file [1..n]
1069
1070         -- and join the split objects into a single object file:
1071         let ld_r args = SysTools.runLink dflags ([
1072                             SysTools.Option "-nostdlib",
1073                             SysTools.Option "-nodefaultlibs",
1074                             SysTools.Option "-Wl,-r",
1075                             SysTools.Option ld_x_flag,
1076                             SysTools.Option "-o",
1077                             SysTools.FileOption "" output_fn ] ++ args)
1078             ld_x_flag | null cLD_X = ""
1079                       | otherwise  = "-Wl,-x"
1080
1081         if cLdIsGNULd == "YES"
1082             then do
1083                   let script = split_odir </> "ld.script"
1084                   writeFile script $
1085                       "INPUT(" ++ unwords (map split_obj [1..n]) ++ ")"
1086                   ld_r [SysTools.FileOption "" script]
1087             else do
1088                   ld_r (map (SysTools.FileOption "" . split_obj) [1..n])
1089
1090         return (StopLn, dflags, maybe_loc, output_fn)
1091
1092 -- warning suppression
1093 runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc =
1094    panic ("runPhase: don't know how to run phase " ++ show other)
1095 -----------------------------------------------------------------------------
1096 -- MoveBinary sort-of-phase
1097 -- After having produced a binary, move it somewhere else and generate a
1098 -- wrapper script calling the binary. Currently, we need this only in
1099 -- a parallel way (i.e. in GUM), because PVM expects the binary in a
1100 -- central directory.
1101 -- This is called from linkBinary below, after linking. I haven't made it
1102 -- a separate phase to minimise interfering with other modules, and
1103 -- we don't need the generality of a phase (MoveBinary is always
1104 -- done after linking and makes only sense in a parallel setup)   -- HWL
1105
1106 runPhase_MoveBinary :: DynFlags -> FilePath -> [PackageId] -> IO Bool
1107 runPhase_MoveBinary dflags input_fn dep_packages
1108     | WayPar `elem` (wayNames dflags) && not opt_Static =
1109         panic ("Don't know how to combine PVM wrapper and dynamic wrapper")
1110     | WayPar `elem` (wayNames dflags) = do
1111         let sysMan = pgm_sysman dflags
1112         pvm_root <- getEnv "PVM_ROOT"
1113         pvm_arch <- getEnv "PVM_ARCH"
1114         let
1115            pvm_executable_base = "=" ++ input_fn
1116            pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
1117         -- nuke old binary; maybe use configur'ed names for cp and rm?
1118         Panic.try (removeFile pvm_executable)
1119         -- move the newly created binary into PVM land
1120         copy dflags "copying PVM executable" input_fn pvm_executable
1121         -- generate a wrapper script for running a parallel prg under PVM
1122         writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
1123         return True
1124     | not opt_Static =
1125         case (dynLibLoader dflags) of
1126           Wrapped wrapmode ->
1127               do
1128                 let (o_base, o_ext) = splitExtension input_fn
1129                 let wrapped_executable | o_ext == "exe" = (o_base ++ "_real") <.> o_ext
1130                                        | otherwise = input_fn ++ "_real"
1131                 behaviour <- wrapper_behaviour dflags wrapmode dep_packages
1132
1133                 -- THINKME isn't this possible to do a bit nicer?
1134                 let behaviour' = concatMap (\x -> if x=='\\' then "\\\\" else [x]) behaviour
1135                 renameFile input_fn wrapped_executable
1136                 let rtsDetails = (getPackageDetails (pkgState dflags) rtsPackageId);
1137                 SysTools.runCc dflags
1138                   ([ SysTools.FileOption "" ((head (libraryDirs rtsDetails)) ++ "/dyn-wrapper.c")
1139                    , SysTools.Option ("-DBEHAVIOUR=\"" ++ behaviour' ++ "\"")
1140                    , SysTools.Option "-o"
1141                    , SysTools.FileOption "" input_fn
1142                    ] ++ map (SysTools.FileOption "-I") (includeDirs rtsDetails))
1143                 return True
1144           _ -> return True
1145     | otherwise = return True
1146
1147 wrapper_behaviour :: DynFlags -> Maybe [Char] -> [PackageId] -> IO [Char]
1148 wrapper_behaviour dflags mode dep_packages =
1149     let seperateBySemiColon strs = tail $ concatMap (';':) strs
1150     in case mode of
1151       Nothing -> do
1152                 pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1153                 return ('H' : (seperateBySemiColon pkg_lib_paths))
1154       Just s -> do
1155         allpkg <- getPreloadPackagesAnd dflags dep_packages
1156         putStrLn (unwords (map (packageIdString . packageConfigId) allpkg))
1157         return $ 'F':s ++ ';':(seperateBySemiColon (map (packageIdString . packageConfigId) allpkg))
1158
1159 -- generates a Perl skript starting a parallel prg under PVM
1160 mk_pvm_wrapper_script :: String -> String -> String -> String
1161 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
1162  [
1163   "eval 'exec perl -S $0 ${1+\"$@\"}'",
1164   "  if $running_under_some_shell;",
1165   "# =!=!=!=!=!=!=!=!=!=!=!",
1166   "# This script is automatically generated: DO NOT EDIT!!!",
1167   "# Generated by Glasgow Haskell Compiler",
1168   "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
1169   "#",
1170   "$pvm_executable      = '" ++ pvm_executable ++ "';",
1171   "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
1172   "$SysMan = '" ++ sysMan ++ "';",
1173   "",
1174   {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
1175   "# first, some magical shortcuts to run "commands" on the binary",
1176   "# (which is hidden)",
1177   "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
1178   "    local($cmd) = $1;",
1179   "    system("$cmd $pvm_executable");",
1180   "    exit(0); # all done",
1181   "}", -}
1182   "",
1183   "# Now, run the real binary; process the args first",
1184   "$ENV{'PE'} = $pvm_executable_base;", --  ++ pvm_executable_base,
1185   "$debug = '';",
1186   "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
1187   "@nonPVM_args = ();",
1188   "$in_RTS_args = 0;",
1189   "",
1190   "args: while ($a = shift(@ARGV)) {",
1191   "    if ( $a eq '+RTS' ) {",
1192   "        $in_RTS_args = 1;",
1193   "    } elsif ( $a eq '-RTS' ) {",
1194   "        $in_RTS_args = 0;",
1195   "    }",
1196   "    if ( $a eq '-d' && $in_RTS_args ) {",
1197   "        $debug = '-';",
1198   "    } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
1199   "        $nprocessors = $1;",
1200   "    } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
1201   "        $nprocessors = $1;",
1202   "    } else {",
1203   "        push(@nonPVM_args, $a);",
1204   "    }",
1205   "}",
1206   "",
1207   "local($return_val) = 0;",
1208   "# Start the parallel execution by calling SysMan",
1209   "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
1210   "$return_val = $?;",
1211   "# ToDo: fix race condition moving files and flushing them!!",
1212   "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
1213   "exit($return_val);"
1214  ]
1215
1216 -----------------------------------------------------------------------------
1217 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
1218
1219 getHCFilePackages :: FilePath -> IO [PackageId]
1220 getHCFilePackages filename =
1221   Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
1222     l <- hGetLine h
1223     case l of
1224       '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
1225           return (map stringToPackageId (words rest))
1226       _other ->
1227           return []
1228
1229 -----------------------------------------------------------------------------
1230 -- Static linking, of .o files
1231
1232 -- The list of packages passed to link is the list of packages on
1233 -- which this program depends, as discovered by the compilation
1234 -- manager.  It is combined with the list of packages that the user
1235 -- specifies on the command line with -package flags.
1236 --
1237 -- In one-shot linking mode, we can't discover the package
1238 -- dependencies (because we haven't actually done any compilation or
1239 -- read any interface files), so the user must explicitly specify all
1240 -- the packages.
1241
1242 linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO ()
1243 linkBinary dflags o_files dep_packages = do
1244     let verb = getVerbFlag dflags
1245         output_fn = exeFileName dflags
1246
1247     -- get the full list of packages to link with, by combining the
1248     -- explicit packages with the auto packages and all of their
1249     -- dependencies, and eliminating duplicates.
1250
1251     pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1252     let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths)
1253 #ifdef linux_TARGET_OS
1254         get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1255                                 | otherwise = ["-L" ++ l]
1256 #else
1257         get_pkg_lib_path_opts l = ["-L" ++ l]
1258 #endif
1259
1260     let lib_paths = libraryPaths dflags
1261     let lib_path_opts = map ("-L"++) lib_paths
1262
1263     pkg_link_opts <- getPackageLinkOpts dflags dep_packages
1264
1265 #ifdef darwin_TARGET_OS
1266     pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
1267     let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths
1268
1269     let framework_paths = frameworkPaths dflags
1270         framework_path_opts = map ("-F"++) framework_paths
1271
1272     pkg_frameworks <- getPackageFrameworks dflags dep_packages
1273     let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1274
1275     let frameworks = cmdlineFrameworks dflags
1276         framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ]
1277          -- reverse because they're added in reverse order from the cmd line
1278 #endif
1279 #ifdef mingw32_TARGET_OS
1280     let dynMain = if not opt_Static then
1281                       (head (libraryDirs (getPackageDetails (pkgState dflags) rtsPackageId))) ++ "/Main.dyn_o"
1282                   else
1283                       ""
1284 #endif
1285         -- probably _stub.o files
1286     extra_ld_inputs <- readIORef v_Ld_inputs
1287
1288         -- opts from -optl-<blah> (including -l<blah> options)
1289     let extra_ld_opts = getOpts dflags opt_l
1290
1291     let ways = wayNames dflags
1292
1293     -- Here are some libs that need to be linked at the *end* of
1294     -- the command line, because they contain symbols that are referred to
1295     -- by the RTS.  We can't therefore use the ordinary way opts for these.
1296     let
1297         debug_opts | WayDebug `elem` ways = [
1298 #if defined(HAVE_LIBBFD)
1299                         "-lbfd", "-liberty"
1300 #endif
1301                          ]
1302                    | otherwise            = []
1303
1304     let
1305         thread_opts | WayThreaded `elem` ways = [
1306 #if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS)
1307                         "-lpthread"
1308 #endif
1309 #if defined(osf3_TARGET_OS)
1310                         , "-lexc"
1311 #endif
1312                         ]
1313                     | otherwise               = []
1314
1315     rc_objs <- maybeCreateManifest dflags output_fn
1316
1317     let (md_c_flags, _) = machdepCCOpts dflags
1318     SysTools.runLink dflags (
1319                        [ SysTools.Option verb
1320                        , SysTools.Option "-o"
1321                        , SysTools.FileOption "" output_fn
1322                        ]
1323                       ++ map SysTools.Option (
1324                          md_c_flags
1325                       ++ o_files
1326 #ifdef mingw32_TARGET_OS
1327                       ++ [dynMain]
1328 #endif
1329                       ++ extra_ld_inputs
1330                       ++ lib_path_opts
1331                       ++ extra_ld_opts
1332                       ++ rc_objs
1333 #ifdef darwin_TARGET_OS
1334                       ++ framework_path_opts
1335                       ++ framework_opts
1336 #endif
1337                       ++ pkg_lib_path_opts
1338                       ++ pkg_link_opts
1339 #ifdef darwin_TARGET_OS
1340                       ++ pkg_framework_path_opts
1341                       ++ pkg_framework_opts
1342 #endif
1343                       ++ debug_opts
1344                       ++ thread_opts
1345                     ))
1346
1347     -- parallel only: move binary to another dir -- HWL
1348     success <- runPhase_MoveBinary dflags output_fn dep_packages
1349     if success then return ()
1350                else throwDyn (InstallationError ("cannot move binary"))
1351
1352
1353 exeFileName :: DynFlags -> FilePath
1354 exeFileName dflags
1355   | Just s <- outputFile dflags =
1356 #if defined(mingw32_HOST_OS)
1357       if null (takeExtension s)
1358         then s <.> "exe"
1359         else s
1360 #else
1361       s
1362 #endif
1363   | otherwise =
1364 #if defined(mingw32_HOST_OS)
1365         "main.exe"
1366 #else
1367         "a.out"
1368 #endif
1369
1370 maybeCreateManifest
1371    :: DynFlags
1372    -> FilePath                          -- filename of executable
1373    -> IO [FilePath]                     -- extra objects to embed, maybe
1374 #ifndef mingw32_TARGET_OS
1375 maybeCreateManifest _ _ = do
1376   return []
1377 #else
1378 maybeCreateManifest dflags exe_filename = do
1379   if not (dopt Opt_GenManifest dflags) then return [] else do
1380
1381   let manifest_filename = exe_filename <.> "manifest"
1382
1383   writeFile manifest_filename $
1384       "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
1385       "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
1386       "  <assemblyIdentity version=\"1.0.0.0\"\n"++
1387       "     processorArchitecture=\"X86\"\n"++
1388       "     name=\"" ++ dropExtension exe_filename ++ "\"\n"++
1389       "     type=\"win32\"/>\n\n"++
1390       "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
1391       "    <security>\n"++
1392       "      <requestedPrivileges>\n"++
1393       "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
1394       "        </requestedPrivileges>\n"++
1395       "       </security>\n"++
1396       "  </trustInfo>\n"++
1397       "</assembly>\n"
1398
1399   -- Windows will find the manifest file if it is named foo.exe.manifest.
1400   -- However, for extra robustness, and so that we can move the binary around,
1401   -- we can embed the manifest in the binary itself using windres:
1402   if not (dopt Opt_EmbedManifest dflags) then return [] else do
1403
1404   rc_filename <- newTempName dflags "rc"
1405   rc_obj_filename <- newTempName dflags (objectSuf dflags)
1406
1407   writeFile rc_filename $
1408       "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
1409         -- magic numbers :-)
1410         -- show is a bit hackish above, but we need to escape the
1411         -- backslashes in the path.
1412
1413   let wr_opts = getOpts dflags opt_windres
1414   runWindres dflags $ map SysTools.Option $
1415         ["--input="++rc_filename,
1416          "--output="++rc_obj_filename,
1417          "--output-format=coff"]
1418         ++ wr_opts
1419         -- no FileOptions here: windres doesn't like seeing
1420         -- backslashes, apparently
1421
1422   return [rc_obj_filename]
1423 #endif
1424
1425
1426 linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
1427 linkDynLib dflags o_files dep_packages = do
1428     let verb = getVerbFlag dflags
1429     let o_file = outputFile dflags
1430
1431     pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1432     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1433
1434     let lib_paths = libraryPaths dflags
1435     let lib_path_opts = map ("-L"++) lib_paths
1436
1437     pkg_link_opts <- getPackageLinkOpts dflags dep_packages
1438
1439         -- probably _stub.o files
1440     extra_ld_inputs <- readIORef v_Ld_inputs
1441
1442     let (md_c_flags, _) = machdepCCOpts dflags
1443     let extra_ld_opts = getOpts dflags opt_l
1444 #if defined(mingw32_HOST_OS)
1445     -----------------------------------------------------------------------------
1446     -- Making a DLL
1447     -----------------------------------------------------------------------------
1448     let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
1449
1450     SysTools.runLink dflags
1451          ([ SysTools.Option verb
1452           , SysTools.Option "-o"
1453           , SysTools.FileOption "" output_fn
1454           , SysTools.Option "-shared"
1455           , SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
1456           ]
1457          ++ map (SysTools.FileOption "") o_files
1458          ++ map SysTools.Option (
1459             md_c_flags
1460          ++ extra_ld_inputs
1461          ++ lib_path_opts
1462          ++ extra_ld_opts
1463          ++ pkg_lib_path_opts
1464          ++ pkg_link_opts
1465         ))
1466 #elif defined(darwin_TARGET_OS)
1467     -----------------------------------------------------------------------------
1468     -- Making a darwin dylib
1469     -----------------------------------------------------------------------------
1470     -- About the options used for Darwin:
1471     -- -dynamiclib
1472     --   Apple's way of saying -shared
1473     -- -undefined dynamic_lookup:
1474     --   Without these options, we'd have to specify the correct dependencies
1475     --   for each of the dylibs. Note that we could (and should) do without this
1476     --   for all libraries except the RTS; all we need to do is to pass the
1477     --   correct HSfoo_dyn.dylib files to the link command.
1478     --   This feature requires Mac OS X 10.3 or later; there is a similar feature,
1479     --   -flat_namespace -undefined suppress, which works on earlier versions,
1480     --   but it has other disadvantages.
1481     -- -single_module
1482     --   Build the dynamic library as a single "module", i.e. no dynamic binding
1483     --   nonsense when referring to symbols from within the library. The NCG
1484     --   assumes that this option is specified (on i386, at least).
1485     -- -Wl,-macosx_version_min -Wl,10.3
1486     --   Tell the linker its safe to assume that the library will run on 10.3 or
1487     --   later, so that it will not complain about the use of the option
1488     --   -undefined dynamic_lookup above.
1489     -- -install_name
1490     --   Causes the dynamic linker to ignore the DYLD_LIBRARY_PATH when loading
1491     --   this lib and instead look for it at its absolute path.
1492     --   When installing the .dylibs (see target.mk), we'll change that path to
1493     --   point to the place they are installed. Therefore, we won't have to set
1494     --   up DYLD_LIBRARY_PATH specifically for ghc.
1495     -----------------------------------------------------------------------------
1496
1497     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1498
1499     pwd <- getCurrentDirectory
1500     SysTools.runLink dflags
1501          ([ SysTools.Option verb
1502           , SysTools.Option "-dynamiclib"
1503           , SysTools.Option "-o"
1504           , SysTools.FileOption "" output_fn
1505           ]
1506          ++ map SysTools.Option (
1507             md_c_flags
1508          ++ o_files
1509          ++ [ "-undefined", "dynamic_lookup", "-single_module", "-Wl,-macosx_version_min","-Wl,10.3", "-install_name " ++ (pwd </> output_fn) ]
1510          ++ extra_ld_inputs
1511          ++ lib_path_opts
1512          ++ extra_ld_opts
1513          ++ pkg_lib_path_opts
1514          ++ pkg_link_opts
1515         ))
1516 #else
1517     -----------------------------------------------------------------------------
1518     -- Making a DSO
1519     -----------------------------------------------------------------------------
1520
1521     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1522
1523     SysTools.runLink dflags
1524          ([ SysTools.Option verb
1525           , SysTools.Option "-o"
1526           , SysTools.FileOption "" output_fn
1527           ]
1528          ++ map SysTools.Option (
1529             md_c_flags
1530          ++ o_files
1531          ++ [ "-shared", "-Wl,-Bsymbolic" ] -- we need symbolic linking to resolve non-PIC intra-package-relocations
1532          ++ extra_ld_inputs
1533          ++ lib_path_opts
1534          ++ extra_ld_opts
1535          ++ pkg_lib_path_opts
1536          ++ pkg_link_opts
1537         ))
1538 #endif
1539 -- -----------------------------------------------------------------------------
1540 -- Running CPP
1541
1542 doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO ()
1543 doCpp dflags raw include_cc_opts input_fn output_fn = do
1544     let hscpp_opts = getOpts dflags opt_P
1545     let cmdline_include_paths = includePaths dflags
1546
1547     pkg_include_dirs <- getPackageIncludePath dflags []
1548     let include_paths = foldr (\ x xs -> "-I" : x : xs) []
1549                           (cmdline_include_paths ++ pkg_include_dirs)
1550
1551     let verb = getVerbFlag dflags
1552
1553     let cc_opts
1554           | not include_cc_opts = []
1555           | otherwise           = (optc ++ md_c_flags)
1556                 where
1557                       optc = getOpts dflags opt_c
1558                       (md_c_flags, _) = machdepCCOpts dflags
1559
1560     let cpp_prog args | raw       = SysTools.runCpp dflags args
1561                       | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
1562
1563     let target_defs =
1564           [ "-D" ++ HOST_OS     ++ "_BUILD_OS=1",
1565             "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH=1",
1566             "-D" ++ TARGET_OS   ++ "_HOST_OS=1",
1567             "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ]
1568         -- remember, in code we *compile*, the HOST is the same our TARGET,
1569         -- and BUILD is the same as our HOST.
1570
1571     cpp_prog       ([SysTools.Option verb]
1572                     ++ map SysTools.Option include_paths
1573                     ++ map SysTools.Option hsSourceCppOpts
1574                     ++ map SysTools.Option hscpp_opts
1575                     ++ map SysTools.Option cc_opts
1576                     ++ map SysTools.Option target_defs
1577                     ++ [ SysTools.Option     "-x"
1578                        , SysTools.Option     "c"
1579                        , SysTools.Option     input_fn
1580         -- We hackily use Option instead of FileOption here, so that the file
1581         -- name is not back-slashed on Windows.  cpp is capable of
1582         -- dealing with / in filenames, so it works fine.  Furthermore
1583         -- if we put in backslashes, cpp outputs #line directives
1584         -- with *double* backslashes.   And that in turn means that
1585         -- our error messages get double backslashes in them.
1586         -- In due course we should arrange that the lexer deals
1587         -- with these \\ escapes properly.
1588                        , SysTools.Option     "-o"
1589                        , SysTools.FileOption "" output_fn
1590                        ])
1591
1592 cHaskell1Version :: String
1593 cHaskell1Version = "5" -- i.e., Haskell 98
1594
1595 hsSourceCppOpts :: [String]
1596 -- Default CPP defines in Haskell source
1597 hsSourceCppOpts =
1598         [ "-D__HASKELL1__="++cHaskell1Version
1599         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
1600         , "-D__HASKELL98__"
1601         , "-D__CONCURRENT_HASKELL__"
1602         ]
1603
1604
1605 -- -----------------------------------------------------------------------------
1606 -- Misc.
1607
1608 hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase
1609 hscNextPhase _ HsBootFile _        =  StopLn
1610 hscNextPhase dflags _ hsc_lang =
1611   case hsc_lang of
1612         HscC -> HCc
1613         HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle
1614                | otherwise -> As
1615         HscNothing     -> StopLn
1616         HscInterpreted -> StopLn
1617         _other         -> StopLn
1618
1619
1620 hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget
1621 hscMaybeAdjustTarget dflags stop _ current_hsc_lang
1622   = hsc_lang
1623   where
1624         keep_hc = dopt Opt_KeepHcFiles dflags
1625         hsc_lang
1626                 -- don't change the lang if we're interpreting
1627                  | current_hsc_lang == HscInterpreted = current_hsc_lang
1628
1629                 -- force -fvia-C if we are being asked for a .hc file
1630                  | HCc <- stop = HscC
1631                  | keep_hc     = HscC
1632                 -- otherwise, stick to the plan
1633                  | otherwise = current_hsc_lang
1634
1635 GLOBAL_VAR(v_Split_info, ("",0), (String,Int))
1636         -- The split prefix and number of files