ghc/compiler/main/Main.hs

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