ghc/compiler/main/Main.hs

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