ghc/compiler/main/Main.hs

   1 {-# OPTIONS -W -fno-warn-incomplete-patterns #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: Main.hs,v 1.7 2000/10/24 15:58:02 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
  98 #ifndef mingw32_TARGET_OS
  99    let sig_handler = Catch (throwTo main_thread
 100                                 (DynException (toDyn Interrupted)))
 101    installHandler sigQUIT sig_handler Nothing
 102    installHandler sigINT  sig_handler Nothing
 103 #endif
 104
 105    pgm    <- getProgName
 106    writeIORef prog_name pgm
 107
 108    argv   <- getArgs
 109
 110         -- grab any -B options from the command line first
 111    argv'  <- setTopDir argv
 112    top_dir <- readIORef topDir
 113
 114    let installed s = top_dir ++ s
 115        inplace s   = top_dir ++ '/':cCURRENT_DIR ++ '/':s
 116
 117        installed_pkgconfig = installed ("package.conf")
 118        inplace_pkgconfig   = inplace (cGHC_DRIVER_DIR ++ "/package.conf.inplace")
 119
 120         -- discover whether we're running in a build tree or in an installation,
 121         -- by looking for the package configuration file.
 122    am_installed <- doesFileExist installed_pkgconfig
 123
 124    if am_installed
 125         then writeIORef path_package_config installed_pkgconfig
 126         else do am_inplace <- doesFileExist inplace_pkgconfig
 127                 if am_inplace
 128                     then writeIORef path_package_config inplace_pkgconfig
 129                     else throwDyn (OtherError "can't find package.conf")
 130
 131         -- set the location of our various files
 132    if am_installed
 133         then do writeIORef path_usage (installed "ghc-usage.txt")
 134                 writeIORef pgm_L (installed "unlit")
 135                 writeIORef pgm_m (installed "ghc-asm")
 136                 writeIORef pgm_s (installed "ghc-split")
 137
 138         else do writeIORef path_usage (inplace (cGHC_DRIVER_DIR ++ "/ghc-usage.txt"))
 139                 writeIORef pgm_L (inplace cGHC_UNLIT)
 140                 writeIORef pgm_m (inplace cGHC_MANGLER)
 141                 writeIORef pgm_s (inplace cGHC_SPLIT)
 142
 143         -- read the package configuration
 144    conf_file <- readIORef path_package_config
 145    contents <- readFile conf_file
 146    writeIORef package_details (read contents)
 147
 148         -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
 149    (flags2, mode, stop_flag) <- getGhcMode argv'
 150    writeIORef v_GhcMode mode
 151
 152         -- process all the other arguments, and get the source files
 153    non_static <- processArgs static_flags flags2 []
 154
 155         -- find the build tag, and re-process the build-specific options
 156    more_opts <- findBuildTag
 157    _ <- processArgs static_flags more_opts []
 158
 159         -- give the static flags to hsc
 160    build_hsc_opts
 161
 162         -- build the default DynFlags (these may be adjusted on a per
 163         -- module basis by OPTIONS pragmas and settings in the interpreter).
 164
 165    core_todo <- buildCoreToDo
 166
 167    lang <- readIORef hsc_lang
 168    writeIORef v_DynFlags
 169         DynFlags{ coreToDo =  core_todo,
 170                   stgToDo  = error "ToDo: stgToDo"
 171                   hscLang  = lang,
 172                   -- leave out hscOutName for now
 173                   flags = [] }
 174
 175         -- the rest of the arguments are "dynamic"
 176    srcs <- processArgs dynamic_flags non_static []
 177         -- save the "initial DynFlags" away
 178    dyn_flags <- readIORef v_DynFlags
 179    writeIORef v_InitDynFlags
 180
 181         -- complain about any unknown flags
 182    let unknown_flags = [ f | ('-':f) <- srcs ]
 183    mapM unknownFlagErr unknown_flags
 184
 185         -- get the -v flag
 186    verb <- readIORef verbose
 187
 188    when verb (do hPutStr stderr "Glasgow Haskell Compiler, Version "
 189                  hPutStr stderr version_str
 190                  hPutStr stderr ", for Haskell 98, compiled by GHC version "
 191                  hPutStrLn stderr booter_version)
 192
 193    when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
 194
 195         -- mkdependHS is special
 196    when (mode == DoMkDependHS) beginMkDependHS
 197
 198         -- make is special
 199    when (mode == DoMake) beginMake
 200
 201         -- for each source file, find which phases to run
 202    pipelines <- mapM (genPipeline mode stop_flag) srcs
 203    let src_pipelines = zip srcs pipelines
 204
 205    o_file <- readIORef output_file
 206    if isJust o_file && mode /= DoLink && length srcs > 1
 207         then throwDyn (UsageError "can't apply -o option to multiple source files")
 208         else do
 209
 210    if null srcs then throwDyn (UsageError "no input files") else do
 211
 212         -- save the flag state, because this could be modified by OPTIONS pragmas
 213         -- during the compilation, and we'll need to restore it before starting
 214         -- the next compilation.
 215    saved_driver_state <- readIORef driver_state
 216
 217    let compileFile (src, phases) = do
 218           r <- runPipeline phases src (mode==DoLink) True
 219           writeIORef driver_state saved_driver_state
 220           return r
 221
 222    o_files <- mapM compileFile src_pipelines
 223
 224    when (mode == DoMkDependHS) endMkDependHS
 225    when (mode == DoLink) (doLink o_files)
 226
 227         -- grab the last -B option on the command line, and
 228         -- set topDir to its value.
 229 setTopDir :: [String] -> IO [String]
 230 setTopDir args = do
 231   let (minusbs, others) = partition (prefixMatch "-B") args
 232   (case minusbs of
 233     []   -> writeIORef topDir clibdir
 234     some -> writeIORef topDir (drop 2 (last some)))
 235   return others
 236
 237 beginMake = panic "`ghc --make' unimplemented"
 238
 239 -----------------------------------------------------------------------------
 240 -- compatibility code
 241
 242 #if __GLASGOW_HASKELL__ <= 408
 243 catchJust = catchIO
 244 ioErrors  = justIoErrors
 245 throwTo   = raiseInThread
 246 #endif
 247
 248 #ifdef mingw32_TARGET_OS
 249 foreign import "_getpid" getProcessID :: IO Int
 250 #endif