ghc/compiler/main/Main.hs

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