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 input_fn
 617        (dflags,unhandled_flags) <- parseDynamicFlags dflags0 (map unLoc src_opts)
 618        checkProcessArgsResult unhandled_flags (basename <.> suff)
 619
 620        if not (dopt Opt_Cpp dflags) then
 621            -- no need to preprocess CPP, just pass input file along
 622            -- to the next phase of the pipeline.
 623           return (HsPp sf, dflags, maybe_loc, input_fn)
 624         else do
 625             output_fn <- get_output_fn dflags (HsPp sf) maybe_loc
 626             doCpp dflags True{-raw-} False{-no CC opts-} input_fn output_fn
 627             return (HsPp sf, dflags, maybe_loc, output_fn)
 628
 629 -------------------------------------------------------------------------------
 630 -- HsPp phase
 631
 632 runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
 633   = do let dflags = hsc_dflags hsc_env
 634        if not (dopt Opt_Pp dflags) then
 635            -- no need to preprocess, just pass input file along
 636            -- to the next phase of the pipeline.
 637           return (Hsc sf, dflags, maybe_loc, input_fn)
 638         else do
 639             let hspp_opts = getOpts dflags opt_F
 640             let orig_fn = basename <.> suff
 641             output_fn <- get_output_fn dflags (Hsc sf) maybe_loc
 642             SysTools.runPp dflags
 643                            ( [ SysTools.Option     orig_fn
 644                              , SysTools.Option     input_fn
 645                              , SysTools.FileOption "" output_fn
 646                              ] ++
 647                              map SysTools.Option hspp_opts
 648                            )
 649             return (Hsc sf, dflags, maybe_loc, output_fn)
 650
 651 -----------------------------------------------------------------------------
 652 -- Hsc phase
 653
 654 -- Compilation of a single module, in "legacy" mode (_not_ under
 655 -- the direction of the compilation manager).
 656 runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _maybe_loc
 657  = do   -- normal Hsc mode, not mkdependHS
 658         let dflags0 = hsc_dflags hsc_env
 659
 660   -- we add the current directory (i.e. the directory in which
 661   -- the .hs files resides) to the include path, since this is
 662   -- what gcc does, and it's probably what you want.
 663         let current_dir = case takeDirectory basename of
 664                       "" -> "." -- XXX Hack
 665                       d -> d
 666
 667             paths = includePaths dflags0
 668             dflags = dflags0 { includePaths = current_dir : paths }
 669
 670   -- gather the imports and module name
 671         (hspp_buf,mod_name,imps,src_imps) <-
 672             case src_flavour of
 673                 ExtCoreFile -> do {  -- no explicit imports in ExtCore input.
 674                                   ; m <- getCoreModuleName input_fn
 675                                   ; return (Nothing, mkModuleName m, [], []) }
 676
 677                 _           -> do { buf <- hGetStringBuffer input_fn
 678                             ; (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff)
 679                             ; return (Just buf, mod_name, imps, src_imps) }
 680
 681   -- Build a ModLocation to pass to hscMain.
 682   -- The source filename is rather irrelevant by now, but it's used
 683   -- by hscMain for messages.  hscMain also needs
 684   -- the .hi and .o filenames, and this is as good a way
 685   -- as any to generate them, and better than most. (e.g. takes
 686   -- into accout the -osuf flags)
 687         location1 <- mkHomeModLocation2 dflags mod_name basename suff
 688
 689   -- Boot-ify it if necessary
 690         let location2 | isHsBoot src_flavour = addBootSuffixLocn location1
 691                       | otherwise            = location1
 692
 693
 694   -- Take -ohi into account if present
 695   -- This can't be done in mkHomeModuleLocation because
 696   -- it only applies to the module being compiles
 697         let ohi = outputHi dflags
 698             location3 | Just fn <- ohi = location2{ ml_hi_file = fn }
 699                       | otherwise      = location2
 700
 701   -- Take -o into account if present
 702   -- Very like -ohi, but we must *only* do this if we aren't linking
 703   -- (If we're linking then the -o applies to the linked thing, not to
 704   -- the object file for one module.)
 705   -- Note the nasty duplication with the same computation in compileFile above
 706         let expl_o_file = outputFile dflags
 707             location4 | Just ofile <- expl_o_file
 708                       , isNoLink (ghcLink dflags)
 709                       = location3 { ml_obj_file = ofile }
 710                       | otherwise = location3
 711
 712             o_file = ml_obj_file location4      -- The real object file
 713
 714
 715   -- Figure out if the source has changed, for recompilation avoidance.
 716   --
 717   -- Setting source_unchanged to True means that M.o seems
 718   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 719   -- changed (which the compiler itself figures out).
 720   -- Setting source_unchanged to False tells the compiler that M.o is out of
 721   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 722         src_timestamp <- getModificationTime (basename <.> suff)
 723
 724         let force_recomp = dopt Opt_ForceRecomp dflags
 725         source_unchanged <-
 726           if force_recomp || not (isStopLn stop)
 727                 -- Set source_unchanged to False unconditionally if
 728                 --      (a) recompilation checker is off, or
 729                 --      (b) we aren't going all the way to .o file (e.g. ghc -S)
 730              then return False
 731                 -- Otherwise look at file modification dates
 732              else do o_file_exists <- doesFileExist o_file
 733                      if not o_file_exists
 734                         then return False       -- Need to recompile
 735                         else do t2 <- getModificationTime o_file
 736                                 if t2 > src_timestamp
 737                                   then return True
 738                                   else return False
 739
 740   -- get the DynFlags
 741         let hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags)
 742         let next_phase = hscNextPhase dflags src_flavour hsc_lang
 743         output_fn  <- get_output_fn dflags next_phase (Just location4)
 744
 745         let dflags' = dflags { hscTarget = hsc_lang,
 746                                hscOutName = output_fn,
 747                                extCoreName = basename ++ ".hcr" }
 748
 749         let hsc_env' = hsc_env {hsc_dflags = dflags'}
 750
 751   -- Tell the finder cache about this module
 752         mod <- addHomeModuleToFinder hsc_env' mod_name location4
 753
 754   -- Make the ModSummary to hand to hscMain
 755         let
 756             mod_summary = ModSummary {  ms_mod       = mod,
 757                                         ms_hsc_src   = src_flavour,
 758                                         ms_hspp_file = input_fn,
 759                                         ms_hspp_opts = dflags,
 760                                         ms_hspp_buf  = hspp_buf,
 761                                         ms_location  = location4,
 762                                         ms_hs_date   = src_timestamp,
 763                                         ms_obj_date  = Nothing,
 764                                         ms_imps      = imps,
 765                                         ms_srcimps   = src_imps }
 766
 767   -- run the compiler!
 768         mbResult <- hscCompileOneShot hsc_env'
 769                           mod_summary source_unchanged
 770                           Nothing       -- No iface
 771                           Nothing       -- No "module i of n" progress info
 772
 773         case mbResult of
 774           Nothing -> throwDyn (PhaseFailed "hsc" (ExitFailure 1))
 775           Just HscNoRecomp
 776               -> do SysTools.touch dflags' "Touching object file" o_file
 777                     -- The .o file must have a later modification date
 778                     -- than the source file (else we wouldn't be in HscNoRecomp)
 779                     -- but we touch it anyway, to keep 'make' happy (we think).
 780                     return (StopLn, dflags', Just location4, o_file)
 781           Just (HscRecomp hasStub)
 782               -> do when hasStub $
 783                          do stub_o <- compileStub hsc_env' mod location4
 784                             consIORef v_Ld_inputs stub_o
 785                     -- In the case of hs-boot files, generate a dummy .o-boot
 786                     -- stamp file for the benefit of Make
 787                     when (isHsBoot src_flavour) $
 788                       SysTools.touch dflags' "Touching object file" o_file
 789                     return (next_phase, dflags', Just location4, output_fn)
 790
 791 -----------------------------------------------------------------------------
 792 -- Cmm phase
 793
 794 runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 795   = do
 796        let dflags = hsc_dflags hsc_env
 797        output_fn <- get_output_fn dflags Cmm maybe_loc
 798        doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn
 799        return (Cmm, dflags, maybe_loc, output_fn)
 800
 801 runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc
 802   = do
 803         let dflags = hsc_dflags hsc_env
 804         let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags)
 805         let next_phase = hscNextPhase dflags HsSrcFile hsc_lang
 806         output_fn <- get_output_fn dflags next_phase maybe_loc
 807
 808         let dflags' = dflags { hscTarget = hsc_lang,
 809                                hscOutName = output_fn,
 810                                extCoreName = basename ++ ".hcr" }
 811         let hsc_env' = hsc_env {hsc_dflags = dflags'}
 812
 813         ok <- hscCmmFile hsc_env' input_fn
 814
 815         when (not ok) $ throwDyn (PhaseFailed "cmm" (ExitFailure 1))
 816
 817         return (next_phase, dflags, maybe_loc, output_fn)
 818
 819 -----------------------------------------------------------------------------
 820 -- Cc phase
 821
 822 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 823 -- way too many hacks, and I can't say I've ever used it anyway.
 824
 825 runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 826    | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc
 827    = do let dflags = hsc_dflags hsc_env
 828         let cc_opts = getOpts dflags opt_c
 829             hcc = cc_phase `eqPhase` HCc
 830
 831         let cmdline_include_paths = includePaths dflags
 832
 833         -- HC files have the dependent packages stamped into them
 834         pkgs <- if hcc then getHCFilePackages input_fn else return []
 835
 836         -- add package include paths even if we're just compiling .c
 837         -- files; this is the Value Add(TM) that using ghc instead of
 838         -- gcc gives you :)
 839         pkg_include_dirs <- getPackageIncludePath dflags pkgs
 840         let include_paths = foldr (\ x xs -> "-I" : x : xs) []
 841                               (cmdline_include_paths ++ pkg_include_dirs)
 842
 843         let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags
 844         gcc_extra_viac_flags <- getExtraViaCOpts dflags
 845         let pic_c_flags = picCCOpts dflags
 846
 847         let verb = getVerbFlag dflags
 848
 849         pkg_extra_cc_opts <- getPackageExtraCcOpts dflags pkgs
 850
 851 #ifdef darwin_TARGET_OS
 852         pkg_framework_paths <- getPackageFrameworkPath dflags pkgs
 853         let cmdline_framework_paths = frameworkPaths dflags
 854         let framework_paths = map ("-F"++)
 855                         (cmdline_framework_paths ++ pkg_framework_paths)
 856 #endif
 857
 858         let split_objs = dopt Opt_SplitObjs dflags
 859             split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ]
 860                       | otherwise         = [ ]
 861
 862         let cc_opt | optLevel dflags >= 2 = "-O2"
 863                    | otherwise            = "-O"
 864
 865         -- Decide next phase
 866
 867         let mangle = dopt Opt_DoAsmMangling dflags
 868             next_phase
 869                 | hcc && mangle     = Mangle
 870                 | otherwise         = As
 871         output_fn <- get_output_fn dflags next_phase maybe_loc
 872
 873         let
 874           more_hcc_opts =
 875 #if i386_TARGET_ARCH
 876                 -- on x86 the floating point regs have greater precision
 877                 -- than a double, which leads to unpredictable results.
 878                 -- By default, we turn this off with -ffloat-store unless
 879                 -- the user specified -fexcess-precision.
 880                 (if dopt Opt_ExcessPrecision dflags
 881                         then []
 882                         else [ "-ffloat-store" ]) ++
 883 #endif
 884                 -- gcc's -fstrict-aliasing allows two accesses to memory
 885                 -- to be considered non-aliasing if they have different types.
 886                 -- This interacts badly with the C code we generate, which is
 887                 -- very weakly typed, being derived from C--.
 888                 ["-fno-strict-aliasing"]
 889
 890
 891
 892         SysTools.runCc dflags (
 893                 -- force the C compiler to interpret this file as C when
 894                 -- compiling .hc files, by adding the -x c option.
 895                 -- Also useful for plain .c files, just in case GHC saw a
 896                 -- -x c option.
 897                         [ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp
 898                                                 then SysTools.Option "c++" else SysTools.Option "c"] ++
 899                         [ SysTools.FileOption "" input_fn
 900                         , SysTools.Option "-o"
 901                         , SysTools.FileOption "" output_fn
 902                         ]
 903                        ++ map SysTools.Option (
 904                           md_c_flags
 905                        ++ pic_c_flags
 906 #ifdef sparc_TARGET_ARCH
 907         -- We only support SparcV9 and better because V8 lacks an atomic CAS
 908         -- instruction. Note that the user can still override this
 909         -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag
 910         -- regardless of the ordering.
 911         --
 912         -- This is a temporary hack.
 913                        ++ ["-mcpu=v9"]
 914 #endif
 915                        ++ (if hcc && mangle
 916                              then md_regd_c_flags
 917                              else [])
 918                        ++ (if hcc
 919                              then if mangle
 920                                      then gcc_extra_viac_flags
 921                                      else filter (=="-fwrapv")
 922                                                 gcc_extra_viac_flags
 923                                 -- still want -fwrapv even for unreg'd
 924                              else [])
 925                        ++ (if hcc
 926                              then more_hcc_opts
 927                              else [])
 928                        ++ [ verb, "-S", "-Wimplicit", cc_opt ]
 929                        ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 930 #ifdef darwin_TARGET_OS
 931                        ++ framework_paths
 932 #endif
 933                        ++ cc_opts
 934                        ++ split_opt
 935                        ++ include_paths
 936                        ++ pkg_extra_cc_opts
 937                        ))
 938
 939         return (next_phase, dflags, maybe_loc, output_fn)
 940
 941         -- ToDo: postprocess the output from gcc
 942
 943 -----------------------------------------------------------------------------
 944 -- Mangle phase
 945
 946 runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 947    = do let dflags = hsc_dflags hsc_env
 948         let mangler_opts = getOpts dflags opt_m
 949
 950 #if i386_TARGET_ARCH
 951         machdep_opts <- return [ show (stolen_x86_regs dflags) ]
 952 #else
 953         machdep_opts <- return []
 954 #endif
 955
 956         let split = dopt Opt_SplitObjs dflags
 957             next_phase
 958                 | split = SplitMangle
 959                 | otherwise = As
 960         output_fn <- get_output_fn dflags next_phase maybe_loc
 961
 962         SysTools.runMangle dflags (map SysTools.Option mangler_opts
 963                           ++ [ SysTools.FileOption "" input_fn
 964                              , SysTools.FileOption "" output_fn
 965                              ]
 966                           ++ map SysTools.Option machdep_opts)
 967
 968         return (next_phase, dflags, maybe_loc, output_fn)
 969
 970 -----------------------------------------------------------------------------
 971 -- Splitting phase
 972
 973 runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc
 974   = do  -- tmp_pfx is the prefix used for the split .s files
 975         -- We also use it as the file to contain the no. of split .s files (sigh)
 976         let dflags = hsc_dflags hsc_env
 977         split_s_prefix <- SysTools.newTempName dflags "split"
 978         let n_files_fn = split_s_prefix
 979
 980         SysTools.runSplit dflags
 981                           [ SysTools.FileOption "" input_fn
 982                           , SysTools.FileOption "" split_s_prefix
 983                           , SysTools.FileOption "" n_files_fn
 984                           ]
 985
 986         -- Save the number of split files for future references
 987         s <- readFile n_files_fn
 988         let n_files = read s :: Int
 989         writeIORef v_Split_info (split_s_prefix, n_files)
 990
 991         -- Remember to delete all these files
 992         addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s"
 993                         | n <- [1..n_files]]
 994
 995         return (SplitAs, dflags, maybe_loc, "**splitmangle**")
 996           -- we don't use the filename
 997
 998 -----------------------------------------------------------------------------
 999 -- As phase
