ghc/compiler/main/Main.hs

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