[project @ 2001-02-28 11:44:39 by simonpj]

[ghc-hetmet.git] / ghc / compiler / main / Main.hs

diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index 8566b7e..bfd2087 100644 (file)
--- a/ghc/compiler/main/Main.hs
+++ b/ghc/compiler/main/Main.hs
@@ -1,6 +1,6 @@
-{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
+{-# OPTIONS -fno-warn-incomplete-patterns #-}

 -----------------------------------------------------------------------------
 -----------------------------------------------------------------------------

--- $Id: Main.hs,v 1.6 2000/10/17 13:22:11 simonmar Exp $
+-- $Id: Main.hs,v 1.57 2001/02/28 11:44:39 simonpj Exp $

 --
 -- GHC Driver program
 --
 --
 -- GHC Driver program
 --

@@ -15,24 +15,37 @@ module Main (main) where
 
 #include "HsVersions.h"
 
 
 #include "HsVersions.h"
 

+
+#ifdef GHCI
+import InteractiveUI
+import Char            ( toLower )
+#endif
+
+#ifndef mingw32_TARGET_OS
+import Dynamic
+import Posix
+#endif
+
+import CompManager

 import DriverPipeline
 import DriverState
 import DriverFlags
 import DriverMkDepend
 import DriverUtil
 import DriverPipeline
 import DriverState
 import DriverFlags
 import DriverMkDepend
 import DriverUtil

+import Panic
+import DriverPhases    ( Phase(..), haskellish_file, objish_file )
+import CmdLineOpts

 import TmpFiles
 import TmpFiles

+import Finder          ( initFinder )
+import CmStaticInfo

 import Config
 import Util
 import Config
 import Util

-import Panic
+

 
 import Concurrent
 
 import Concurrent

-#ifndef mingw32_TARGET_OS
-import Posix
-#endif

 import Directory
 import IOExts
 import Exception
 import Directory
 import IOExts
 import Exception

-import Dynamic

 
 import IO
 import Monad
 
 import IO
 import Monad

@@ -40,6 +53,7 @@ import List
 import System
 import Maybe
 
 import System
 import Maybe
 

+

 -----------------------------------------------------------------------------
 -- Changes:
 
 -----------------------------------------------------------------------------
 -- Changes:
 

@@ -49,17 +63,16 @@ import Maybe
 -----------------------------------------------------------------------------
 -- ToDo:
 
 -----------------------------------------------------------------------------
 -- ToDo:
 

+-- -nohi doesn't work

 -- new mkdependHS doesn't support all the options that the old one did (-X et al.)
 -- time commands when run with -v
 -- split marker
 -- new mkdependHS doesn't support all the options that the old one did (-X et al.)
 -- time commands when run with -v
 -- split marker

--- mkDLL

 -- java generation
 -- user ways
 -- Win32 support: proper signal handling
 -- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too
 -- reading the package configuration file is too slow
 -- java generation
 -- user ways
 -- Win32 support: proper signal handling
 -- make sure OPTIONS in .hs file propogate to .hc file if -C or -keep-hc-file-too
 -- reading the package configuration file is too slow

--- -H, -K, -Rghc-timing
--- hi-diffs
+-- -K<size>

 
 -----------------------------------------------------------------------------
 -- Differences vs. old driver:
 
 -----------------------------------------------------------------------------
 -- Differences vs. old driver:

@@ -67,25 +80,29 @@ import Maybe
 -- No more "Enter your Haskell program, end with ^D (on a line of its own):"
 -- consistency checking removed (may do this properly later)
 -- removed -noC
 -- No more "Enter your Haskell program, end with ^D (on a line of its own):"
 -- consistency checking removed (may do this properly later)
 -- removed -noC

--- no hi diffs (could be added later)

 -- no -Ofile
 
 -----------------------------------------------------------------------------
 -- Main loop
 
 main =
 -- no -Ofile
 
 -----------------------------------------------------------------------------
 -- Main loop
 
 main =

+  -- top-level exception handler: any unrecognised exception is a compiler bug.
+  handle (\exception -> do hPutStr stderr (show (Panic (show exception)))
+                          exitWith (ExitFailure 1)
+         ) $ do
+

   -- all error messages are propagated as exceptions
   handleDyn (\dyn -> case dyn of
                          PhaseFailed _phase code -> exitWith code
                          Interrupted -> exitWith (ExitFailure 1)
   -- all error messages are propagated as exceptions
   handleDyn (\dyn -> case dyn of
                          PhaseFailed _phase code -> exitWith code
                          Interrupted -> exitWith (ExitFailure 1)

-                         _ -> do hPutStrLn stderr (show (dyn :: BarfKind))
+                         _ -> do hPutStrLn stderr (show (dyn :: GhcException))

                                  exitWith (ExitFailure 1)
                                  exitWith (ExitFailure 1)

-             ) $ do
+           ) $ do

 
    -- make sure we clean up after ourselves
 
    -- make sure we clean up after ourselves

-   later (do  forget_it <- readIORef keep_tmp_files
+   later (do  forget_it <- readIORef v_Keep_tmp_files

              unless forget_it $ do
              unless forget_it $ do

-             verb <- readIORef verbose
+             verb <- dynFlag verbosity

              cleanTempFiles verb
      ) $ do
        -- exceptions will be blocked while we clean the temporary files,
              cleanTempFiles verb
      ) $ do
        -- exceptions will be blocked while we clean the temporary files,

@@ -94,7 +111,6 @@ main =
 
        -- install signal handlers
    main_thread <- myThreadId
 
        -- install signal handlers
    main_thread <- myThreadId

-

 #ifndef mingw32_TARGET_OS
    let sig_handler = Catch (throwTo main_thread 
                                (DynException (toDyn Interrupted)))
 #ifndef mingw32_TARGET_OS
    let sig_handler = Catch (throwTo main_thread 
                                (DynException (toDyn Interrupted)))

@@ -102,16 +118,13 @@ main =
    installHandler sigINT  sig_handler Nothing
 #endif
 
    installHandler sigINT  sig_handler Nothing
 #endif
 

-   pgm    <- getProgName
-   writeIORef prog_name pgm
-

    argv   <- getArgs
 
        -- grab any -B options from the command line first
    argv'  <- setTopDir argv
    argv   <- getArgs
 
        -- grab any -B options from the command line first
    argv'  <- setTopDir argv

-   top_dir <- readIORef topDir
+   top_dir <- readIORef v_TopDir

 
 

-   let installed s = top_dir ++ s
+   let installed s = top_dir ++ '/':s

        inplace s   = top_dir ++ '/':cCURRENT_DIR ++ '/':s
 
        installed_pkgconfig = installed ("package.conf")
        inplace s   = top_dir ++ '/':cCURRENT_DIR ++ '/':s
 
        installed_pkgconfig = installed ("package.conf")

@@ -122,94 +135,168 @@ main =
    am_installed <- doesFileExist installed_pkgconfig
 
    if am_installed
    am_installed <- doesFileExist installed_pkgconfig
 
    if am_installed

-       then writeIORef path_package_config installed_pkgconfig
+       then writeIORef v_Path_package_config installed_pkgconfig

        else do am_inplace <- doesFileExist inplace_pkgconfig
                if am_inplace
        else do am_inplace <- doesFileExist inplace_pkgconfig
                if am_inplace

-                   then writeIORef path_package_config inplace_pkgconfig
+                   then writeIORef v_Path_package_config inplace_pkgconfig

                    else throwDyn (OtherError "can't find package.conf")
 
        -- set the location of our various files
    if am_installed
                    else throwDyn (OtherError "can't find package.conf")
 
        -- set the location of our various files
    if am_installed

-       then do writeIORef path_usage (installed "ghc-usage.txt")
-               writeIORef pgm_L (installed "unlit")
-               writeIORef pgm_m (installed "ghc-asm")
-               writeIORef pgm_s (installed "ghc-split")
+       then do writeIORef v_Path_usage (installed "ghc-usage.txt")
+               writeIORef v_Pgm_L (installed "unlit")
+               writeIORef v_Pgm_m (installed "ghc-asm")
+               writeIORef v_Pgm_s (installed "ghc-split")

 
 

-       else do writeIORef path_usage (inplace (cGHC_DRIVER_DIR ++ "/ghc-usage.txt"))
-               writeIORef pgm_L (inplace cGHC_UNLIT)
-               writeIORef pgm_m (inplace cGHC_MANGLER)
-               writeIORef pgm_s (inplace cGHC_SPLIT)
+       else do writeIORef v_Path_usage (inplace (cGHC_DRIVER_DIR ++ "/ghc-usage.txt"))
+               writeIORef v_Pgm_L (inplace cGHC_UNLIT)
+               writeIORef v_Pgm_m (inplace cGHC_MANGLER)
+               writeIORef v_Pgm_s (inplace cGHC_SPLIT)

 
        -- read the package configuration
 
        -- read the package configuration

-   conf_file <- readIORef path_package_config
+   conf_file <- readIORef v_Path_package_config

    contents <- readFile conf_file
    contents <- readFile conf_file

-   writeIORef package_details (read contents)
+   let pkg_details = read contents     -- ToDo: faster
+   writeIORef v_Package_details pkg_details

 
        -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
    (flags2, mode, stop_flag) <- getGhcMode argv'
    writeIORef v_GhcMode mode
 
 
        -- find the phase to stop after (i.e. -E, -C, -c, -S flags)
    (flags2, mode, stop_flag) <- getGhcMode argv'
    writeIORef v_GhcMode mode
 

+       -- Show the GHCi banner?
+#  ifdef GHCI
+   when (mode == DoInteractive) $
+      hPutStrLn stdout ghciWelcomeMsg
+#  endif
+

        -- process all the other arguments, and get the source files
    non_static <- processArgs static_flags flags2 []
 
        -- process all the other arguments, and get the source files
    non_static <- processArgs static_flags flags2 []
 

-       -- find the build tag, and re-process the build-specific options
-   more_opts <- findBuildTag
-   _ <- processArgs static_flags more_opts []
- 
+       -- -O and --interactive are not a good combination
+       -- ditto with any kind of way selection
+   orig_opt_level <- readIORef v_OptLevel
+   when (orig_opt_level > 0 && mode == DoInteractive) $
+      do putStr "warning: -O conflicts with --interactive; -O turned off.\n"
+         writeIORef v_OptLevel 0
+   orig_ways <- readIORef v_Ways
+   when (not (null orig_ways) && mode == DoInteractive) $
+      do throwDyn (OtherError 
+                   "--interactive can't be used with -prof, -ticky, -unreg or -smp.")
+
+       -- Find the build tag, and re-process the build-specific options.
+       -- Also add in flags for unregisterised compilation, if 
+       -- GhcUnregisterised=YES.
+   way_opts <- findBuildTag
+   let unreg_opts | cGhcUnregisterised == "YES" = unregFlags
+                 | otherwise = []
+   way_non_static <- processArgs static_flags (unreg_opts ++ way_opts) []
+

        -- give the static flags to hsc
        -- give the static flags to hsc

-   build_hsc_opts
+   static_opts <- buildStaticHscOpts
+   writeIORef v_Static_hsc_opts static_opts
+
+   -- build the default DynFlags (these may be adjusted on a per
+   -- module basis by OPTIONS pragmas and settings in the interpreter).
+
+   core_todo <- buildCoreToDo
+   stg_todo  <- buildStgToDo
+
+   -- set the "global" HscLang.  The HscLang can be further adjusted on a module
+   -- by module basis, using only the -fvia-C and -fasm flags.  If the global
+   -- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect.
+   opt_level  <- readIORef v_OptLevel
+
+
+   let lang = case mode of 
+                StopBefore HCc -> HscC
+                DoInteractive  -> HscInterpreted
+                _other        | opt_level >= 1  -> HscC  -- -O implies -fvia-C 
+                              | otherwise       -> defaultHscLang
+
+   writeIORef v_DynFlags 
+       defaultDynFlags{ coreToDo = core_todo,
+                        stgToDo  = stg_todo,
+                        hscLang  = lang,
+                        -- leave out hscOutName for now
+                        hscOutName = panic "Main.main:hscOutName not set",
+
+                        verbosity = case mode of
+                                       DoInteractive -> 1
+                                       DoMake        -> 1
+                                       _other        -> 0,
+                       }

 
        -- the rest of the arguments are "dynamic"
 
        -- the rest of the arguments are "dynamic"

-   srcs <- processArgs dynamic_flags non_static []
+   srcs <- processArgs dynamic_flags (way_non_static ++ non_static) []

        -- save the "initial DynFlags" away
        -- save the "initial DynFlags" away

-   dyn_flags <- readIORef v_DynFlags
-   writeIORef v_InitDynFlags dyn_flags
+   init_dyn_flags <- readIORef v_DynFlags
+   writeIORef v_InitDynFlags init_dyn_flags

 
        -- complain about any unknown flags
 
        -- complain about any unknown flags

-   let unknown_flags = [ f | ('-':f) <- srcs ]
-   mapM unknownFlagErr unknown_flags
+   mapM unknownFlagErr [ f | f@('-':_) <- srcs ]
+
+   verb <- dynFlag verbosity
+
+   when (verb >= 2) 
+       (do hPutStr stderr "Glasgow Haskell Compiler, Version "
+           hPutStr stderr cProjectVersion
+           hPutStr stderr ", for Haskell 98, compiled by GHC version "
+           hPutStrLn stderr cBooterVersion)

 
 

-       -- get the -v flag
-   verb <- readIORef verbose
+   when (verb >= 2) 
+       (hPutStrLn stderr ("Using package config file: " ++ conf_file))

 
 

-   when verb (do hPutStr stderr "Glasgow Haskell Compiler, Version "
-                hPutStr stderr version_str
-                hPutStr stderr ", for Haskell 98, compiled by GHC version "
-                hPutStrLn stderr booter_version)
+   when (verb >= 3) 
+       (hPutStrLn stderr ("Hsc static flags: " ++ unwords static_opts))

 
 

-   when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
+       -- initialise the finder
+   pkg_avails <- getPackageInfo
+   initFinder pkg_avails

 
        -- mkdependHS is special
    when (mode == DoMkDependHS) beginMkDependHS
 
 
        -- mkdependHS is special
    when (mode == DoMkDependHS) beginMkDependHS
 

-       -- make is special
-   when (mode == DoMake) beginMake
+       -- make/interactive require invoking the compilation manager
+   if (mode == DoMake)        then beginMake srcs        else do
+   if (mode == DoInteractive) then beginInteractive srcs else do

 
 

-       -- for each source file, find which phases to run
-   pipelines <- mapM (genPipeline mode stop_flag) srcs
-   let src_pipelines = zip srcs pipelines
-
-   o_file <- readIORef output_file
-   if isJust o_file && mode /= DoLink && length srcs > 1
-       then throwDyn (UsageError "can't apply -o option to multiple source files")
+       -- sanity checking
+   o_file <- readIORef v_Output_file
+   ohi    <- readIORef v_Output_hi
+   if length srcs > 1 && (isJust ohi || (isJust o_file && mode /= DoLink && mode /= DoMkDLL))
+       then throwDyn (UsageError "can't apply -o or -ohi options to multiple source files")

        else do
 
    if null srcs then throwDyn (UsageError "no input files") else do
 
        else do
 
    if null srcs then throwDyn (UsageError "no input files") else do
 

-       -- save the flag state, because this could be modified by OPTIONS pragmas
-       -- during the compilation, and we'll need to restore it before starting
-       -- the next compilation.
-   saved_driver_state <- readIORef driver_state
+   let compileFile src = do
+         writeIORef v_DynFlags init_dyn_flags
+
+         -- We compile in two stages, because the file may have an
+         -- OPTIONS pragma that affects the compilation pipeline (eg. -fvia-C)
+
+         let (basename, suffix) = splitFilename src

 
 

-   let compileFile (src, phases) = do
-         r <- runPipeline phases src (mode==DoLink) True
-         writeIORef driver_state saved_driver_state
+         -- just preprocess
+         pp <- if not (haskellish_file src) || mode == StopBefore Hsc
+                       then return src else do
+               phases <- genPipeline (StopBefore Hsc) stop_flag
+                           False{-not persistent-} defaultHscLang src
+               pipeLoop phases src False{-no linking-} False{-no -o flag-}
+                       basename suffix
+
+         -- rest of compilation
+         dyn_flags <- readIORef v_DynFlags
+         phases <- genPipeline mode stop_flag True (hscLang dyn_flags) pp
+         r <- pipeLoop phases pp (mode==DoLink || mode==DoMkDLL) True{-use -o flag-}
+                       basename suffix

          return r
 
          return r
 

-   o_files <- mapM compileFile src_pipelines
+   o_files <- mapM compileFile srcs

 
    when (mode == DoMkDependHS) endMkDependHS
    when (mode == DoLink) (doLink o_files)
 
    when (mode == DoMkDependHS) endMkDependHS
    when (mode == DoLink) (doLink o_files)

+   when (mode == DoMkDLL) (doMkDLL o_files)

 
        -- grab the last -B option on the command line, and
        -- set topDir to its value.
 
        -- grab the last -B option on the command line, and
        -- set topDir to its value.

@@ -217,21 +304,37 @@ setTopDir :: [String] -> IO [String]
 setTopDir args = do
   let (minusbs, others) = partition (prefixMatch "-B") args
   (case minusbs of
 setTopDir args = do
   let (minusbs, others) = partition (prefixMatch "-B") args
   (case minusbs of

-    []   -> writeIORef topDir clibdir
-    some -> writeIORef topDir (drop 2 (last some)))
+    []   -> writeIORef v_TopDir clibdir
+    some -> writeIORef v_TopDir (drop 2 (last some)))

   return others
 
   return others
 

-beginMake = panic "`ghc --make' unimplemented"
-
------------------------------------------------------------------------------
--- compatibility code
-
-#if __GLASGOW_HASKELL__ <= 408
-catchJust = catchIO
-ioErrors  = justIoErrors
-throwTo   = raiseInThread
-#endif
-
-#ifdef mingw32_TARGET_OS
-foreign import "_getpid" getProcessID :: IO Int 
+beginMake :: [String] -> IO ()
+beginMake fileish_args
+  = do let (objs, mods) = partition objish_file fileish_args
+       mapM (add v_Ld_inputs) objs
+
+       case mods of
+        []    -> throwDyn (UsageError "no input files")
+        [mod] -> do state <- cmInit Batch
+                    cmLoadModule state mod
+                    return ()
+        _     -> throwDyn (UsageError "only one module allowed with --make")
+
+
+beginInteractive :: [String] -> IO ()
+#ifndef GHCI
+beginInteractive = throwDyn (OtherError "not built for interactive use")
+#else
+beginInteractive fileish_args
+  = do minus_ls <- readIORef v_Cmdline_libraries
+
+       let (objs, mods) = partition objish_file fileish_args
+          libs = map Left objs ++ map Right minus_ls
+
+       state <- cmInit Interactive
+       case mods of
+         []    -> interactiveUI state Nothing    libs
+         [mod] -> interactiveUI state (Just mod) libs
+         _     -> throwDyn (UsageError 
+                             "only one module allowed with --interactive")

 #endif
 #endif