1000
1001 runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
1002   = do  let dflags = hsc_dflags hsc_env
1003         let as_opts =  getOpts dflags opt_a
1004         let cmdline_include_paths = includePaths dflags
1005
1006         output_fn <- get_output_fn dflags StopLn maybe_loc
1007
1008         -- we create directories for the object file, because it
1009         -- might be a hierarchical module.
1010         createDirectoryHierarchy (takeDirectory output_fn)
1011
1012         SysTools.runAs dflags
1013                        (map SysTools.Option as_opts
1014                        ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
1015 #ifdef sparc_TARGET_ARCH
1016         -- We only support SparcV9 and better because V8 lacks an atomic CAS
1017         -- instruction so we have to make sure that the assembler accepts the
1018         -- instruction set. Note that the user can still override this
1019         -- (e.g., -mcpu=ultrasparc). GCC picks the "best" -mcpu flag
1020         -- regardless of the ordering.
1021         --
1022         -- This is a temporary hack.
1023                        ++ [ SysTools.Option "-mcpu=v9" ]
1024 #endif
1025                        ++ [ SysTools.Option "-c"
1026                           , SysTools.FileOption "" input_fn
1027                           , SysTools.Option "-o"
1028                           , SysTools.FileOption "" output_fn
1029                           ])
1030
1031         return (StopLn, dflags, maybe_loc, output_fn)
1032
1033
1034 runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc
1035   = do
1036         let dflags = hsc_dflags hsc_env
1037         output_fn <- get_output_fn dflags StopLn maybe_loc
1038
1039         let base_o = dropExtension output_fn
1040             split_odir  = base_o ++ "_split"
1041             osuf = objectSuf dflags
1042
1043         createDirectoryHierarchy split_odir
1044
1045         -- remove M_split/ *.o, because we're going to archive M_split/ *.o
1046         -- later and we don't want to pick up any old objects.
1047         fs <- getDirectoryContents split_odir
1048         mapM_ removeFile $ map (split_odir </>) $ filter (osuf `isSuffixOf`) fs
1049
1050         let as_opts = getOpts dflags opt_a
1051
1052         (split_s_prefix, n) <- readIORef v_Split_info
1053
1054         let split_s   n = split_s_prefix ++ "__" ++ show n <.> "s"
1055             split_obj n = split_odir </>
1056                           takeFileName base_o ++ "__" ++ show n <.> osuf
1057
1058         let assemble_file n
1059               = SysTools.runAs dflags
1060                          (map SysTools.Option as_opts ++
1061                           [ SysTools.Option "-c"
1062                           , SysTools.Option "-o"
1063                           , SysTools.FileOption "" (split_obj n)
1064                           , SysTools.FileOption "" (split_s n)
1065                           ])
1066
1067         mapM_ assemble_file [1..n]
1068
1069         -- and join the split objects into a single object file:
1070         let ld_r args = SysTools.runLink dflags ([
1071                             SysTools.Option "-nostdlib",
1072                             SysTools.Option "-nodefaultlibs",
1073                             SysTools.Option "-Wl,-r",
1074                             SysTools.Option ld_x_flag,
1075                             SysTools.Option "-o",
1076                             SysTools.FileOption "" output_fn ] ++ args)
1077             ld_x_flag | null cLD_X = ""
1078                       | otherwise  = "-Wl,-x"
1079
1080         if cLdIsGNULd == "YES"
1081             then do
1082                   let script = split_odir </> "ld.script"
1083                   writeFile script $
1084                       "INPUT(" ++ unwords (map split_obj [1..n]) ++ ")"
1085                   ld_r [SysTools.FileOption "" script]
1086             else do
1087                   ld_r (map (SysTools.FileOption "" . split_obj) [1..n])
1088
1089         return (StopLn, dflags, maybe_loc, output_fn)
1090
1091 -- warning suppression
1092 runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc =
1093    panic ("runPhase: don't know how to run phase " ++ show other)
1094 -----------------------------------------------------------------------------
1095 -- MoveBinary sort-of-phase
1096 -- After having produced a binary, move it somewhere else and generate a
1097 -- wrapper script calling the binary. Currently, we need this only in
1098 -- a parallel way (i.e. in GUM), because PVM expects the binary in a
1099 -- central directory.
1100 -- This is called from linkBinary below, after linking. I haven't made it
1101 -- a separate phase to minimise interfering with other modules, and
1102 -- we don't need the generality of a phase (MoveBinary is always
1103 -- done after linking and makes only sense in a parallel setup)   -- HWL
1104
1105 runPhase_MoveBinary :: DynFlags -> FilePath -> [PackageId] -> IO Bool
1106 runPhase_MoveBinary dflags input_fn dep_packages
1107     | WayPar `elem` (wayNames dflags) && not opt_Static =
1108         panic ("Don't know how to combine PVM wrapper and dynamic wrapper")
1109     | WayPar `elem` (wayNames dflags) = do
1110         let sysMan = pgm_sysman dflags
1111         pvm_root <- getEnv "PVM_ROOT"
1112         pvm_arch <- getEnv "PVM_ARCH"
1113         let
1114            pvm_executable_base = "=" ++ input_fn
1115            pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
1116         -- nuke old binary; maybe use configur'ed names for cp and rm?
1117         Panic.try (removeFile pvm_executable)
1118         -- move the newly created binary into PVM land
1119         copy dflags "copying PVM executable" input_fn pvm_executable
1120         -- generate a wrapper script for running a parallel prg under PVM
1121         writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
1122         return True
1123     | not opt_Static =
1124         case (dynLibLoader dflags) of
1125           Wrapped wrapmode ->
1126               do
1127                 let (o_base, o_ext) = splitExtension input_fn
1128                 let wrapped_executable | o_ext == "exe" = (o_base ++ "_real") <.> o_ext
1129                                        | otherwise = input_fn ++ "_real"
1130                 behaviour <- wrapper_behaviour dflags wrapmode dep_packages
1131
1132                 -- THINKME isn't this possible to do a bit nicer?
1133                 let behaviour' = concatMap (\x -> if x=='\\' then "\\\\" else [x]) behaviour
1134                 renameFile input_fn wrapped_executable
1135                 let rtsDetails = (getPackageDetails (pkgState dflags) rtsPackageId);
1136                 SysTools.runCc dflags
1137                   ([ SysTools.FileOption "" ((head (libraryDirs rtsDetails)) ++ "/dyn-wrapper.c")
1138                    , SysTools.Option ("-DBEHAVIOUR=\"" ++ behaviour' ++ "\"")
1139                    , SysTools.Option "-o"
1140                    , SysTools.FileOption "" input_fn
1141                    ] ++ map (SysTools.FileOption "-I") (includeDirs rtsDetails))
1142                 return True
1143           _ -> return True
1144     | otherwise = return True
1145
1146 wrapper_behaviour :: DynFlags -> Maybe [Char] -> [PackageId] -> IO [Char]
1147 wrapper_behaviour dflags mode dep_packages =
1148     let seperateBySemiColon strs = tail $ concatMap (';':) strs
1149     in case mode of
1150       Nothing -> do
1151                 pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1152                 return ('H' : (seperateBySemiColon pkg_lib_paths))
1153       Just s -> do
1154         allpkg <- getPreloadPackagesAnd dflags dep_packages
1155         putStrLn (unwords (map (packageIdString . packageConfigId) allpkg))
1156         return $ 'F':s ++ ';':(seperateBySemiColon (map (packageIdString . packageConfigId) allpkg))
1157
1158 -- generates a Perl skript starting a parallel prg under PVM
1159 mk_pvm_wrapper_script :: String -> String -> String -> String
1160 mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
1161  [
1162   "eval 'exec perl -S $0 ${1+\"$@\"}'",
1163   "  if $running_under_some_shell;",
1164   "# =!=!=!=!=!=!=!=!=!=!=!",
1165   "# This script is automatically generated: DO NOT EDIT!!!",
1166   "# Generated by Glasgow Haskell Compiler",
1167   "# ngoqvam choHbogh vaj' vIHoHnISbej !!!!",
1168   "#",
1169   "$pvm_executable      = '" ++ pvm_executable ++ "';",
1170   "$pvm_executable_base = '" ++ pvm_executable_base ++ "';",
1171   "$SysMan = '" ++ sysMan ++ "';",
1172   "",
1173   {- ToDo: add the magical shortcuts again iff we actually use them -- HWL
1174   "# first, some magical shortcuts to run "commands" on the binary",
1175   "# (which is hidden)",
1176   "if ($#ARGV == 1 && $ARGV[0] eq '+RTS' && $ARGV[1] =~ /^--((size|file|strip|rm|nm).*)/ ) {",
1177   "    local($cmd) = $1;",
1178   "    system("$cmd $pvm_executable");",
1179   "    exit(0); # all done",
1180   "}", -}
1181   "",
1182   "# Now, run the real binary; process the args first",
1183   "$ENV{'PE'} = $pvm_executable_base;", --  ++ pvm_executable_base,
1184   "$debug = '';",
1185   "$nprocessors = 0; # the default: as many PEs as machines in PVM config",
1186   "@nonPVM_args = ();",
1187   "$in_RTS_args = 0;",
1188   "",
1189   "args: while ($a = shift(@ARGV)) {",
1190   "    if ( $a eq '+RTS' ) {",
1191   "        $in_RTS_args = 1;",
1192   "    } elsif ( $a eq '-RTS' ) {",
1193   "        $in_RTS_args = 0;",
1194   "    }",
1195   "    if ( $a eq '-d' && $in_RTS_args ) {",
1196   "        $debug = '-';",
1197   "    } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
1198   "        $nprocessors = $1;",
1199   "    } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
1200   "        $nprocessors = $1;",
1201   "    } else {",
1202   "        push(@nonPVM_args, $a);",
1203   "    }",
1204   "}",
1205   "",
1206   "local($return_val) = 0;",
1207   "# Start the parallel execution by calling SysMan",
1208   "system(\"$SysMan $debug $pvm_executable $nprocessors @nonPVM_args\");",
1209   "$return_val = $?;",
1210   "# ToDo: fix race condition moving files and flushing them!!",
1211   "system(\"cp $ENV{'HOME'}/$pvm_executable_base.???.gr .\") if -f \"$ENV{'HOME'}/$pvm_executable_base.002.gr\";",
1212   "exit($return_val);"
1213  ]
1214
1215 -----------------------------------------------------------------------------
1216 -- Complain about non-dynamic flags in OPTIONS pragmas
1217
1218 checkProcessArgsResult :: [String] -> FilePath -> IO ()
1219 checkProcessArgsResult flags filename
1220   = do when (notNull flags) (throwDyn (ProgramError (
1221           showSDoc (hang (text filename <> char ':')
1222                       4 (text "unknown flags in  {-# OPTIONS #-} pragma:" <+>
1223                           hsep (map text flags)))
1224         )))
1225
1226 -----------------------------------------------------------------------------
1227 -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file
1228
1229 getHCFilePackages :: FilePath -> IO [PackageId]
1230 getHCFilePackages filename =
1231   Exception.bracket (openFile filename ReadMode) hClose $ \h -> do
1232     l <- hGetLine h
1233     case l of
1234       '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest ->
1235           return (map stringToPackageId (words rest))
1236       _other ->
1237           return []
1238
1239 -----------------------------------------------------------------------------
1240 -- Static linking, of .o files
1241
1242 -- The list of packages passed to link is the list of packages on
1243 -- which this program depends, as discovered by the compilation
1244 -- manager.  It is combined with the list of packages that the user
1245 -- specifies on the command line with -package flags.
1246 --
1247 -- In one-shot linking mode, we can't discover the package
1248 -- dependencies (because we haven't actually done any compilation or
1249 -- read any interface files), so the user must explicitly specify all
1250 -- the packages.
1251
1252 linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO ()
1253 linkBinary dflags o_files dep_packages = do
1254     let verb = getVerbFlag dflags
1255         output_fn = exeFileName dflags
1256
1257     -- get the full list of packages to link with, by combining the
1258     -- explicit packages with the auto packages and all of their
1259     -- dependencies, and eliminating duplicates.
1260
1261     pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1262     let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths)
1263 #ifdef linux_TARGET_OS
1264         get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l]
1265                                 | otherwise = ["-L" ++ l]
1266 #else
1267         get_pkg_lib_path_opts l = ["-L" ++ l]
1268 #endif
1269
1270     let lib_paths = libraryPaths dflags
1271     let lib_path_opts = map ("-L"++) lib_paths
1272
1273     pkg_link_opts <- getPackageLinkOpts dflags dep_packages
1274
1275 #ifdef darwin_TARGET_OS
1276     pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages
1277     let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths
1278
1279     let framework_paths = frameworkPaths dflags
1280         framework_path_opts = map ("-F"++) framework_paths
1281
1282     pkg_frameworks <- getPackageFrameworks dflags dep_packages
1283     let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ]
1284
1285     let frameworks = cmdlineFrameworks dflags
1286         framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ]
1287          -- reverse because they're added in reverse order from the cmd line
1288 #endif
1289 #ifdef mingw32_TARGET_OS
1290     let dynMain = if not opt_Static then
1291                       (head (libraryDirs (getPackageDetails (pkgState dflags) rtsPackageId))) ++ "/Main.dyn_o"
1292                   else
1293                       ""
1294 #endif
1295         -- probably _stub.o files
1296     extra_ld_inputs <- readIORef v_Ld_inputs
1297
1298         -- opts from -optl-<blah> (including -l<blah> options)
1299     let extra_ld_opts = getOpts dflags opt_l
1300
1301     let ways = wayNames dflags
1302
1303     -- Here are some libs that need to be linked at the *end* of
1304     -- the command line, because they contain symbols that are referred to
1305     -- by the RTS.  We can't therefore use the ordinary way opts for these.
1306     let
1307         debug_opts | WayDebug `elem` ways = [
1308 #if defined(HAVE_LIBBFD)
1309                         "-lbfd", "-liberty"
1310 #endif
1311                          ]
1312                    | otherwise            = []
1313
1314     let
1315         thread_opts | WayThreaded `elem` ways = [
1316 #if !defined(mingw32_TARGET_OS) && !defined(freebsd_TARGET_OS)
1317                         "-lpthread"
1318 #endif
1319 #if defined(osf3_TARGET_OS)
1320                         , "-lexc"
1321 #endif
1322                         ]
1323                     | otherwise               = []
1324
1325     rc_objs <- maybeCreateManifest dflags output_fn
1326
1327     let (md_c_flags, _) = machdepCCOpts dflags
1328     SysTools.runLink dflags (
1329                        [ SysTools.Option verb
1330                        , SysTools.Option "-o"
1331                        , SysTools.FileOption "" output_fn
1332                        ]
1333                       ++ map SysTools.Option (
1334                          md_c_flags
1335                       ++ o_files
1336 #ifdef mingw32_TARGET_OS
1337                       ++ [dynMain]
1338 #endif
1339                       ++ extra_ld_inputs
1340                       ++ lib_path_opts
1341                       ++ extra_ld_opts
1342                       ++ rc_objs
1343 #ifdef darwin_TARGET_OS
1344                       ++ framework_path_opts
1345                       ++ framework_opts
1346 #endif
1347                       ++ pkg_lib_path_opts
1348                       ++ pkg_link_opts
1349 #ifdef darwin_TARGET_OS
1350                       ++ pkg_framework_path_opts
1351                       ++ pkg_framework_opts
1352 #endif
1353                       ++ debug_opts
1354                       ++ thread_opts
1355                     ))
1356
1357     -- parallel only: move binary to another dir -- HWL
1358     success <- runPhase_MoveBinary dflags output_fn dep_packages
1359     if success then return ()
1360                else throwDyn (InstallationError ("cannot move binary"))
1361
1362
1363 exeFileName :: DynFlags -> FilePath
1364 exeFileName dflags
1365   | Just s <- outputFile dflags =
1366 #if defined(mingw32_HOST_OS)
1367       if null (takeExtension s)
1368         then s <.> "exe"
1369         else s
1370 #else
1371       s
1372 #endif
1373   | otherwise =
1374 #if defined(mingw32_HOST_OS)
1375         "main.exe"
1376 #else
1377         "a.out"
1378 #endif
1379
1380 maybeCreateManifest
1381    :: DynFlags
1382    -> FilePath                          -- filename of executable
1383    -> IO [FilePath]                     -- extra objects to embed, maybe
1384 #ifndef mingw32_TARGET_OS
1385 maybeCreateManifest _ _ = do
1386   return []
1387 #else
1388 maybeCreateManifest dflags exe_filename = do
1389   if not (dopt Opt_GenManifest dflags) then return [] else do
1390
1391   let manifest_filename = exe_filename <.> "manifest"
1392
1393   writeFile manifest_filename $
1394       "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>\n"++
1395       "  <assembly xmlns=\"urn:schemas-microsoft-com:asm.v1\" manifestVersion=\"1.0\">\n"++
1396       "  <assemblyIdentity version=\"1.0.0.0\"\n"++
1397       "     processorArchitecture=\"X86\"\n"++
1398       "     name=\"" ++ dropExtension exe_filename ++ "\"\n"++
1399       "     type=\"win32\"/>\n\n"++
1400       "  <trustInfo xmlns=\"urn:schemas-microsoft-com:asm.v3\">\n"++
1401       "    <security>\n"++
1402       "      <requestedPrivileges>\n"++
1403       "        <requestedExecutionLevel level=\"asInvoker\" uiAccess=\"false\"/>\n"++
1404       "        </requestedPrivileges>\n"++
1405       "       </security>\n"++
1406       "  </trustInfo>\n"++
1407       "</assembly>\n"
1408
1409   -- Windows will find the manifest file if it is named foo.exe.manifest.
1410   -- However, for extra robustness, and so that we can move the binary around,
1411   -- we can embed the manifest in the binary itself using windres:
1412   if not (dopt Opt_EmbedManifest dflags) then return [] else do
1413
1414   rc_filename <- newTempName dflags "rc"
1415   rc_obj_filename <- newTempName dflags (objectSuf dflags)
1416
1417   writeFile rc_filename $
1418       "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n"
1419         -- magic numbers :-)
1420         -- show is a bit hackish above, but we need to escape the
1421         -- backslashes in the path.
1422
1423   let wr_opts = getOpts dflags opt_windres
1424   runWindres dflags $ map SysTools.Option $
1425         ["--input="++rc_filename,
1426          "--output="++rc_obj_filename,
1427          "--output-format=coff"]
1428         ++ wr_opts
1429         -- no FileOptions here: windres doesn't like seeing
1430         -- backslashes, apparently
1431
1432   return [rc_obj_filename]
1433 #endif
1434
1435
1436 linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO ()
1437 linkDynLib dflags o_files dep_packages = do
1438     let verb = getVerbFlag dflags
1439     let o_file = outputFile dflags
1440
1441     pkg_lib_paths <- getPackageLibraryPath dflags dep_packages
1442     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1443
1444     let lib_paths = libraryPaths dflags
1445     let lib_path_opts = map ("-L"++) lib_paths
1446
1447     pkg_link_opts <- getPackageLinkOpts dflags dep_packages
1448
1449         -- probably _stub.o files
1450     extra_ld_inputs <- readIORef v_Ld_inputs
1451
1452     let (md_c_flags, _) = machdepCCOpts dflags
1453     let extra_ld_opts = getOpts dflags opt_l
1454 #if defined(mingw32_HOST_OS)
1455     -----------------------------------------------------------------------------
1456     -- Making a DLL
1457     -----------------------------------------------------------------------------
1458     let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
1459
1460     SysTools.runLink dflags
1461          ([ SysTools.Option verb
1462           , SysTools.Option "-o"
1463           , SysTools.FileOption "" output_fn
1464           , SysTools.Option "-shared"
1465           , SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a")
1466           ]
1467          ++ map (SysTools.FileOption "") o_files
1468          ++ map SysTools.Option (
1469             md_c_flags
1470          ++ extra_ld_inputs
1471          ++ lib_path_opts
1472          ++ extra_ld_opts
1473          ++ pkg_lib_path_opts
1474          ++ pkg_link_opts
1475         ))
1476 #elif defined(darwin_TARGET_OS)
1477     -----------------------------------------------------------------------------
1478     -- Making a darwin dylib
1479     -----------------------------------------------------------------------------
1480     -- About the options used for Darwin:
1481     -- -dynamiclib
1482     --   Apple's way of saying -shared
1483     -- -undefined dynamic_lookup:
1484     --   Without these options, we'd have to specify the correct dependencies
1485     --   for each of the dylibs. Note that we could (and should) do without this
1486     --   for all libraries except the RTS; all we need to do is to pass the
1487     --   correct HSfoo_dyn.dylib files to the link command.
1488     --   This feature requires Mac OS X 10.3 or later; there is a similar feature,
1489     --   -flat_namespace -undefined suppress, which works on earlier versions,
1490     --   but it has other disadvantages.
1491     -- -single_module
1492     --   Build the dynamic library as a single "module", i.e. no dynamic binding
1493     --   nonsense when referring to symbols from within the library. The NCG
1494     --   assumes that this option is specified (on i386, at least).
1495     -- -Wl,-macosx_version_min -Wl,10.3
1496     --   Tell the linker its safe to assume that the library will run on 10.3 or
1497     --   later, so that it will not complain about the use of the option
1498     --   -undefined dynamic_lookup above.
1499     -- -install_name
1500     --   Causes the dynamic linker to ignore the DYLD_LIBRARY_PATH when loading
1501     --   this lib and instead look for it at its absolute path.
1502     --   When installing the .dylibs (see target.mk), we'll change that path to
1503     --   point to the place they are installed. Therefore, we won't have to set
1504     --   up DYLD_LIBRARY_PATH specifically for ghc.
1505     -----------------------------------------------------------------------------
1506
1507     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1508
1509     pwd <- getCurrentDirectory
1510     SysTools.runLink dflags
1511          ([ SysTools.Option verb
1512           , SysTools.Option "-dynamiclib"
1513           , SysTools.Option "-o"
1514           , SysTools.FileOption "" output_fn
1515           ]
1516          ++ map SysTools.Option (
1517             md_c_flags
1518          ++ o_files
1519          ++ [ "-undefined", "dynamic_lookup", "-single_module", "-Wl,-macosx_version_min","-Wl,10.3", "-install_name " ++ (pwd </> output_fn) ]
1520          ++ extra_ld_inputs
1521          ++ lib_path_opts
1522          ++ extra_ld_opts
1523          ++ pkg_lib_path_opts
1524          ++ pkg_link_opts
1525         ))
1526 #else
1527     -----------------------------------------------------------------------------
1528     -- Making a DSO
1529     -----------------------------------------------------------------------------
1530
1531     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1532
1533     SysTools.runLink dflags
1534          ([ SysTools.Option verb
1535           , SysTools.Option "-o"
1536           , SysTools.FileOption "" output_fn
1537           ]
1538          ++ map SysTools.Option (
1539             md_c_flags
1540          ++ o_files
1541          ++ [ "-shared", "-Wl,-Bsymbolic" ] -- we need symbolic linking to resolve non-PIC intra-package-relocations
1542          ++ extra_ld_inputs
1543          ++ lib_path_opts
1544          ++ extra_ld_opts
1545          ++ pkg_lib_path_opts
1546          ++ pkg_link_opts
1547         ))
1548 #endif
1549 -- -----------------------------------------------------------------------------
1550 -- Running CPP
1551
1552 doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO ()
1553 doCpp dflags raw include_cc_opts input_fn output_fn = do
1554     let hscpp_opts = getOpts dflags opt_P
1555     let cmdline_include_paths = includePaths dflags
1556
1557     pkg_include_dirs <- getPackageIncludePath dflags []
1558     let include_paths = foldr (\ x xs -> "-I" : x : xs) []
1559                           (cmdline_include_paths ++ pkg_include_dirs)
1560
1561     let verb = getVerbFlag dflags
1562
1563     let cc_opts
1564           | not include_cc_opts = []
1565           | otherwise           = (optc ++ md_c_flags)
1566                 where
1567                       optc = getOpts dflags opt_c
1568                       (md_c_flags, _) = machdepCCOpts dflags
1569
1570     let cpp_prog args | raw       = SysTools.runCpp dflags args
1571                       | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args)
1572
1573     let target_defs =
1574           [ "-D" ++ HOST_OS     ++ "_BUILD_OS=1",
1575             "-D" ++ HOST_ARCH   ++ "_BUILD_ARCH=1",
1576             "-D" ++ TARGET_OS   ++ "_HOST_OS=1",
1577             "-D" ++ TARGET_ARCH ++ "_HOST_ARCH=1" ]
1578         -- remember, in code we *compile*, the HOST is the same our TARGET,
1579         -- and BUILD is the same as our HOST.
1580
1581     cpp_prog       ([SysTools.Option verb]
1582                     ++ map SysTools.Option include_paths
1583                     ++ map SysTools.Option hsSourceCppOpts
1584                     ++ map SysTools.Option hscpp_opts
1585                     ++ map SysTools.Option cc_opts
1586                     ++ map SysTools.Option target_defs
1587                     ++ [ SysTools.Option     "-x"
1588                        , SysTools.Option     "c"
1589                        , SysTools.Option     input_fn
1590         -- We hackily use Option instead of FileOption here, so that the file
1591         -- name is not back-slashed on Windows.  cpp is capable of
1592         -- dealing with / in filenames, so it works fine.  Furthermore
1593         -- if we put in backslashes, cpp outputs #line directives
1594         -- with *double* backslashes.   And that in turn means that
1595         -- our error messages get double backslashes in them.
1596         -- In due course we should arrange that the lexer deals
1597         -- with these \\ escapes properly.
1598                        , SysTools.Option     "-o"
1599                        , SysTools.FileOption "" output_fn
1600                        ])
1601
1602 cHaskell1Version :: String
1603 cHaskell1Version = "5" -- i.e., Haskell 98
1604
1605 hsSourceCppOpts :: [String]
1606 -- Default CPP defines in Haskell source
1607 hsSourceCppOpts =
1608         [ "-D__HASKELL1__="++cHaskell1Version
1609         , "-D__GLASGOW_HASKELL__="++cProjectVersionInt
1610         , "-D__HASKELL98__"
1611         , "-D__CONCURRENT_HASKELL__"
1612         ]
1613
1614
1615 -- -----------------------------------------------------------------------------
1616 -- Misc.
1617
1618 hscNextPhase :: DynFlags -> HscSource -> HscTarget -> Phase
1619 hscNextPhase _ HsBootFile _        =  StopLn
1620 hscNextPhase dflags _ hsc_lang =
1621   case hsc_lang of
1622         HscC -> HCc
1623         HscAsm | dopt Opt_SplitObjs dflags -> SplitMangle
1624                | otherwise -> As
1625         HscNothing     -> StopLn
1626         HscInterpreted -> StopLn
1627         _other         -> StopLn
1628
1629
1630 hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget
1631 hscMaybeAdjustTarget dflags stop _ current_hsc_lang
1632   = hsc_lang
1633   where
1634         keep_hc = dopt Opt_KeepHcFiles dflags
1635         hsc_lang
1636                 -- don't change the lang if we're interpreting
1637                  | current_hsc_lang == HscInterpreted = current_hsc_lang
1638
1639                 -- force -fvia-C if we are being asked for a .hc file
1640                  | HCc <- stop = HscC
1641                  | keep_hc     = HscC
1642                 -- otherwise, stick to the plan
1643                  | otherwise = current_hsc_lang
1644
1645 GLOBAL_VAR(v_Split_info, ("",0), (String,Int))
1646         -- The split prefix and number of files