[project @ 2000-12-11 16:42:26 by sewardj]

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

diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index 9e91f96..5786dec 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.36 2000/12/11 16:42:26 sewardj Exp $

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

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

+
+#ifdef GHCI
+import Interpreter
+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 Panic

 import DriverPhases    ( Phase(..) )
 import CmdLineOpts     ( HscLang(..), DynFlags(..), v_Static_hsc_opts )
 import TmpFiles
 import Finder          ( initFinder )
 import DriverPhases    ( Phase(..) )
 import CmdLineOpts     ( HscLang(..), DynFlags(..), v_Static_hsc_opts )
 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 IO
 import Monad

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

@@ -65,6 +76,7 @@ import Maybe
 -- reading the package configuration file is too slow
 -- -H, -K, -Rghc-timing
 -- hi-diffs
 -- reading the package configuration file is too slow
 -- -H, -K, -Rghc-timing
 -- hi-diffs

+-- -ddump-all doesn't do anything

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

@@ -90,8 +102,8 @@ main =
    -- 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
-             cleanTempFiles verb
+             verb <- dynFlag verbosity
+             cleanTempFiles (verb >= 2)

      ) $ do
        -- exceptions will be blocked while we clean the temporary files,
        -- so there shouldn't be any difficulty if we receive further
      ) $ do
        -- exceptions will be blocked while we clean the temporary files,
        -- so there shouldn't be any difficulty if we receive further

@@ -106,9 +118,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,23 +156,20 @@ 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 ()
-

        -- 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
        -- 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 []
- 
+   way_non_static <- processArgs static_flags more_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

@@ -183,64 +189,86 @@ main =
    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 
        DynFlags{ coreToDo = core_todo,
                  stgToDo  = stg_todo,
                   hscLang  = lang,
                  -- leave out hscOutName for now
    writeIORef v_DynFlags 
        DynFlags{ 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,
+

                  flags = [] }
 
        -- the rest of the arguments are "dynamic"
                  flags = [] }
 
        -- the rest of the arguments are "dynamic"

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

        -- 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 ]
+
+       -- 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
+   writeIORef v_InitDriverState saved_driver_state

 
 

-       -- 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))

 
        -- 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
+       -- 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
 
        -- for each source file, find which phases to run

-   pipelines <- mapM (genPipeline mode stop_flag) srcs
+   let lang = hscLang init_dyn_flags
+   pipelines <- mapM (genPipeline mode stop_flag True lang) srcs

    let src_pipelines = zip srcs pipelines
 
    let src_pipelines = zip srcs pipelines
 

+       -- 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))
+       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, phases) = do
    let compileFile (src, phases) = do

-         r <- runPipeline phases src (mode==DoLink) True

          writeIORef v_Driver_state saved_driver_state
          writeIORef v_Driver_state saved_driver_state

+         writeIORef v_DynFlags init_dyn_flags
+         r <- runPipeline phases src (mode==DoLink) True

          return r
 
    o_files <- mapM compileFile src_pipelines
          return r
 
    o_files <- mapM compileFile src_pipelines

@@ -258,17 +286,26 @@ 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 build for interactive use")
+#else
+beginInteractive mods
+  = do state <- cmInit Interactive
+       let mod = case mods of
+               []    -> Nothing
+               [mod] -> Just mod
+               _     -> throwDyn (UsageError 
+                                   "only one module allowed with --interactive")
+       interactiveUI state mod

 #endif
 #endif