ghc/compiler/main/Main.hs

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