ghc/compiler/main/Main.hs

   1 {-# OPTIONS -fno-warn-incomplete-patterns #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: Main.hs,v 1.39 2000/12/12 14:42:43 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 Interpreter
  21 import InteractiveUI
  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(..) )
  37 import CmdLineOpts      ( HscLang(..), DynFlags(..), v_Static_hsc_opts )
  38 import TmpFiles
  39 import Finder           ( initFinder )
  40 import CmStaticInfo
  41 import Config
  42 import Util
  43
  44
  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 -- mkDLL
  72 -- java generation
  73 -- user ways
  74 -- Win32 support: proper signal handling
  75 -- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too
  76 -- reading the package configuration file is too slow
  77 -- -H, -K, -Rghc-timing
  78 -- hi-diffs
  79 -- -ddump-all doesn't do anything
  80
  81 -----------------------------------------------------------------------------
  82 -- Differences vs. old driver:
  83
  84 -- No more "Enter your Haskell program, end with ^D (on a line of its own):"
  85 -- consistency checking removed (may do this properly later)
  86 -- removed -noC
  87 -- no hi diffs (could be added later)
  88 -- no -Ofile
  89
  90 -----------------------------------------------------------------------------
  91 -- Main loop
  92
  93 main =
  94   -- top-level exception handler: any unrecognised exception is a compiler bug.
  95   handle (\exception -> hPutStr stderr (show (Panic (show exception)))) $ do
  96
  97   -- all error messages are propagated as exceptions
  98   handleDyn (\dyn -> case dyn of
  99                           PhaseFailed _phase code -> exitWith code
 100                           Interrupted -> exitWith (ExitFailure 1)
 101                           _ -> do hPutStrLn stderr (show (dyn :: GhcException))
 102                                   exitWith (ExitFailure 1)
 103               ) $ do
 104
 105    -- make sure we clean up after ourselves
 106    later (do  forget_it <- readIORef v_Keep_tmp_files
 107               unless forget_it $ do
 108               verb <- dynFlag verbosity
 109               cleanTempFiles (verb >= 2)
 110      ) $ do
 111         -- exceptions will be blocked while we clean the temporary files,
 112         -- so there shouldn't be any difficulty if we receive further
 113         -- signals.
 114
 115         -- install signal handlers
 116    main_thread <- myThreadId
 117 #ifndef mingw32_TARGET_OS
 118    let sig_handler = Catch (throwTo main_thread
 119                                 (DynException (toDyn Interrupted)))
 120    installHandler sigQUIT sig_handler Nothing
 121    installHandler sigINT  sig_handler Nothing
 122 #endif
 123
 124    argv   <- getArgs
 125
 126         -- grab any -B options from the command line first
 127    argv'  <- setTopDir argv
 128    top_dir <- readIORef v_TopDir
 129
 130    let installed s = top_dir ++ '/':s
 131        inplace s   = top_dir ++ '/':cCURRENT_DIR ++ '/':s
 132
 133        installed_pkgconfig = installed ("package.conf")
 134        inplace_pkgconfig   = inplace (cGHC_DRIVER_DIR ++ "/package.conf.inplace")
 135
 136         -- discover whether we're running in a build tree or in an installation,
 137         -- by looking for the package configuration file.
 138    am_installed <- doesFileExist installed_pkgconfig
 139
 140    if am_installed
 141         then writeIORef v_Path_package_config installed_pkgconfig
 142         else do am_inplace <- doesFileExist inplace_pkgconfig
 143                 if am_inplace
 144                     then writeIORef v_Path_package_config inplace_pkgconfig
 145                     else throwDyn (OtherError "can't find package.conf")
 146
 147         -- set the location of our various files
 148    if am_installed
 149         then do writeIORef v_Path_usage (installed "ghc-usage.txt")
 150                 writeIORef v_Pgm_L (installed "unlit")
 151                 writeIORef v_Pgm_m (installed "ghc-asm")
 152                 writeIORef v_Pgm_s (installed "ghc-split")
 153
 154         else do writeIORef v_Path_usage (inplace (cGHC_DRIVER_DIR ++ "/ghc-usage.txt"))
 155                 writeIORef v_Pgm_L (inplace cGHC_UNLIT)
 156                 writeIORef v_Pgm_m (inplace cGHC_MANGLER)
 157                 writeIORef v_Pgm_s (inplace cGHC_SPLIT)
 158
 159         -- read the package configuration
 160    conf_file <- readIORef v_Path_package_config
 161    contents <- readFile conf_file
 162    let pkg_details = read contents      -- ToDo: faster
 163    writeIORef v_Package_details pkg_details
 164
 165         -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
 166    (flags2, mode, stop_flag) <- getGhcMode argv'
 167    writeIORef v_GhcMode mode
 168
 169         -- process all the other arguments, and get the source files
 170    non_static <- processArgs static_flags flags2 []
 171
 172         -- find the build tag, and re-process the build-specific options
 173    more_opts <- findBuildTag
 174    way_non_static <- processArgs static_flags more_opts []
 175
 176         -- give the static flags to hsc
 177    static_opts <- buildStaticHscOpts
 178    writeIORef v_Static_hsc_opts static_opts
 179
 180         -- warnings
 181    warn_level <- readIORef v_Warning_opt
 182
 183    let warn_opts =  case warn_level of
 184                         W_default -> standardWarnings
 185                         W_        -> minusWOpts
 186                         W_all     -> minusWallOpts
 187                         W_not     -> []
 188
 189         -- build the default DynFlags (these may be adjusted on a per
 190         -- module basis by OPTIONS pragmas and settings in the interpreter).
 191
 192    core_todo <- buildCoreToDo
 193    stg_todo  <- buildStgToDo
 194
 195    -- set the "global" HscLang.  The HscLang can be further adjusted on a module
 196    -- by module basis, using only the -fvia-C and -fasm flags.  If the global
 197    -- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect.
 198    opt_level  <- readIORef v_OptLevel
 199    let lang = case mode of
 200                  StopBefore HCc -> HscC
 201                  DoInteractive  -> HscInterpreted
 202                  _other        | opt_level >= 1  -> HscC  -- -O implies -fvia-C
 203                                | otherwise       -> defaultHscLang
 204
 205    writeIORef v_DynFlags
 206         DynFlags{ coreToDo = core_todo,
 207                   stgToDo  = stg_todo,
 208                   hscLang  = lang,
 209                   -- leave out hscOutName for now
 210                   hscOutName = panic "Main.main:hscOutName not set",
 211
 212                   verbosity = case mode of
 213                                 DoInteractive -> 1
 214                                 DoMake        -> 1
 215                                 _other        -> 0,
 216
 217                   flags = [] }
 218
 219         -- the rest of the arguments are "dynamic"
 220    srcs <- processArgs dynamic_flags (way_non_static ++
 221                                         non_static ++ warn_opts) []
 222         -- save the "initial DynFlags" away
 223    init_dyn_flags <- readIORef v_DynFlags
 224    writeIORef v_InitDynFlags init_dyn_flags
 225
 226         -- complain about any unknown flags
 227    mapM unknownFlagErr [ f | f@('-':_) <- srcs ]
 228
 229         -- save the flag state, because this could be modified by OPTIONS
 230         -- pragmas during the compilation, and we'll need to restore it
 231         -- before starting the next compilation.
 232    saved_driver_state <- readIORef v_Driver_state
 233    writeIORef v_InitDriverState saved_driver_state
 234
 235    verb <- dynFlag verbosity
 236
 237    when (verb >= 2)
 238         (do hPutStr stderr "Glasgow Haskell Compiler, Version "
 239             hPutStr stderr cProjectVersion
 240             hPutStr stderr ", for Haskell 98, compiled by GHC version "
 241             hPutStrLn stderr cBooterVersion)
 242
 243    when (verb >= 2)
 244         (hPutStrLn stderr ("Using package config file: " ++ conf_file))
 245
 246         -- initialise the finder
 247    pkg_avails <- getPackageInfo
 248    initFinder pkg_avails
 249
 250         -- mkdependHS is special
 251    when (mode == DoMkDependHS) beginMkDependHS
 252
 253         -- make/interactive require invoking the compilation manager
 254    if (mode == DoMake)        then beginMake srcs        else do
 255    if (mode == DoInteractive) then beginInteractive srcs else do
 256
 257         -- for each source file, find which phases to run
 258    let lang = hscLang init_dyn_flags
 259    pipelines <- mapM (genPipeline mode stop_flag True lang) srcs
 260    let src_pipelines = zip srcs pipelines
 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))
 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, phases) = do
 272           writeIORef v_Driver_state saved_driver_state
 273           writeIORef v_DynFlags init_dyn_flags
 274           r <- runPipeline phases src (mode==DoLink) True
 275           return r
 276
 277    o_files <- mapM compileFile src_pipelines
 278
 279    when (mode == DoMkDependHS) endMkDependHS
 280    when (mode == DoLink) (doLink o_files)
 281
 282         -- grab the last -B option on the command line, and
 283         -- set topDir to its value.
 284 setTopDir :: [String] -> IO [String]
 285 setTopDir args = do
 286   let (minusbs, others) = partition (prefixMatch "-B") args
 287   (case minusbs of
 288     []   -> writeIORef v_TopDir clibdir
 289     some -> writeIORef v_TopDir (drop 2 (last some)))
 290   return others
 291
 292 beginMake :: [String] -> IO ()
 293 beginMake mods
 294   = do case mods of
 295          []    -> throwDyn (UsageError "no input files")
 296          [mod] -> do state <- cmInit Batch
 297                      cmLoadModule state mod
 298                      return ()
 299          _     -> throwDyn (UsageError "only one module allowed with --make")
 300
 301
 302 beginInteractive :: [String] -> IO ()
 303 #ifndef GHCI
 304 beginInteractive = throwDyn (OtherError "not build for interactive use")
 305 #else
 306 beginInteractive mods
 307   = do state <- cmInit Interactive
 308        let mod = case mods of
 309                 []    -> Nothing
 310                 [mod] -> Just mod
 311                 _     -> throwDyn (UsageError
 312                                     "only one module allowed with --interactive")
 313        interactiveUI state mod
 314 #endif