ghc/compiler/main/Main.hs

   1 {-# OPTIONS -fno-warn-incomplete-patterns #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: Main.hs,v 1.53 2001/02/14 11:36:07 sewardj 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 Char             ( toLower )
  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 -- mkDLL
  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")
 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    contents <- readFile conf_file
 160    let pkg_details = read contents      -- ToDo: faster
 161    writeIORef v_Package_details pkg_details
 162
 163         -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
 164    (flags2, mode, stop_flag) <- getGhcMode argv'
 165    writeIORef v_GhcMode mode
 166
 167         -- Show the GHCi banner?
 168 #  ifdef GHCI
 169    when (mode == DoInteractive) $
 170       hPutStrLn stdout ghciWelcomeMsg
 171 #  endif
 172
 173         -- process all the other arguments, and get the source files
 174    non_static <- processArgs static_flags flags2 []
 175
 176         -- -O and --interactive are not a good combination
 177         -- ditto with any kind of way selection
 178    orig_opt_level <- readIORef v_OptLevel
 179    when (orig_opt_level > 0 && mode == DoInteractive) $
 180       do putStr "warning: -O conflicts with --interactive; -O turned off.\n"
 181          writeIORef v_OptLevel 0
 182    orig_ways <- readIORef v_Ways
 183    when (not (null orig_ways) && mode == DoInteractive) $
 184       do throwDyn (OtherError
 185                    "--interactive can't be used with -prof, -ticky, -unreg or -smp.")
 186
 187         -- Find the build tag, and re-process the build-specific options.
 188         -- Also add in flags for unregisterised compilation, if
 189         -- GhcUnregisterised=YES.
 190    way_opts <- findBuildTag
 191    let unreg_opts | cGhcUnregisterised == "YES" = unregFlags
 192                   | otherwise = []
 193    way_non_static <- processArgs static_flags (unreg_opts ++ way_opts) []
 194
 195         -- give the static flags to hsc
 196    static_opts <- buildStaticHscOpts
 197    writeIORef v_Static_hsc_opts static_opts
 198
 199         -- warnings
 200    warn_level <- readIORef v_Warning_opt
 201
 202    let warn_opts =  case warn_level of
 203                         W_default -> standardWarnings
 204                         W_        -> minusWOpts
 205                         W_all     -> minusWallOpts
 206                         W_not     -> []
 207
 208    -- build the default DynFlags (these may be adjusted on a per
 209    -- module basis by OPTIONS pragmas and settings in the interpreter).
 210
 211    core_todo <- buildCoreToDo
 212    stg_todo  <- buildStgToDo
 213
 214    -- set the "global" HscLang.  The HscLang can be further adjusted on a module
 215    -- by module basis, using only the -fvia-C and -fasm flags.  If the global
 216    -- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect.
 217    opt_level  <- readIORef v_OptLevel
 218
 219
 220    let lang = case mode of
 221                  StopBefore HCc -> HscC
 222                  DoInteractive  -> HscInterpreted
 223                  _other        | opt_level >= 1  -> HscC  -- -O implies -fvia-C
 224                                | otherwise       -> defaultHscLang
 225
 226    writeIORef v_DynFlags
 227         defaultDynFlags{ coreToDo = core_todo,
 228                          stgToDo  = stg_todo,
 229                          hscLang  = lang,
 230                          -- leave out hscOutName for now
 231                          hscOutName = panic "Main.main:hscOutName not set",
 232
 233                          verbosity = case mode of
 234                                         DoInteractive -> 1
 235                                         DoMake        -> 1
 236                                         _other        -> 0,
 237                         }
 238
 239         -- the rest of the arguments are "dynamic"
 240    srcs <- processArgs dynamic_flags (way_non_static ++
 241                                         non_static ++ warn_opts) []
 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         -- make/interactive require invoking the compilation manager
 271    if (mode == DoMake)        then beginMake srcs        else do
 272    if (mode == DoInteractive) then beginInteractive srcs else do
 273
 274         -- sanity checking
 275    o_file <- readIORef v_Output_file
 276    ohi    <- readIORef v_Output_hi
 277    if length srcs > 1 && (isJust ohi || (isJust o_file && mode /= DoLink && mode /= DoMkDLL))
 278         then throwDyn (UsageError "can't apply -o or -ohi options to multiple source files")
 279         else do
 280
 281    if null srcs then throwDyn (UsageError "no input files") else do
 282
 283    let compileFile src = do
 284           writeIORef v_DynFlags init_dyn_flags
 285
 286           -- We compile in two stages, because the file may have an
 287           -- OPTIONS pragma that affects the compilation pipeline (eg. -fvia-C)
 288
 289           let (basename, suffix) = splitFilename src
 290
 291           -- just preprocess
 292           pp <- if not (haskellish_file src) || mode == StopBefore Hsc
 293                         then return src else do
 294                 phases <- genPipeline (StopBefore Hsc) stop_flag
 295                             False{-not persistent-} defaultHscLang src
 296                 pipeLoop phases src False{-no linking-} False{-no -o flag-}
 297                         basename suffix
 298
 299           -- rest of compilation
 300           dyn_flags <- readIORef v_DynFlags
 301           phases <- genPipeline mode stop_flag True (hscLang dyn_flags) pp
 302           r <- pipeLoop phases pp (mode==DoLink || mode==DoMkDLL) True{-use -o flag-}
 303                         basename suffix
 304           return r
 305
 306    o_files <- mapM compileFile srcs
 307
 308    when (mode == DoMkDependHS) endMkDependHS
 309    when (mode == DoLink) (doLink o_files)
 310    when (mode == DoMkDLL) (doMkDLL o_files)
 311
 312         -- grab the last -B option on the command line, and
 313         -- set topDir to its value.
 314 setTopDir :: [String] -> IO [String]
 315 setTopDir args = do
 316   let (minusbs, others) = partition (prefixMatch "-B") args
 317   (case minusbs of
 318     []   -> writeIORef v_TopDir clibdir
 319     some -> writeIORef v_TopDir (drop 2 (last some)))
 320   return others
 321
 322 beginMake :: [String] -> IO ()
 323 beginMake mods
 324   = do case mods of
 325          []    -> throwDyn (UsageError "no input files")
 326          [mod] -> do state <- cmInit Batch
 327                      cmLoadModule state mod
 328                      return ()
 329          _     -> throwDyn (UsageError "only one module allowed with --make")
 330
 331
 332 beginInteractive :: [String] -> IO ()
 333 #ifndef GHCI
 334 beginInteractive = throwDyn (OtherError "not built for interactive use")
 335 #else
 336 beginInteractive fileish_args
 337   = do minus_ls <- readIORef v_Cmdline_libraries
 338        let is_libraryish nm
 339               = let nmr = map toLower (reverse nm)
 340                     in take 2 nmr == "o."
 341            libs = map Left (filter is_libraryish fileish_args)
 342                   ++ map Right minus_ls
 343            mods = filter (not.is_libraryish) fileish_args
 344            mod = case mods of
 345                     []    -> Nothing
 346                     [mod] -> Just mod
 347                     _     -> throwDyn (UsageError
 348                                        "only one module allowed with --interactive")
 349        state <- cmInit Interactive
 350        interactiveUI state mod libs
 351 #endif