ghc/compiler/main/Main.hs

   1 {-# OPTIONS -fno-warn-incomplete-patterns #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: Main.hs,v 1.66 2001/05/28 03:31:19 sof 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 ParsePkgConf
  30 import DriverPipeline
  31 import DriverState
  32 import DriverFlags
  33 import DriverMkDepend
  34 import DriverUtil
  35 import Panic
  36 import DriverPhases     ( Phase(..), haskellish_src_file, objish_file )
  37 import CmdLineOpts
  38 import TmpFiles
  39 import Finder           ( initFinder )
  40 import CmStaticInfo
  41 import Config
  42 import Outputable
  43 import Util
  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 (InstallationError
 143                                      ("Can't find package.conf in " ++
 144                                       inplace_pkgconfig))
 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 #if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
 153                 writeIORef v_Pgm_T (installed cTOUCH)
 154 #endif
 155
 156         else do writeIORef v_Path_usage (inplace (cGHC_DRIVER_DIR ++ "/ghc-usage.txt"))
 157                 writeIORef v_Pgm_L (inplace cGHC_UNLIT)
 158                 writeIORef v_Pgm_m (inplace cGHC_MANGLER)
 159                 writeIORef v_Pgm_s (inplace cGHC_SPLIT)
 160 #if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
 161                 writeIORef v_Pgm_T (inplace cTOUCH)
 162 #endif
 163
 164         -- read the package configuration
 165    conf_file <- readIORef v_Path_package_config
 166    r <- parsePkgConf conf_file
 167    case r of {
 168         Left err -> throwDyn (InstallationError (showSDoc err));
 169         Right pkg_details -> do
 170
 171    writeIORef v_Package_details pkg_details
 172
 173         -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
 174    (flags2, mode, stop_flag) <- getGhcMode argv'
 175    writeIORef v_GhcMode mode
 176
 177         -- Show the GHCi banner?
 178 #  ifdef GHCI
 179    when (mode == DoInteractive) $
 180       hPutStrLn stdout ghciWelcomeMsg
 181 #  endif
 182
 183         -- process all the other arguments, and get the source files
 184    non_static <- processArgs static_flags flags2 []
 185
 186         -- -O and --interactive are not a good combination
 187         -- ditto with any kind of way selection
 188    orig_opt_level <- readIORef v_OptLevel
 189    when (orig_opt_level > 0 && mode == DoInteractive) $
 190       do putStr "warning: -O conflicts with --interactive; -O turned off.\n"
 191          writeIORef v_OptLevel 0
 192    orig_ways <- readIORef v_Ways
 193    when (not (null orig_ways) && mode == DoInteractive) $
 194       do throwDyn (UsageError
 195                    "--interactive can't be used with -prof, -ticky, -unreg or -smp.")
 196
 197         -- Find the build tag, and re-process the build-specific options.
 198         -- Also add in flags for unregisterised compilation, if
 199         -- GhcUnregisterised=YES.
 200    way_opts <- findBuildTag
 201    let unreg_opts | cGhcUnregisterised == "YES" = unregFlags
 202                   | otherwise = []
 203    way_non_static <- processArgs static_flags (unreg_opts ++ way_opts) []
 204
 205         -- give the static flags to hsc
 206    static_opts <- buildStaticHscOpts
 207    writeIORef v_Static_hsc_opts static_opts
 208
 209    -- build the default DynFlags (these may be adjusted on a per
 210    -- module basis by OPTIONS pragmas and settings in the interpreter).
 211
 212    core_todo <- buildCoreToDo
 213    stg_todo  <- buildStgToDo
 214
 215    -- set the "global" HscLang.  The HscLang can be further adjusted on a module
 216    -- by module basis, using only the -fvia-C and -fasm flags.  If the global
 217    -- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect.
 218    opt_level  <- readIORef v_OptLevel
 219
 220
 221    let lang = case mode of
 222                  StopBefore HCc -> HscC
 223                  DoInteractive  -> HscInterpreted
 224                  _other        | opt_level >= 1  -> HscC  -- -O implies -fvia-C
 225                                | otherwise       -> defaultHscLang
 226
 227    writeIORef v_DynFlags
 228         defaultDynFlags{ coreToDo = core_todo,
 229                          stgToDo  = stg_todo,
 230                          hscLang  = lang,
 231                          -- leave out hscOutName for now
 232                          hscOutName = panic "Main.main:hscOutName not set",
 233
 234                          verbosity = case mode of
 235                                         DoInteractive -> 1
 236                                         DoMake        -> 1
 237                                         _other        -> 0,
 238                         }
 239
 240         -- the rest of the arguments are "dynamic"
 241    srcs <- processArgs dynamic_flags (way_non_static ++ non_static) []
 242         -- save the "initial DynFlags" away
 243    init_dyn_flags <- readIORef v_DynFlags
 244    writeIORef v_InitDynFlags init_dyn_flags
 245
 246         -- complain about any unknown flags
 247    mapM unknownFlagErr [ f | f@('-':_) <- srcs ]
 248
 249    verb <- dynFlag verbosity
 250
 251    when (verb >= 2)
 252         (do hPutStr stderr "Glasgow Haskell Compiler, Version "
 253             hPutStr stderr cProjectVersion
 254             hPutStr stderr ", for Haskell 98, compiled by GHC version "
 255             hPutStrLn stderr cBooterVersion)
 256
 257    when (verb >= 2)
 258         (hPutStrLn stderr ("Using package config file: " ++ conf_file))
 259
 260    when (verb >= 3)
 261         (hPutStrLn stderr ("Hsc static flags: " ++ unwords static_opts))
 262
 263         -- initialise the finder
 264    pkg_avails <- getPackageInfo
 265    initFinder pkg_avails
 266
 267         -- mkdependHS is special
 268    when (mode == DoMkDependHS) beginMkDependHS
 269
 270         -- -ohi sanity checking
 271    ohi    <- readIORef v_Output_hi
 272    if (isJust ohi &&
 273         (mode == DoMake || mode == DoInteractive || length srcs > 1))
 274         then throwDyn (UsageError "-ohi can only be used when compiling a single source file")
 275         else do
 276
 277         -- make/interactive require invoking the compilation manager
 278    if (mode == DoMake)        then beginMake srcs        else do
 279    if (mode == DoInteractive) then beginInteractive srcs else do
 280
 281         -- -o sanity checking
 282    o_file <- readIORef v_Output_file
 283    if (length srcs > 1 && isJust o_file && mode /= DoLink && mode /= DoMkDLL)
 284         then throwDyn (UsageError "can't apply -o to multiple source files")
 285         else do
 286
 287    if null srcs then throwDyn (UsageError "no input files") else do
 288
 289    let compileFile src = do
 290           writeIORef v_DynFlags init_dyn_flags
 291
 292           exists <- doesFileExist src
 293           when (not exists) $
 294                 throwDyn (CmdLineError ("file `" ++ src ++ "' does not exist"))
 295
 296           -- We compile in two stages, because the file may have an
 297           -- OPTIONS pragma that affects the compilation pipeline (eg. -fvia-C)
 298           let (basename, suffix) = splitFilename src
 299
 300           -- just preprocess (Haskell source only)
 301           pp <- if not (haskellish_src_file src) || mode == StopBefore Hsc
 302                         then return src else do
 303                 phases <- genPipeline (StopBefore Hsc) stop_flag
 304                             False{-not persistent-} defaultHscLang src
 305                 pipeLoop phases src False{-no linking-} False{-no -o flag-}
 306                         basename suffix
 307
 308           -- rest of compilation
 309           dyn_flags <- readIORef v_DynFlags
 310           phases <- genPipeline mode stop_flag True (hscLang dyn_flags) pp
 311           r <- pipeLoop phases pp (mode==DoLink || mode==DoMkDLL) True{-use -o flag-}
 312                         basename suffix
 313           return r
 314
 315    o_files <- mapM compileFile srcs
 316
 317    when (mode == DoMkDependHS) endMkDependHS
 318    when (mode == DoLink) (doLink o_files)
 319    when (mode == DoMkDLL) (doMkDLL o_files)
 320   }
 321         -- grab the last -B option on the command line, and
 322         -- set topDir to its value.
 323 setTopDir :: [String] -> IO [String]
 324 setTopDir args = do
 325   let (minusbs, others) = partition (prefixMatch "-B") args
 326   (case minusbs of
 327     []   -> throwDyn (InstallationError ("missing -B<dir> option"))
 328     some -> writeIORef v_TopDir (drop 2 (last some)))
 329   return others
 330
 331 beginMake :: [String] -> IO ()
 332 beginMake fileish_args
 333   = do let (objs, mods) = partition objish_file fileish_args
 334        mapM (add v_Ld_inputs) objs
 335
 336        case mods of
 337          []    -> throwDyn (UsageError "no input files")
 338          [mod] -> do state <- cmInit Batch
 339                      cmLoadModule state mod
 340                      return ()
 341          _     -> throwDyn (UsageError "only one module allowed with --make")
 342
 343
 344 beginInteractive :: [String] -> IO ()
 345 #ifndef GHCI
 346 beginInteractive = throwDyn (CmdLineError "not built for interactive use")
 347 #else
 348 beginInteractive fileish_args
 349   = do minus_ls <- readIORef v_Cmdline_libraries
 350
 351        let (objs, mods) = partition objish_file fileish_args
 352            libs = map Left objs ++ map Right minus_ls
 353
 354        state <- cmInit Interactive
 355        case mods of
 356           []    -> interactiveUI state Nothing    libs
 357           [mod] -> interactiveUI state (Just mod) libs
 358           _     -> throwDyn (UsageError
 359                              "only one module allowed with --interactive")
 360 #endif