ghc/compiler/main/Main.hs

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