diff options
| -rw-r--r-- | ghc/compiler/main/DriverPipeline.hs | 75 | ||||
| -rw-r--r-- | ghc/compiler/main/Finder.lhs | 4 | ||||
| -rw-r--r-- | ghc/compiler/main/HscMain.lhs | 3 | ||||
| -rw-r--r-- | ghc/compiler/main/Main.hs | 23 | ||||
| -rw-r--r-- | ghc/compiler/main/MkIface.lhs | 6 |
5 files changed, 61 insertions, 50 deletions
diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 8efa7ee031..502a849319 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPipeline.hs,v 1.6 2000/10/25 14:42:32 sewardj Exp $ +-- $Id: DriverPipeline.hs,v 1.7 2000/10/26 14:38:42 simonmar Exp $ -- -- GHC Driver -- @@ -29,18 +29,17 @@ import DriverUtil import DriverMkDepend import DriverPhases import DriverFlags +import HscMain import Finder import TmpFiles import HscTypes -import UniqFM import Outputable import Module -import ErrUtils import CmdLineOpts import Config import Util -import Panic +import Posix import Directory import System import IOExts @@ -149,10 +148,8 @@ genPipeline todo stop_flag filename cish = cish_suffix suffix -- for a .hc file, or if the -C flag is given, we need to force lang to HscC - real_lang - | suffix == "hc" = HscC - | todo == StopBefore HCc && haskellish = HscC - | otherwise = lang + real_lang | suffix == "hc" = HscC + | otherwise = lang let ----------- ----- ---- --- -- -- - - - @@ -302,8 +299,6 @@ run_phase Unlit _basename _suff input_fn output_fn run_phase Cpp _basename _suff input_fn output_fn = do src_opts <- getOptionsFromSource input_fn - -- ToDo: this is *wrong* if we're processing more than one file: - -- the OPTIONS will persist through the subsequent compilations. _ <- processArgs dynamic_flags src_opts [] do_cpp <- readState cpp_flag @@ -395,7 +390,7 @@ run_phase MkDependHS basename suff input_fn _output_fn = do ----------------------------------------------------------------------------- -- Hsc phase -run_phase Hsc basename suff input_fn output_fn +run_phase Hsc basename suff input_fn output_fn = do -- we add the current directory (i.e. the directory in which @@ -441,44 +436,54 @@ run_phase Hsc basename suff input_fn output_fn -- build a bogus ModSummary to pass to hscMain. let summary = ModSummary { ms_location = error "no loc", - ms_ppsource = Just (loc, error "no fingerprint"), + ms_ppsource = Just (input_fn, error "no fingerprint"), ms_imports = error "no imports" } + -- get the DynFlags + dyn_flags <- readIORef v_DynFlags + -- run the compiler! - result <- hscMain dyn_flags mod_summary - Nothing{-no iface-} - output_fn emptyUFM emptyPCS + pcs <- initPersistentCompilerState + result <- hscMain dyn_flags{ hscOutName = output_fn } + (error "no Finder!") + summary + Nothing -- no iface + emptyModuleEnv -- HomeSymbolTable + emptyModuleEnv -- HomeIfaceTable + emptyModuleEnv -- PackageIfaceTable + pcs case result of { - HscErrs pcs errs warns -> do { - printErrorsAndWarnings errs warns - throwDyn (PhaseFailed "hsc" (ExitFailure 1)) }; - - HscOK details maybe_iface maybe_stub_h maybe_stub_c pcs warns -> do - - pprBagOfWarnings warns + HscFail pcs -> throwDyn (PhaseFailed "hsc" (ExitFailure 1)); - -- get the module name + HscOK details maybe_iface maybe_stub_h maybe_stub_c + _maybe_interpreted_code pcs -> do -- generate the interface file - case iface of + case maybe_iface of Nothing -> -- compilation not required do run_something "Touching object file" ("touch " ++ o_file) return False Just iface -> do -- discover the filename for the .hi file in a roundabout way - let mod = md_id details - locn <- mkHomeModule mod basename input_fn - let hifile = hi_file locn - -- write out the interface file here... - return () + let mod = moduleString (mi_module iface) + ohi <- readIORef output_hi + hifile <- case ohi of + Just fn -> fn + Nothing -> do hisuf <- readIORef hi_suf + return (current_dir ++ + '/'mod ++ '.':hisuf) + -- write out the interface... + if_hdl <- openFile hifile WriteMode + printForIface if_hdl (pprIface iface) + hClose if_hdl -- deal with stubs maybe_stub_o <- dealWithStubs basename maybe_stub_h maybe_stub_c - case stub_o of + case maybe_stub_o of Nothing -> return () Just stub_o -> add ld_inputs stub_o @@ -531,7 +536,7 @@ run_phase cc_phase _basename _suff input_fn output_fn verb <- is_verbose - o2 <- readIORef opt_minus_o2_for_C + o2 <- readIORef v_minus_o2_for_C let opt_flag | o2 = "-O2" | otherwise = "-O" @@ -720,7 +725,7 @@ preprocess filename = compile :: Finder -- to find modules -> ModSummary -- summary, including source - -> Maybe ModIFace -- old interface, if available + -> Maybe ModIface -- old interface, if available -> HomeSymbolTable -- for home module ModDetails -> PersistentCompilerState -- persistent compiler state -> IO CompResult @@ -757,13 +762,13 @@ compile finder summary old_iface hst pcs = do HscAsm -> newTempName (phaseInputExt As) HscC -> newTempName (phaseInputExt HCc) HscJava -> newTempName "java" -- ToDo - HscInterpreter -> return (error "no output file") + HscInterpreted -> return (error "no output file") -- run the compiler hsc_result <- hscMain dyn_flags summary old_iface output_fn hst pcs case hsc_result of { - HscErrs pcs errs warns -> return (CompErrs pcs errs warns); + HscFail pcs -> return (CompErrs pcs); HscOK details maybe_iface maybe_stub_h maybe_stub_c maybe_interpreted_code pcs warns -> do @@ -784,7 +789,7 @@ compile finder summary old_iface hst pcs = do -- in interpreted mode, just return the compiled code -- as our "unlinked" object. - HscInterpreter -> + HscInterpreted -> case maybe_interpreted_code of Just code -> return (Trees code) Nothing -> panic "compile: no interpreted code" diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index d0de38f549..bc2a5f3944 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -118,12 +118,12 @@ mkHomeModuleLocn mod_name basename source_fn = do ohi <- readIORef output_hi hisuf <- readIORef hi_suf let hifile = case ohi of - Nothing -> basename ++ hisuf + Nothing -> basename ++ '.':hisuf Just fn -> fn -- figure out the .o file name. It also lives in the same dir -- as the source, but can be overriden by a -odir flag. - o_file <- odir_ify (basename ++ '.':phaseInputExt Ln) + o_file <- odir_ify (basename ++ '.':phaseInputExt Ln) >>= osuf_ify return (Just (mkHomeModule mod_name, ModuleLocation{ diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 4d8a9e8852..62b1cf2888 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -4,7 +4,8 @@ \section[GHC_Main]{Main driver for Glasgow Haskell compiler} \begin{code} -module HscMain ( hscMain ) where +module HscMain ( HscResult(..), hscMain, + initPersistentCompilerState ) where #include "HsVersions.h" diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index b0886cedbb..ce7e26d44c 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,6 +1,6 @@ {-# OPTIONS -W -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.8 2000/10/24 16:08:16 simonmar Exp $ +-- $Id: Main.hs,v 1.9 2000/10/26 14:38:42 simonmar Exp $ -- -- GHC Driver program -- @@ -94,7 +94,6 @@ main = -- install signal handlers main_thread <- myThreadId - #ifndef mingw32_TARGET_OS let sig_handler = Catch (throwTo main_thread (DynException (toDyn Interrupted))) @@ -149,6 +148,10 @@ main = (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 hsc_lang HscC + _ -> return () + -- process all the other arguments, and get the source files non_static <- processArgs static_flags flags2 [] @@ -160,6 +163,14 @@ main = static_opts <- buildStaticHscOpts writeIORef static_hsc_opts static_opts + -- warnings + warn_level <- readIORef 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). @@ -174,14 +185,6 @@ main = -- leave out hscOutName for now flags = [] } - -- warnings - warn_level <- readIORef warning_opt - let warn_opts = case warn_level of - W_default -> standardWarnings - W_ -> minusWOpts - W_all -> minusWallOpts - W_not -> [] - -- the rest of the arguments are "dynamic" srcs <- processArgs dynamic_flags non_static [] -- save the "initial DynFlags" away diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 1172df3152..b16a95a046 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -5,7 +5,8 @@ \begin{code} module MkIface ( - mkModDetails, mkModDetailsFromIface, completeIface, writeIface + mkModDetails, mkModDetailsFromIface, completeIface, + writeIface, pprIface ) where #include "HsVersions.h" @@ -266,7 +267,7 @@ ifaceTyCls (AnId id) %* * %************************************************************************ -\begin{code} +\begin{code} ifaceInstance :: DFunId -> RenamedInstDecl ifaceInstance dfun_id = InstDecl (toHsType tidy_ty) EmptyMonoBinds [] (Just (getName dfun_id)) noSrcLoc @@ -621,6 +622,7 @@ writeIface finder (Just mod_iface) where mod_name = moduleName (mi_module mod_iface) +pprIface :: ModIface -> SDoc pprIface iface = vcat [ ptext SLIT("__interface") <+> doubleQuotes (ptext opt_InPackage) |