ghc/compiler/main/Main.hs

   1 {-# OPTIONS -W -fno-warn-incomplete-patterns #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: Main.hs,v 1.3 2000/10/11 14:08:52 simonmar Exp $
   4 --
   5 -- GHC Driver program
   6 --
   7 -- (c) Simon Marlow 2000
   8 --
   9 -----------------------------------------------------------------------------
  10
  11 -- with path so that ghc -M can find config.h
  12 #include "../includes/config.h"
  13
  14 module Main (main) where
  15
  16 #include "HsVersions.h"
  17
  18 import CmSummarise ( getImports )
  19 import CmStaticInfo ( Package(..) )
  20 import TmpFiles
  21 import Config
  22 import CmdLineOpts
  23 import Util ( global )
  24
  25 import RegexString
  26 import Concurrent
  27 #ifndef mingw32_TARGET_OS
  28 import Posix
  29 #endif
  30 import Directory
  31 import IOExts
  32 import Exception
  33 import Dynamic
  34
  35 import IO
  36 import Monad
  37 import List
  38 import System
  39 import Maybe
  40 import Char
  41
  42 -----------------------------------------------------------------------------
  43 -- Changes:
  44
  45 -- * -fglasgow-exts NO LONGER IMPLIES -package lang!!!  (-fglasgow-exts is a
  46 --   dynamic flag whereas -package is a static flag.)
  47
  48 -----------------------------------------------------------------------------
  49 -- ToDo:
  50
  51 -- certain options in OPTIONS pragmas are persistent through subsequent compilations.
  52 -- new mkdependHS doesn't support all the options that the old one did (-X et al.)
  53 -- time commands when run with -v
  54 -- split marker
  55 -- mkDLL
  56 -- java generation
  57 -- user ways
  58 -- Win32 support: proper signal handling
  59 -- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too
  60 -- reading the package configuration file is too slow
  61 -- -H, -K, -Rghc-timing
  62 -- hi-diffs
  63
  64 -----------------------------------------------------------------------------
  65 -- Differences vs. old driver:
  66
  67 -- No more "Enter your Haskell program, end with ^D (on a line of its own):"
  68 -- consistency checking removed (may do this properly later)
  69 -- removed -noC
  70 -- no hi diffs (could be added later)
  71 -- no -Ofile
  72
  73 -----------------------------------------------------------------------------
  74 -- Phases
  75
  76 {-
  77 Phase of the           | Suffix saying | Flag saying   | (suffix of)
  78 compilation system     | ``start here''| ``stop after''| output file
  79
  80 literate pre-processor | .lhs          | -             | -
  81 C pre-processor (opt.) | -             | -E            | -
  82 Haskell compiler       | .hs           | -C, -S        | .hc, .s
  83 C compiler (opt.)      | .hc or .c     | -S            | .s
  84 assembler              | .s  or .S     | -c            | .o
  85 linker                 | other         | -             | a.out
  86 -}
  87
  88 data Phase
  89         = MkDependHS    -- haskell dependency generation
  90         | Unlit
  91         | Cpp
  92         | Hsc
  93         | Cc
  94         | HCc           -- Haskellised C (as opposed to vanilla C) compilation
  95         | Mangle        -- assembly mangling, now done by a separate script.
  96         | SplitMangle   -- after mangler if splitting
  97         | SplitAs
  98         | As
  99         | Ln
 100   deriving (Eq)
 101
 102 -----------------------------------------------------------------------------
 103 -- Build the Hsc command line
 104
 105 build_hsc_opts :: IO [String]
 106 build_hsc_opts = do
 107   opt_C_ <- getOpts opt_C               -- misc hsc opts
 108
 109         -- take into account -fno-* flags by removing the equivalent -f*
 110         -- flag from our list.
 111   anti_flags <- getOpts anti_opt_C
 112   let basic_opts = opt_C_ ++ warn_opts ++ optimisation_opts ++ stg_opts
 113       filtered_opts = filter (`notElem` anti_flags) basic_opts
 114
 115         -- warnings
 116   warn_level <- readIORef warning_opt
 117   let warn_opts =  case warn_level of
 118                         W_default -> standardWarnings
 119                         W_        -> minusWOpts
 120                         W_all     -> minusWallOpts
 121                         W_not     -> []
 122
 123         -- optimisation
 124   minus_o <- readIORef opt_level
 125   optimisation_opts <-
 126         case minus_o of
 127             0 -> hsc_minusNoO_flags
 128             1 -> hsc_minusO_flags
 129             2 -> hsc_minusO2_flags
 130             _ -> error "unknown opt level"
 131             -- ToDo: -Ofile
 132
 133         -- STG passes
 134   ways_ <- readIORef ways
 135   let stg_massage | WayProf `elem` ways_ =  "-fmassage-stg-for-profiling"
 136                   | otherwise            = ""
 137
 138   stg_stats <- readIORef opt_StgStats
 139   let stg_stats_flag | stg_stats = "-dstg-stats"
 140                      | otherwise = ""
 141
 142   let stg_opts = [ stg_massage, stg_stats_flag, "-flet-no-escape" ]
 143         -- let-no-escape always on for now
 144
 145   verb <- is_verbose
 146   let hi_vers = "-fhi-version="++cProjectVersionInt
 147
 148   static <- (do s <- readIORef static; if s then return "-static" else return "")
 149
 150   l <- readIORef hsc_lang
 151   let lang = case l of
 152                 HscC    -> "-olang=C"
 153                 HscAsm  -> "-olang=asm"
 154                 HscJava -> "-olang=java"
 155
 156   -- get hi-file suffix
 157   hisuf <- readIORef hi_suf
 158
 159   -- hi-suffix for packages depends on the build tag.
 160   package_hisuf <-
 161         do tag <- readIORef build_tag
 162            if null tag
 163                 then return "hi"
 164                 else return (tag ++ "_hi")
 165
 166   import_dirs <- readIORef import_paths
 167   package_import_dirs <- getPackageImportPath
 168
 169   let hi_map = "-himap=" ++
 170                 makeHiMap import_dirs hisuf
 171                          package_import_dirs package_hisuf
 172                          split_marker
 173
 174       hi_map_sep = "-himap-sep=" ++ [split_marker]
 175
 176   scale <- readIORef scale_sizes_by
 177   heap  <- readState specific_heap_size
 178   stack <- readState specific_stack_size
 179
 180   return
 181         (
 182         filtered_opts
 183         -- ToDo: C stub files
 184         ++ [ hi_vers, static, verb, lang, hi_map, hi_map_sep ]
 185         )
 186
 187 makeHiMap
 188   (import_dirs         :: [String])
 189   (hi_suffix           :: String)
 190   (package_import_dirs :: [String])
 191   (package_hi_suffix   :: String)
 192   (split_marker        :: Char)
 193   = foldr (add_dir hi_suffix)
 194         (foldr (add_dir package_hi_suffix) "" package_import_dirs)
 195         import_dirs
 196   where
 197      add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str
 198
 199 -----------------------------------------------------------------------------
 200 -- Main loop
 201
 202 main =
 203   -- all error messages are propagated as exceptions
 204   my_catchDyn (\dyn -> case dyn of
 205                           PhaseFailed _phase code -> exitWith code
 206                           Interrupted -> exitWith (ExitFailure 1)
 207                           _ -> do hPutStrLn stderr (show (dyn :: BarfKind))
 208                                   exitWith (ExitFailure 1)
 209               ) $ do
 210
 211    -- make sure we clean up after ourselves
 212    later (do  forget_it <- readIORef keep_tmp_files
 213               unless forget_it $ do
 214               verb <- readIORef verbose
 215               cleanTempFiles verb
 216          )
 217         -- exceptions will be blocked while we clean the temporary files,
 218         -- so there shouldn't be any difficulty if we receive further
 219         -- signals.
 220
 221         -- install signal handlers
 222    main_thread <- myThreadId
 223
 224 #ifndef mingw32_TARGET_OS
 225    let sig_handler = Catch (raiseInThread main_thread
 226                                 (DynException (toDyn Interrupted)))
 227    installHandler sigQUIT sig_handler Nothing
 228    installHandler sigINT  sig_handler Nothing
 229 #endif
 230
 231    pgm    <- getProgName
 232    writeIORef prog_name pgm
 233
 234    argv   <- getArgs
 235
 236         -- grab any -B options from the command line first
 237    argv'  <- setTopDir argv
 238    top_dir <- readIORef topDir
 239
 240    let installed s = top_dir ++ s
 241        inplace s   = top_dir ++ '/':cCURRENT_DIR ++ '/':s
 242
 243        installed_pkgconfig = installed ("package.conf")
 244        inplace_pkgconfig   = inplace (cGHC_DRIVER_DIR ++ "/package.conf.inplace")
 245
 246         -- discover whether we're running in a build tree or in an installation,
 247         -- by looking for the package configuration file.
 248    am_installed <- doesFileExist installed_pkgconfig
 249
 250    if am_installed
 251         then writeIORef path_pkgconfig installed_pkgconfig
 252         else do am_inplace <- doesFileExist inplace_pkgconfig
 253                 if am_inplace
 254                     then writeIORef path_pkgconfig inplace_pkgconfig
 255                     else throw (OtherError "can't find package.conf")
 256
 257         -- set the location of our various files
 258    if am_installed
 259         then do writeIORef path_usage (installed "ghc-usage.txt")
 260                 writeIORef pgm_L (installed "unlit")
 261                 writeIORef pgm_C (installed "hsc")
 262                 writeIORef pgm_m (installed "ghc-asm")
 263                 writeIORef pgm_s (installed "ghc-split")
 264
 265         else do writeIORef path_usage (inplace (cGHC_DRIVER_DIR ++ '/':usage_file))
 266                 writeIORef pgm_L (inplace cGHC_UNLIT)
 267                 writeIORef pgm_C (inplace cGHC_HSC)
 268                 writeIORef pgm_m (inplace cGHC_MANGLER)
 269                 writeIORef pgm_s (inplace cGHC_SPLIT)
 270
 271         -- read the package configuration
 272    conf_file <- readIORef path_pkgconfig
 273    contents <- readFile conf_file
 274    writeIORef package_details (read contents)
 275
 276         -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
 277    (flags2, todo, stop_flag) <- getToDo argv'
 278    writeIORef v_todo todo
 279
 280         -- process all the other arguments, and get the source files
 281    non_static <- processArgs static_flags flags2 []
 282
 283         -- find the build tag, and re-process the build-specific options
 284    more_opts <- findBuildTag
 285    _ <- processArgs static_opts more_opts []
 286
 287         -- give the static flags to hsc
 288    build_hsc_opts
 289
 290         -- the rest of the arguments are "dynamic"
 291    srcs <- processArgs dynamic_flags non_static []
 292
 293         -- complain about any unknown flags
 294    let unknown_flags = [ f | ('-':f) <- srcs ]
 295    mapM unknownFlagErr unknown_flags
 296
 297         -- get the -v flag
 298    verb <- readIORef verbose
 299
 300    when verb (do hPutStr stderr "Glasgow Haskell Compiler, Version "
 301                  hPutStr stderr version_str
 302                  hPutStr stderr ", for Haskell 98, compiled by GHC version "
 303                  hPutStrLn stderr booter_version)
 304
 305    when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
 306
 307         -- mkdependHS is special
 308    when (todo == DoMkDependHS) beginMkDependHS
 309
 310         -- make is special
 311    when (todo == DoMake) beginMake
 312
 313         -- for each source file, find which phases to run
 314    pipelines <- mapM (genPipeline todo stop_flag) srcs
 315    let src_pipelines = zip srcs pipelines
 316
 317    o_file <- readIORef output_file
 318    if isJust o_file && todo /= DoLink && length srcs > 1
 319         then throwDyn (UsageError "can't apply -o option to multiple source files")
 320         else do
 321
 322    if null srcs then throwDyn (UsageError "no input files") else do
 323
 324         -- save the flag state, because this could be modified by OPTIONS pragmas
 325         -- during the compilation, and we'll need to restore it before starting
 326         -- the next compilation.
 327    saved_driver_state <- readIORef driver_state
 328
 329    let compileFile (src, phases) = do
 330           r <- run_pipeline phases src (todo==DoLink) True orig_base orig_suff
 331           writeIORef driver_state saved_driver_state
 332           return r
 333           where (orig_base, orig_suff) = splitFilename src
 334
 335    o_files <- mapM compileFile src_pipelines
 336
 337    when (todo == DoMkDependHS) endMkDependHS
 338
 339    when (todo == DoLink) (do_link o_files)
 340
 341         -- grab the last -B option on the command line, and
 342         -- set topDir to its value.
 343 setTopDir :: [String] -> IO [String]
 344 setTopDir args = do
 345   let (minusbs, others) = partition (prefixMatch "-B") args
 346   (case minusbs of
 347     []   -> writeIORef topDir clibdir
 348     some -> writeIORef topDir (drop 2 (last some)))
 349   return others
 350
 351 -----------------------------------------------------------------------------
 352 -- Which phase to stop at
 353
 354 data ToDo = DoMkDependHS | DoMkDLL | StopBefore Phase | DoLink | DoInteractive
 355   deriving (Eq)
 356
 357 GLOBAL_VAR(v_todo, error "todo", ToDo)
 358
 359 todoFlag :: String -> Maybe ToDo
 360 todoFlag "-M"            = Just $ DoMkDependHS
 361 todoFlag "-E"            = Just $ StopBefore Hsc
 362 todoFlag "-C"            = Just $ StopBefore HCc
 363 todoFlag "-S"            = Just $ StopBefore As
 364 todoFlag "-c"            = Just $ StopBefore Ln
 365 todoFlag "--make"        = Just $ DoMake
 366 todoFlag "--interactive" = Just $ DoInteractive
 367 todoFlag _               = Nothing
 368
 369 getToDo :: [String]
 370          -> IO ( [String]   -- rest of command line
 371                , ToDo
 372                , String     -- "ToDo" flag
 373                )
 374 getToDo flags
 375   = case my_partition todoFlag flags of
 376         ([]   , rest) -> return (rest, DoLink,  "") -- default is to do linking
 377         ([(flag,one)], rest) -> return (rest, one, flag)
 378         (_    , _   ) ->
 379           throwDyn (OtherError
 380                 "only one of the flags -M, -E, -C, -S, -c, --make is allowed")
 381
 382 -----------------------------------------------------------------------------
 383 -- genPipeline
 384 --
 385 -- Herein is all the magic about which phases to run in which order, whether
 386 -- the intermediate files should be in /tmp or in the current directory,
 387 -- what the suffix of the intermediate files should be, etc.
 388
 389 -- The following compilation pipeline algorithm is fairly hacky.  A
 390 -- better way to do this would be to express the whole comilation as a
 391 -- data flow DAG, where the nodes are the intermediate files and the
 392 -- edges are the compilation phases.  This framework would also work
 393 -- nicely if a haskell dependency generator was included in the
 394 -- driver.
 395
 396 -- It would also deal much more cleanly with compilation phases that
 397 -- generate multiple intermediates, (eg. hsc generates .hc, .hi, and
 398 -- possibly stub files), where some of the output files need to be
 399 -- processed further (eg. the stub files need to be compiled by the C
 400 -- compiler).
 401
 402 -- A cool thing to do would then be to execute the data flow graph
 403 -- concurrently, automatically taking advantage of extra processors on
 404 -- the host machine.  For example, when compiling two Haskell files
 405 -- where one depends on the other, the data flow graph would determine
 406 -- that the C compiler from the first comilation can be overlapped
 407 -- with the hsc comilation for the second file.
 408
 409 data IntermediateFileType
 410   = Temporary
 411   | Persistent
 412   deriving (Eq)
 413
 414 -- the first compilation phase for a given file is determined
 415 -- by its suffix.
 416 startPhase "lhs"   = Unlit
 417 startPhase "hs"    = Cpp
 418 startPhase "hc"    = HCc
 419 startPhase "c"     = Cc
 420 startPhase "raw_s" = Mangle
 421 startPhase "s"     = As
 422 startPhase "S"     = As
 423 startPhase "o"     = Ln
 424 startPhase _       = Ln    -- all unknown file types
 425
 426 genPipeline
 427    :: ToDo              -- when to stop
 428    -> String            -- "stop after" flag (for error messages)
 429    -> String            -- original filename
 430    -> IO [              -- list of phases to run for this file
 431              (Phase,
 432               IntermediateFileType,  -- keep the output from this phase?
 433               String)                -- output file suffix
 434          ]
 435
 436 genPipeline todo stop_flag filename
 437  = do
 438    split      <- readIORef split_object_files
 439    mangle     <- readIORef do_asm_mangling
 440    lang       <- readIORef hsc_lang
 441    keep_hc    <- readIORef keep_hc_files
 442    keep_raw_s <- readIORef keep_raw_s_files
 443    keep_s     <- readIORef keep_s_files
 444
 445    let
 446    ----------- -----  ----   ---   --   --  -  -  -
 447     (_basename, suffix) = splitFilename filename
 448
 449     start_phase = startPhase suffix
 450
 451     haskell_ish_file = suffix `elem` [ "hs", "lhs", "hc" ]
 452     c_ish_file       = suffix `elem` [ "c", "s", "S" ]  -- maybe .cc et al.??
 453
 454    -- for a .hc file, or if the -C flag is given, we need to force lang to HscC
 455     real_lang
 456         | suffix == "hc"  = HscC
 457         | todo == StopBefore HCc && lang /= HscC && haskell_ish_file = HscC
 458         | otherwise = lang
 459
 460    let
 461    ----------- -----  ----   ---   --   --  -  -  -
 462     pipeline
 463       | todo == DoMkDependHS = [ Unlit, Cpp, MkDependHS ]
 464
 465       | haskell_ish_file =
 466        case real_lang of
 467         HscC    | split && mangle -> [ Unlit, Cpp, Hsc, HCc, Mangle,
 468                                         SplitMangle, SplitAs ]
 469                 | mangle          -> [ Unlit, Cpp, Hsc, HCc, Mangle, As ]
 470                 | split           -> not_valid
 471                 | otherwise       -> [ Unlit, Cpp, Hsc, HCc, As ]
 472
 473         HscAsm  | split           -> [ Unlit, Cpp, Hsc, SplitMangle, SplitAs ]
 474                 | otherwise       -> [ Unlit, Cpp, Hsc, As ]
 475
 476         HscJava | split           -> not_valid
 477                 | otherwise       -> error "not implemented: compiling via Java"
 478
 479       | c_ish_file      = [ Cc, As ]
 480
 481       | otherwise       = [ ]  -- just pass this file through to the linker
 482
 483         -- ToDo: this is somewhat cryptic
 484     not_valid = throwDyn (OtherError ("invalid option combination"))
 485    ----------- -----  ----   ---   --   --  -  -  -
 486
 487         -- this shouldn't happen.
 488    if start_phase /= Ln && start_phase `notElem` pipeline
 489         then throwDyn (OtherError ("can't find starting phase for "
 490                                     ++ filename))
 491         else do
 492
 493         -- if we can't find the phase we're supposed to stop before,
 494         -- something has gone wrong.
 495    case todo of
 496         StopBefore phase ->
 497            when (phase /= Ln
 498                  && phase `notElem` pipeline
 499                  && not (phase == As && SplitAs `elem` pipeline)) $
 500               throwDyn (OtherError
 501                 ("flag " ++ stop_flag
 502                  ++ " is incompatible with source file `" ++ filename ++ "'"))
 503         _ -> return ()
 504
 505    let
 506    ----------- -----  ----   ---   --   --  -  -  -
 507       annotatePipeline
 508          :: [Phase]             -- raw pipeline
 509          -> Phase               -- phase to stop before
 510          -> [(Phase, IntermediateFileType, String{-file extension-})]
 511       annotatePipeline []     _    = []
 512       annotatePipeline (Ln:_) _    = []
 513       annotatePipeline (phase:next_phase:ps) stop =
 514           (phase, keep_this_output, phase_input_ext next_phase)
 515              : annotatePipeline (next_phase:ps) stop
 516           where
 517                 keep_this_output
 518                      | next_phase == stop = Persistent
 519                      | otherwise =
 520                         case next_phase of
 521                              Ln -> Persistent
 522                              Mangle | keep_raw_s -> Persistent
 523                              As     | keep_s     -> Persistent
 524                              HCc    | keep_hc    -> Persistent
 525                              _other              -> Temporary
 526
 527         -- add information about output files to the pipeline
 528         -- the suffix on an output file is determined by the next phase
 529         -- in the pipeline, so we add linking to the end of the pipeline
 530         -- to force the output from the final phase to be a .o file.
 531       stop_phase = case todo of StopBefore phase -> phase
 532                                 DoMkDependHS     -> Ln
 533                                 DoLink           -> Ln
 534       annotated_pipeline = annotatePipeline (pipeline ++ [ Ln ]) stop_phase
 535
 536       phase_ne p (p1,_,_) = (p1 /= p)
 537    ----------- -----  ----   ---   --   --  -  -  -
 538
 539    return $
 540      dropWhile (phase_ne start_phase) .
 541         foldr (\p ps -> if phase_ne stop_phase p then p:ps else [])  []
 542                 $ annotated_pipeline
 543
 544
 545
 546 run_pipeline
 547   :: [ (Phase, IntermediateFileType, String) ] -- phases to run
 548   -> String                     -- input file
 549   -> Bool                       -- doing linking afterward?
 550   -> Bool                       -- take into account -o when generating output?
 551   -> String                     -- original basename (eg. Main)
 552   -> String                     -- original suffix   (eg. hs)
 553   -> IO String                  -- return final filename
 554
 555 run_pipeline [] input_fn _ _ _ _ = return input_fn
 556 run_pipeline ((phase, keep, o_suffix):phases)
 557         input_fn do_linking use_ofile orig_basename orig_suffix
 558   = do
 559
 560      output_fn <- outputFileName (null phases) keep o_suffix
 561
 562      carry_on <- run_phase phase orig_basename orig_suffix input_fn output_fn
 563         -- sometimes we bail out early, eg. when the compiler's recompilation
 564         -- checker has determined that recompilation isn't necessary.
 565      if not carry_on
 566         then do let (_,keep,final_suffix) = last phases
 567                 ofile <- outputFileName True keep final_suffix
 568                 return ofile
 569         else do -- carry on ...
 570
 571         -- sadly, ghc -E is supposed to write the file to stdout.  We
 572         -- generate <file>.cpp, so we also have to cat the file here.
 573      when (null phases && phase == Cpp) $
 574         run_something "Dump pre-processed file to stdout"
 575                       ("cat " ++ output_fn)
 576
 577      run_pipeline phases output_fn do_linking use_ofile orig_basename orig_suffix
 578
 579   where
 580      outputFileName last_phase keep suffix
 581         = do o_file <- readIORef output_file
 582              if last_phase && not do_linking && use_ofile && isJust o_file
 583                then case o_file of
 584                        Just s  -> return s
 585                        Nothing -> error "outputFileName"
 586                else if keep == Persistent
 587                            then do f <- odir_ify (orig_basename ++ '.':suffix)
 588                                    osuf_ify f
 589                            else newTempName suffix
 590
 591 -------------------------------------------------------------------------------
 592 -- mkdependHS
 593
 594         -- flags
 595 GLOBAL_VAR(dep_makefile,        "Makefile", String);
 596 GLOBAL_VAR(dep_include_prelude, False, Bool);
 597 GLOBAL_VAR(dep_ignore_dirs,     [], [String]);
 598 GLOBAL_VAR(dep_suffixes,        [], [String]);
 599 GLOBAL_VAR(dep_warnings,        True, Bool);
 600
 601         -- global vars
 602 GLOBAL_VAR(dep_makefile_hdl,    error "dep_makefile_hdl", Maybe Handle);
 603 GLOBAL_VAR(dep_tmp_file,        error "dep_tmp_file", String);
 604 GLOBAL_VAR(dep_tmp_hdl,         error "dep_tmp_hdl", Handle);
 605 GLOBAL_VAR(dep_dir_contents,    error "dep_dir_contents", [(String,[String])]);
 606
 607 depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies"
 608 depEndMarker   = "# DO NOT DELETE: End of Haskell dependencies"
 609
 610 -- for compatibility with the old mkDependHS, we accept options of the form
 611 -- -optdep-f -optdep.depend, etc.
 612 dep_opts = [
 613    (  "s",                      SepArg (add dep_suffixes) ),
 614    (  "f",                      SepArg (writeIORef dep_makefile) ),
 615    (  "w",                      NoArg (writeIORef dep_warnings False) ),
 616    (  "-include-prelude",       NoArg (writeIORef dep_include_prelude True) ),
 617    (  "X",                      Prefix (addToDirList dep_ignore_dirs) ),
 618    (  "-exclude-directory=",    Prefix (addToDirList dep_ignore_dirs) )
 619  ]
 620
 621 beginMkDependHS :: IO ()
 622 beginMkDependHS = do
 623
 624         -- slurp in the mkdependHS-style options
 625   flags <- getOpts opt_dep
 626   _ <- processArgs dep_opts flags []
 627
 628         -- open a new temp file in which to stuff the dependency info
 629         -- as we go along.
 630   dep_file <- newTempName "dep"
 631   writeIORef dep_tmp_file dep_file
 632   tmp_hdl <- openFile dep_file WriteMode
 633   writeIORef dep_tmp_hdl tmp_hdl
 634
 635         -- open the makefile
 636   makefile <- readIORef dep_makefile
 637   exists <- doesFileExist makefile
 638   if not exists
 639         then do
 640            writeIORef dep_makefile_hdl Nothing
 641            return ()
 642
 643         else do
 644            makefile_hdl <- openFile makefile ReadMode
 645            writeIORef dep_makefile_hdl (Just makefile_hdl)
 646
 647                 -- slurp through until we get the magic start string,
 648                 -- copying the contents into dep_makefile
 649            let slurp = do
 650                 l <- hGetLine makefile_hdl
 651                 if (l == depStartMarker)
 652                         then return ()
 653                         else do hPutStrLn tmp_hdl l; slurp
 654
 655                 -- slurp through until we get the magic end marker,
 656                 -- throwing away the contents
 657            let chuck = do
 658                 l <- hGetLine makefile_hdl
 659                 if (l == depEndMarker)
 660                         then return ()
 661                         else chuck
 662
 663            catchJust ioErrors slurp
 664                 (\e -> if isEOFError e then return () else ioError e)
 665            catchJust ioErrors chuck
 666                 (\e -> if isEOFError e then return () else ioError e)
 667
 668
 669         -- write the magic marker into the tmp file
 670   hPutStrLn tmp_hdl depStartMarker
 671
 672         -- cache the contents of all the import directories, for future
 673         -- reference.
 674   import_dirs <- readIORef import_paths
 675   pkg_import_dirs <- getPackageImportPath
 676   import_dir_contents <- mapM getDirectoryContents import_dirs
 677   pkg_import_dir_contents <- mapM getDirectoryContents pkg_import_dirs
 678   writeIORef dep_dir_contents
 679         (zip import_dirs import_dir_contents ++
 680          zip pkg_import_dirs pkg_import_dir_contents)
 681
 682         -- ignore packages unless --include-prelude is on
 683   include_prelude <- readIORef dep_include_prelude
 684   when (not include_prelude) $
 685     mapM_ (add dep_ignore_dirs) pkg_import_dirs
 686
 687   return ()
 688
 689
 690 endMkDependHS :: IO ()
 691 endMkDependHS = do
 692   makefile     <- readIORef dep_makefile
 693   makefile_hdl <- readIORef dep_makefile_hdl
 694   tmp_file     <- readIORef dep_tmp_file
 695   tmp_hdl      <- readIORef dep_tmp_hdl
 696
 697         -- write the magic marker into the tmp file
 698   hPutStrLn tmp_hdl depEndMarker
 699
 700   case makefile_hdl of
 701      Nothing  -> return ()
 702      Just hdl -> do
 703
 704           -- slurp the rest of the orignal makefile and copy it into the output
 705         let slurp = do
 706                 l <- hGetLine hdl
 707                 hPutStrLn tmp_hdl l
 708                 slurp
 709
 710         catchJust ioErrors slurp
 711                 (\e -> if isEOFError e then return () else ioError e)
 712
 713         hClose hdl
 714
 715   hClose tmp_hdl  -- make sure it's flushed
 716
 717         -- create a backup of the original makefile
 718   when (isJust makefile_hdl) $
 719      run_something ("Backing up " ++ makefile)
 720         (unwords [ "cp", makefile, makefile++".bak" ])
 721
 722         -- copy the new makefile in place
 723   run_something "Installing new makefile"
 724         (unwords [ "cp", tmp_file, makefile ])
 725
 726
 727 findDependency :: String -> Import -> IO (Maybe (String, Bool))
 728 findDependency mod imp = do
 729    dir_contents <- readIORef dep_dir_contents
 730    ignore_dirs  <- readIORef dep_ignore_dirs
 731    hisuf <- readIORef hi_suf
 732
 733    let
 734      (imp_mod, is_source) =
 735         case imp of
 736            Normal str -> (str, False)
 737            Source str -> (str, True )
 738
 739      imp_hi = imp_mod ++ '.':hisuf
 740      imp_hiboot = imp_mod ++ ".hi-boot"
 741      imp_hiboot_v = imp_mod ++ ".hi-boot-" ++ cHscIfaceFileVersion
 742      imp_hs = imp_mod ++ ".hs"
 743      imp_lhs = imp_mod ++ ".lhs"
 744
 745      deps | is_source = [ imp_hiboot_v, imp_hiboot, imp_hs, imp_lhs ]
 746           | otherwise = [ imp_hi, imp_hs, imp_lhs ]
 747
 748      search [] = throwDyn (OtherError ("can't find one of the following: " ++
 749                                       unwords (map (\d -> '`': d ++ "'") deps) ++
 750                                       " (imported from `" ++ mod ++ "')"))
 751      search ((dir, contents) : dirs)
 752            | null present = search dirs
 753            | otherwise =
 754                 if dir `elem` ignore_dirs
 755                         then return Nothing
 756                         else if is_source
 757                                 then if dep /= imp_hiboot_v
 758                                         then return (Just (dir++'/':imp_hiboot, False))
 759                                         else return (Just (dir++'/':dep, False))
 760                                 else return (Just (dir++'/':imp_hi, not is_source))
 761            where
 762                 present = filter (`elem` contents) deps
 763                 dep     = head present
 764
 765    -- in
 766    search dir_contents
 767
 768
 769 -----------------------------------------------------------------------------
 770 -- MkDependHS phase
 771
 772 run_phase MkDependHS basename suff input_fn _output_fn = do
 773    src <- readFile input_fn
 774    let imports = getImports src
 775
 776    deps <- mapM (findDependency basename) imports
 777
 778    osuf_opt <- readIORef output_suf
 779    let osuf = case osuf_opt of
 780                         Nothing -> "o"
 781                         Just s  -> s
 782
 783    extra_suffixes <- readIORef dep_suffixes
 784    let suffixes = osuf : map (++ ('_':osuf)) extra_suffixes
 785        ofiles = map (\suf -> basename ++ '.':suf) suffixes
 786
 787    objs <- mapM odir_ify ofiles
 788
 789    hdl <- readIORef dep_tmp_hdl
 790
 791         -- std dependeny of the object(s) on the source file
 792    hPutStrLn hdl (unwords objs ++ " : " ++ basename ++ '.':suff)
 793
 794    let genDep (dep, False {- not an hi file -}) =
 795           hPutStrLn hdl (unwords objs ++ " : " ++ dep)
 796        genDep (dep, True  {- is an hi file -}) = do
 797           hisuf <- readIORef hi_suf
 798           let dep_base = remove_suffix '.' dep
 799               deps = (dep_base ++ hisuf)
 800                      : map (\suf -> dep_base ++ suf ++ '_':hisuf) extra_suffixes
 801                   -- length objs should be == length deps
 802           sequence_ (zipWith (\o d -> hPutStrLn hdl (o ++ " : " ++ d)) objs deps)
 803
 804    mapM genDep [ d | Just d <- deps ]
 805
 806    return True
 807
 808 -- add the lines to dep_makefile:
 809            -- always:
 810                    -- this.o : this.hs
 811
 812            -- if the dependency is on something other than a .hi file:
 813                    -- this.o this.p_o ... : dep
 814            -- otherwise
 815                    -- if the import is {-# SOURCE #-}
 816                            -- this.o this.p_o ... : dep.hi-boot[-$vers]
 817
 818                    -- else
 819                            -- this.o ...   : dep.hi
 820                            -- this.p_o ... : dep.p_hi
 821                            -- ...
 822
 823            -- (where .o is $osuf, and the other suffixes come from
 824            -- the cmdline -s options).
 825
 826 -----------------------------------------------------------------------------
 827 -- Hsc phase
 828
 829 run_phase Hsc   basename suff input_fn output_fn
 830   = do  hsc <- readIORef pgm_C
 831
 832   -- we add the current directory (i.e. the directory in which
 833   -- the .hs files resides) to the import path, since this is
 834   -- what gcc does, and it's probably what you want.
 835         let current_dir = getdir basename
 836
 837         paths <- readIORef include_paths
 838         writeIORef include_paths (current_dir : paths)
 839
 840   -- build the hsc command line
 841         hsc_opts <- build_hsc_opts
 842
 843         doing_hi <- readIORef produceHi
 844         tmp_hi_file <- if doing_hi
 845                           then newTempName "hi"
 846                           else return ""
 847
 848   -- tmp files for foreign export stub code
 849         tmp_stub_h <- newTempName "stub_h"
 850         tmp_stub_c <- newTempName "stub_c"
 851
 852   -- figure out where to put the .hi file
 853         ohi    <- readIORef output_hi
 854         hisuf  <- readIORef hi_suf
 855         let hi_flags = case ohi of
 856                            Nothing -> [ "-hidir="++current_dir, "-hisuf="++hisuf ]
 857                            Just fn -> [ "-hifile="++fn ]
 858
 859   -- figure out if the source has changed, for recompilation avoidance.
 860   -- only do this if we're eventually going to generate a .o file.
 861   -- (ToDo: do when generating .hc files too?)
 862   --
 863   -- Setting source_unchanged to "-fsource_unchanged" means that M.o seems
 864   -- to be up to date wrt M.hs; so no need to recompile unless imports have
 865   -- changed (which the compiler itself figures out).
 866   -- Setting source_unchanged to "" tells the compiler that M.o is out of
 867   -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless.
 868         do_recomp <- readIORef recomp
 869         todo <- readIORef v_todo
 870         o_file <- odir_ify (basename ++ '.':phase_input_ext Ln)
 871         source_unchanged <-
 872           if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
 873              then return ""
 874              else do t1 <- getModificationTime (basename ++ '.':suff)
 875                      o_file_exists <- doesFileExist o_file
 876                      if not o_file_exists
 877                         then return ""  -- Need to recompile
 878                         else do t2 <- getModificationTime o_file
 879                                 if t2 > t1
 880                                   then return "-fsource-unchanged"
 881                                   else return ""
 882
 883   -- run the compiler!
 884         run_something "Haskell Compiler"
 885                  (unwords (hsc : input_fn : (
 886                     hsc_opts
 887                     ++ hi_flags
 888                     ++ [
 889                           source_unchanged,
 890                           "-ofile="++output_fn,
 891                           "-F="++tmp_stub_c,
 892                           "-FH="++tmp_stub_h
 893                        ]
 894                     ++ stat_opts
 895                  )))
 896
 897   -- check whether compilation was performed, bail out if not
 898         b <- doesFileExist output_fn
 899         if not b && not (null source_unchanged) -- sanity
 900                 then do run_something "Touching object file"
 901                             ("touch " ++ o_file)
 902                         return False
 903                 else do -- carry on...
 904
 905   -- Deal with stubs
 906         let stub_h = basename ++ "_stub.h"
 907         let stub_c = basename ++ "_stub.c"
 908
 909                 -- copy .h_stub file into current dir if present
 910         b <- doesFileExist tmp_stub_h
 911         when b (do
 912                 run_something "Copy stub .h file"
 913                                 ("cp " ++ tmp_stub_h ++ ' ':stub_h)
 914
 915                         -- #include <..._stub.h> in .hc file
 916                 addCmdlineHCInclude tmp_stub_h  -- hack
 917
 918                         -- copy the _stub.c file into the current dir
 919                 run_something "Copy stub .c file"
 920                     (unwords [
 921                         "rm -f", stub_c, "&&",
 922                         "echo \'#include \""++stub_h++"\"\' >"++stub_c, " &&",
 923                         "cat", tmp_stub_c, ">> ", stub_c
 924                         ])
 925
 926                         -- compile the _stub.c file w/ gcc
 927                 pipeline <- genPipeline (StopBefore Ln) "" stub_c
 928                 run_pipeline pipeline stub_c False{-no linking-}
 929                                 False{-no -o option-}
 930                                 (basename++"_stub") "c"
 931
 932                 add ld_inputs (basename++"_stub.o")
 933          )
 934         return True
 935
 936 -----------------------------------------------------------------------------
 937 -- Cc phase
 938
 939 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 940 -- way too many hacks, and I can't say I've ever used it anyway.
 941
 942 run_phase cc_phase _basename _suff input_fn output_fn
 943    | cc_phase == Cc || cc_phase == HCc
 944    = do cc <- readIORef pgm_c
 945         cc_opts <- (getOpts opt_c)
 946         cmdline_include_dirs <- readIORef include_paths
 947
 948         let hcc = cc_phase == HCc
 949
 950                 -- add package include paths even if we're just compiling
 951                 -- .c files; this is the Value Add(TM) that using
 952                 -- ghc instead of gcc gives you :)
 953         pkg_include_dirs <- getPackageIncludePath
 954         let include_paths = map (\p -> "-I"++p) (cmdline_include_dirs
 955                                                         ++ pkg_include_dirs)
 956
 957         c_includes <- getPackageCIncludes
 958         cmdline_includes <- readState cmdline_hc_includes -- -#include options
 959
 960         let cc_injects | hcc = unlines (map mk_include
 961                                         (c_includes ++ reverse cmdline_includes))
 962                        | otherwise = ""
 963             mk_include h_file =
 964                 case h_file of
 965                    '"':_{-"-} -> "#include "++h_file
 966                    '<':_      -> "#include "++h_file
 967                    _          -> "#include \""++h_file++"\""
 968
 969         cc_help <- newTempName "c"
 970         h <- openFile cc_help WriteMode
 971         hPutStr h cc_injects
 972         hPutStrLn h ("#include \"" ++ input_fn ++ "\"\n")
 973         hClose h
 974
 975         ccout <- newTempName "ccout"
 976
 977         mangle <- readIORef do_asm_mangling
 978         (md_c_flags, md_regd_c_flags) <- machdepCCOpts
 979
 980         verb <- is_verbose
 981
 982         o2 <- readIORef opt_minus_o2_for_C
 983         let opt_flag | o2        = "-O2"
 984                      | otherwise = "-O"
 985
 986         pkg_extra_cc_opts <- getPackageExtraCcOpts
 987
 988         excessPrecision <- readState excess_precision
 989
 990         run_something "C Compiler"
 991          (unwords ([ cc, "-x", "c", cc_help, "-o", output_fn ]
 992                    ++ md_c_flags
 993                    ++ (if cc_phase == HCc && mangle
 994                          then md_regd_c_flags
 995                          else [])
 996                    ++ [ verb, "-S", "-Wimplicit", opt_flag ]
 997                    ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ]
 998                    ++ cc_opts
 999 #ifdef mingw32_TARGET_OS
1000                    ++ [" -mno-cygwin"]
1001 #endif
1002                    ++ (if excessPrecision then [] else [ "-ffloat-store" ])
1003                    ++ include_paths
1004                    ++ pkg_extra_cc_opts
1005 --                 ++ [">", ccout]
1006                    ))
1007         return True
1008
1009         -- ToDo: postprocess the output from gcc
1010
1011 -----------------------------------------------------------------------------
1012 -- Mangle phase
1013
1014 run_phase Mangle _basename _suff input_fn output_fn
1015   = do mangler <- readIORef pgm_m
1016        mangler_opts <- getOpts opt_m
1017        machdep_opts <-
1018          if (prefixMatch "i386" cTARGETPLATFORM)
1019             then do n_regs <- readState stolen_x86_regs
1020                     return [ show n_regs ]
1021             else return []
1022        run_something "Assembly Mangler"
1023         (unwords (mangler :
1024                      mangler_opts
1025                   ++ [ input_fn, output_fn ]
1026                   ++ machdep_opts
1027                 ))
1028        return True
1029
1030 -----------------------------------------------------------------------------
1031 -- Splitting phase
1032
1033 run_phase SplitMangle _basename _suff input_fn _output_fn
1034   = do  splitter <- readIORef pgm_s
1035
1036         -- this is the prefix used for the split .s files
1037         tmp_pfx <- readIORef tmpdir
1038         x <- getProcessID
1039         let split_s_prefix = tmp_pfx ++ "/ghc" ++ show x
1040         writeIORef split_prefix split_s_prefix
1041         addFilesToClean (split_s_prefix ++ "__*") -- d:-)
1042
1043         -- allocate a tmp file to put the no. of split .s files in (sigh)
1044         n_files <- newTempName "n_files"
1045
1046         run_something "Split Assembly File"
1047          (unwords [ splitter
1048                   , input_fn
1049                   , split_s_prefix
1050                   , n_files ]
1051          )
1052
1053         -- save the number of split files for future references
1054         s <- readFile n_files
1055         let n = read s :: Int
1056         writeIORef n_split_files n
1057         return True
1058
1059 -----------------------------------------------------------------------------
1060 -- As phase
1061
1062 run_phase As _basename _suff input_fn output_fn
1063   = do  as <- readIORef pgm_a
1064         as_opts <- getOpts opt_a
1065
1066         cmdline_include_paths <- readIORef include_paths
1067         let cmdline_include_flags = map (\p -> "-I"++p) cmdline_include_paths
1068         run_something "Assembler"
1069            (unwords (as : as_opts
1070                        ++ cmdline_include_flags
1071                        ++ [ "-c", input_fn, "-o",  output_fn ]
1072                     ))
1073         return True
1074
1075 run_phase SplitAs basename _suff _input_fn _output_fn
1076   = do  as <- readIORef pgm_a
1077         as_opts <- getOpts opt_a
1078
1079         split_s_prefix <- readIORef split_prefix
1080         n <- readIORef n_split_files
1081
1082         odir <- readIORef output_dir
1083         let real_odir = case odir of
1084                                 Nothing -> basename
1085                                 Just d  -> d
1086
1087         let assemble_file n = do
1088                     let input_s  = split_s_prefix ++ "__" ++ show n ++ ".s"
1089                     let output_o = newdir real_odir
1090                                         (basename ++ "__" ++ show n ++ ".o")
1091                     real_o <- osuf_ify output_o
1092                     run_something "Assembler"
1093                             (unwords (as : as_opts
1094                                       ++ [ "-c", "-o", real_o, input_s ]
1095                             ))
1096
1097         mapM_ assemble_file [1..n]
1098         return True
1099
1100 -----------------------------------------------------------------------------
1101 -- Linking
1102
1103 do_link :: [String] -> IO ()
1104 do_link o_files = do
1105     ln <- readIORef pgm_l
1106     verb <- is_verbose
1107     o_file <- readIORef output_file
1108     let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; }
1109
1110     pkg_lib_paths <- getPackageLibraryPath
1111     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
1112
1113     lib_paths <- readIORef library_paths
1114     let lib_path_opts = map ("-L"++) lib_paths
1115
1116     pkg_libs <- getPackageLibraries
1117     let pkg_lib_opts = map (\lib -> "-l"++lib) pkg_libs
1118
1119     libs <- readIORef cmdline_libraries
1120     let lib_opts = map ("-l"++) (reverse libs)
1121          -- reverse because they're added in reverse order from the cmd line
1122
1123     pkg_extra_ld_opts <- getPackageExtraLdOpts
1124
1125         -- probably _stub.o files
1126     extra_ld_inputs <- readIORef ld_inputs
1127
1128         -- opts from -optl-<blah>
1129     extra_ld_opts <- getOpts opt_l
1130
1131     run_something "Linker"
1132        (unwords
1133          ([ ln, verb, "-o", output_fn ]
1134          ++ o_files
1135          ++ extra_ld_inputs
1136          ++ lib_path_opts
1137          ++ lib_opts
1138          ++ pkg_lib_path_opts
1139          ++ pkg_lib_opts
1140          ++ pkg_extra_ld_opts
1141          ++ extra_ld_opts
1142         )
1143        )
1144
1145 -----------------------------------------------------------------------------
1146 -- compatibility code
1147
1148 #if __GLASGOW_HASKELL__ <= 408
1149 catchJust = catchIO
1150 ioErrors  = justIoErrors
1151 #endif
1152
1153 #ifdef mingw32_TARGET_OS
1154 foreign import "_getpid" getProcessID :: IO Int
1155 #endif