ghc/compiler/main/Main.hs

   1 {-# OPTIONS -W -fno-warn-incomplete-patterns #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: Main.hs,v 1.34 2000/11/24 17:02:02 simonpj 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   -- 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 :: BarfKind))
  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 >= 2)
 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 (OtherError "can't find package.conf")
 143
 144         -- set the location of our various files
 145    if am_installed
 146         then do writeIORef v_Path_usage (installed "ghc-usage.txt")
 147                 writeIORef v_Pgm_L (installed "unlit")
 148                 writeIORef v_Pgm_m (installed "ghc-asm")
 149                 writeIORef v_Pgm_s (installed "ghc-split")
 150
 151         else do writeIORef v_Path_usage (inplace (cGHC_DRIVER_DIR ++ "/ghc-usage.txt"))
 152                 writeIORef v_Pgm_L (inplace cGHC_UNLIT)
 153                 writeIORef v_Pgm_m (inplace cGHC_MANGLER)
 154                 writeIORef v_Pgm_s (inplace cGHC_SPLIT)
 155
 156         -- read the package configuration
 157    conf_file <- readIORef v_Path_package_config
 158    contents <- readFile conf_file
 159    let pkg_details = read contents      -- ToDo: faster
 160    writeIORef v_Package_details pkg_details
 161
 162         -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
 163    (flags2, mode, stop_flag) <- getGhcMode argv'
 164    writeIORef v_GhcMode mode
 165
 166         -- process all the other arguments, and get the source files
 167    non_static <- processArgs static_flags flags2 []
 168
 169         -- find the build tag, and re-process the build-specific options
 170    more_opts <- findBuildTag
 171    way_non_static <- processArgs static_flags more_opts []
 172
 173         -- give the static flags to hsc
 174    static_opts <- buildStaticHscOpts
 175    writeIORef v_Static_hsc_opts static_opts
 176
 177         -- warnings
 178    warn_level <- readIORef v_Warning_opt
 179
 180    let warn_opts =  case warn_level of
 181                         W_default -> standardWarnings
 182                         W_        -> minusWOpts
 183                         W_all     -> minusWallOpts
 184                         W_not     -> []
 185
 186         -- build the default DynFlags (these may be adjusted on a per
 187         -- module basis by OPTIONS pragmas and settings in the interpreter).
 188
 189    core_todo <- buildCoreToDo
 190    stg_todo  <- buildStgToDo
 191
 192    -- set the "global" HscLang.  The HscLang can be further adjusted on a module
 193    -- by module basis, using only the -fvia-C and -fasm flags.  If the global
 194    -- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect.
 195    opt_level  <- readIORef v_OptLevel
 196    let lang = case mode of
 197                  StopBefore HCc -> HscC
 198                  DoInteractive  -> HscInterpreted
 199                  _other        | opt_level >= 1  -> HscC  -- -O implies -fvia-C
 200                                | otherwise       -> defaultHscLang
 201
 202    writeIORef v_DynFlags
 203         DynFlags{ coreToDo = core_todo,
 204                   stgToDo  = stg_todo,
 205                   hscLang  = lang,
 206                   -- leave out hscOutName for now
 207                   hscOutName = panic "Main.main:hscOutName not set",
 208
 209                   verbosity = case mode of
 210                                 DoInteractive -> 1
 211                                 DoMake        -> 1
 212                                 _other        -> 0,
 213
 214                   flags = [] }
 215
 216         -- the rest of the arguments are "dynamic"
 217    srcs <- processArgs dynamic_flags (way_non_static ++
 218                                         non_static ++ warn_opts) []
 219         -- save the "initial DynFlags" away
 220    init_dyn_flags <- readIORef v_DynFlags
 221    writeIORef v_InitDynFlags init_dyn_flags
 222
 223         -- complain about any unknown flags
 224    mapM unknownFlagErr [ f | f@('-':_) <- srcs ]
 225
 226         -- save the flag state, because this could be modified by OPTIONS
 227         -- pragmas during the compilation, and we'll need to restore it
 228         -- before starting the next compilation.
 229    saved_driver_state <- readIORef v_Driver_state
 230    writeIORef v_InitDriverState saved_driver_state
 231
 232    verb <- dynFlag verbosity
 233
 234    when (verb >= 2)
 235         (do hPutStr stderr "Glasgow Haskell Compiler, Version "
 236             hPutStr stderr cProjectVersion
 237             hPutStr stderr ", for Haskell 98, compiled by GHC version "
 238             hPutStrLn stderr cBooterVersion)
 239
 240    when (verb >= 2)
 241         (hPutStrLn stderr ("Using package config file: " ++ conf_file))
 242
 243         -- initialise the finder
 244    pkg_avails <- getPackageInfo
 245    initFinder pkg_avails
 246
 247         -- mkdependHS is special
 248    when (mode == DoMkDependHS) beginMkDependHS
 249
 250         -- make/interactive require invoking the compilation manager
 251    if (mode == DoMake)        then beginMake srcs        else do
 252    if (mode == DoInteractive) then beginInteractive srcs else do
 253
 254         -- for each source file, find which phases to run
 255    let lang = hscLang init_dyn_flags
 256    pipelines <- mapM (genPipeline mode stop_flag True lang) srcs
 257    let src_pipelines = zip srcs pipelines
 258
 259         -- sanity checking
 260    o_file <- readIORef v_Output_file
 261    ohi    <- readIORef v_Output_hi
 262    if length srcs > 1 && (isJust ohi || (isJust o_file && mode /= DoLink))
 263         then throwDyn (UsageError "can't apply -o or -ohi options to multiple source files")
 264         else do
 265
 266    if null srcs then throwDyn (UsageError "no input files") else do
 267
 268    let compileFile (src, phases) = do
 269           writeIORef v_Driver_state saved_driver_state
 270           writeIORef v_DynFlags init_dyn_flags
 271           r <- runPipeline phases src (mode==DoLink) True
 272           return r
 273
 274    o_files <- mapM compileFile src_pipelines
 275
 276    when (mode == DoMkDependHS) endMkDependHS
 277    when (mode == DoLink) (doLink o_files)
 278
 279         -- grab the last -B option on the command line, and
 280         -- set topDir to its value.
 281 setTopDir :: [String] -> IO [String]
 282 setTopDir args = do
 283   let (minusbs, others) = partition (prefixMatch "-B") args
 284   (case minusbs of
 285     []   -> writeIORef v_TopDir clibdir
 286     some -> writeIORef v_TopDir (drop 2 (last some)))
 287   return others
 288
 289 beginMake :: [String] -> IO ()
 290 beginMake mods
 291   = do case mods of
 292          []    -> throwDyn (UsageError "no input files")
 293          [mod] -> do state <- cmInit Batch
 294                      cmLoadModule state mod
 295                      return ()
 296          _     -> throwDyn (UsageError "only one module allowed with --make")
 297
 298
 299 beginInteractive :: [String] -> IO ()
 300 #ifndef GHCI
 301 beginInteractive = throwDyn (OtherError "not build for interactive use")
 302 #else
 303 beginInteractive mods
 304   = do state <- cmInit Interactive
 305        (state', ok, ms)
 306           <- case mods of
 307                 []    -> return (state, True, [])
 308                 [mod] -> cmLoadModule state mod
 309                 _     -> throwDyn (UsageError
 310                                     "only one module allowed with --interactive")
 311        interactiveUI state' ms
 312 #endif