ghc/compiler/main/DriverPipeline.hs

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