ghc/compiler/main/Main.hs

   1 {-# OPTIONS -W -fno-warn-incomplete-patterns #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: Main.hs,v 1.24 2000/11/16 15:57:06 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 import CompManager
  19 import Interpreter
  20 #ifdef GHCI
  21 import InteractiveUI
  22 #endif
  23 import DriverPipeline
  24 import DriverState
  25 import DriverFlags
  26 import DriverMkDepend
  27 import DriverUtil
  28 import Panic
  29 import DriverPhases     ( Phase(..) )
  30 import CmdLineOpts      ( HscLang(..), DynFlags(..), v_Static_hsc_opts )
  31 import Module           ( mkModuleName )
  32 import TmpFiles
  33 import Finder           ( initFinder )
  34 import CmStaticInfo
  35 import Config
  36 import Util
  37
  38 import Concurrent
  39 #ifndef mingw32_TARGET_OS
  40 import Posix
  41 #endif
  42 import Directory
  43 import IOExts
  44 import Exception
  45 import Dynamic
  46
  47 import IO
  48 import Monad
  49 import List
  50 import System
  51 import Maybe
  52
  53
  54 -----------------------------------------------------------------------------
  55 -- Changes:
  56
  57 -- * -fglasgow-exts NO LONGER IMPLIES -package lang!!!  (-fglasgow-exts is a
  58 --   dynamic flag whereas -package is a static flag.)
  59
  60 -----------------------------------------------------------------------------
  61 -- ToDo:
  62
  63 -- -nohi doesn't work
  64 -- new mkdependHS doesn't support all the options that the old one did (-X et al.)
  65 -- time commands when run with -v
  66 -- split marker
  67 -- mkDLL
  68 -- java generation
  69 -- user ways
  70 -- Win32 support: proper signal handling
  71 -- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too
  72 -- reading the package configuration file is too slow
  73 -- -H, -K, -Rghc-timing
  74 -- hi-diffs
  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 hi diffs (could be added later)
  83 -- no -Ofile
  84
  85 -----------------------------------------------------------------------------
  86 -- Main loop
  87
  88 main =
  89   -- all error messages are propagated as exceptions
  90   handleDyn (\dyn -> case dyn of
  91                           PhaseFailed _phase code -> exitWith code
  92                           Interrupted -> exitWith (ExitFailure 1)
  93                           _ -> do hPutStrLn stderr (show (dyn :: BarfKind))
  94                                   exitWith (ExitFailure 1)
  95               ) $ do
  96
  97    -- make sure we clean up after ourselves
  98    later (do  forget_it <- readIORef v_Keep_tmp_files
  99               unless forget_it $ do
 100               verb <- readIORef v_Verbose
 101               cleanTempFiles verb
 102      ) $ do
 103         -- exceptions will be blocked while we clean the temporary files,
 104         -- so there shouldn't be any difficulty if we receive further
 105         -- signals.
 106
 107         -- install signal handlers
 108    main_thread <- myThreadId
 109 #ifndef mingw32_TARGET_OS
 110    let sig_handler = Catch (throwTo main_thread
 111                                 (DynException (toDyn Interrupted)))
 112    installHandler sigQUIT sig_handler Nothing
 113    installHandler sigINT  sig_handler Nothing
 114 #endif
 115
 116    pgm    <- getProgName
 117    writeIORef v_Prog_name pgm
 118
 119    argv   <- getArgs
 120
 121         -- grab any -B options from the command line first
 122    argv'  <- setTopDir argv
 123    top_dir <- readIORef v_TopDir
 124
 125    let installed s = top_dir ++ '/':s
 126        inplace s   = top_dir ++ '/':cCURRENT_DIR ++ '/':s
 127
 128        installed_pkgconfig = installed ("package.conf")
 129        inplace_pkgconfig   = inplace (cGHC_DRIVER_DIR ++ "/package.conf.inplace")
 130
 131         -- discover whether we're running in a build tree or in an installation,
 132         -- by looking for the package configuration file.
 133    am_installed <- doesFileExist installed_pkgconfig
 134
 135    if am_installed
 136         then writeIORef v_Path_package_config installed_pkgconfig
 137         else do am_inplace <- doesFileExist inplace_pkgconfig
 138                 if am_inplace
 139                     then writeIORef v_Path_package_config inplace_pkgconfig
 140                     else throwDyn (OtherError "can't find package.conf")
 141
 142         -- set the location of our various files
 143    if am_installed
 144         then do writeIORef v_Path_usage (installed "ghc-usage.txt")
 145                 writeIORef v_Pgm_L (installed "unlit")
 146                 writeIORef v_Pgm_m (installed "ghc-asm")
 147                 writeIORef v_Pgm_s (installed "ghc-split")
 148
 149         else do writeIORef v_Path_usage (inplace (cGHC_DRIVER_DIR ++ "/ghc-usage.txt"))
 150                 writeIORef v_Pgm_L (inplace cGHC_UNLIT)
 151                 writeIORef v_Pgm_m (inplace cGHC_MANGLER)
 152                 writeIORef v_Pgm_s (inplace cGHC_SPLIT)
 153
 154         -- read the package configuration
 155    conf_file <- readIORef v_Path_package_config
 156    contents <- readFile conf_file
 157    let pkg_details = read contents      -- ToDo: faster
 158    writeIORef v_Package_details pkg_details
 159
 160         -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
 161    (flags2, mode, stop_flag) <- getGhcMode argv'
 162    writeIORef v_GhcMode mode
 163
 164         -- process all the other arguments, and get the source files
 165    non_static <- processArgs static_flags flags2 []
 166
 167         -- find the build tag, and re-process the build-specific options
 168    more_opts <- findBuildTag
 169    way_non_static <- processArgs static_flags more_opts []
 170
 171         -- give the static flags to hsc
 172    static_opts <- buildStaticHscOpts
 173    writeIORef v_Static_hsc_opts static_opts
 174
 175         -- warnings
 176    warn_level <- readIORef v_Warning_opt
 177
 178    let warn_opts =  case warn_level of
 179                         W_default -> standardWarnings
 180                         W_        -> minusWOpts
 181                         W_all     -> minusWallOpts
 182                         W_not     -> []
 183
 184         -- build the default DynFlags (these may be adjusted on a per
 185         -- module basis by OPTIONS pragmas and settings in the interpreter).
 186
 187    core_todo <- buildCoreToDo
 188    stg_todo  <- buildStgToDo
 189
 190    -- set the "global" HscLang.  The HscLang can be further adjusted on a module
 191    -- by module basis, using only the -fvia-C and -fasm flags.  If the global
 192    -- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect.
 193    opt_level  <- readIORef v_OptLevel
 194    let lang = case mode of
 195                  StopBefore HCc -> HscC
 196                  DoInteractive  -> HscInterpreted
 197                  _other        | opt_level >= 1  -> HscC  -- -O implies -fvia-C
 198                                | otherwise       -> defaultHscLang
 199
 200    writeIORef v_DynFlags
 201         DynFlags{ coreToDo = core_todo,
 202                   stgToDo  = stg_todo,
 203                   hscLang  = lang,
 204                   -- leave out hscOutName for now
 205                   hscOutName = panic "Main.main:hscOutName not set",
 206                   flags = [] }
 207
 208         -- the rest of the arguments are "dynamic"
 209    srcs <- processArgs dynamic_flags (way_non_static ++
 210                                         non_static ++ warn_opts) []
 211         -- save the "initial DynFlags" away
 212    init_dyn_flags <- readIORef v_DynFlags
 213    writeIORef v_InitDynFlags init_dyn_flags
 214
 215         -- complain about any unknown flags
 216    mapM unknownFlagErr [ f | f@('-':_) <- srcs ]
 217
 218         -- get the -v flag
 219    verb <- readIORef v_Verbose
 220
 221    when verb (do hPutStr stderr "Glasgow Haskell Compiler, Version "
 222                  hPutStr stderr cProjectVersion
 223                  hPutStr stderr ", for Haskell 98, compiled by GHC version "
 224                  hPutStrLn stderr cBooterVersion)
 225
 226    when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
 227
 228         -- initialise the finder
 229    initFinder pkg_details
 230
 231         -- mkdependHS is special
 232    when (mode == DoMkDependHS) beginMkDependHS
 233
 234         -- make/interactive require invoking the compilation manager
 235    if (mode == DoMake)        then beginMake pkg_details srcs        else do
 236    if (mode == DoInteractive) then beginInteractive pkg_details srcs else do
 237
 238         -- for each source file, find which phases to run
 239    let lang = hscLang init_dyn_flags
 240    pipelines <- mapM (genPipeline mode stop_flag True lang) srcs
 241    let src_pipelines = zip srcs pipelines
 242
 243         -- sanity checking
 244    o_file <- readIORef v_Output_file
 245    ohi    <- readIORef v_Output_hi
 246    if length srcs > 1 && (isJust ohi || (isJust o_file && mode /= DoLink))
 247         then throwDyn (UsageError "can't apply -o or -ohi options to multiple source files")
 248         else do
 249
 250    if null srcs then throwDyn (UsageError "no input files") else do
 251
 252         -- save the flag state, because this could be modified by OPTIONS
 253         -- pragmas during the compilation, and we'll need to restore it
 254         -- before starting the next compilation.
 255    saved_driver_state <- readIORef v_Driver_state
 256
 257    let compileFile (src, phases) = do
 258           writeIORef v_Driver_state saved_driver_state
 259           writeIORef v_DynFlags init_dyn_flags
 260           r <- runPipeline phases src (mode==DoLink) True
 261           return r
 262
 263    o_files <- mapM compileFile src_pipelines
 264
 265    when (mode == DoMkDependHS) endMkDependHS
 266    when (mode == DoLink) (doLink o_files)
 267
 268         -- grab the last -B option on the command line, and
 269         -- set topDir to its value.
 270 setTopDir :: [String] -> IO [String]
 271 setTopDir args = do
 272   let (minusbs, others) = partition (prefixMatch "-B") args
 273   (case minusbs of
 274     []   -> writeIORef v_TopDir clibdir
 275     some -> writeIORef v_TopDir (drop 2 (last some)))
 276   return others
 277
 278 beginMake :: PackageConfigInfo -> [String] -> IO ()
 279 beginMake pkg_details mods
 280   = do case mods of
 281          []    -> throwDyn (UsageError "no input files")
 282          [mod] -> do state <- cmInit pkg_details Batch
 283                      cmLoadModule state (mkModuleName mod)
 284                      return ()
 285          _     -> throwDyn (UsageError "only one module allowed with --make")
 286
 287 #ifndef GHCI
 288 beginInteractive = throwDyn (OtherError "not build for interactive use")
 289 #else
 290 beginInteractive pkg_details mods
 291   = do state <- cmInit pkg_details Interactive
 292        case mods of
 293            []    -> return ()
 294            [mod] -> do cmLoadModule state (mkModuleName mod); return ()
 295            _     -> throwDyn (UsageError
 296                                 "only one module allowed with --interactive")
 297        interactiveUI state
 298 #endif