ghc/compiler/main/DriverPipeline.hs

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