ghc/compiler/main/DriverPipeline.hs

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