ghc/compiler/main/Main.hs

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