From 76c2a7cf2f1c40b4e672ab27710143efe5aaed1a Mon Sep 17 00:00:00 2001
From: simonmar <unknown>
Date: Thu, 26 Oct 2000 14:38:42 +0000
Subject: [PATCH] [project @ 2000-10-26 14:38:42 by simonmar] Simon's stuff
---
ghc/compiler/main/DriverPipeline.hs | 75 +++++++++++++++--------------
ghc/compiler/main/Finder.lhs | 4 +-
ghc/compiler/main/HscMain.lhs | 3 +-
ghc/compiler/main/Main.hs | 23 +++++----
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 8efa7ee03111..502a849319fb 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 d0de38f5492f..bc2a5f39446f 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 4d8a9e88522e..62b1cf288888 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 b0886cedbb90..ce7e26d44c41 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 1172df31526f..b16a95a046b1 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)
--
GitLab