ghc/compiler/main/Main.hs

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