ghc/compiler/main/Main.hs

   1 {-# OPTIONS -W -fno-warn-incomplete-patterns #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: Main.hs,v 1.9 2000/10/26 14:38:42 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 DriverPipeline
  19 import DriverState
  20 import DriverFlags
  21 import DriverMkDepend
  22 import DriverUtil
  23 import TmpFiles
  24 import Config
  25 import Util
  26 import Panic
  27
  28 import Concurrent
  29 #ifndef mingw32_TARGET_OS
  30 import Posix
  31 #endif
  32 import Directory
  33 import IOExts
  34 import Exception
  35 import Dynamic
  36
  37 import IO
  38 import Monad
  39 import List
  40 import System
  41 import Maybe
  42
  43 -----------------------------------------------------------------------------
  44 -- Changes:
  45
  46 -- * -fglasgow-exts NO LONGER IMPLIES -package lang!!!  (-fglasgow-exts is a
  47 --   dynamic flag whereas -package is a static flag.)
  48
  49 -----------------------------------------------------------------------------
  50 -- ToDo:
  51
  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 -- Main loop
  75
  76 main =
  77   -- all error messages are propagated as exceptions
  78   handleDyn (\dyn -> case dyn of
  79                           PhaseFailed _phase code -> exitWith code
  80                           Interrupted -> exitWith (ExitFailure 1)
  81                           _ -> do hPutStrLn stderr (show (dyn :: BarfKind))
  82                                   exitWith (ExitFailure 1)
  83               ) $ do
  84
  85    -- make sure we clean up after ourselves
  86    later (do  forget_it <- readIORef keep_tmp_files
  87               unless forget_it $ do
  88               verb <- readIORef verbose
  89               cleanTempFiles verb
  90      ) $ do
  91         -- exceptions will be blocked while we clean the temporary files,
  92         -- so there shouldn't be any difficulty if we receive further
  93         -- signals.
  94
  95         -- install signal handlers
  96    main_thread <- myThreadId
  97 #ifndef mingw32_TARGET_OS
  98    let sig_handler = Catch (throwTo main_thread
  99                                 (DynException (toDyn Interrupted)))
 100    installHandler sigQUIT sig_handler Nothing
 101    installHandler sigINT  sig_handler Nothing
 102 #endif
 103
 104    pgm    <- getProgName
 105    writeIORef prog_name pgm
 106
 107    argv   <- getArgs
 108
 109         -- grab any -B options from the command line first
 110    argv'  <- setTopDir argv
 111    top_dir <- readIORef topDir
 112
 113    let installed s = top_dir ++ s
 114        inplace s   = top_dir ++ '/':cCURRENT_DIR ++ '/':s
 115
 116        installed_pkgconfig = installed ("package.conf")
 117        inplace_pkgconfig   = inplace (cGHC_DRIVER_DIR ++ "/package.conf.inplace")
 118
 119         -- discover whether we're running in a build tree or in an installation,
 120         -- by looking for the package configuration file.
 121    am_installed <- doesFileExist installed_pkgconfig
 122
 123    if am_installed
 124         then writeIORef path_package_config installed_pkgconfig
 125         else do am_inplace <- doesFileExist inplace_pkgconfig
 126                 if am_inplace
 127                     then writeIORef path_package_config inplace_pkgconfig
 128                     else throwDyn (OtherError "can't find package.conf")
 129
 130         -- set the location of our various files
 131    if am_installed
 132         then do writeIORef path_usage (installed "ghc-usage.txt")
 133                 writeIORef pgm_L (installed "unlit")
 134                 writeIORef pgm_m (installed "ghc-asm")
 135                 writeIORef pgm_s (installed "ghc-split")
 136
 137         else do writeIORef path_usage (inplace (cGHC_DRIVER_DIR ++ "/ghc-usage.txt"))
 138                 writeIORef pgm_L (inplace cGHC_UNLIT)
 139                 writeIORef pgm_m (inplace cGHC_MANGLER)
 140                 writeIORef pgm_s (inplace cGHC_SPLIT)
 141
 142         -- read the package configuration
 143    conf_file <- readIORef path_package_config
 144    contents <- readFile conf_file
 145    writeIORef package_details (read contents)
 146
 147         -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
 148    (flags2, mode, stop_flag) <- getGhcMode argv'
 149    writeIORef v_GhcMode mode
 150
 151         -- force lang to "C" if the -C flag was given
 152    case mode of StopBefore HCc -> writeIORef hsc_lang HscC
 153                 _ -> return ()
 154
 155         -- process all the other arguments, and get the source files
 156    non_static <- processArgs static_flags flags2 []
 157
 158         -- find the build tag, and re-process the build-specific options
 159    more_opts <- findBuildTag
 160    _ <- processArgs static_flags more_opts []
 161
 162         -- give the static flags to hsc
 163    static_opts <- buildStaticHscOpts
 164    writeIORef static_hsc_opts static_opts
 165
 166         -- warnings
 167     warn_level <- readIORef warning_opt
 168     let warn_opts =  case warn_level of
 169                         W_default -> standardWarnings
 170                         W_        -> minusWOpts
 171                         W_all     -> minusWallOpts
 172                         W_not     -> []
 173
 174         -- build the default DynFlags (these may be adjusted on a per
 175         -- module basis by OPTIONS pragmas and settings in the interpreter).
 176
 177    core_todo <- buildCoreToDo
 178    stg_todo  <- buildStgToDo
 179
 180    lang <- readIORef hsc_lang
 181    writeIORef v_DynFlags
 182         DynFlags{ coreToDo = core_todo,
 183                   stgToDo  = stg_todo,
 184                   hscLang  = lang,
 185                   -- leave out hscOutName for now
 186                   flags = [] }
 187
 188         -- the rest of the arguments are "dynamic"
 189    srcs <- processArgs dynamic_flags non_static []
 190         -- save the "initial DynFlags" away
 191    dyn_flags <- readIORef v_DynFlags
 192    writeIORef v_InitDynFlags
 193
 194         -- complain about any unknown flags
 195    let unknown_flags = [ f | ('-':f) <- srcs ]
 196    mapM unknownFlagErr unknown_flags
 197
 198         -- get the -v flag
 199    verb <- readIORef verbose
 200
 201    when verb (do hPutStr stderr "Glasgow Haskell Compiler, Version "
 202                  hPutStr stderr version_str
 203                  hPutStr stderr ", for Haskell 98, compiled by GHC version "
 204                  hPutStrLn stderr booter_version)
 205
 206    when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
 207
 208         -- mkdependHS is special
 209    when (mode == DoMkDependHS) beginMkDependHS
 210
 211         -- make is special
 212    when (mode == DoMake) beginMake
 213
 214         -- for each source file, find which phases to run
 215    pipelines <- mapM (genPipeline mode stop_flag) srcs
 216    let src_pipelines = zip srcs pipelines
 217
 218    o_file <- readIORef output_file
 219    if isJust o_file && mode /= DoLink && length srcs > 1
 220         then throwDyn (UsageError "can't apply -o option to multiple source files")
 221         else do
 222
 223    if null srcs then throwDyn (UsageError "no input files") else do
 224
 225         -- save the flag state, because this could be modified by OPTIONS pragmas
 226         -- during the compilation, and we'll need to restore it before starting
 227         -- the next compilation.
 228    saved_driver_state <- readIORef driver_state
 229
 230    let compileFile (src, phases) = do
 231           r <- runPipeline phases src (mode==DoLink) True
 232           writeIORef driver_state saved_driver_state
 233           return r
 234
 235    o_files <- mapM compileFile src_pipelines
 236
 237    when (mode == DoMkDependHS) endMkDependHS
 238    when (mode == DoLink) (doLink o_files)
 239
 240         -- grab the last -B option on the command line, and
 241         -- set topDir to its value.
 242 setTopDir :: [String] -> IO [String]
 243 setTopDir args = do
 244   let (minusbs, others) = partition (prefixMatch "-B") args
 245   (case minusbs of
 246     []   -> writeIORef topDir clibdir
 247     some -> writeIORef topDir (drop 2 (last some)))
 248   return others
 249
 250 beginMake = panic "`ghc --make' unimplemented"
 251
 252 -----------------------------------------------------------------------------
 253 -- compatibility code
 254
 255 #if __GLASGOW_HASKELL__ <= 408
 256 catchJust = catchIO
 257 ioErrors  = justIoErrors
 258 throwTo   = raiseInThread
 259 #endif
 260
 261 #ifdef mingw32_TARGET_OS
 262 foreign import "_getpid" getProcessID :: IO Int
 263 #endif