[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 6ad4b8b..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.14 2000/10/27 14:36:36 simonmar Exp $
+-- $Id: Main.hs,v 1.36 2000/12/11 16:42:26 sewardj Exp $

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

@@ -15,12 +15,24 @@ 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 CompManager
 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 DriverPhases    ( Phase(..) )
 import CmdLineOpts     ( HscLang(..), DynFlags(..), v_Static_hsc_opts )
 import TmpFiles

@@ -28,16 +40,13 @@ import Finder               ( initFinder )
 import CmStaticInfo
 import Config
 import Util
 import CmStaticInfo
 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

@@ -55,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

@@ -66,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:

@@ -91,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

@@ -107,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

@@ -155,19 +163,12 @@ main =
    (flags2, mode, stop_flag) <- getGhcMode argv'
    writeIORef v_GhcMode mode
 
    (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

-   left_over <- processArgs static_flags more_opts []
-   if not (null left_over) 
-       then throwDyn (OtherError "non-static flag in way-specific options")
-       else do
+   way_non_static <- processArgs static_flags more_opts []

 
        -- give the static flags to hsc
    static_opts <- buildStaticHscOpts
 
        -- give the static flags to hsc
    static_opts <- buildStaticHscOpts

@@ -188,35 +189,60 @@ 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 ++ warn_opts) []
+   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

-   mapM unknownFlagErr [ f | ('-':f) <- srcs ]
+   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

-   initFinder pkg_details
+   pkg_avails <- getPackageInfo
+   initFinder pkg_avails

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

@@ -226,24 +252,23 @@ main =
    if (mode == DoInteractive) then beginInteractive srcs else do
 
        -- for each source file, find which phases to run
    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 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

@@ -261,12 +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 [] = throwDyn (UsageError "no input files")
-beginMake (_:_:_) = throwDyn (UsageError "only one module allowed with --make")
-{-
-beginMake [mod] = do
-  state <- cmInit ""{-ToDo:remove-} pkg_details
-  cmLoadModule state (mkModuleName mod)
--}
-
-beginInteractive srcs = panic "`ghc --interactive' unimplemented"
+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