ghc/compiler/main/Main.hs

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