ghc/compiler/main/Main.hs

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