[project @ 2001-02-20 11:04:42 by simonmar]

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

diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index 9e91f96..df50f1c 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.12 2000/10/27 11:48:55 sewardj Exp $
+-- $Id: Main.hs,v 1.54 2001/02/20 11:04:42 simonmar Exp $

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

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

+
+#ifdef GHCI
+import InteractiveUI
+#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 DriverPhases    ( Phase(..) )
-import CmdLineOpts     ( HscLang(..), DynFlags(..), v_Static_hsc_opts )
+import Panic
+import DriverPhases    ( Phase(..), haskellish_file )
+import CmdLineOpts

 import TmpFiles
 import Finder          ( initFinder )
 import TmpFiles
 import Finder          ( initFinder )

-import CmStaticInfo    ( mkPCI )
+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 List
 
 import IO
 import Monad
 import List

+import Char            ( toLower )

 import System
 import Maybe
 
 import System
 import Maybe
 

@@ -54,6 +63,7 @@ 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

@@ -63,8 +73,7 @@ import Maybe
 -- 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
 -- 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:

@@ -72,25 +81,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
    later (do  forget_it <- readIORef v_Keep_tmp_files
              unless forget_it $ do
 
    -- make sure we clean up after ourselves
    later (do  forget_it <- readIORef v_Keep_tmp_files
              unless forget_it $ do

-             verb <- readIORef v_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,

@@ -106,9 +119,6 @@ main =
    installHandler sigINT  sig_handler Nothing
 #endif
 
    installHandler sigINT  sig_handler Nothing
 #endif
 

-   pgm    <- getProgName
-   writeIORef v_Prog_name pgm
-

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

@@ -147,106 +157,147 @@ main =
        -- read the package configuration
    conf_file <- readIORef v_Path_package_config
    contents <- readFile conf_file
        -- read the package configuration
    conf_file <- readIORef v_Path_package_config
    contents <- readFile conf_file

-   writeIORef v_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
 

-       -- force lang to "C" if the -C flag was given
-   case mode of StopBefore HCc -> writeIORef v_Hsc_Lang HscC
-               _ -> return ()
+       -- 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
    static_opts <- buildStaticHscOpts
    writeIORef v_Static_hsc_opts static_opts
 
        -- give the static flags to hsc
    static_opts <- buildStaticHscOpts
    writeIORef v_Static_hsc_opts static_opts
 

-       -- warnings
-   warn_level <- readIORef v_Warning_opt
-
-   let warn_opts =  case warn_level of
-                       W_default -> standardWarnings
-                       W_        -> minusWOpts
-                       W_all     -> minusWallOpts
-                       W_not     -> []
-
-       -- build the default DynFlags (these may be adjusted on a per
-       -- module basis by OPTIONS pragmas and settings in the interpreter).
+   -- 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
 
 
    core_todo <- buildCoreToDo
    stg_todo  <- buildStgToDo
 

-   lang <- readIORef v_Hsc_Lang
+   -- 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 
    writeIORef v_DynFlags 

-       DynFlags{ coreToDo = core_todo,
-                 stgToDo  = stg_todo,
-                  hscLang  = lang,
-                 -- leave out hscOutName for now
-                 flags = [] }
+       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 ]

 
 

-       -- get the -v flag
-   verb <- readIORef v_Verbose
+   verb <- dynFlag verbosity

 
 

-   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 >= 2) 
+       (do hPutStr stderr "Glasgow Haskell Compiler, Version "
+           hPutStr stderr cProjectVersion
+           hPutStr stderr ", for Haskell 98, compiled by GHC version "
+           hPutStrLn stderr cBooterVersion)

 
 

-   when verb (hPutStrLn stderr ("Using package config file: " ++ conf_file))
+   when (verb >= 2) 
+       (hPutStrLn stderr ("Using package config file: " ++ conf_file))
+
+   when (verb >= 3) 
+       (hPutStrLn stderr ("Hsc static flags: " ++ unwords static_opts))

 
        -- initialise the finder
 
        -- initialise the finder

-   pkg_details <- readIORef v_Package_details
-   pci         <- mkPCI pkg_details
-   initFinder pci
+   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
-
-       -- for each source file, find which phases to run
-   pipelines <- mapM (genPipeline mode stop_flag) srcs
-   let src_pipelines = zip srcs pipelines
+       -- make/interactive require invoking the compilation manager
+   if (mode == DoMake)        then beginMake srcs        else do
+   if (mode == DoInteractive) then beginInteractive srcs else do

 
 

+       -- sanity checking

    o_file <- readIORef v_Output_file
    o_file <- readIORef v_Output_file

-   if isJust o_file && mode /= DoLink && length srcs > 1
-       then throwDyn (UsageError "can't apply -o option to multiple source files")
+   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 v_Driver_state
+   let compileFile src = do
+         writeIORef v_DynFlags init_dyn_flags

 
 

-   let compileFile (src, phases) = do
-         r <- runPipeline phases src (mode==DoLink) True
-         writeIORef v_Driver_state saved_driver_state
+         -- 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
+
+         -- 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.

@@ -258,17 +309,33 @@ setTopDir args = do
     some -> writeIORef v_TopDir (drop 2 (last some)))
   return others
 
     some -> writeIORef v_TopDir (drop 2 (last some)))
   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 mods
+  = do 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 is_libraryish nm
+              = let nmr = map toLower (reverse nm)
+                    in take 2 nmr == "o."
+           libs = map Left (filter is_libraryish fileish_args)
+                  ++ map Right minus_ls
+           mods = filter (not.is_libraryish) fileish_args
+           mod = case mods of
+                   []    -> Nothing
+                   [mod] -> Just mod
+                   _     -> throwDyn (UsageError 
+                                       "only one module allowed with --interactive")
+       state <- cmInit Interactive
+       interactiveUI state mod libs

 #endif
 #endif