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