ghc/compiler/main/Main.hs

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