ghc/compiler/main/Main.hs

   1 {-# OPTIONS -fno-warn-incomplete-patterns #-}
   2 -----------------------------------------------------------------------------
   3 -- $Id: Main.hs,v 1.69 2001/06/13 10:25: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
  19 #ifdef GHCI
  20 import InteractiveUI
  21 #endif
  22
  23 #ifndef mingw32_TARGET_OS
  24 import Dynamic
  25 import Posix
  26 #endif
  27
  28 import CompManager
  29 import ParsePkgConf
  30 import DriverPipeline
  31 import DriverState
  32 import DriverFlags
  33 import DriverMkDepend
  34 import DriverUtil
  35 import Panic
  36 import DriverPhases     ( Phase(..), haskellish_src_file, objish_file )
  37 import CmdLineOpts
  38 import TmpFiles
  39 import Finder           ( initFinder )
  40 import CmStaticInfo
  41 import Config
  42 import Outputable
  43 import Util
  44
  45 import Concurrent
  46 import Directory
  47 import IOExts
  48 import Exception
  49
  50 import IO
  51 import Monad
  52 import List
  53 import System
  54 import Maybe
  55
  56
  57 -----------------------------------------------------------------------------
  58 -- Changes:
  59
  60 -- * -fglasgow-exts NO LONGER IMPLIES -package lang!!!  (-fglasgow-exts is a
  61 --   dynamic flag whereas -package is a static flag.)
  62
  63 -----------------------------------------------------------------------------
  64 -- ToDo:
  65
  66 -- new mkdependHS doesn't support all the options that the old one did (-X et al.)
  67 -- time commands when run with -v
  68 -- split marker
  69 -- java generation
  70 -- user ways
  71 -- Win32 support: proper signal handling
  72 -- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too
  73 -- reading the package configuration file is too slow
  74 -- -K<size>
  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 -Ofile
  83
  84 -----------------------------------------------------------------------------
  85 -- Main loop
  86
  87 main =
  88   -- top-level exception handler: any unrecognised exception is a compiler bug.
  89   handle (\exception -> do hPutStr stderr (show (Panic (show exception)))
  90                            exitWith (ExitFailure 1)
  91          ) $ do
  92
  93   -- all error messages are propagated as exceptions
  94   handleDyn (\dyn -> case dyn of
  95                           PhaseFailed _phase code -> exitWith code
  96                           Interrupted -> exitWith (ExitFailure 1)
  97                           _ -> do hPutStrLn stderr (show (dyn :: GhcException))
  98                                   exitWith (ExitFailure 1)
  99             ) $ do
 100
 101    -- make sure we clean up after ourselves
 102    later (do  forget_it <- readIORef v_Keep_tmp_files
 103               unless forget_it $ do
 104               verb <- dynFlag verbosity
 105               cleanTempFiles verb
 106      ) $ do
 107         -- exceptions will be blocked while we clean the temporary files,
 108         -- so there shouldn't be any difficulty if we receive further
 109         -- signals.
 110
 111         -- install signal handlers
 112    main_thread <- myThreadId
 113 #ifndef mingw32_TARGET_OS
 114    let sig_handler = Catch (throwTo main_thread
 115                                 (DynException (toDyn Interrupted)))
 116    installHandler sigQUIT sig_handler Nothing
 117    installHandler sigINT  sig_handler Nothing
 118 #endif
 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 (InstallationError
 142                                      ("Can't find package.conf in " ++
 143                                       inplace_pkgconfig))
 144
 145         -- set the location of our various files
 146    if am_installed
 147         then do writeIORef v_Path_usage (installed "ghc-usage.txt")
 148                 writeIORef v_Pgm_L (installed "unlit")
 149                 writeIORef v_Pgm_m (installed "ghc-asm")
 150                 writeIORef v_Pgm_s (installed "ghc-split")
 151 #if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
 152                 writeIORef v_Pgm_T (installed cTOUCH)
 153 #endif
 154
 155         else do writeIORef v_Path_usage (inplace (cGHC_DRIVER_DIR ++ "/ghc-usage.txt"))
 156                 writeIORef v_Pgm_L (inplace cGHC_UNLIT)
 157                 writeIORef v_Pgm_m (inplace cGHC_MANGLER)
 158                 writeIORef v_Pgm_s (inplace cGHC_SPLIT)
 159 #if defined(mingw32_TARGET_OS) && defined(MINIMAL_UNIX_DEPS)
 160                 writeIORef v_Pgm_T (inplace cTOUCH)
 161 #endif
 162
 163         -- read the package configuration
 164    conf_file <- readIORef v_Path_package_config
 165    r <- parsePkgConf conf_file
 166    case r of {
 167         Left err -> throwDyn (InstallationError (showSDoc err));
 168         Right pkg_details -> do
 169
 170    writeIORef v_Package_details (mungePackagePaths top_dir pkg_details)
 171
 172         -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
 173    (flags2, mode, stop_flag) <- getGhcMode argv'
 174    writeIORef v_GhcMode mode
 175
 176         -- Show the GHCi banner?
 177 #  ifdef GHCI
 178    when (mode == DoInteractive) $
 179       hPutStrLn stdout ghciWelcomeMsg
 180 #  endif
 181
 182         -- process all the other arguments, and get the source files
 183    non_static <- processArgs static_flags flags2 []
 184
 185         -- -O and --interactive are not a good combination
 186         -- ditto with any kind of way selection
 187    orig_opt_level <- readIORef v_OptLevel
 188    when (orig_opt_level > 0 && mode == DoInteractive) $
 189       do putStr "warning: -O conflicts with --interactive; -O turned off.\n"
 190          writeIORef v_OptLevel 0
 191    orig_ways <- readIORef v_Ways
 192    when (not (null orig_ways) && mode == DoInteractive) $
 193       do throwDyn (UsageError
 194                    "--interactive can't be used with -prof, -ticky, -unreg or -smp.")
 195
 196         -- Find the build tag, and re-process the build-specific options.
 197         -- Also add in flags for unregisterised compilation, if
 198         -- GhcUnregisterised=YES.
 199    way_opts <- findBuildTag
 200    let unreg_opts | cGhcUnregisterised == "YES" = unregFlags
 201                   | otherwise = []
 202    way_non_static <- processArgs static_flags (unreg_opts ++ way_opts) []
 203
 204         -- give the static flags to hsc
 205    static_opts <- buildStaticHscOpts
 206    writeIORef v_Static_hsc_opts static_opts
 207
 208    -- build the default DynFlags (these may be adjusted on a per
 209    -- module basis by OPTIONS pragmas and settings in the interpreter).
 210
 211    core_todo <- buildCoreToDo
 212    stg_todo  <- buildStgToDo
 213
 214    -- set the "global" HscLang.  The HscLang can be further adjusted on a module
 215    -- by module basis, using only the -fvia-C and -fasm flags.  If the global
 216    -- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect.
 217    opt_level  <- readIORef v_OptLevel
 218
 219
 220    let lang = case mode of
 221                  StopBefore HCc -> HscC
 222                  DoInteractive  -> HscInterpreted
 223                  _other        | opt_level >= 1  -> HscC  -- -O implies -fvia-C
 224                                | otherwise       -> defaultHscLang
 225
 226    writeIORef v_DynFlags
 227         defaultDynFlags{ coreToDo = core_todo,
 228                          stgToDo  = stg_todo,
 229                          hscLang  = lang,
 230                          -- leave out hscOutName for now
 231                          hscOutName = panic "Main.main:hscOutName not set",
 232
 233                          verbosity = case mode of
 234                                         DoInteractive -> 1
 235                                         DoMake        -> 1
 236                                         _other        -> 0,
 237                         }
 238
 239         -- the rest of the arguments are "dynamic"
 240    srcs <- processArgs dynamic_flags (way_non_static ++ non_static) []
 241         -- save the "initial DynFlags" away
 242    init_dyn_flags <- readIORef v_DynFlags
 243    writeIORef v_InitDynFlags init_dyn_flags
 244
 245         -- complain about any unknown flags
 246    mapM unknownFlagErr [ f | f@('-':_) <- srcs ]
 247
 248    verb <- dynFlag verbosity
 249
 250    when (verb >= 2)
 251         (do hPutStr stderr "Glasgow Haskell Compiler, Version "
 252             hPutStr stderr cProjectVersion
 253             hPutStr stderr ", for Haskell 98, compiled by GHC version "
 254             hPutStrLn stderr cBooterVersion)
 255
 256    when (verb >= 2)
 257         (hPutStrLn stderr ("Using package config file: " ++ conf_file))
 258
 259    when (verb >= 3)
 260         (hPutStrLn stderr ("Hsc static flags: " ++ unwords static_opts))
 261
 262         -- initialise the finder
 263    pkg_avails <- getPackageInfo
 264    initFinder pkg_avails
 265
 266         -- mkdependHS is special
 267    when (mode == DoMkDependHS) beginMkDependHS
 268
 269         -- -ohi sanity checking
 270    ohi    <- readIORef v_Output_hi
 271    if (isJust ohi &&
 272         (mode == DoMake || mode == DoInteractive || length srcs > 1))
 273         then throwDyn (UsageError "-ohi can only be used when compiling a single source file")
 274         else do
 275
 276         -- make/interactive require invoking the compilation manager
 277    if (mode == DoMake)        then beginMake srcs        else do
 278    if (mode == DoInteractive) then beginInteractive srcs else do
 279
 280         -- -o sanity checking
 281    o_file <- readIORef v_Output_file
 282    if (length srcs > 1 && isJust o_file && mode /= DoLink && mode /= DoMkDLL)
 283         then throwDyn (UsageError "can't apply -o to multiple source files")
 284         else do
 285
 286    if null srcs then throwDyn (UsageError "no input files") else do
 287
 288    let compileFile src = do
 289           writeIORef v_DynFlags init_dyn_flags
 290
 291           exists <- doesFileExist src
 292           when (not exists) $
 293                 throwDyn (CmdLineError ("file `" ++ src ++ "' does not exist"))
 294
 295           -- We compile in two stages, because the file may have an
 296           -- OPTIONS pragma that affects the compilation pipeline (eg. -fvia-C)
 297           let (basename, suffix) = splitFilename src
 298
 299           -- just preprocess (Haskell source only)
 300           pp <- if not (haskellish_src_file src) || mode == StopBefore Hsc
 301                         then return src else do
 302                 phases <- genPipeline (StopBefore Hsc) stop_flag
 303                             False{-not persistent-} defaultHscLang src
 304                 pipeLoop phases src False{-no linking-} False{-no -o flag-}
 305                         basename suffix
 306
 307           -- rest of compilation
 308           dyn_flags <- readIORef v_DynFlags
 309           phases <- genPipeline mode stop_flag True (hscLang dyn_flags) pp
 310           r <- pipeLoop phases pp (mode==DoLink || mode==DoMkDLL) True{-use -o flag-}
 311                         basename suffix
 312           return r
 313
 314    o_files <- mapM compileFile srcs
 315
 316    when (mode == DoMkDependHS) endMkDependHS
 317    when (mode == DoLink) (doLink o_files)
 318    when (mode == DoMkDLL) (doMkDLL o_files)
 319   }
 320
 321
 322 -- grab the last -B option on the command line, and
 323 -- set topDir to its value.
 324 setTopDir :: [String] -> IO [String]
 325 setTopDir args = do
 326   let (minusbs, others) = partition (prefixMatch "-B") args
 327   (case minusbs of
 328     []   -> throwDyn (InstallationError ("missing -B<dir> option"))
 329     some -> writeIORef v_TopDir (drop 2 (last some)))
 330   return others
 331
 332
 333 -- replace the string "$libdir" at the beginning of a path with the
 334 -- current libdir (obtained from the -B option).
 335 mungePackagePaths top_dir ps = map munge_pkg ps
 336  where
 337   munge_pkg p = p{ import_dirs  = munge_paths (import_dirs p),
 338                    include_dirs = munge_paths (include_dirs p),
 339                    library_dirs = munge_paths (library_dirs p) }
 340
 341   munge_paths = map munge_path
 342
 343   munge_path p
 344           | Just p' <- my_prefix_match "$libdir" p = top_dir ++ p'
 345           | otherwise = trace ("not: " ++ p) p
 346
 347
 348 beginMake :: [String] -> IO ()
 349 beginMake fileish_args
 350   = do let (objs, mods) = partition objish_file fileish_args
 351        mapM (add v_Ld_inputs) objs
 352
 353        case mods of
 354          []    -> throwDyn (UsageError "no input files")
 355          [mod] -> do state <- cmInit Batch
 356                      cmLoadModule state mod
 357                      return ()
 358          _     -> throwDyn (UsageError "only one module allowed with --make")
 359
 360
 361 beginInteractive :: [String] -> IO ()
 362 #ifndef GHCI
 363 beginInteractive = throwDyn (CmdLineError "not built for interactive use")
 364 #else
 365 beginInteractive fileish_args
 366   = do minus_ls <- readIORef v_Cmdline_libraries
 367
 368        let (objs, mods) = partition objish_file fileish_args
 369            libs = map Left objs ++ map Right minus_ls
 370
 371        state <- cmInit Interactive
 372        case mods of
 373           []    -> interactiveUI state Nothing    libs
 374           [mod] -> interactiveUI state (Just mod) libs
 375           _     -> throwDyn (UsageError
 376                              "only one module allowed with --interactive")
 377 #endif