ghc/compiler/main/DriverPipeline.hs

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