ghc/compiler/main/Main.hs

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