ghc/compiler/main/Main.hs

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