ghc/compiler/main/DriverPipeline.hs

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