[project @ 2000-10-26 14:38:42 by simonmar]

Simon's stuff

ghc/compiler/main/DriverPipeline.hs

 -----------------------------------------------------------------------------
--- $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"

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{

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"
 

ghc/compiler/main/Main.hs

 {-# 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

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)