ghc/compiler/main/Main.hs

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