ghc/compiler/main/Main.hs

   1 {-# OPTIONS -fno-warn-incomplete-patterns #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: Main.hs,v 1.57 2001/02/28 11:44:39 simonpj 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 import Char             ( toLower )
  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, objish_file )
  37 import CmdLineOpts
  38 import TmpFiles
  39 import Finder           ( initFinder )
  40 import CmStaticInfo
  41 import Config
  42 import Util
  43
  44
  45 import Concurrent
  46 import Directory
  47 import IOExts
  48 import Exception
  49
  50 import IO
  51 import Monad
  52 import List
  53 import System
  54 import Maybe
  55
  56
  57 -----------------------------------------------------------------------------
  58 -- Changes:
  59
  60 -- * -fglasgow-exts NO LONGER IMPLIES -package lang!!!  (-fglasgow-exts is a
  61 --   dynamic flag whereas -package is a static flag.)
  62
  63 -----------------------------------------------------------------------------
  64 -- ToDo:
  65
  66 -- -nohi doesn't work
  67 -- new mkdependHS doesn't support all the options that the old one did (-X et al.)
  68 -- time commands when run with -v
  69 -- split marker
  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
 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         -- Show the GHCi banner?
 167 #  ifdef GHCI
 168    when (mode == DoInteractive) $
 169       hPutStrLn stdout ghciWelcomeMsg
 170 #  endif
 171
 172         -- process all the other arguments, and get the source files
 173    non_static <- processArgs static_flags flags2 []
 174
 175         -- -O and --interactive are not a good combination
 176         -- ditto with any kind of way selection
 177    orig_opt_level <- readIORef v_OptLevel
 178    when (orig_opt_level > 0 && mode == DoInteractive) $
 179       do putStr "warning: -O conflicts with --interactive; -O turned off.\n"
 180          writeIORef v_OptLevel 0
 181    orig_ways <- readIORef v_Ways
 182    when (not (null orig_ways) && mode == DoInteractive) $
 183       do throwDyn (OtherError
 184                    "--interactive can't be used with -prof, -ticky, -unreg or -smp.")
 185
 186         -- Find the build tag, and re-process the build-specific options.
 187         -- Also add in flags for unregisterised compilation, if
 188         -- GhcUnregisterised=YES.
 189    way_opts <- findBuildTag
 190    let unreg_opts | cGhcUnregisterised == "YES" = unregFlags
 191                   | otherwise = []
 192    way_non_static <- processArgs static_flags (unreg_opts ++ way_opts) []
 193
 194         -- give the static flags to hsc
 195    static_opts <- buildStaticHscOpts
 196    writeIORef v_Static_hsc_opts static_opts
 197
 198    -- build the default DynFlags (these may be adjusted on a per
 199    -- module basis by OPTIONS pragmas and settings in the interpreter).
 200
 201    core_todo <- buildCoreToDo
 202    stg_todo  <- buildStgToDo
 203
 204    -- set the "global" HscLang.  The HscLang can be further adjusted on a module
 205    -- by module basis, using only the -fvia-C and -fasm flags.  If the global
 206    -- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect.
 207    opt_level  <- readIORef v_OptLevel
 208
 209
 210    let lang = case mode of
 211                  StopBefore HCc -> HscC
 212                  DoInteractive  -> HscInterpreted
 213                  _other        | opt_level >= 1  -> HscC  -- -O implies -fvia-C
 214                                | otherwise       -> defaultHscLang
 215
 216    writeIORef v_DynFlags
 217         defaultDynFlags{ coreToDo = core_todo,
 218                          stgToDo  = stg_todo,
 219                          hscLang  = lang,
 220                          -- leave out hscOutName for now
 221                          hscOutName = panic "Main.main:hscOutName not set",
 222
 223                          verbosity = case mode of
 224                                         DoInteractive -> 1
 225                                         DoMake        -> 1
 226                                         _other        -> 0,
 227                         }
 228
 229         -- the rest of the arguments are "dynamic"
 230    srcs <- processArgs dynamic_flags (way_non_static ++ non_static) []
 231         -- save the "initial DynFlags" away
 232    init_dyn_flags <- readIORef v_DynFlags
 233    writeIORef v_InitDynFlags init_dyn_flags
 234
 235         -- complain about any unknown flags
 236    mapM unknownFlagErr [ f | f@('-':_) <- srcs ]
 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_DynFlags init_dyn_flags
 274
 275           -- We compile in two stages, because the file may have an
 276           -- OPTIONS pragma that affects the compilation pipeline (eg. -fvia-C)
 277
 278           let (basename, suffix) = splitFilename src
 279
 280           -- just preprocess
 281           pp <- if not (haskellish_file src) || mode == StopBefore Hsc
 282                         then return src else do
 283                 phases <- genPipeline (StopBefore Hsc) stop_flag
 284                             False{-not persistent-} defaultHscLang src
 285                 pipeLoop phases src False{-no linking-} False{-no -o flag-}
 286                         basename suffix
 287
 288           -- rest of compilation
 289           dyn_flags <- readIORef v_DynFlags
 290           phases <- genPipeline mode stop_flag True (hscLang dyn_flags) pp
 291           r <- pipeLoop phases pp (mode==DoLink || mode==DoMkDLL) True{-use -o flag-}
 292                         basename suffix
 293           return r
 294
 295    o_files <- mapM compileFile srcs
 296
 297    when (mode == DoMkDependHS) endMkDependHS
 298    when (mode == DoLink) (doLink o_files)
 299    when (mode == DoMkDLL) (doMkDLL o_files)
 300
 301         -- grab the last -B option on the command line, and
 302         -- set topDir to its value.
 303 setTopDir :: [String] -> IO [String]
 304 setTopDir args = do
 305   let (minusbs, others) = partition (prefixMatch "-B") args
 306   (case minusbs of
 307     []   -> writeIORef v_TopDir clibdir
 308     some -> writeIORef v_TopDir (drop 2 (last some)))
 309   return others
 310
 311 beginMake :: [String] -> IO ()
 312 beginMake fileish_args
 313   = do let (objs, mods) = partition objish_file fileish_args
 314        mapM (add v_Ld_inputs) objs
 315
 316        case mods of
 317          []    -> throwDyn (UsageError "no input files")
 318          [mod] -> do state <- cmInit Batch
 319                      cmLoadModule state mod
 320                      return ()
 321          _     -> throwDyn (UsageError "only one module allowed with --make")
 322
 323
 324 beginInteractive :: [String] -> IO ()
 325 #ifndef GHCI
 326 beginInteractive = throwDyn (OtherError "not built for interactive use")
 327 #else
 328 beginInteractive fileish_args
 329   = do minus_ls <- readIORef v_Cmdline_libraries
 330
 331        let (objs, mods) = partition objish_file fileish_args
 332            libs = map Left objs ++ map Right minus_ls
 333
 334        state <- cmInit Interactive
 335        case mods of
 336           []    -> interactiveUI state Nothing    libs
 337           [mod] -> interactiveUI state (Just mod) libs
 338           _     -> throwDyn (UsageError
 339                              "only one module allowed with --interactive")
 340 #endif