diff options
author | simonpj <unknown> | 2002-09-13 15:02:50 +0000 |
---|---|---|
committer | simonpj <unknown> | 2002-09-13 15:02:50 +0000 |
commit | 9af77fa423926fbda946b31e174173d0ec5ebac8 (patch) | |
tree | 140cc94aa3e04f6e50c4bf07ceb0efe67d11b9c6 /ghc/compiler/main | |
parent | 69e55e7476392a2b59b243a32065350c258d4970 (diff) | |
download | haskell-9af77fa423926fbda946b31e174173d0ec5ebac8.tar.gz |
[project @ 2002-09-13 15:02:25 by simonpj]
--------------------------------------
Make Template Haskell into the HEAD
--------------------------------------
This massive commit transfers to the HEAD all the stuff that
Simon and Tim have been doing on Template Haskell. The
meta-haskell-branch is no more!
WARNING: make sure that you
* Update your links if you are using link trees.
Some modules have been added, some have gone away.
* Do 'make clean' in all library trees.
The interface file format has changed, and you can
get strange panics (sadly) if GHC tries to read old interface files:
e.g. ghc-5.05: panic! (the `impossible' happened, GHC version 5.05):
Binary.get(TyClDecl): ForeignType
* You need to recompile the rts too; Linker.c has changed
However the libraries are almost unaltered; just a tiny change in
Base, and to the exports in Prelude.
NOTE: so far as TH itself is concerned, expression splices work
fine, but declaration splices are not complete.
---------------
The main change
---------------
The main structural change: renaming and typechecking have to be
interleaved, because we can't rename stuff after a declaration splice
until after we've typechecked the stuff before (and the splice
itself).
* Combine the renamer and typecheker monads into one
(TcRnMonad, TcRnTypes)
These two replace TcMonad and RnMonad
* Give them a single 'driver' (TcRnDriver). This driver
replaces TcModule.lhs and Rename.lhs
* The haskell-src library package has a module
Language/Haskell/THSyntax
which defines the Haskell data type seen by the TH programmer.
* New modules:
hsSyn/Convert.hs converts THSyntax -> HsSyn
deSugar/DsMeta.hs converts HsSyn -> THSyntax
* New module typecheck/TcSplice type-checks Template Haskell splices.
-------------
Linking stuff
-------------
* ByteCodeLink has been split into
ByteCodeLink (which links)
ByteCodeAsm (which assembles)
* New module ghci/ObjLink is the object-code linker.
* compMan/CmLink is removed entirely (was out of place)
Ditto CmTypes (which was tiny)
* Linker.c initialises the linker when it is first used (no need to call
initLinker any more). Template Haskell makes it harder to know when
and whether to initialise the linker.
-------------------------------------
Gathering the LIE in the type checker
-------------------------------------
* Instead of explicitly gathering constraints in the LIE
tcExpr :: RenamedExpr -> TcM (TypecheckedExpr, LIE)
we now dump the constraints into a mutable varabiable carried
by the monad, so we get
tcExpr :: RenamedExpr -> TcM TypecheckedExpr
Much less clutter in the code, and more efficient too.
(Originally suggested by Mark Shields.)
-----------------
Remove "SysNames"
-----------------
Because the renamer and the type checker were entirely separate,
we had to carry some rather tiresome implicit binders (or "SysNames")
along inside some of the HsDecl data structures. They were both
tiresome and fragile.
Now that the typechecker and renamer are more intimately coupled,
we can eliminate SysNames (well, mostly... default methods still
carry something similar).
-------------
Clean up HsPat
-------------
One big clean up is this: instead of having two HsPat types (InPat and
OutPat), they are now combined into one. This is more consistent with
the way that HsExpr etc is handled; there are some 'Out' constructors
for the type checker output.
So:
HsPat.InPat --> HsPat.Pat
HsPat.OutPat --> HsPat.Pat
No 'pat' type parameter in HsExpr, HsBinds, etc
Constructor patterns are nicer now: they use
HsPat.HsConDetails
for the three cases of constructor patterns:
prefix, infix, and record-bindings
The *same* data type HsConDetails is used in the type
declaration of the data type (HsDecls.TyData)
Lots of associated clean-up operations here and there. Less code.
Everything is wonderful.
Diffstat (limited to 'ghc/compiler/main')
-rw-r--r-- | ghc/compiler/main/BinIface.hs | 138 | ||||
-rw-r--r-- | ghc/compiler/main/CodeOutput.lhs | 57 | ||||
-rw-r--r-- | ghc/compiler/main/Constants.lhs | 3 | ||||
-rw-r--r-- | ghc/compiler/main/DriverFlags.hs | 7 | ||||
-rw-r--r-- | ghc/compiler/main/DriverMkDepend.hs | 6 | ||||
-rw-r--r-- | ghc/compiler/main/DriverPhases.hs | 2 | ||||
-rw-r--r-- | ghc/compiler/main/DriverPipeline.hs | 494 | ||||
-rw-r--r-- | ghc/compiler/main/DriverState.hs | 93 | ||||
-rw-r--r-- | ghc/compiler/main/DriverUtil.hs | 2 | ||||
-rw-r--r-- | ghc/compiler/main/ErrUtils.lhs | 106 | ||||
-rw-r--r-- | ghc/compiler/main/Finder.lhs | 33 | ||||
-rw-r--r-- | ghc/compiler/main/GetImports.hs | 2 | ||||
-rw-r--r-- | ghc/compiler/main/HscMain.lhs | 725 | ||||
-rw-r--r-- | ghc/compiler/main/HscStats.lhs | 10 | ||||
-rw-r--r-- | ghc/compiler/main/HscTypes.lhs | 620 | ||||
-rw-r--r-- | ghc/compiler/main/Interpreter.hs | 12 | ||||
-rw-r--r-- | ghc/compiler/main/Main.hs | 25 | ||||
-rw-r--r-- | ghc/compiler/main/MkIface.lhs | 424 | ||||
-rw-r--r-- | ghc/compiler/main/Packages.lhs | 74 | ||||
-rw-r--r-- | ghc/compiler/main/SysTools.lhs | 5 | ||||
-rw-r--r-- | ghc/compiler/main/TidyPgm.lhs | 45 |
21 files changed, 1660 insertions, 1223 deletions
diff --git a/ghc/compiler/main/BinIface.hs b/ghc/compiler/main/BinIface.hs index cb8a5701df..8e461ca525 100644 --- a/ghc/compiler/main/BinIface.hs +++ b/ghc/compiler/main/BinIface.hs @@ -5,7 +5,7 @@ -- -- Binary interface file support. -module BinIface ( writeBinIface ) where +module BinIface ( writeBinIface, readBinIface ) where #include "HsVersions.h" @@ -16,27 +16,63 @@ import HsTypes import HsCore import HsDecls import HsBinds +import HsPat ( HsConDetails(..) ) import TyCon import Class import VarEnv import CostCentre -import Name ( Name, nameOccName ) +import RdrName ( mkRdrUnqual, mkRdrQual ) +import Name ( Name, nameOccName, nameModule_maybe ) import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts ) +import Module ( moduleName ) import OccName ( OccName ) -import RnMonad ( ParsedIface(..) ) import RnHsSyn import DriverState ( v_Build_tag ) import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion ) -import StringBuffer ( hGetStringBuffer ) import Panic import SrcLoc import Binary import DATA_IOREF ( readIORef ) import EXCEPTION ( throwDyn ) - import Monad ( when ) +#include "HsVersions.h" + +-- --------------------------------------------------------------------------- +-- We write out a ModIface, but read it in as a ParsedIface. +-- There are some big differences, and some subtle ones. We do most +-- of the conversion on the way out, so there is minimal fuss when we +-- read it back in again (see RnMonad.lhs) + +-- The main difference is that all Names in a ModIface are RdrNames in +-- a ParsedIface, so when writing out a Name in binary we make sure it +-- is binary-compatible with a RdrName. + +-- Other subtle differences: +-- - pi_mod is a ModuleName, but mi_mod is a Module. Hence we put +-- Modules as ModuleNames. +-- - pi_exports and pi_usages, Names have +-- to be converted to OccNames. +-- - pi_fixity is a NameEnv in ModIface, +-- but a list of (Name,Fixity) pairs in ParsedIface. +-- - versioning is totally different. +-- - deprecations are different. + +writeBinIface :: FilePath -> ModIface -> IO () +writeBinIface hi_path mod_iface + = putBinFileWithDict hi_path (mi_module mod_iface) mod_iface + +readBinIface :: FilePath -> IO ParsedIface +readBinIface hi_path = getBinFileWithDict hi_path + + +-- %********************************************************* +-- %* * +-- All the Binary instances +-- %* * +-- %********************************************************* + -- BasicTypes {-! for IPName derive: Binary !-} {-! for Fixity derive: Binary !-} @@ -46,6 +82,20 @@ import Monad ( when ) {-! for StrictnessMark derive: Binary !-} {-! for Activation derive: Binary !-} +instance Binary Name where + -- we must print these as RdrNames, because that's how they will be read in + put_ bh name + = case nameModule_maybe name of + Just mod + | this_mod == mod -> put_ bh (mkRdrUnqual occ) + | otherwise -> put_ bh (mkRdrQual (moduleName mod) occ) + _ -> put_ bh (mkRdrUnqual occ) + where + occ = nameOccName name + (this_mod,_,_,_) = getUserData bh + + get bh = error "can't Binary.get a Name" + -- NewDemand {-! for Demand derive: Binary !-} {-! for Demands derive: Binary !-} @@ -81,7 +131,7 @@ instance Binary DmdType where {-! for ConDetails derive: Binary !-} {-! for BangType derive: Binary !-} -instance (Binary name) => Binary (TyClDecl name pat) where +instance (Binary name) => Binary (TyClDecl name) where put_ bh (IfaceSig name ty idinfo _) = do putByte bh 0 put_ bh name @@ -89,7 +139,7 @@ instance (Binary name) => Binary (TyClDecl name pat) where lazyPut bh idinfo put_ bh (ForeignType ae af ag ah) = error "Binary.put_(TyClDecl): ForeignType" - put_ bh (TyData ai aj ak al am an ao _) = do + put_ bh (TyData ai aj ak al am _ (Just generics) _) = do putByte bh 2 put_ bh ai put_ bh aj @@ -97,13 +147,13 @@ instance (Binary name) => Binary (TyClDecl name pat) where put_ bh al put_ bh am -- ignore Derivs - put_ bh ao -- store the SysNames for now (later: derive them) + put_ bh generics -- Record whether generics needed or not put_ bh (TySynonym aq ar as _) = do putByte bh 3 put_ bh aq put_ bh ar put_ bh as - put_ bh c@(ClassDecl ctxt nm tyvars fds sigs _ sysnames _) = do + put_ bh c@(ClassDecl ctxt nm tyvars fds sigs _ _) = do putByte bh 4 put_ bh ctxt put_ bh nm @@ -111,7 +161,6 @@ instance (Binary name) => Binary (TyClDecl name pat) where put_ bh fds put_ bh sigs -- ignore methods (there should be none) - put_ bh sysnames -- ignore SrcLoc get bh = do h <- getByte bh @@ -130,9 +179,9 @@ instance (Binary name) => Binary (TyClDecl name pat) where nm <- get bh tyvars <- get bh cons <- get bh - sysnames <- get bh + generics <- get bh return (TyData n_or_d ctx nm tyvars cons - Nothing sysnames noSrcLoc) + Nothing (Just generics) noSrcLoc) 3 -> do aq <- get bh ar <- get bh @@ -144,27 +193,24 @@ instance (Binary name) => Binary (TyClDecl name pat) where tyvars <- get bh fds <- get bh sigs <- get bh - sysnames <- get bh return (ClassDecl ctxt nm tyvars fds sigs - Nothing sysnames noSrcLoc) + Nothing noSrcLoc) instance (Binary name) => Binary (ConDecl name) where - put_ bh (ConDecl aa ab ac ad ae _) = do + put_ bh (ConDecl aa ac ad ae _) = do put_ bh aa - put_ bh ab put_ bh ac put_ bh ad put_ bh ae -- ignore SrcLoc get bh = do aa <- get bh - ab <- get bh ac <- get bh ad <- get bh ae <- get bh - return (ConDecl aa ab ac ad ae noSrcLoc) + return (ConDecl aa ac ad ae noSrcLoc) -instance (Binary name) => Binary (InstDecl name pat) where +instance (Binary name) => Binary (InstDecl name) where put_ bh (InstDecl aa _ _ ad _) = do put_ bh aa -- ignore MonoBinds @@ -176,7 +222,7 @@ instance (Binary name) => Binary (InstDecl name pat) where ad <- get bh return (InstDecl aa EmptyMonoBinds [{-no sigs-}] ad noSrcLoc) -instance (Binary name) => Binary (RuleDecl name pat) where +instance (Binary name) => Binary (RuleDecl name) where put_ bh (IfaceRule ag ah ai aj ak al _) = do put_ bh ag put_ bh ah @@ -217,27 +263,7 @@ instance Binary name => Binary (Sig name) where {-! for IsDupdCC derive: Binary !-} {-! for CostCentre derive: Binary !-} --- --------------------------------------------------------------------------- --- HscTypes --- NB. we write out a ModIface, but read it in as a ParsedIface. --- There are some big differences, and some subtle ones. We do most --- of the conversion on the way out, so there is minimal fuss when we --- read it back in again (see RnMonad.lhs) - --- The main difference is that all Names in a ModIface are RdrNames in --- a ParsedIface, so when writing out a Name in binary we make sure it --- is binary-compatible with a RdrName. - --- Other subtle differences: --- - pi_mod is a ModuleName, but mi_mod is a Module. Hence we put --- Modules as ModuleNames. --- - pi_exports and pi_usages, Names have --- to be converted to OccNames. --- - pi_fixity is a NameEnv in ModIface, --- but a list of (Name,Fixity) pairs in ParsedIface. --- - versioning is totally different. --- - deprecations are different. instance Binary ModIface where put_ bh iface = do @@ -365,13 +391,6 @@ instance Binary ParsedIface where pi_deprecs = deprecs }) -- ---------------------------------------------------------------------------- --- Writing a binary interface - -writeBinIface :: FilePath -> ModIface -> IO () -writeBinIface hi_path mod_iface = - putBinFileWithDict hi_path (mi_module mod_iface) mod_iface - --- ---------------------------------------------------------------------------- {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-} -- Imported from other files :- @@ -500,6 +519,15 @@ instance Binary Fixity where ab <- get bh return (Fixity aa ab) +instance (Binary name) => Binary (FixitySig name) where + put_ bh (FixitySig aa ab _) = do + put_ bh aa + put_ bh ab + get bh = do + aa <- get bh + ab <- get bh + return (FixitySig aa ab noSrcLoc) + instance (Binary name) => Binary (IPName name) where put_ bh (Dupable aa) = do putByte bh 0 @@ -604,16 +632,14 @@ instance (Binary name) => Binary (HsTyVarBndr name) where ac <- get bh return (IfaceTyVar ab ac) -instance (Binary name) => Binary (HsTupCon name) where - put_ bh (HsTupCon aa ab ac) = do - put_ bh aa +instance Binary HsTupCon where + put_ bh (HsTupCon ab ac) = do put_ bh ab put_ bh ac get bh = do - aa <- get bh ab <- get bh ac <- get bh - return (HsTupCon aa ab ac) + return (HsTupCon ab ac) instance (Binary name) => Binary (HsTyOp name) where put_ bh HsArrow = putByte bh 0 @@ -927,8 +953,8 @@ instance (Binary name) => Binary (BangType name) where ab <- get bh return (BangType aa ab) -instance (Binary name) => Binary (ConDetails name) where - put_ bh (VanillaCon aa) = do +instance (Binary name, Binary arg) => Binary (HsConDetails name arg) where + put_ bh (PrefixCon aa) = do putByte bh 0 put_ bh aa put_ bh (InfixCon ab ac) = do @@ -942,7 +968,7 @@ instance (Binary name) => Binary (ConDetails name) where h <- getByte bh case h of 0 -> do aa <- get bh - return (VanillaCon aa) + return (PrefixCon aa) 1 -> do ab <- get bh ac <- get bh return (InfixCon ab ac) @@ -1028,5 +1054,3 @@ instance Binary CostCentre where return (NormalCC aa ab ac ad) _ -> do ae <- get bh return (AllCafsCC ae) - - diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 15b9a9cc8c..2b0d745ae3 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -19,26 +19,24 @@ import IlxGen ( ilxGen ) #ifdef JAVA import JavaGen ( javaGen ) +import OccurAnal ( occurAnalyseBinds ) import qualified PrintJava import OccurAnal ( occurAnalyseBinds ) #endif +import FastString ( unpackFS ) import DriverState ( v_HCHeader ) -import TyCon ( TyCon ) import Id ( Id ) -import CoreSyn ( CoreBind ) import StgSyn ( StgBinding ) import AbsCSyn ( AbstractC ) import PprAbsC ( dumpRealC, writeRealC ) -import Module ( Module ) +import HscTypes ( ModGuts(..), ModGuts, ForeignStubs(..), typeEnvTyCons ) import CmdLineOpts import ErrUtils ( dumpIfSet_dyn, showPass ) import Outputable import Pretty ( Mode(..), printDoc ) import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName ) - -import DATA_IOREF ( readIORef ) - +import DATA_IOREF ( readIORef, writeIORef ) import Monad ( when ) import IO \end{code} @@ -52,17 +50,20 @@ import IO \begin{code} codeOutput :: DynFlags - -> Module - -> [TyCon] -- Local tycons - -> [CoreBind] -- Core bindings + -> ModGuts -> [(StgBinding,[Id])] -- The STG program with SRTs - -> SDoc -- C stubs for foreign exported functions - -> SDoc -- Header file prototype for foreign exported functions - -> AbstractC -- Compiled abstract C + -> AbstractC -- Compiled abstract C -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-}) -codeOutput dflags mod_name tycons core_binds stg_binds - c_code h_code flat_abstractC - = -- You can have C (c_output) or assembly-language (ncg_output), +codeOutput dflags + (ModGuts {mg_module = mod_name, + mg_types = type_env, + mg_foreign = foreign_stubs, + mg_binds = core_binds}) + stg_binds flat_abstractC + = let + tycons = typeEnvTyCons type_env + in + -- You can have C (c_output) or assembly-language (ncg_output), -- but not both. [Allowing for both gives a space leak on -- flat_abstractC. WDP 94/10] @@ -70,7 +71,7 @@ codeOutput dflags mod_name tycons core_binds stg_binds do { showPass dflags "CodeOutput" ; let filenm = dopt_OutName dflags - ; stub_names <- outputForeignStubs dflags c_code h_code + ; stub_names <- outputForeignStubs dflags foreign_stubs ; case dopt_HscLang dflags of HscInterpreted -> return stub_names HscAsm -> outputAsm dflags filenm flat_abstractC @@ -188,7 +189,20 @@ outputIlx dflags filename mod tycons stg_binds %************************************************************************ \begin{code} -outputForeignStubs dflags c_code h_code + -- Turn the list of headers requested in foreign import + -- declarations into a string suitable for emission into generated + -- C code... +mkForeignHeaders headers + = unlines + . map (\fname -> "#include \"" ++ unpackFS fname ++ "\"") + . reverse + $ headers + +outputForeignStubs :: DynFlags -> ForeignStubs + -> IO (Bool, -- Header file created + Bool) -- C file created +outputForeignStubs dflags NoStubs = return (False, False) +outputForeignStubs dflags (ForeignStubs h_code c_code hdrs _) = do dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export header file" stub_h_output_d @@ -200,16 +214,19 @@ outputForeignStubs dflags c_code h_code dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export stubs" stub_c_output_d - hc_header <- readIORef v_HCHeader + -- Extend the list of foreign headers (used in outputC) + fhdrs <- readIORef v_HCHeader + let new_fhdrs = fhdrs ++ mkForeignHeaders hdrs + writeIORef v_HCHeader new_fhdrs stub_c_file_exists <- outputForeignStubs_help (hscStubCOutName dflags) stub_c_output_w ("#define IN_STG_CODE 0\n" ++ - hc_header ++ + new_fhdrs ++ "#include \"RtsAPI.h\"\n" ++ cplusplus_hdr) cplusplus_ftr - -- we're adding the default hc_header to the stub file, but this + -- We're adding the default hc_header to the stub file, but this -- isn't really HC code, so we need to define IN_STG_CODE==0 to -- avoid the register variables etc. being enabled. diff --git a/ghc/compiler/main/Constants.lhs b/ghc/compiler/main/Constants.lhs index 6ba8e00fbd..1feffacb84 100644 --- a/ghc/compiler/main/Constants.lhs +++ b/ghc/compiler/main/Constants.lhs @@ -89,7 +89,8 @@ module Constants ( All pretty arbitrary: \begin{code} -mAX_TUPLE_SIZE = (37 :: Int) +mAX_TUPLE_SIZE = (62 :: Int) -- Should really match the number + -- of decls in Data.Tuple mAX_CONTEXT_REDUCTION_DEPTH = (20 :: Int) \end{code} diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 7c6ebaa3a1..8b1a8dad90 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.101 2002/08/29 15:44:15 simonmar Exp $ +-- $Id: DriverFlags.hs,v 1.102 2002/09/13 15:02:34 simonpj Exp $ -- -- Driver flags -- @@ -493,8 +493,13 @@ decodeSize str ----------------------------------------------------------------------------- -- RTS Hooks +#if __GLASGOW_HASKELL__ >= 504 +foreign import ccall unsafe "setHeapSize" setHeapSize :: Int -> IO () +foreign import ccall unsafe "enableTimingStats" enableTimingStats :: IO () +#else foreign import "setHeapSize" unsafe setHeapSize :: Int -> IO () foreign import "enableTimingStats" unsafe enableTimingStats :: IO () +#endif ----------------------------------------------------------------------------- -- Build the Hsc static command line opts diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs index 5035fec046..e4d10dbb64 100644 --- a/ghc/compiler/main/DriverMkDepend.hs +++ b/ghc/compiler/main/DriverMkDepend.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverMkDepend.hs,v 1.21 2002/08/29 15:44:15 simonmar Exp $ +-- $Id: DriverMkDepend.hs,v 1.22 2002/09/13 15:02:34 simonpj Exp $ -- -- GHC Driver -- @@ -16,9 +16,9 @@ import DriverUtil ( add, softGetDirectoryContents ) import DriverFlags import SysTools ( newTempName ) import qualified SysTools -import Module ( ModuleName, moduleNameUserString, isHomeModule ) +import Module ( ModuleName, ModLocation(..), + moduleNameUserString, isHomeModule ) import Finder ( findModuleDep ) -import HscTypes ( ModuleLocation(..) ) import Util ( global ) import Panic diff --git a/ghc/compiler/main/DriverPhases.hs b/ghc/compiler/main/DriverPhases.hs index 08715628e5..4632babb98 100644 --- a/ghc/compiler/main/DriverPhases.hs +++ b/ghc/compiler/main/DriverPhases.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPhases.hs,v 1.21 2002/07/05 20:30:38 sof Exp $ +-- $Id: DriverPhases.hs,v 1.22 2002/09/13 15:02:34 simonpj Exp $ -- -- GHC Driver -- diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index bc75ba7e8d..72e326f5f7 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -10,14 +10,14 @@ module DriverPipeline ( - -- interfaces for the batch-mode driver - genPipeline, runPipeline, pipeLoop, + -- Interfaces for the batch-mode driver + genPipeline, runPipeline, pipeLoop, staticLink, - -- interfaces for the compilation manager (interpreted/batch-mode) - preprocess, compile, CompResult(..), + -- Interfaces for the compilation manager (interpreted/batch-mode) + preprocess, + compile, CompResult(..), + link, - -- batch-mode linking interface - doLink, -- DLL building doMkDLL ) where @@ -25,7 +25,6 @@ module DriverPipeline ( #include "HsVersions.h" import Packages -import CmTypes import GetImports import DriverState import DriverUtil @@ -44,6 +43,7 @@ import CmdLineOpts import Config import Panic import Util +import BasicTypes ( SuccessFlag(..) ) import Maybes ( expectJust ) import ParserCoreUtils ( getCoreModuleName ) @@ -60,9 +60,271 @@ import IO import Monad import Maybe + +----------------------------------------------------------------------------- +-- Pre process +----------------------------------------------------------------------------- + +-- Just preprocess a file, put the result in a temp. file (used by the +-- compilation manager during the summary phase). + +preprocess :: FilePath -> IO FilePath +preprocess filename = + ASSERT(haskellish_src_file filename) + do restoreDynFlags -- Restore to state of last save + let fInfo = (filename, getFileSuffix filename) + pipeline <- genPipeline (StopBefore Hsc) ("preprocess") False + defaultHscLang fInfo + (fn,_) <- runPipeline pipeline fInfo + False{-no linking-} False{-no -o flag-} + return fn + +----------------------------------------------------------------------------- +-- Compile +----------------------------------------------------------------------------- + +-- Compile a single module, under the control of the compilation manager. +-- +-- This is the interface between the compilation manager and the +-- compiler proper (hsc), where we deal with tedious details like +-- reading the OPTIONS pragma from the source file, and passing the +-- output of hsc through the C compiler. + +-- The driver sits between 'compile' and 'hscMain', translating calls +-- to the former into calls to the latter, and results from the latter +-- into results from the former. It does things like preprocessing +-- the .hs file if necessary, and compiling up the .stub_c files to +-- generate Linkables. + +-- NB. No old interface can also mean that the source has changed. + +compile :: GhciMode -- distinguish batch from interactive + -> Module + -> ModLocation + -> Bool -- True <=> source unchanged + -> Bool -- True <=> have object + -> Maybe ModIface -- old interface, if available + -> HomePackageTable -- For home-module stuff + -> PersistentCompilerState -- persistent compiler state + -> IO CompResult + +data CompResult + = CompOK PersistentCompilerState -- Updated PCS + ModDetails -- New details + ModIface -- New iface + (Maybe Linkable) -- New code; Nothing => compilation was not reqd + -- (old code is still valid) + + | CompErrs PersistentCompilerState -- Updated PCS + + +compile ghci_mode this_mod location + source_unchanged have_object + old_iface hpt pcs = do + + dyn_flags <- restoreDynFlags -- Restore to the state of the last save + + + showPass dyn_flags + (showSDoc (text "Compiling" <+> ppr this_mod)) + + let verb = verbosity dyn_flags + let input_fn = expectJust "compile:hs" (ml_hs_file location) + let input_fnpp = expectJust "compile:hspp" (ml_hspp_file location) + let mod_name = moduleName this_mod + + when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp)) + + opts <- getOptionsFromSource input_fnpp + processArgs dynamic_flags opts [] + dyn_flags <- getDynFlags + + let hsc_lang = hscLang dyn_flags + (basename, _) = splitFilename input_fn + + keep_hc <- readIORef v_Keep_hc_files +#ifdef ILX + keep_il <- readIORef v_Keep_il_files +#endif + keep_s <- readIORef v_Keep_s_files + + output_fn <- + case hsc_lang of + HscAsm | keep_s -> return (basename ++ '.':phaseInputExt As) + | otherwise -> newTempName (phaseInputExt As) + HscC | keep_hc -> return (basename ++ '.':phaseInputExt HCc) + | otherwise -> newTempName (phaseInputExt HCc) + HscJava -> newTempName "java" -- ToDo +#ifdef ILX + HscILX | keep_il -> return (basename ++ '.':phaseInputExt Ilasm) + | otherwise -> newTempName (phaseInputExt Ilx2Il) +#endif + HscInterpreted -> return (error "no output file") + HscNothing -> return (error "no output file") + + let dyn_flags' = dyn_flags { hscOutName = output_fn, + hscStubCOutName = basename ++ "_stub.c", + hscStubHOutName = basename ++ "_stub.h", + extCoreName = basename ++ ".hcr" } + + -- figure out which header files to #include in a generated .hc file + c_includes <- getPackageCIncludes + cmdline_includes <- dynFlag cmdlineHcIncludes -- -#include options + + let cc_injects = unlines (map mk_include + (c_includes ++ reverse cmdline_includes)) + mk_include h_file = + case h_file of + '"':_{-"-} -> "#include "++h_file + '<':_ -> "#include "++h_file + _ -> "#include \""++h_file++"\"" + + writeIORef v_HCHeader cc_injects + + -- -no-recomp should also work with --make + do_recomp <- readIORef v_Recomp + let source_unchanged' = source_unchanged && do_recomp + hsc_env = HscEnv { hsc_mode = ghci_mode, + hsc_dflags = dyn_flags', + hsc_HPT = hpt } + + -- run the compiler + hsc_result <- hscMain hsc_env pcs this_mod location + source_unchanged' have_object old_iface + + case hsc_result of + HscFail pcs -> return (CompErrs pcs) + + HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing) + + HscRecomp pcs details iface + stub_h_exists stub_c_exists maybe_interpreted_code -> do + let + maybe_stub_o <- compileStub dyn_flags' stub_c_exists + let stub_unlinked = case maybe_stub_o of + Nothing -> [] + Just stub_o -> [ DotO stub_o ] + + (hs_unlinked, unlinked_time) <- + case hsc_lang of + + -- in interpreted mode, just return the compiled code + -- as our "unlinked" object. + HscInterpreted -> + case maybe_interpreted_code of +#ifdef GHCI + Just comp_bc -> do tm <- getClockTime + return ([BCOs comp_bc], tm) +#endif + Nothing -> panic "compile: no interpreted code" + + -- we're in batch mode: finish the compilation pipeline. + _other -> do pipe <- genPipeline (StopBefore Ln) "" True + hsc_lang (output_fn, getFileSuffix output_fn) + -- runPipeline takes input_fn so it can split off + -- the base name and use it as the base of + -- the output object file. + let (basename, suffix) = splitFilename input_fn + (o_file,_) <- + pipeLoop pipe (output_fn, getFileSuffix output_fn) + False False + basename suffix + o_time <- getModificationTime o_file + return ([DotO o_file], o_time) + + let linkable = LM unlinked_time mod_name + (hs_unlinked ++ stub_unlinked) + + return (CompOK pcs details iface (Just linkable)) + ----------------------------------------------------------------------------- --- genPipeline +-- stub .h and .c files (for foreign export support) + +compileStub dflags stub_c_exists + | not stub_c_exists = return Nothing + | stub_c_exists = do + -- compile the _stub.c file w/ gcc + let stub_c = hscStubCOutName dflags + pipeline <- genPipeline (StopBefore Ln) "" True defaultHscLang (stub_c,"c") + (stub_o,_) <- runPipeline pipeline (stub_c,"c") False{-no linking-} + False{-no -o option-} + return (Just stub_o) + + +----------------------------------------------------------------------------- +-- Link +----------------------------------------------------------------------------- + +link :: GhciMode -- interactive or batch + -> DynFlags -- dynamic flags + -> Bool -- attempt linking in batch mode? + -> [Linkable] + -> IO SuccessFlag + +-- For the moment, in the batch linker, we don't bother to tell doLink +-- which packages to link -- it just tries all that are available. +-- batch_attempt_linking should only be *looked at* in batch mode. It +-- should only be True if the upsweep was successful and someone +-- exports main, i.e., we have good reason to believe that linking +-- will succeed. + +-- There will be (ToDo: are) two lists passed to link. These +-- correspond to -- +-- 1. The list of all linkables in the current home package. This is +-- used by the batch linker to link the program, and by the interactive +-- linker to decide which modules from the previous link it can +-- throw away. +-- 2. The list of modules on which we just called "compile". This list +-- is used by the interactive linker to decide which modules need +-- to be actually linked this time around (or unlinked and re-linked +-- if the module was recompiled). + +link mode dflags batch_attempt_linking linkables + = do let verb = verbosity dflags + when (verb >= 3) $ do + hPutStrLn stderr "link: linkables are ..." + hPutStrLn stderr (showSDoc (vcat (map ppr linkables))) + + res <- link' mode dflags batch_attempt_linking linkables + + when (verb >= 3) (hPutStrLn stderr "link: done") + + return res + +#ifdef GHCI +link' Interactive dflags batch_attempt_linking linkables + = do showPass dflags "Not Linking...(demand linker will do the job)" + -- linkModules dflags linkables + return Succeeded +#endif + +link' Batch dflags batch_attempt_linking linkables + | batch_attempt_linking + = do when (verb >= 1) $ + hPutStrLn stderr "ghc: linking ..." + + -- Don't showPass in Batch mode; doLink will do that for us. + staticLink (concatMap getOfiles linkables) + + -- staticLink only returns if it succeeds + return Succeeded + + | otherwise + = do when (verb >= 3) $ do + hPutStrLn stderr "link(batch): upsweep (partially) failed OR" + hPutStrLn stderr " Main.main not exported; not linking." + return Succeeded + where + verb = verbosity dflags + getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) + + + +----------------------------------------------------------------------------- +-- genPipeline: Pipeline construction +----------------------------------------------------------------------------- + -- Herein is all the magic about which phases to run in which order, whether -- the intermediate files should be in TMPDIR or in the current directory, -- what the suffix of the intermediate files should be, etc. @@ -516,7 +778,7 @@ run_phase Hsc basename suff input_fn output_fn else getImportsFromFile input_fn - -- build a ModuleLocation to pass to hscMain. + -- build a ModLocation to pass to hscMain. (mod, location') <- mkHomeModuleLocn mod_name basename (basename ++ '.':suff) @@ -563,18 +825,18 @@ run_phase Hsc basename suff input_fn output_fn hscStubCOutName = basename ++ "_stub.c", hscStubHOutName = basename ++ "_stub.h", extCoreName = basename ++ ".hcr" } + hsc_env = HscEnv { hsc_mode = OneShot, + hsc_dflags = dyn_flags', + hsc_HPT = emptyHomePackageTable } + -- run the compiler! pcs <- initPersistentCompilerState - result <- hscMain OneShot - dyn_flags' mod + result <- hscMain hsc_env pcs mod location{ ml_hspp_file=Just input_fn } source_unchanged False Nothing -- no iface - emptyModuleEnv -- HomeSymbolTable - emptyModuleEnv -- HomeIfaceTable - pcs case result of { @@ -780,7 +1042,7 @@ run_phase Ilasm _basename _suff input_fn output_fn -- wrapper script calling the binary. Currently, we need this only in -- a parallel way (i.e. in GUM), because PVM expects the binary in a -- central directory. --- This is called from doLink below, after linking. I haven't made it +-- This is called from staticLink below, after linking. I haven't made it -- a separate phase to minimise interfering with other modules, and -- we don't need the generality of a phase (MoveBinary is always -- done after linking and makes only sense in a parallel setup) -- HWL @@ -868,10 +1130,10 @@ checkProcessArgsResult flags basename suff ++ unwords flags)) (ExitFailure 1)) ----------------------------------------------------------------------------- --- Linking +-- Static linking, of .o files -doLink :: [String] -> IO () -doLink o_files = do +staticLink :: [String] -> IO () +staticLink o_files = do verb <- getVerbFlag static <- readIORef v_Static no_hs_main <- readIORef v_NoHsMain @@ -916,12 +1178,12 @@ doLink o_files = do -- opts from -optl-<blah> extra_ld_opts <- getStaticOpts v_Opt_l - rts_pkg <- getPackageDetails ["rts"] - std_pkg <- getPackageDetails ["std"] + [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, preludePackage] + let extra_os = if static || no_hs_main then [] - else [ head (library_dirs (head rts_pkg)) ++ "/Main.dll_o", - head (library_dirs (head std_pkg)) ++ "/PrelMain.dll_o" ] + else [ head (library_dirs rts_pkg) ++ "/Main.dll_o", + head (library_dirs std_pkg) ++ "/PrelMain.dll_o" ] (md_c_flags, _) <- machdepCCOpts SysTools.runLink ( [ SysTools.Option verb @@ -992,13 +1254,12 @@ doMkDLL o_files = do -- opts from -optdll-<blah> extra_ld_opts <- getStaticOpts v_Opt_dll - rts_pkg <- getPackageDetails ["rts"] - std_pkg <- getPackageDetails ["std"] + [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, stdPackage] let extra_os = if static || no_hs_main then [] - else [ head (library_dirs (head rts_pkg)) ++ "/Main.dll_o", - head (library_dirs (head std_pkg)) ++ "/PrelMain.dll_o" ] + else [ head (library_dirs rts_pkg) ++ "/Main.dll_o", + head (library_dirs std_pkg) ++ "/PrelMain.dll_o" ] (md_c_flags, _) <- machdepCCOpts SysTools.runMkDLL @@ -1022,184 +1283,3 @@ doMkDLL o_files = do else [ "--export-all" ]) ++ extra_ld_opts )) - ------------------------------------------------------------------------------ --- Just preprocess a file, put the result in a temp. file (used by the --- compilation manager during the summary phase). - -preprocess :: FilePath -> IO FilePath -preprocess filename = - ASSERT(haskellish_src_file filename) - do restoreDynFlags -- Restore to state of last save - let fInfo = (filename, getFileSuffix filename) - pipeline <- genPipeline (StopBefore Hsc) ("preprocess") False - defaultHscLang fInfo - (fn,_) <- runPipeline pipeline fInfo - False{-no linking-} False{-no -o flag-} - return fn - ------------------------------------------------------------------------------ --- Compile a single module, under the control of the compilation manager. --- --- This is the interface between the compilation manager and the --- compiler proper (hsc), where we deal with tedious details like --- reading the OPTIONS pragma from the source file, and passing the --- output of hsc through the C compiler. - --- The driver sits between 'compile' and 'hscMain', translating calls --- to the former into calls to the latter, and results from the latter --- into results from the former. It does things like preprocessing --- the .hs file if necessary, and compiling up the .stub_c files to --- generate Linkables. - --- NB. No old interface can also mean that the source has changed. - -compile :: GhciMode -- distinguish batch from interactive - -> ModSummary -- summary, including source - -> Bool -- True <=> source unchanged - -> Bool -- True <=> have object - -> Maybe ModIface -- old interface, if available - -> HomeSymbolTable -- for home module ModDetails - -> HomeIfaceTable -- for home module Ifaces - -> PersistentCompilerState -- persistent compiler state - -> IO CompResult - -data CompResult - = CompOK PersistentCompilerState -- updated PCS - ModDetails -- new details (HST additions) - ModIface -- new iface (HIT additions) - (Maybe Linkable) - -- new code; Nothing => compilation was not reqd - -- (old code is still valid) - - | CompErrs PersistentCompilerState -- updated PCS - - -compile ghci_mode summary source_unchanged have_object - old_iface hst hit pcs = do - dyn_flags <- restoreDynFlags -- Restore to the state of the last save - - - showPass dyn_flags - (showSDoc (text "Compiling" <+> ppr (modSummaryName summary))) - - let verb = verbosity dyn_flags - let location = ms_location summary - let input_fn = expectJust "compile:hs" (ml_hs_file location) - let input_fnpp = expectJust "compile:hspp" (ml_hspp_file location) - - when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp)) - - opts <- getOptionsFromSource input_fnpp - processArgs dynamic_flags opts [] - dyn_flags <- getDynFlags - - let hsc_lang = hscLang dyn_flags - (basename, _) = splitFilename input_fn - - keep_hc <- readIORef v_Keep_hc_files -#ifdef ILX - keep_il <- readIORef v_Keep_il_files -#endif - keep_s <- readIORef v_Keep_s_files - - output_fn <- - case hsc_lang of - HscAsm | keep_s -> return (basename ++ '.':phaseInputExt As) - | otherwise -> newTempName (phaseInputExt As) - HscC | keep_hc -> return (basename ++ '.':phaseInputExt HCc) - | otherwise -> newTempName (phaseInputExt HCc) - HscJava -> newTempName "java" -- ToDo -#ifdef ILX - HscILX | keep_il -> return (basename ++ '.':phaseInputExt Ilasm) - | otherwise -> newTempName (phaseInputExt Ilx2Il) -#endif - HscInterpreted -> return (error "no output file") - HscNothing -> return (error "no output file") - - let dyn_flags' = dyn_flags { hscOutName = output_fn, - hscStubCOutName = basename ++ "_stub.c", - hscStubHOutName = basename ++ "_stub.h", - extCoreName = basename ++ ".hcr" } - - -- figure out which header files to #include in a generated .hc file - c_includes <- getPackageCIncludes - cmdline_includes <- dynFlag cmdlineHcIncludes -- -#include options - - let cc_injects = unlines (map mk_include - (c_includes ++ reverse cmdline_includes)) - mk_include h_file = - case h_file of - '"':_{-"-} -> "#include "++h_file - '<':_ -> "#include "++h_file - _ -> "#include \""++h_file++"\"" - - writeIORef v_HCHeader cc_injects - - -- -no-recomp should also work with --make - do_recomp <- readIORef v_Recomp - let source_unchanged' = source_unchanged && do_recomp - - -- run the compiler - hsc_result <- hscMain ghci_mode dyn_flags' - (ms_mod summary) location - source_unchanged' have_object old_iface hst hit pcs - - case hsc_result of - HscFail pcs -> return (CompErrs pcs) - - HscNoRecomp pcs details iface -> return (CompOK pcs details iface Nothing) - - HscRecomp pcs details iface - stub_h_exists stub_c_exists maybe_interpreted_code -> do - let - maybe_stub_o <- compileStub dyn_flags' stub_c_exists - let stub_unlinked = case maybe_stub_o of - Nothing -> [] - Just stub_o -> [ DotO stub_o ] - - (hs_unlinked, unlinked_time) <- - case hsc_lang of - - -- in interpreted mode, just return the compiled code - -- as our "unlinked" object. - HscInterpreted -> - case maybe_interpreted_code of -#ifdef GHCI - Just (bcos,itbl_env) -> do tm <- getClockTime - return ([BCOs bcos itbl_env], tm) -#endif - Nothing -> panic "compile: no interpreted code" - - -- we're in batch mode: finish the compilation pipeline. - _other -> do pipe <- genPipeline (StopBefore Ln) "" True - hsc_lang (output_fn, getFileSuffix output_fn) - -- runPipeline takes input_fn so it can split off - -- the base name and use it as the base of - -- the output object file. - let (basename, suffix) = splitFilename input_fn - (o_file,_) <- - pipeLoop pipe (output_fn, getFileSuffix output_fn) - False False - basename suffix - o_time <- getModificationTime o_file - return ([DotO o_file], o_time) - - let linkable = LM unlinked_time (modSummaryName summary) - (hs_unlinked ++ stub_unlinked) - - return (CompOK pcs details iface (Just linkable)) - - ------------------------------------------------------------------------------ --- stub .h and .c files (for foreign export support) - -compileStub dflags stub_c_exists - | not stub_c_exists = return Nothing - | stub_c_exists = do - -- compile the _stub.c file w/ gcc - let stub_c = hscStubCOutName dflags - pipeline <- genPipeline (StopBefore Ln) "" True defaultHscLang (stub_c,"c") - (stub_o,_) <- runPipeline pipeline (stub_c,"c") False{-no linking-} - False{-no -o option-} - return (Just stub_o) diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index 845c8aac47..c4b1b8c6c0 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.81 2002/08/29 15:44:15 simonmar Exp $ +-- $Id: DriverState.hs,v 1.82 2002/09/13 15:02:34 simonpj Exp $ -- -- Settings for the driver -- @@ -14,7 +14,11 @@ module DriverState where import SysTools ( getTopDir ) import ParsePkgConf ( loadPackageConfig ) -import Packages ( PackageConfig(..), mungePackagePaths ) +import Packages ( PackageConfig(..), PackageConfigMap, + PackageName, mkPackageName, packageNameString, + packageDependents, + mungePackagePaths, emptyPkgMap, extendPkgMap, lookupPkg, + preludePackage, rtsPackage, haskell98Package ) import CmdLineOpts import DriverPhases import DriverUtil @@ -456,34 +460,61 @@ GLOBAL_VAR(v_HCHeader, "", String) ----------------------------------------------------------------------------- -- Packages --- package list is maintained in dependency order -GLOBAL_VAR(v_Packages, ("haskell98":"base":"rts":[]), [String]) +------------------------ +-- The PackageConfigMap is read in from the configuration file +-- It doesn't change during a run +GLOBAL_VAR(v_Package_details, emptyPkgMap, PackageConfigMap) readPackageConf :: String -> IO () readPackageConf conf_file = do - proto_pkg_details <- loadPackageConfig conf_file - top_dir <- getTopDir - let pkg_details = mungePackagePaths top_dir proto_pkg_details - old_pkg_details <- readIORef v_Package_details + proto_pkg_configs <- loadPackageConfig conf_file + top_dir <- getTopDir + old_pkg_map <- readIORef v_Package_details - let -- new package override old ones - new_pkg_names = map name pkg_details - filtered_old_pkg_details = - filter (\p -> name p `notElem` new_pkg_names) old_pkg_details + let pkg_configs = mungePackagePaths top_dir proto_pkg_configs + new_pkg_map = extendPkgMap old_pkg_map pkg_configs + + writeIORef v_Package_details new_pkg_map - writeIORef v_Package_details (pkg_details ++ filtered_old_pkg_details) +getPackageConfigMap :: IO PackageConfigMap +getPackageConfigMap = readIORef v_Package_details + + +------------------------ +-- The package list reflects what was given as command-line options, +-- plus their dependent packages. +-- It is maintained in dependency order; +-- earlier ones depend on later ones, but not vice versa +GLOBAL_VAR(v_Packages, initPackageList, [PackageName]) + +getPackages :: IO [PackageName] +getPackages = readIORef v_Packages + +initPackageList = [haskell98Package, + preludePackage, + rtsPackage] addPackage :: String -> IO () addPackage package - = do pkg_details <- readIORef v_Package_details - case lookupPkg package pkg_details of - Nothing -> throwDyn (CmdLineError ("unknown package name: " ++ package)) - Just details -> do - ps <- readIORef v_Packages - unless (package `elem` ps) $ do - mapM_ addPackage (package_deps details) - ps <- readIORef v_Packages - writeIORef v_Packages (package:ps) + = do { pkg_details <- getPackageConfigMap + ; ps <- readIORef v_Packages + ; ps' <- add_package pkg_details ps (mkPackageName package) + -- Throws an exception if it fails + ; writeIORef v_Packages ps' } + +add_package :: PackageConfigMap -> [PackageName] + -> PackageName -> IO [PackageName] +add_package pkg_details ps p + | p `elem` ps -- Check if we've already added this package + = return ps + | Just details <- lookupPkg pkg_details p + = do { -- Add the package's dependents first + ps' <- foldM (add_package pkg_details) ps + (packageDependents details) + ; return (p : ps') } + + | otherwise + = throwDyn (CmdLineError ("unknown package name: " ++ packageNameString p)) getPackageImportPath :: IO [String] getPackageImportPath = do @@ -573,22 +604,14 @@ getPackageFrameworks = do #endif getPackageInfo :: IO [PackageConfig] -getPackageInfo = do - ps <- readIORef v_Packages - getPackageDetails ps +getPackageInfo = do ps <- getPackages + getPackageDetails ps -getPackageDetails :: [String] -> IO [PackageConfig] +getPackageDetails :: [PackageName] -> IO [PackageConfig] getPackageDetails ps = do - pkg_details <- readIORef v_Package_details - return [ pkg | p <- ps, Just pkg <- [ lookupPkg p pkg_details ] ] - -GLOBAL_VAR(v_Package_details, [], [PackageConfig]) + pkg_details <- getPackageConfigMap + return [ pkg | Just pkg <- map (lookupPkg pkg_details) ps ] -lookupPkg :: String -> [PackageConfig] -> Maybe PackageConfig -lookupPkg nm ps - = case [p | p <- ps, name p == nm] of - [] -> Nothing - (p:_) -> Just p ----------------------------------------------------------------------------- -- Ways diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs index 367ae543e9..919fc3b731 100644 --- a/ghc/compiler/main/DriverUtil.hs +++ b/ghc/compiler/main/DriverUtil.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverUtil.hs,v 1.33 2002/08/29 15:44:15 simonmar Exp $ +-- $Id: DriverUtil.hs,v 1.34 2002/09/13 15:02:34 simonpj Exp $ -- -- Utils for the driver -- diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index c8beedd89f..9a04b72583 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -5,7 +5,8 @@ \begin{code} module ErrUtils ( - ErrMsg, WarnMsg, Message, Messages, errorsFound, warningsFound, + ErrMsg, WarnMsg, Message, + Messages, errorsFound, warningsFound, emptyMessages, addShortErrLocLine, addShortWarnLocLine, addErrLocHdrLine, addWarnLocHdrLine, dontAddErrLoc, @@ -15,16 +16,17 @@ module ErrUtils ( printError, ghcExit, doIfSet, doIfSet_dyn, - dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, + dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, showPass ) where #include "HsVersions.h" -import Bag ( Bag, bagToList, isEmptyBag ) +import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) import SrcLoc ( SrcLoc, noSrcLoc, isGoodSrcLoc ) import Util ( sortLt ) import Outputable +import qualified Pretty import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt ) import List ( replicate ) @@ -33,42 +35,53 @@ import IO ( hPutStr, hPutStrLn, stderr, stdout ) \end{code} \begin{code} -type MsgWithLoc = (SrcLoc, SDoc) +type MsgWithLoc = (SrcLoc, Pretty.Doc) + -- The SrcLoc is used for sorting errors into line-number order + -- NB Pretty.Doc not SDoc: we deal with the printing style (in ptic + -- whether to qualify an External Name) at the error occurrence type ErrMsg = MsgWithLoc type WarnMsg = MsgWithLoc type Message = SDoc -addShortErrLocLine :: SrcLoc -> Message -> ErrMsg -addErrLocHdrLine :: SrcLoc -> Message -> Message -> ErrMsg -addWarnLocHdrLine :: SrcLoc -> Message -> Message -> ErrMsg -addShortWarnLocLine :: SrcLoc -> Message -> WarnMsg - -addShortErrLocLine locn rest_of_err_msg - | isGoodSrcLoc locn = (locn, hang (ppr locn <> colon) 4 - rest_of_err_msg) - | otherwise = (locn, rest_of_err_msg) - -addErrLocHdrLine locn hdr rest_of_err_msg - = ( locn - , hang (ppr locn <> colon<+> hdr) - 4 rest_of_err_msg - ) - -addWarnLocHdrLine locn hdr rest_of_err_msg - = ( locn - , hang (ppr locn <> colon <+> ptext SLIT("Warning:") <+> hdr) - 4 (rest_of_err_msg) - ) - -addShortWarnLocLine locn rest_of_err_msg - | isGoodSrcLoc locn = (locn, hang (ppr locn <> colon) 4 - (ptext SLIT("Warning:") <+> rest_of_err_msg)) - | otherwise = (locn, rest_of_err_msg) +addShortErrLocLine :: SrcLoc -> PrintUnqualified -> Message -> ErrMsg +addShortWarnLocLine :: SrcLoc -> PrintUnqualified -> Message -> WarnMsg + -- Used heavily by renamer/typechecker + -- Be refined about qualification, return an ErrMsg -dontAddErrLoc :: Message -> ErrMsg -dontAddErrLoc msg = (noSrcLoc, msg) +addErrLocHdrLine :: SrcLoc -> Message -> Message -> Message +addWarnLocHdrLine :: SrcLoc -> Message -> Message -> Message + -- Used by Lint and other system stuff + -- Always print qualified, return a Message + +addShortErrLocLine locn print_unqual msg + = (locn, doc (mkErrStyle print_unqual)) + where + doc = mkErrDoc locn msg + +addShortWarnLocLine locn print_unqual msg + = (locn, doc (mkErrStyle print_unqual)) + where + doc = mkWarnDoc locn msg +addErrLocHdrLine locn hdr msg + = mkErrDoc locn (hdr $$ msg) + +addWarnLocHdrLine locn hdr msg + = mkWarnDoc locn (hdr $$ msg) + +dontAddErrLoc :: Message -> ErrMsg +dontAddErrLoc msg = (noSrcLoc, msg defaultErrStyle) + +mkErrDoc locn msg + | isGoodSrcLoc locn = hang (ppr locn <> colon) 4 msg + | otherwise = msg + +mkWarnDoc locn msg + | isGoodSrcLoc locn = hang (ppr locn <> colon) 4 warn_msg + | otherwise = warn_msg + where + warn_msg = ptext SLIT("Warning:") <+> msg \end{code} \begin{code} @@ -79,32 +92,35 @@ printError str = hPutStrLn stderr str \begin{code} type Messages = (Bag WarnMsg, Bag ErrMsg) +emptyMessages :: Messages +emptyMessages = (emptyBag, emptyBag) + errorsFound :: Messages -> Bool errorsFound (warns, errs) = not (isEmptyBag errs) warningsFound :: Messages -> Bool warningsFound (warns, errs) = not (isEmptyBag warns) -printErrorsAndWarnings :: PrintUnqualified -> Messages -> IO () +printErrorsAndWarnings :: Messages -> IO () -- Don't print any warnings if there are errors -printErrorsAndWarnings unqual (warns, errs) +printErrorsAndWarnings (warns, errs) | no_errs && no_warns = return () - | no_errs = printErrs unqual (pprBagOfWarnings warns) - | otherwise = printErrs unqual (pprBagOfErrors errs) + | no_errs = printErrs (pprBagOfWarnings warns) + | otherwise = printErrs (pprBagOfErrors errs) where no_warns = isEmptyBag warns no_errs = isEmptyBag errs -pprBagOfErrors :: Bag ErrMsg -> SDoc +pprBagOfErrors :: Bag ErrMsg -> Pretty.Doc pprBagOfErrors bag_of_errors - = vcat [text "" $$ p | (_,p) <- sorted_errs ] + = Pretty.vcat [Pretty.text "" Pretty.$$ p | (_,p) <- sorted_errs ] where bag_ls = bagToList bag_of_errors sorted_errs = sortLt occ'ed_before bag_ls occ'ed_before (a,_) (b,_) = LT == compare a b -pprBagOfWarnings :: Bag WarnMsg -> SDoc +pprBagOfWarnings :: Bag WarnMsg -> Pretty.Doc pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns \end{code} @@ -135,21 +151,21 @@ showPass dflags what dumpIfSet :: Bool -> String -> SDoc -> IO () dumpIfSet flag hdr doc | not flag = return () - | otherwise = printDump (dump hdr doc) + | otherwise = printDump (mkDumpDoc hdr doc) dumpIfSet_core :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpIfSet_core dflags flag hdr doc | dopt flag dflags || verbosity dflags >= 4 - || dopt Opt_D_verbose_core2core dflags = printDump (dump hdr doc) + || dopt Opt_D_verbose_core2core dflags = printDump (mkDumpDoc hdr doc) | otherwise = return () dumpIfSet_dyn :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpIfSet_dyn dflags flag hdr doc | dopt flag dflags || verbosity dflags >= 4 = if flag `elem` [Opt_D_dump_stix, Opt_D_dump_asm] - then printForC stdout (dump hdr doc) - else printDump (dump hdr doc) + then printForC stdout (mkDumpDoc hdr doc) + else printDump (mkDumpDoc hdr doc) | otherwise = return () @@ -157,10 +173,10 @@ dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO () dumpIfSet_dyn_or dflags flags hdr doc | or [dopt flag dflags | flag <- flags] || verbosity dflags >= 4 - = printDump (dump hdr doc) + = printDump (mkDumpDoc hdr doc) | otherwise = return () -dump hdr doc +mkDumpDoc hdr doc = vcat [text "", line <+> text hdr <+> line, doc, diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index a710609458..f8f2a7181d 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -6,23 +6,24 @@ \begin{code} module Finder ( initFinder, -- :: [PackageConfig] -> IO (), - findModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) - findModuleDep, -- :: ModuleName -> Bool -> IO (Maybe (Module, ModuleLocation)) - findPackageModule, -- :: ModuleName -> IO (Maybe (Module, ModuleLocation)) + findModule, -- :: ModuleName -> IO (Maybe (Module, ModLocation)) + findModuleDep, -- :: ModuleName -> Bool -> IO (Maybe (Module, ModLocation)) + findPackageModule, -- :: ModuleName -> IO (Maybe (Module, ModLocation)) mkHomeModuleLocn, -- :: ModuleName -> String -> FilePath - -- -> IO ModuleLocation + -- -> IO ModLocation emptyHomeDirCache, -- :: IO () flushPackageCache -- :: [PackageConfig] -> IO () ) where #include "HsVersions.h" -import HscTypes ( ModuleLocation(..) ) +import Module ( Module, ModLocation(..), ModuleName, + moduleNameUserString, mkHomeModule, mkPackageModule + ) import Packages ( PackageConfig(..) ) import DriverPhases import DriverState import DriverUtil -import Module import FastString import Config @@ -54,10 +55,10 @@ flushPackageCache pkgs = return () emptyHomeDirCache :: IO () emptyHomeDirCache = return () -findModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) +findModule :: ModuleName -> IO (Maybe (Module, ModLocation)) findModule name = findModuleDep name False -findModuleDep :: ModuleName -> Bool -> IO (Maybe (Module, ModuleLocation)) +findModuleDep :: ModuleName -> Bool -> IO (Maybe (Module, ModLocation)) findModuleDep name is_source = do { j <- maybeHomeModule name is_source ; case j of @@ -65,7 +66,7 @@ findModuleDep name is_source Nothing -> findPackageMod name False is_source } -maybeHomeModule :: ModuleName -> Bool -> IO (Maybe (Module, ModuleLocation)) +maybeHomeModule :: ModuleName -> Bool -> IO (Maybe (Module, ModLocation)) maybeHomeModule mod_name is_source = do home_path <- readIORef v_Import_paths hisuf <- readIORef v_Hi_suf @@ -109,7 +110,7 @@ maybeHomeModule mod_name is_source = do mkHiOnlyModuleLocn mod_name hi_file = return ( mkHomeModule mod_name - , ModuleLocation{ ml_hspp_file = Nothing + , ModLocation{ ml_hspp_file = Nothing , ml_hs_file = Nothing , ml_hi_file = hi_file , ml_obj_file = Nothing @@ -141,7 +142,7 @@ mkHomeModuleLocn mod_name o_file <- odir_ify (basename ++ '.':phaseInputExt Ln) >>= osuf_ify return (mkHomeModule mod_name, - ModuleLocation{ ml_hspp_file = Nothing + ModLocation{ ml_hspp_file = Nothing , ml_hs_file = Just source_fn , ml_hi_file = hi , ml_obj_file = Just o_file @@ -150,7 +151,7 @@ mkHomeModuleLocn mod_name findPackageMod :: ModuleName -> Bool -> Bool - -> IO (Maybe (Module, ModuleLocation)) + -> IO (Maybe (Module, ModLocation)) findPackageMod mod_name hiOnly is_source = do pkgs <- getPackageInfo @@ -166,7 +167,7 @@ findPackageMod mod_name hiOnly is_source = do retPackageModule mod_name mbFName path = return ( mkPackageModule mod_name - , ModuleLocation{ ml_hspp_file = Nothing + , ModLocation{ ml_hspp_file = Nothing , ml_hs_file = mbFName , ml_hi_file = path ++ '.':package_hisuf , ml_obj_file = Nothing @@ -190,13 +191,13 @@ findPackageMod mod_name hiOnly is_source = do ]))) where -findPackageModule :: ModuleName -> IO (Maybe (Module, ModuleLocation)) +findPackageModule :: ModuleName -> IO (Maybe (Module, ModLocation)) findPackageModule mod_name = findPackageMod mod_name True False searchPathExts :: [FilePath] -> String - -> [(String, FilePath -> String -> IO (Module, ModuleLocation))] - -> IO (Maybe (Module, ModuleLocation)) + -> [(String, FilePath -> String -> IO (Module, ModLocation))] + -> IO (Maybe (Module, ModLocation)) searchPathExts path basename exts = search path where search [] = return Nothing diff --git a/ghc/compiler/main/GetImports.hs b/ghc/compiler/main/GetImports.hs index 50e374ef0c..57ded51da4 100644 --- a/ghc/compiler/main/GetImports.hs +++ b/ghc/compiler/main/GetImports.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: GetImports.hs,v 1.9 2002/07/16 06:42:04 sof Exp $ +-- $Id: GetImports.hs,v 1.10 2002/09/13 15:02:34 simonpj Exp $ -- -- GHC Driver program -- diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index cf6420054a..ebf7fb5606 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -5,59 +5,49 @@ \section[GHC_Main]{Main driver for Glasgow Haskell compiler} \begin{code} -module HscMain ( HscResult(..), hscMain, +module HscMain ( + HscResult(..), hscMain, initPersistentCompilerState #ifdef GHCI - hscStmt, hscThing, hscModuleContents, + , hscStmt, hscTcExpr, hscThing, + , compileExpr #endif - initPersistentCompilerState ) where + ) where #include "HsVersions.h" #ifdef GHCI -import Interpreter -import ByteCodeGen ( byteCodeGen ) +import TcHsSyn ( TypecheckedHsExpr ) +import CodeOutput ( outputForeignStubs ) +import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) +import Linker ( HValue, linkExpr ) import TidyPgm ( tidyCoreExpr ) import CorePrep ( corePrepExpr ) -import Rename ( renameStmt, renameRdrName, slurpIface ) -import RdrName ( rdrNameOcc, setRdrNameOcc ) +import Flattening ( flattenExpr ) +import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnThing ) import RdrHsSyn ( RdrNameStmt ) -import OccName ( dataName, tcClsName, - occNameSpace, setOccNameSpace ) import Type ( Type ) -import Id ( Id, idName, setGlobalIdDetails ) -import IdInfo ( GlobalIdDetails(VanillaGlobal) ) -import Name ( isInternalName ) -import NameEnv ( lookupNameEnv ) -import Module ( lookupModuleEnv ) -import RdrName ( rdrEnvElts ) import PrelNames ( iNTERACTIVE ) import StringBuffer ( stringToStringBuffer ) -import Maybes ( catMaybes ) - -import List ( nub ) #endif import HsSyn -import RdrName ( mkRdrOrig ) +import RdrName ( nameRdrName ) import Id ( idName ) import IdInfo ( CafInfo(..), CgInfoEnv, CgInfo(..) ) import StringBuffer ( hGetStringBuffer, freeStringBuffer ) import Parser import Lex ( ParseResult(..), ExtFlags(..), mkPState ) import SrcLoc ( mkSrcLoc ) -import Finder ( findModule ) -import Rename ( checkOldIface, renameModule, renameExtCore, - closeIfaceDecls, RnResult(..) ) +import TcRnDriver ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface ) import Rules ( emptyRuleBase ) import PrelInfo ( wiredInThingEnv, wiredInThings ) import PrelRules ( builtinRules ) -import PrelNames ( knownKeyNames, gHC_PRIM_Name ) -import MkIface ( mkFinalIface ) -import TcModule +import PrelNames ( knownKeyNames ) +import MkIface ( mkIface ) import InstEnv ( emptyInstEnv ) import Desugar -import Flattening ( flatten, flattenExpr ) +import Flattening ( flatten ) import SimplCore import CoreUtils ( coreBindsSize ) import TidyPgm ( tidyCorePgm ) @@ -66,11 +56,10 @@ import StgSyn import CoreToStg ( coreToStg ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) -import CodeOutput ( codeOutput, outputForeignStubs ) +import CodeOutput ( codeOutput ) -import Module ( ModuleName, moduleName, mkHomeModule ) +import Module ( ModuleName, moduleName ) import CmdLineOpts -import DriverState ( v_HCHeader ) import DriverPhases ( isExtCore_file ) import ErrUtils ( dumpIfSet_dyn, showPass, printError ) import UniqSupply ( mkSplitUniqSupply ) @@ -86,10 +75,10 @@ import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM ) import OccName ( OccName ) import Name ( Name, nameModule, nameOccName, getName ) import NameEnv ( emptyNameEnv, mkNameEnv ) -import Module ( Module ) +import NameSet ( emptyNameSet ) +import Module ( Module, ModLocation(..), showModMsg ) import FastString import Maybes ( expectJust ) -import Util ( seqList ) import DATA_IOREF ( newIORef, readIORef, writeIORef ) import UNSAFE_IO ( unsafePerformIO ) @@ -120,134 +109,110 @@ data HscResult ModIface -- new iface (if any compilation was done) Bool -- stub_h exists Bool -- stub_c exists -#ifdef GHCI - (Maybe ([UnlinkedBCO],ItblEnv)) -- interpreted code, if any -#else - (Maybe ()) -- no interpreted code whatsoever -#endif + (Maybe CompiledByteCode) -- no errors or warnings; the individual passes -- (parse/rename/typecheck) print messages themselves hscMain - :: GhciMode - -> DynFlags + :: HscEnv + -> PersistentCompilerState -- IN: persistent compiler state -> Module - -> ModuleLocation -- location info + -> ModLocation -- location info -> Bool -- True <=> source unchanged -> Bool -- True <=> have an object file (for msgs only) -> Maybe ModIface -- old interface, if available - -> HomeSymbolTable -- for home module ModDetails - -> HomeIfaceTable - -> PersistentCompilerState -- IN: persistent compiler state -> IO HscResult -hscMain ghci_mode dflags mod location source_unchanged have_object - maybe_old_iface hst hit pcs - = {-# SCC "hscMain" #-} - do { - showPass dflags ("Checking old interface for hs = " - ++ show (ml_hs_file location) - ++ ", hspp = " ++ show (ml_hspp_file location)); - - (pcs_ch, errs_found, (recomp_reqd, maybe_checked_iface)) - <- _scc_ "checkOldIface" - checkOldIface ghci_mode dflags hit hst pcs mod (ml_hi_file location) - source_unchanged maybe_old_iface; - - if errs_found then - return (HscFail pcs_ch) - else do { +hscMain hsc_env pcs mod location + source_unchanged have_object maybe_old_iface + = do { + (pcs_ch, maybe_chk_result) <- _scc_ "checkOldIface" + checkOldIface hsc_env pcs mod + (ml_hi_file location) + source_unchanged maybe_old_iface; + case maybe_chk_result of { + Nothing -> return (HscFail pcs_ch) ; + Just (recomp_reqd, maybe_checked_iface) -> do { let no_old_iface = not (isJust maybe_checked_iface) what_next | recomp_reqd || no_old_iface = hscRecomp | otherwise = hscNoRecomp - ; - what_next ghci_mode dflags have_object mod location - maybe_checked_iface hst hit pcs_ch - }} + ; what_next hsc_env pcs_ch have_object + mod location maybe_checked_iface + }}} --- we definitely expect to have the old interface available -hscNoRecomp ghci_mode dflags have_object - mod location (Just old_iface) hst hit pcs_ch - | ghci_mode == OneShot + +-- hscNoRecomp definitely expects to have the old interface available +hscNoRecomp hsc_env pcs_ch have_object + mod location (Just old_iface) + | hsc_mode hsc_env == OneShot = do { - when (verbosity dflags > 0) $ + when (verbosity (hsc_dflags hsc_env) > 0) $ hPutStrLn stderr "compilation IS NOT required"; let { bomb = panic "hscNoRecomp:OneShot" }; return (HscNoRecomp pcs_ch bomb bomb) } | otherwise = do { - when (verbosity dflags >= 1) $ + when (verbosity (hsc_dflags hsc_env) >= 1) $ hPutStrLn stderr ("Skipping " ++ showModMsg have_object mod location); - -- CLOSURE - (pcs_cl, closure_errs, cl_hs_decls) - <- closeIfaceDecls dflags hit hst pcs_ch old_iface ; - if closure_errs then - return (HscFail pcs_cl) - else do { - - -- TYPECHECK - maybe_tc_result - <- typecheckIface dflags pcs_cl hst old_iface cl_hs_decls; + -- Typecheck + (pcs_tc, maybe_tc_result) <- tcRnIface hsc_env pcs_ch old_iface ; case maybe_tc_result of { - Nothing -> return (HscFail pcs_cl); - Just (pcs_tc, new_details) -> + Nothing -> return (HscFail pcs_tc); + Just new_details -> return (HscNoRecomp pcs_tc new_details old_iface) - }}} + }} -hscRecomp ghci_mode dflags have_object - mod location maybe_checked_iface hst hit pcs_ch +hscRecomp hsc_env pcs_ch have_object + mod location maybe_checked_iface = do { -- what target are we shooting for? - ; let toInterp = dopt_HscLang dflags == HscInterpreted - ; let toNothing = dopt_HscLang dflags == HscNothing + ; let one_shot = hsc_mode hsc_env == OneShot + ; let dflags = hsc_dflags hsc_env + ; let toInterp = dopt_HscLang dflags == HscInterpreted ; let toCore = isJust (ml_hs_file location) && isExtCore_file (fromJust (ml_hs_file location)) - ; when (ghci_mode /= OneShot && verbosity dflags >= 1) $ + ; when (not one_shot && verbosity dflags >= 1) $ hPutStrLn stderr ("Compiling " ++ showModMsg (not toInterp) mod location); - ; front_res <- - (if toCore then hscCoreFrontEnd else hscFrontEnd) - ghci_mode dflags location hst hit pcs_ch + ; front_res <- if toCore then + hscCoreFrontEnd hsc_env pcs_ch location + else + hscFrontEnd hsc_env pcs_ch location + ; case front_res of Left flure -> return flure; - Right (this_mod, rdr_module, - dont_discard, new_iface, - pcs_tc, ds_details, foreign_stuff) -> do { + Right (pcs_tc, ds_result) -> do { - let { - imported_module_names = - filter (/= gHC_PRIM_Name) $ - map ideclName (hsModuleImports rdr_module); - imported_modules = - map (moduleNameToModule hit (pcs_PIT pcs_tc)) - imported_module_names; - } - - -- force this out now, so we don't keep a hold of rdr_module or pcs_tc - ; seqList imported_modules (return ()) + -- OMITTED: + -- ; seqList imported_modules (return ()) ------------------- -- FLATTENING ------------------- - ; flat_details - <- _scc_ "Flattening" - flatten dflags pcs_tc hst ds_details + ; flat_result <- _scc_ "Flattening" + flatten hsc_env pcs_tc ds_result + + ; let pcs_middle = pcs_tc + +{- Again, omit this because it loses the usage info + which is needed in mkIface. Maybe we should compute + usage info earlier. ; pcs_middle <- _scc_ "pcs_middle" - if ghci_mode == OneShot - then do init_pcs <- initPersistentCompilerState + if one_shot then + do init_pcs <- initPersistentCompilerState init_prs <- initPersistentRenamerState let rules = pcs_rules pcs_tc @@ -257,11 +222,12 @@ hscRecomp ghci_mode dflags have_object orig_tc `seq` rules `seq` new_prs `seq` return init_pcs{ pcs_PRS = new_prs, pcs_rules = rules } - else return pcs_tc + else return pcs_tc +-} --- Should we remove bits of flat_details at this point? --- ; flat_details <- case flat_details of --- ModDetails { md_binds = binds } -> +-- Should we remove bits of flat_result at this point? +-- ; flat_result <- case flat_result of +-- ModResult { md_binds = binds } -> -- return ModDetails { md_binds = binds, -- md_rules = [], -- md_types = emptyTypeEnv, @@ -269,17 +235,13 @@ hscRecomp ghci_mode dflags have_object -- alive at this point: -- pcs_middle - -- foreign_stuff - -- flat_details - -- imported_modules (seq'd) - -- new_iface + -- flat_result ------------------- -- SIMPLIFY ------------------- - ; simpl_details - <- _scc_ "Core2Core" - core2core dflags pcs_middle hst dont_discard flat_details + ; simpl_result <- _scc_ "Core2Core" + core2core hsc_env pcs_middle flat_result ------------------- -- TIDY @@ -295,112 +257,44 @@ hscRecomp ghci_mode dflags have_object -- cg_info_ref will be filled in just after restOfCodeGeneration -- Meanwhile, tidyCorePgm is careful not to look at cg_info! - ; (pcs_simpl, tidy_details) + ; (pcs_simpl, tidy_result) <- _scc_ "CoreTidy" - tidyCorePgm dflags this_mod pcs_middle cg_info simpl_details - - ; pcs_final <- if ghci_mode == OneShot then initPersistentCompilerState - else return pcs_simpl - - -- alive at this point: - -- tidy_details - -- new_iface + tidyCorePgm dflags pcs_middle cg_info simpl_result - ; emitExternalCore dflags new_iface tidy_details +-- Space-saving ploy doesn't work so well now +-- because mkIface needs the populated PIT to +-- generate usage info. Maybe we should re-visit this. +-- ; pcs_final <- if one_shot then initPersistentCompilerState +-- else return pcs_simpl + ; let pcs_final = pcs_simpl - ; let final_details = tidy_details {md_binds = []} - ; final_details `seq` return () + -- Alive at this point: + -- tidy_result, pcs_final ------------------- -- PREPARE FOR CODE GENERATION - ------------------- - -- Do saturation and convert to A-normal form - ; prepd_details <- _scc_ "CorePrep" - corePrepPgm dflags tidy_details + -- Do saturation and convert to A-normal form + ; prepd_result <- _scc_ "CorePrep" + corePrepPgm dflags tidy_result ------------------- -- CONVERT TO STG and COMPLETE CODE GENERATION - ------------------- - ; let - ModDetails{md_binds=binds, md_types=env_tc} = prepd_details - - local_tycons = typeEnvTyCons env_tc - local_classes = typeEnvClasses env_tc - - (h_code, c_code, headers, fe_binders) = foreign_stuff - - -- turn the list of headers requested in foreign import - -- declarations into a string suitable for emission into generated - -- C code... - -- - foreign_headers = - unlines - . map (\fname -> "#include \"" ++ unpackFS fname ++ "\"") - . reverse - $ headers - - -- ...and add the string to the headers requested via command line - -- options - -- - ; fhdrs <- readIORef v_HCHeader - ; writeIORef v_HCHeader (fhdrs ++ foreign_headers) - - ; (stub_h_exists, stub_c_exists, maybe_bcos, final_iface ) - <- if toInterp -#ifdef GHCI - then do - ----------------- Generate byte code ------------------ - (bcos,itbl_env) <- byteCodeGen dflags binds - local_tycons local_classes - - -- Fill in the code-gen info - writeIORef cg_info_ref (Just emptyNameEnv) - - ------------------ BUILD THE NEW ModIface ------------ - final_iface <- _scc_ "MkFinalIface" - mkFinalIface ghci_mode dflags location - maybe_checked_iface new_iface tidy_details - - ------------------ Create f-x-dynamic C-side stuff --- - (istub_h_exists, istub_c_exists) - <- outputForeignStubs dflags c_code h_code + ; (stub_h_exists, stub_c_exists, maybe_bcos) + <- hscBackEnd dflags cg_info_ref prepd_result - return ( istub_h_exists, istub_c_exists, - Just (bcos,itbl_env), final_iface ) -#else - then error "GHC not compiled with interpreter" -#endif - - else do - ----------------- Convert to STG ------------------ - (stg_binds, cost_centre_info, stg_back_end_info) - <- _scc_ "CoreToStg" - myCoreToStg dflags this_mod binds - - -- Fill in the code-gen info for the earlier tidyCorePgm - writeIORef cg_info_ref (Just stg_back_end_info) - - ------------------ BUILD THE NEW ModIface ------------ - final_iface <- _scc_ "MkFinalIface" - mkFinalIface ghci_mode dflags location - maybe_checked_iface new_iface tidy_details - if toNothing - then do - return (False, False, Nothing, final_iface) - else do - ------------------ Code generation ------------------ - abstractC <- _scc_ "CodeGen" - codeGen dflags this_mod imported_modules - cost_centre_info fe_binders - local_tycons stg_binds - - ------------------ Code output ----------------------- - (stub_h_exists, stub_c_exists) - <- codeOutput dflags this_mod [] --local_tycons - binds stg_binds - c_code h_code abstractC - - return (stub_h_exists, stub_c_exists, Nothing, final_iface) + ------------------- + -- BUILD THE NEW ModIface and ModDetails + -- and emit external core if necessary + -- This has to happen *after* code gen so that the back-end + -- info has been set. Not yet clear if it matters waiting + -- until after code output + ; final_iface <- _scc_ "MkFinalIface" + mkIface hsc_env location + maybe_checked_iface tidy_result + ; let final_details = ModDetails { md_types = mg_types tidy_result, + md_insts = mg_insts tidy_result, + md_rules = mg_rules tidy_result } + ; emitExternalCore dflags tidy_result -- and the answer is ... ; return (HscRecomp pcs_final @@ -410,7 +304,7 @@ hscRecomp ghci_mode dflags have_object maybe_bcos) }} -hscCoreFrontEnd ghci_mode dflags location hst hit pcs_ch = do { +hscCoreFrontEnd hsc_env pcs_ch location = do { ------------------- -- PARSE ------------------- @@ -418,76 +312,91 @@ hscCoreFrontEnd ghci_mode dflags location hst hit pcs_ch = do { ; case parseCore inp 1 of FailP s -> hPutStrLn stderr s >> return (Left (HscFail pcs_ch)); OkP rdr_module -> do { - ; let this_mod = mkHomeModule (hsModuleName rdr_module) ------------------- - -- RENAME + -- RENAME and TYPECHECK ------------------- - ; (pcs_rn, print_unqual, maybe_rn_result) - <- renameExtCore dflags hit hst pcs_ch this_mod rdr_module - ; case maybe_rn_result of { - Nothing -> return (Left (HscFail pcs_ch)); - Just (dont_discard, new_iface, rn_decls) -> do { - - ------------------- - -- TYPECHECK - ------------------- - ; maybe_tc_result - <- _scc_ "TypeCheck" - typecheckCoreModule dflags pcs_rn hst new_iface rn_decls + ; (pcs_tc, maybe_tc_result) <- _scc_ "TypeCheck" + tcRnExtCore hsc_env pcs_ch rdr_module ; case maybe_tc_result of { - Nothing -> return (Left (HscFail pcs_ch)); - Just (pcs_tc, tc_result) -> do { - - ------------------- - -- DESUGAR - ------------------- - ; (ds_details, foreign_stuff) <- deSugarCore tc_result - ; return (Right (this_mod, rdr_module, dont_discard, new_iface, - pcs_tc, ds_details, foreign_stuff)) - }}}}}} + Nothing -> return (Left (HscFail pcs_tc)); + Just mod_guts -> return (Right (pcs_tc, mod_guts)) + -- No desugaring to do! + }}} -hscFrontEnd ghci_mode dflags location hst hit pcs_ch = do { +hscFrontEnd hsc_env pcs_ch location = do { ------------------- -- PARSE ------------------- - ; maybe_parsed <- myParseModule dflags + ; maybe_parsed <- myParseModule (hsc_dflags hsc_env) (expectJust "hscRecomp:hspp" (ml_hspp_file location)) + ; case maybe_parsed of { Nothing -> return (Left (HscFail pcs_ch)); Just rdr_module -> do { - ; let this_mod = mkHomeModule (hsModuleName rdr_module) ------------------- - -- RENAME - ------------------- - ; (pcs_rn, print_unqual, maybe_rn_result) - <- _scc_ "Rename" - renameModule dflags ghci_mode hit hst pcs_ch this_mod rdr_module - ; case maybe_rn_result of { - Nothing -> return (Left (HscFail pcs_ch)); - Just (dont_discard, new_iface, rn_result) -> do { - - ------------------- - -- TYPECHECK + -- RENAME and TYPECHECK ------------------- - ; maybe_tc_result - <- _scc_ "TypeCheck" - typecheckModule dflags pcs_rn hst print_unqual rn_result + ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck and Rename" + tcRnModule hsc_env pcs_ch rdr_module ; case maybe_tc_result of { Nothing -> return (Left (HscFail pcs_ch)); - Just (pcs_tc, tc_result) -> do { + Just tc_result -> do { ------------------- -- DESUGAR ------------------- - ; (ds_details, foreign_stuff) - <- _scc_ "DeSugar" - deSugar dflags pcs_tc hst this_mod print_unqual tc_result - ; return (Right (this_mod, rdr_module, dont_discard, new_iface, - pcs_tc, ds_details, foreign_stuff)) - }}}}}}} + ; ds_result <- _scc_ "DeSugar" + deSugar hsc_env pcs_tc tc_result + ; return (Right (pcs_tc, ds_result)) + }}}}} + + +hscBackEnd dflags cg_info_ref prepd_result + = case dopt_HscLang dflags of + HscNothing -> return (False, False, Nothing) + + HscInterpreted -> +#ifdef GHCI + do ----------------- Generate byte code ------------------ + comp_bc <- byteCodeGen dflags prepd_result + + -- Fill in the code-gen info + writeIORef cg_info_ref (Just emptyNameEnv) + + ------------------ Create f-x-dynamic C-side stuff --- + (istub_h_exists, istub_c_exists) + <- outputForeignStubs dflags (mg_foreign prepd_result) + + return ( istub_h_exists, istub_c_exists, + Just comp_bc ) +#else + panic "GHC not compiled with interpreter" +#endif + + other -> + do + ----------------- Convert to STG ------------------ + (stg_binds, cost_centre_info, stg_back_end_info) + <- _scc_ "CoreToStg" + myCoreToStg dflags prepd_result + + -- Fill in the code-gen info for the earlier tidyCorePgm + writeIORef cg_info_ref (Just stg_back_end_info) + + ------------------ Code generation ------------------ + abstractC <- _scc_ "CodeGen" + codeGen dflags prepd_result + cost_centre_info stg_binds + + ------------------ Code output ----------------------- + (stub_h_exists, stub_c_exists) + <- codeOutput dflags prepd_result + stg_binds abstractC + + return (stub_h_exists, stub_c_exists, Nothing) myParseModule dflags src_filename @@ -508,7 +417,7 @@ myParseModule dflags src_filename freeStringBuffer buf; return Nothing }; - POk _ rdr_module@(HsModule mod_name _ _ _ _ _ _) -> do { + POk _ rdr_module -> do { dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; @@ -520,7 +429,7 @@ myParseModule dflags src_filename }} -myCoreToStg dflags this_mod tidy_binds +myCoreToStg dflags (ModGuts {mg_module = this_mod, mg_binds = tidy_binds}) = do () <- coreBindsSize tidy_binds `seq` return () -- TEMP: the above call zaps some space usage allocated by the @@ -553,22 +462,6 @@ myCoreToStg dflags this_mod tidy_binds %* * %************************************************************************ -\begin{code} -#ifdef GHCI -hscStmt - :: DynFlags - -> HomeSymbolTable - -> HomeIfaceTable - -> PersistentCompilerState -- IN: persistent compiler state - -> InteractiveContext -- Context for compiling - -> String -- The statement - -> Bool -- just treat it as an expression - -> IO ( PersistentCompilerState, - Maybe ( [Id], - Type, - UnlinkedBCOExpr) ) -\end{code} - When the UnlinkedBCOExpr is linked you get an HValue of type IO [HValue] When you run it you get a list of HValues that should be @@ -596,77 +489,57 @@ A naked expression returns a singleton Name [it]. result not showable) ==> error \begin{code} -hscStmt dflags hst hit pcs0 icontext stmt just_expr - = do { maybe_stmt <- hscParseStmt dflags stmt - ; case maybe_stmt of - Nothing -> return (pcs0, Nothing) - Just parsed_stmt -> do { - - let { notExprStmt (ExprStmt _ _ _) = False; - notExprStmt _ = True - }; - - if (just_expr && notExprStmt parsed_stmt) - then do hPutStrLn stderr ("not an expression: `" ++ stmt ++ "'") - return (pcs0, Nothing) - else do { - - -- Rename it - (pcs1, print_unqual, maybe_renamed_stmt) - <- renameStmt dflags hit hst pcs0 icontext parsed_stmt - - ; case maybe_renamed_stmt of - Nothing -> return (pcs0, Nothing) - Just (bound_names, rn_stmt) -> do { - - -- Typecheck it - maybe_tc_return <- - if just_expr - then case rn_stmt of { (ExprStmt e _ _, decls) -> - typecheckExpr dflags pcs1 hst (ic_type_env icontext) - print_unqual iNTERACTIVE (e,decls) } - else typecheckStmt dflags pcs1 hst (ic_type_env icontext) - print_unqual iNTERACTIVE bound_names rn_stmt - - ; case maybe_tc_return of - Nothing -> return (pcs0, Nothing) - Just (pcs2, tc_expr, bound_ids, ty) -> do { - - -- Desugar it - ds_expr <- deSugarExpr dflags pcs2 hst iNTERACTIVE print_unqual tc_expr - - -- Flatten it - ; flat_expr <- flattenExpr dflags pcs2 hst ds_expr +#ifdef GHCI +hscStmt -- Compile a stmt all the way to an HValue, but don't run it + :: HscEnv + -> PersistentCompilerState -- IN: persistent compiler state + -> InteractiveContext -- Context for compiling + -> String -- The statement + -> IO ( PersistentCompilerState, + Maybe (InteractiveContext, [Name], HValue) ) - -- Simplify it - ; simpl_expr <- simplifyExpr dflags pcs2 hst flat_expr +hscStmt hsc_env pcs icontext stmt + = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt + ; case maybe_stmt of { + Nothing -> return (pcs, Nothing) ; + Just parsed_stmt -> do { - -- Tidy it (temporary, until coreSat does cloning) - ; tidy_expr <- tidyCoreExpr simpl_expr + -- Rename and typecheck it + (pcs1, maybe_tc_result) + <- tcRnStmt hsc_env pcs icontext parsed_stmt - -- Prepare for codegen - ; prepd_expr <- corePrepExpr dflags tidy_expr - - -- Convert to BCOs - ; bcos <- coreExprToBCOs dflags prepd_expr + ; case maybe_tc_result of { + Nothing -> return (pcs1, Nothing) ; + Just (new_ic, bound_names, tc_expr) -> do { - ; let - -- Make all the bound ids "global" ids, now that - -- they're notionally top-level bindings. This is - -- important: otherwise when we come to compile an expression - -- using these ids later, the byte code generator will consider - -- the occurrences to be free rather than global. - global_bound_ids = map globaliseId bound_ids; - globaliseId id = setGlobalIdDetails id VanillaGlobal + -- Then desugar, code gen, and link it + ; hval <- compileExpr hsc_env pcs1 iNTERACTIVE + (icPrintUnqual new_ic) tc_expr - ; return (pcs2, Just (global_bound_ids, ty, bcos)) + ; return (pcs1, Just (new_ic, bound_names, hval)) + }}}}} - }}}}} +hscTcExpr -- Typecheck an expression (but don't run it) + :: HscEnv + -> PersistentCompilerState -- IN: persistent compiler state + -> InteractiveContext -- Context for compiling + -> String -- The expression + -> IO (PersistentCompilerState, Maybe Type) + +hscTcExpr hsc_env pcs icontext expr + = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr + ; case maybe_stmt of { + Just (ExprStmt expr _ _) + -> tcRnExpr hsc_env pcs icontext expr ; + Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ; + return (pcs, Nothing) } ; + Nothing -> return (pcs, Nothing) } } +\end{code} +\begin{code} hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt) hscParseStmt dflags str - = do -------------------------- Parser ---------------- - showPass dflags "Parser" + = do showPass dflags "Parser" _scc_ "Parser" do buf <- stringToStringBuffer str @@ -706,53 +579,28 @@ hscParseStmt dflags str \begin{code} #ifdef GHCI hscThing -- like hscStmt, but deals with a single identifier - :: DynFlags - -> HomeSymbolTable - -> HomeIfaceTable + :: HscEnv -> PersistentCompilerState -- IN: persistent compiler state -> InteractiveContext -- Context for compiling -> String -- The identifier -> IO ( PersistentCompilerState, [TyThing] ) -hscThing dflags hst hit pcs0 ic str - = do maybe_rdr_name <- myParseIdentifier dflags str +hscThing hsc_env pcs0 ic str + = do let dflags = hsc_dflags hsc_env + + maybe_rdr_name <- myParseIdentifier dflags str case maybe_rdr_name of { Nothing -> return (pcs0, []); Just rdr_name -> do - -- if the identifier is a constructor (begins with an - -- upper-case letter), then we need to consider both - -- constructor and type class identifiers. - let rdr_names - | occNameSpace occ == dataName = [ rdr_name, tccls_name ] - | otherwise = [ rdr_name ] - where - occ = rdrNameOcc rdr_name - tccls_occ = setOccNameSpace occ tcClsName - tccls_name = setRdrNameOcc rdr_name tccls_occ - - (pcs, unqual, maybe_rn_result) <- - renameRdrName dflags hit hst pcs0 ic rdr_names - - case maybe_rn_result of { - Nothing -> return (pcs, []); - Just (names, decls) -> do { - - maybe_pcs <- typecheckExtraDecls dflags pcs hst unqual - iNTERACTIVE decls; - - case maybe_pcs of { - Nothing -> return (pcs, []); - Just pcs -> - let do_lookup n - | isInternalName n = lookupNameEnv (ic_type_env ic) n - | otherwise = lookupType hst (pcs_PTE pcs) n - - maybe_ty_things = map do_lookup names - in - return (pcs, catMaybes maybe_ty_things) } - }}} + (pcs1, maybe_tc_result) <- + tcRnThing hsc_env pcs0 ic rdr_name + + case maybe_tc_result of { + Nothing -> return (pcs1, []) ; + Just things -> return (pcs1, things) + }} myParseIdentifier dflags str = do buf <- stringToStringBuffer str @@ -776,62 +624,48 @@ myParseIdentifier dflags str %************************************************************************ %* * -\subsection{Find all the things defined in a module} + Desugar, simplify, convert to bytecode, and link an expression %* * %************************************************************************ \begin{code} #ifdef GHCI -hscModuleContents - :: DynFlags - -> HomeSymbolTable - -> HomeIfaceTable - -> PersistentCompilerState -- IN: persistent compiler state - -> Module -- module to inspect - -> Bool -- grab just the exports, or the whole toplev - -> IO (PersistentCompilerState, Maybe [TyThing]) - -hscModuleContents dflags hst hit pcs0 mod exports_only = do { +compileExpr :: HscEnv + -> PersistentCompilerState + -> Module -> PrintUnqualified + -> TypecheckedHsExpr + -> IO HValue - -- Slurp the interface if necessary (a home module will certainly - -- alraedy be loaded, but a package module might not be) - (pcs1, print_unqual, maybe_rn_stuff) - <- slurpIface dflags hit hst pcs0 mod; +compileExpr hsc_env pcs this_mod print_unqual tc_expr + = do { let dflags = hsc_dflags hsc_env - case maybe_rn_stuff of { - Nothing -> return (pcs0, Nothing); - Just (names, rn_decls) -> do { - - -- Typecheck the declarations - maybe_pcs <- - typecheckExtraDecls dflags pcs1 hst print_unqual iNTERACTIVE rn_decls; + -- Desugar it + ; ds_expr <- deSugarExpr hsc_env pcs this_mod print_unqual tc_expr + + -- Flatten it + ; flat_expr <- flattenExpr hsc_env pcs ds_expr - case maybe_pcs of { - Nothing -> return (pcs1, Nothing); - Just pcs2 -> + -- Simplify it + ; simpl_expr <- simplifyExpr dflags flat_expr - let { all_names - | exports_only = names - | otherwise = -- Invariant; we only have (not exports_only) - -- for a home module so it must already be in the HIT - let { iface = fromJust (lookupModuleEnv hit mod); - env = fromJust (mi_globals iface); - range = rdrEnvElts env; - } in - -- grab all the things from the global env that are locally def'd - nub [ n | elts <- range, GRE n LocalDef _ <- elts ]; + -- Tidy it (temporary, until coreSat does cloning) + ; tidy_expr <- tidyCoreExpr simpl_expr - pte = pcs_PTE pcs2; + -- Prepare for codegen + ; prepd_expr <- corePrepExpr dflags tidy_expr - ty_things = map (fromJust . lookupType hst pte) all_names; + -- Convert to BCOs + ; bcos <- coreExprToBCOs dflags prepd_expr - } in + -- link it + ; hval <- linkExpr hsc_env pcs bcos - return (pcs2, Just ty_things) - }}}} + ; return hval + } #endif \end{code} + %************************************************************************ %* * \subsection{Initial persistent state} @@ -841,35 +675,38 @@ hscModuleContents dflags hst hit pcs0 mod exports_only = do { \begin{code} initPersistentCompilerState :: IO PersistentCompilerState initPersistentCompilerState - = do prs <- initPersistentRenamerState + = do nc <- initNameCache return ( - PCS { pcs_PIT = emptyIfaceTable, - pcs_PTE = wiredInThingEnv, - pcs_insts = emptyInstEnv, - pcs_rules = emptyRuleBase, - pcs_PRS = prs - } - ) - -initPersistentRenamerState :: IO PersistentRenamerState + PCS { pcs_EPS = initExternalPackageState, + pcs_nc = nc }) + +initNameCache :: IO NameCache = do us <- mkSplitUniqSupply 'r' - return ( - PRS { prsOrig = NameSupply { nsUniqs = us, - nsNames = initOrigNames, - nsIPs = emptyFM }, - prsDecls = (emptyNameEnv, 0), - prsInsts = (emptyBag, 0), - prsRules = foldr add_rule (emptyBag, 0) builtinRules, - prsImpMods = emptyFM - } - ) + return (NameCache { nsUniqs = us, + nsNames = initOrigNames, + nsIPs = emptyFM }) + +initExternalPackageState :: ExternalPackageState +initExternalPackageState + = EPS { + eps_decls = (emptyNameEnv, 0), + eps_insts = (emptyBag, 0), + eps_inst_gates = emptyNameSet, + eps_rules = foldr add_rule (emptyBag, 0) builtinRules, + eps_imp_mods = emptyFM, + + eps_PIT = emptyPackageIfaceTable, + eps_PTE = wiredInThingEnv, + eps_inst_env = emptyInstEnv, + eps_rule_base = emptyRuleBase } + where - add_rule (name,rule) (rules, n_rules) - = (gated_decl `consBag` rules, n_rules+1) + add_rule (name,rule) (rules, n_slurped) + = (gated_decl `consBag` rules, n_slurped) where gated_decl = (gate_fn, (mod, IfaceRuleOut rdr_name rule)) mod = nameModule name - rdr_name = mkRdrOrig (moduleName mod) (nameOccName name) + rdr_name = nameRdrName name gate_fn vis_fn = vis_fn name -- Load the rule whenever name is visible initOrigNames :: FiniteMap (ModuleName,OccName) Name diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs index f20d7965ec..8c8fee439d 100644 --- a/ghc/compiler/main/HscStats.lhs +++ b/ghc/compiler/main/HscStats.lhs @@ -101,11 +101,11 @@ ppSourceStats short (HsModule name version exports imports decls _ src_loc) count_binds (MonoBind b sigs _) = case (count_monobinds b, count_sigs sigs) of ((vs,fs),(ts,_,ss,is)) -> (vs,fs,ts,ss,is) - count_monobinds EmptyMonoBinds = (0,0) - count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2 - count_monobinds (PatMonoBind (VarPatIn n) r _) = (1,0) - count_monobinds (PatMonoBind p r _) = (0,1) - count_monobinds (FunMonoBind f _ m _) = (0,1) + count_monobinds EmptyMonoBinds = (0,0) + count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2 + count_monobinds (PatMonoBind (VarPat n) r _) = (1,0) + count_monobinds (PatMonoBind p r _) = (0,1) + count_monobinds (FunMonoBind f _ m _) = (0,1) count_mb_monobinds (Just mbs) = count_monobinds mbs count_mb_monobinds Nothing = (0,0) diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 045c17fdb9..983a3e9d76 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -5,23 +5,26 @@ \begin{code} module HscTypes ( + HscEnv(..), GhciMode(..), - ModuleLocation(..), showModMsg, - ModDetails(..), ModIface(..), - HomeSymbolTable, emptySymbolTable, - PackageTypeEnv, - HomeIfaceTable, PackageIfaceTable, emptyIfaceTable, + ModGuts(..), ModImports(..), ForeignStubs(..), + ParsedIface(..), IfaceDeprecs, + + HomePackageTable, HomeModInfo(..), emptyHomePackageTable, + + ExternalPackageState(..), + PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, lookupIface, lookupIfaceByModName, moduleNameToModule, emptyModIface, - InteractiveContext(..), + InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, VersionInfo(..), initialVersionInfo, lookupVersion, - FixityEnv, lookupFixity, collectFixities, + FixityEnv, lookupFixity, collectFixities, emptyFixityEnv, TyThing(..), isTyClThing, implicitTyThingIds, @@ -30,22 +33,27 @@ module HscTypes ( typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds, ImportedModuleInfo, WhetherHasOrphans, ImportVersion, WhatsImported(..), - PersistentRenamerState(..), IsBootInterface, DeclsMap, - IfaceInsts, IfaceRules, GatedDecl, GatedDecls, GateFn, IsExported, - NameSupply(..), OrigNameCache, OrigIParamCache, - Avails, AvailEnv, emptyAvailEnv, + IsBootInterface, DeclsMap, + IfaceInsts, IfaceRules, GatedDecl, GatedDecls, GateFn, + NameCache(..), OrigNameCache, OrigIParamCache, + Avails, availsToNameSet, availName, availNames, GenAvailInfo(..), AvailInfo, RdrAvailInfo, ExportItem, RdrExportItem, + PersistentCompilerState(..), - Deprecations(..), lookupDeprec, + Deprecations(..), lookupDeprec, plusDeprecs, InstEnv, ClsInstEnv, DFunId, PackageInstEnv, PackageRuleBase, - GlobalRdrEnv, GlobalRdrElt(..), pprGlobalRdrEnv, - LocalRdrEnv, extendLocalRdrEnv, + GlobalRdrEnv, GlobalRdrElt(..), emptyGlobalRdrEnv, pprGlobalRdrEnv, + LocalRdrEnv, extendLocalRdrEnv, isLocalGRE, unQualInScope, + -- Linker stuff + Linkable(..), isObjectLinkable, + Unlinked(..), CompiledByteCode, + isObject, nameOfObject, isInterpretable, byteCodeOfObject, -- Provenance Provenance(..), ImportReason(..), @@ -55,10 +63,16 @@ module HscTypes ( #include "HsVersions.h" -import RdrName ( RdrName, RdrNameEnv, addListToRdrEnv, - mkRdrUnqual, rdrEnvToList ) +#ifdef GHCI +import ByteCodeAsm ( CompiledByteCode ) +#endif + +import RdrName ( RdrName, mkRdrUnqual, + RdrNameEnv, addListToRdrEnv, foldRdrEnv, isUnqual, + rdrEnvToList, emptyRdrEnv ) import Name ( Name, NamedThing, getName, nameOccName, nameModule, nameSrcLoc ) import NameEnv +import NameSet import OccName ( OccName ) import Module import InstEnv ( InstEnv, ClsInstEnv, DFunId ) @@ -68,8 +82,11 @@ import Id ( Id ) import Class ( Class, classSelIds ) import TyCon ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataCons_maybe ) import DataCon ( dataConWorkId, dataConWrapId ) +import Packages ( PackageName, preludePackage ) +import CmdLineOpts ( DynFlags ) -import BasicTypes ( Version, initialVersion, Fixity, defaultFixity, IPName ) +import BasicTypes ( Version, initialVersion, IPName, + Fixity, FixitySig(..), defaultFixity ) import HsSyn ( DeprecTxt, TyClDecl, tyClDeclName, ifaceRuleDeclName, tyClDeclNames ) @@ -77,68 +94,83 @@ import RdrHsSyn ( RdrNameInstDecl, RdrNameRuleDecl, RdrNameTyClDecl ) import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl ) import CoreSyn ( IdCoreRule ) +import PrelNames ( isBuiltInSyntaxName ) import FiniteMap import Bag ( Bag ) -import Maybes ( seqMaybe, orElse, expectJust ) +import Maybes ( orElse ) import Outputable import SrcLoc ( SrcLoc, isGoodSrcLoc ) import Util ( thenCmp, sortLt ) import UniqSupply ( UniqSupply ) import Maybe ( fromJust ) +import FastString ( FastString ) + +import Time ( ClockTime ) \end{code} + %************************************************************************ %* * -\subsection{Which mode we're in +\subsection{Compilation environment} %* * %************************************************************************ +The HscEnv gives the environment in which to compile a chunk of code. + \begin{code} -data GhciMode = Batch | Interactive | OneShot - deriving Eq +data HscEnv = HscEnv { hsc_mode :: GhciMode, + hsc_dflags :: DynFlags, + hsc_HPT :: HomePackageTable } \end{code} +The GhciMode is self-explanatory: -%************************************************************************ -%* * -\subsection{Module locations} -%* * -%************************************************************************ +\begin{code} +data GhciMode = Batch | Interactive | OneShot + deriving Eq +\end{code} \begin{code} -data ModuleLocation - = ModuleLocation { - ml_hs_file :: Maybe FilePath, - ml_hspp_file :: Maybe FilePath, -- path of preprocessed source - ml_hi_file :: FilePath, - ml_obj_file :: Maybe FilePath - } - deriving Show - -instance Outputable ModuleLocation where - ppr = text . show - --- Probably doesn't really belong here, but used in HscMain and InteractiveUI. - -showModMsg :: Bool -> Module -> ModuleLocation -> String -showModMsg use_object mod location = - mod_str ++ replicate (max 0 (16 - length mod_str)) ' ' - ++" ( " ++ expectJust "showModMsg" (ml_hs_file location) ++ ", " - ++ (if use_object - then expectJust "showModMsg" (ml_obj_file location) - else "interpreted") - ++ " )" - where mod_str = moduleUserString mod +type HomePackageTable = ModuleEnv HomeModInfo -- Domain = modules in the home package +type PackageIfaceTable = ModuleEnv ModIface -- Domain = modules in the imported packages + +emptyHomePackageTable = emptyModuleEnv +emptyPackageIfaceTable = emptyModuleEnv + +data HomeModInfo = HomeModInfo { hm_iface :: ModIface, + hm_details :: ModDetails, + hm_linkable :: Linkable } \end{code} -For a module in another package, the hs_file and obj_file -components of ModuleLocation are undefined. +Simple lookups in the symbol table. -The locations specified by a ModuleLocation may or may not -correspond to actual files yet: for example, even if the object -file doesn't exist, the ModuleLocation still contains the path to -where the object file will reside if/when it is created. +\begin{code} +lookupIface :: HomePackageTable -> PackageIfaceTable -> Name -> Maybe ModIface +-- We often have two IfaceTables, and want to do a lookup +lookupIface hpt pit name + = case lookupModuleEnv hpt mod of + Just mod_info -> Just (hm_iface mod_info) + Nothing -> lookupModuleEnv pit mod + where + mod = nameModule name + +lookupIfaceByModName :: HomePackageTable -> PackageIfaceTable -> ModuleName -> Maybe ModIface +-- We often have two IfaceTables, and want to do a lookup +lookupIfaceByModName hpt pit mod + = case lookupModuleEnvByName hpt mod of + Just mod_info -> Just (hm_iface mod_info) + Nothing -> lookupModuleEnvByName pit mod +\end{code} + +\begin{code} +-- Use instead of Finder.findModule if possible: this way doesn't +-- require filesystem operations, and it is guaranteed not to fail +-- when the IfaceTables are properly populated (i.e. after the renamer). +moduleNameToModule :: HomePackageTable -> PackageIfaceTable -> ModuleName -> Module +moduleNameToModule hpt pit mod + = mi_module (fromJust (lookupIfaceByModName hpt pit mod)) +\end{code} %************************************************************************ @@ -162,17 +194,14 @@ data ModIface mi_module :: !Module, mi_package :: !PackageName, -- Which package the module comes from mi_version :: !VersionInfo, -- Module version number + mi_orphan :: !WhetherHasOrphans, -- Whether this module has orphans + mi_boot :: !IsBootInterface, -- Read from an hi-boot file? - mi_orphan :: WhetherHasOrphans, -- Whether this module has orphans - -- NOT STRICT! we fill this field with _|_ sometimes - - mi_boot :: !IsBootInterface, -- read from an hi-boot file? - - mi_usages :: [ImportVersion Name], + mi_usages :: [ImportVersion Name], -- Usages; kept sorted so that it's easy to decide -- whether to write a new iface file (changing usages -- doesn't affect the version of this module) - -- NOT STRICT! we read this field lazilly from the interface file + -- NOT STRICT! we read this field lazily from the interface file mi_exports :: ![ExportItem], -- What it exports Kept sorted by (mod,occ), to make @@ -180,7 +209,8 @@ data ModIface mi_globals :: !(Maybe GlobalRdrEnv), -- Its top level environment or Nothing if we read this - -- interface from a file. + -- interface from an interface file. (We need the source + -- file to figure out the top-level environment.) mi_fixities :: !FixityEnv, -- Fixities mi_deprecs :: Deprecations, -- Deprecations @@ -190,63 +220,99 @@ data ModIface -- NOT STRICT! we fill this field with _|_ sometimes } -data IfaceDecls = IfaceDecls { dcl_tycl :: [RenamedTyClDecl], -- Sorted - dcl_rules :: [RenamedRuleDecl], -- Sorted - dcl_insts :: [RenamedInstDecl] } -- Unsorted - -mkIfaceDecls :: [RenamedTyClDecl] -> [RenamedRuleDecl] -> [RenamedInstDecl] -> IfaceDecls -mkIfaceDecls tycls rules insts - = IfaceDecls { dcl_tycl = sortLt lt_tycl tycls, - dcl_rules = sortLt lt_rule rules, - dcl_insts = insts } - where - d1 `lt_tycl` d2 = tyClDeclName d1 < tyClDeclName d2 - r1 `lt_rule` r2 = ifaceRuleDeclName r1 < ifaceRuleDeclName r2 - - --- typechecker should only look at this, not ModIface -- Should be able to construct ModDetails from mi_decls in ModIface data ModDetails = ModDetails { -- The next three fields are created by the typechecker md_types :: !TypeEnv, md_insts :: ![DFunId], -- Dfun-ids for the instances in this module - md_rules :: ![IdCoreRule], -- Domain may include Ids from other modules - md_binds :: ![CoreBind] + md_rules :: ![IdCoreRule] -- Domain may include Ids from other modules } --- The ModDetails takes on several slightly different forms: --- --- After typecheck + desugar --- md_types Contains TyCons, Classes, and implicit Ids --- md_insts All instances from this module (incl derived ones) --- md_rules All rules from this module --- md_binds Desugared bindings + + +-- A ModGuts is carried through the compiler, accumulating stuff as it goes +-- There is only one ModGuts at any time, the one for the module +-- being compiled right now. Once it is compiled, a ModIface and +-- ModDetails are extracted and the ModGuts is dicarded. + +data ModGuts + = ModGuts { + mg_module :: !Module, + mg_exports :: !Avails, -- What it exports + mg_usages :: ![ImportVersion Name], -- What it imports, directly or otherwise + -- ...exactly as in ModIface + mg_dir_imps :: ![Module], -- Directly imported modules + + mg_rdr_env :: !GlobalRdrEnv, -- Top-level lexical environment + mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in this module + mg_deprecs :: !Deprecations, -- Deprecations declared in the module + + mg_types :: !TypeEnv, + mg_insts :: ![DFunId], -- Instances + mg_rules :: ![IdCoreRule], -- Rules from this module + mg_binds :: ![CoreBind], -- Bindings for this module + mg_foreign :: !ForeignStubs + } + +-- The ModGuts takes on several slightly different forms: -- --- After simplification --- md_types Same as after typecheck --- md_insts Ditto --- md_rules Orphan rules only (local ones now attached to binds) --- md_binds With rules attached +-- After simplification, the following fields change slightly: +-- mg_rules Orphan rules only (local ones now attached to binds) +-- mg_binds With rules attached -- --- After CoreTidy --- md_types Now contains Ids as well, replete with final IdInfo +-- After CoreTidy, the following fields change slightly: +-- mg_types Now contains Ids as well, replete with final IdInfo -- The Ids are only the ones that are visible from -- importing modules. Without -O that means only -- exported Ids, but with -O importing modules may -- see ids mentioned in unfoldings of exported Ids -- --- md_insts Same DFunIds as before, but with final IdInfo, +-- mg_insts Same DFunIds as before, but with final IdInfo, -- and the unique might have changed; remember that -- CoreTidy links up the uniques of old and new versions -- --- md_rules All rules for exported things, substituted with final Ids +-- mg_rules All rules for exported things, substituted with final Ids -- --- md_binds Tidied --- --- Passed back to compilation manager --- Just as after CoreTidy, but with md_binds nuked +-- mg_binds Tidied + + + +data ModImports + = ModImports { + imp_direct :: ![(Module,Bool)], -- Explicitly-imported modules + -- Boolean is true if we imported the whole + -- module (apart, perhaps, from hiding some) + imp_pkg_mods :: !ModuleSet, -- Non-home-package modules on which we depend, + -- directly or indirectly + imp_home_names :: !NameSet -- Home package things on which we depend, + -- directly or indirectly + } + +data ForeignStubs = NoStubs + | ForeignStubs + SDoc -- Header file prototypes for + -- "foreign exported" functions + SDoc -- C stubs to use when calling + -- "foreign exported" functions + [FastString] -- Headers that need to be included + -- into C code generated for this module + [Id] -- Foreign-exported binders + -- we have to generate code to register these + + +data IfaceDecls = IfaceDecls { dcl_tycl :: [RenamedTyClDecl], -- Sorted + dcl_rules :: [RenamedRuleDecl], -- Sorted + dcl_insts :: [RenamedInstDecl] } -- Unsorted +mkIfaceDecls :: [RenamedTyClDecl] -> [RenamedRuleDecl] -> [RenamedInstDecl] -> IfaceDecls +mkIfaceDecls tycls rules insts + = IfaceDecls { dcl_tycl = sortLt lt_tycl tycls, + dcl_rules = sortLt lt_rule rules, + dcl_insts = insts } + where + d1 `lt_tycl` d2 = tyClDeclName d1 < tyClDeclName d2 + r1 `lt_rule` r2 = ifaceRuleDeclName r1 < ifaceRuleDeclName r2 \end{code} \begin{code} @@ -266,46 +332,35 @@ emptyModIface mod } \end{code} -Symbol tables map modules to ModDetails: -\begin{code} -type SymbolTable = ModuleEnv ModDetails -type IfaceTable = ModuleEnv ModIface - -type HomeIfaceTable = IfaceTable -type PackageIfaceTable = IfaceTable - -type HomeSymbolTable = SymbolTable -- Domain = modules in the home package - -emptySymbolTable :: SymbolTable -emptySymbolTable = emptyModuleEnv - -emptyIfaceTable :: IfaceTable -emptyIfaceTable = emptyModuleEnv -\end{code} +%************************************************************************ +%* * + Parsed interface files +%* * +%************************************************************************ -Simple lookups in the symbol table. +A ParsedIface is exactly as read from an interface file. \begin{code} -lookupIface :: HomeIfaceTable -> PackageIfaceTable -> Name -> Maybe ModIface --- We often have two IfaceTables, and want to do a lookup -lookupIface hit pit name - = lookupModuleEnv hit mod `seqMaybe` lookupModuleEnv pit mod - where - mod = nameModule name - -lookupIfaceByModName :: HomeIfaceTable -> PackageIfaceTable -> ModuleName -> Maybe ModIface --- We often have two IfaceTables, and want to do a lookup -lookupIfaceByModName hit pit mod - = lookupModuleEnvByName hit mod `seqMaybe` lookupModuleEnvByName pit mod - --- Use instead of Finder.findModule if possible: this way doesn't --- require filesystem operations, and it is guaranteed not to fail --- when the IfaceTables are properly populated (i.e. after the renamer). -moduleNameToModule :: HomeIfaceTable -> PackageIfaceTable -> ModuleName - -> Module -moduleNameToModule hit pit mod - = mi_module (fromJust (lookupIfaceByModName hit pit mod)) +type IfaceDeprecs = Maybe (Either DeprecTxt [(RdrName,DeprecTxt)]) + -- Nothing => NoDeprecs + -- Just (Left t) => DeprecAll + -- Just (Right p) => DeprecSome + +data ParsedIface + = ParsedIface { + pi_mod :: ModuleName, + pi_pkg :: PackageName, + pi_vers :: Version, -- Module version number + pi_orphan :: WhetherHasOrphans, -- Whether this module has orphans + pi_usages :: [ImportVersion OccName], -- Usages + pi_exports :: (Version, [RdrExportItem]), -- Exports + pi_decls :: [(Version, RdrNameTyClDecl)], -- Local definitions + pi_fixity :: [FixitySig RdrName], -- Local fixity declarations, + pi_insts :: [RdrNameInstDecl], -- Local instance declarations + pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version + pi_deprecs :: IfaceDeprecs -- Deprecations + } \end{code} @@ -327,14 +382,21 @@ data InteractiveContext ic_rn_gbl_env :: GlobalRdrEnv, -- The cached GlobalRdrEnv, built from -- ic_toplev_scope and ic_exports - ic_print_unqual :: PrintUnqualified, - -- cached PrintUnqualified, as above - ic_rn_local_env :: LocalRdrEnv, -- Lexical context for variables bound -- during interaction ic_type_env :: TypeEnv -- Ditto for types } + +emptyInteractiveContext + = InteractiveContext { ic_toplev_scope = [], + ic_exports = [], + ic_rn_gbl_env = emptyRdrEnv, + ic_rn_local_env = emptyRdrEnv, + ic_type_env = emptyTypeEnv } + +icPrintUnqual :: InteractiveContext -> PrintUnqualified +icPrintUnqual ictxt = unQualInScope (ic_rn_gbl_env ictxt) \end{code} @@ -413,10 +475,10 @@ extendTypeEnvWithIds env ids \end{code} \begin{code} -lookupType :: HomeSymbolTable -> PackageTypeEnv -> Name -> Maybe TyThing -lookupType hst pte name - = case lookupModuleEnv hst (nameModule name) of - Just details -> lookupNameEnv (md_types details) name +lookupType :: HomePackageTable -> PackageTypeEnv -> Name -> Maybe TyThing +lookupType hpt pte name + = case lookupModuleEnv hpt (nameModule name) of + Just details -> lookupNameEnv (md_types (hm_details details)) name Nothing -> lookupNameEnv pte name \end{code} @@ -467,6 +529,13 @@ lookupDeprec (DeprecSome env) name = case lookupNameEnv env name of Just (_, txt) -> Just txt Nothing -> Nothing +plusDeprecs :: Deprecations -> Deprecations -> Deprecations +plusDeprecs d NoDeprecs = d +plusDeprecs NoDeprecs d = d +plusDeprecs d (DeprecAll t) = DeprecAll t +plusDeprecs (DeprecAll t) d = DeprecAll t +plusDeprecs (DeprecSome v1) (DeprecSome v2) = DeprecSome (v1 `plusNameEnv` v2) + instance Eq Deprecations where -- Used when checking whether we need write a new interface NoDeprecs == NoDeprecs = True @@ -493,10 +562,18 @@ data GenAvailInfo name = Avail name -- An ordinary identifier type RdrExportItem = (ModuleName, [RdrAvailInfo]) type ExportItem = (ModuleName, [AvailInfo]) -type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it +availsToNameSet :: [AvailInfo] -> NameSet +availsToNameSet avails = foldl add emptyNameSet avails + where + add set avail = addListToNameSet set (availNames avail) + +availName :: GenAvailInfo name -> name +availName (Avail n) = n +availName (AvailTC n _) = n -emptyAvailEnv :: AvailEnv -emptyAvailEnv = emptyNameEnv +availNames :: GenAvailInfo name -> [name] +availNames (Avail n) = [n] +availNames (AvailTC n ns) = ns instance Outputable n => Outputable (GenAvailInfo n) where ppr = pprAvail @@ -510,14 +587,23 @@ pprAvail (Avail n) = ppr n \end{code} \begin{code} -type FixityEnv = NameEnv Fixity +type FixityEnv = NameEnv (FixitySig Name) + -- We keep the whole fixity sig so that we + -- can report line-number info when there is a duplicate + -- fixity declaration + +emptyFixityEnv :: FixityEnv +emptyFixityEnv = emptyNameEnv lookupFixity :: FixityEnv -> Name -> Fixity -lookupFixity env n = lookupNameEnv env n `orElse` defaultFixity +lookupFixity env n = case lookupNameEnv env n of + Just (FixitySig _ fix _) -> fix + Nothing -> defaultFixity -collectFixities :: FixityEnv -> [TyClDecl Name pat] -> [(Name,Fixity)] +collectFixities :: FixityEnv -> [TyClDecl Name] -> [FixitySig Name] +-- Collect fixities for the specified declarations collectFixities env decls - = [ (n, fix) + = [ fix | d <- decls, (n,_) <- tyClDeclNames d, Just fix <- [lookupNameEnv env n] ] @@ -542,8 +628,10 @@ type IsBootInterface = Bool type ImportVersion name = (ModuleName, WhetherHasOrphans, IsBootInterface, WhatsImported name) -data WhatsImported name = NothingAtAll -- The module is below us in the - -- hierarchy, but we import nothing +data WhatsImported name = NothingAtAll -- The module is below us in the + -- hierarchy, but we import nothing + -- Used for orphan modules, so they appear + -- in the usage list | Everything Version -- Used for modules from other packages; -- we record only the module's version number @@ -565,8 +653,6 @@ data WhatsImported name = NothingAtAll -- The module is below us in the -- we imported the module without saying exactly what we imported -- We need to recompile if the module exports changes, because we might -- now have a name clash in the importing module. - -type IsExported = Name -> Bool -- True for names that are exported from this module \end{code} @@ -579,66 +665,70 @@ type IsExported = Name -> Bool -- True for names that are exported from this mo The @PersistentCompilerState@ persists across successive calls to the compiler. - * A ModIface for each non-home-package module - - * An accumulated TypeEnv from all the modules in imported packages - - * An accumulated InstEnv from all the modules in imported packages - The point is that we don't want to keep recreating it whenever - we compile a new module. The InstEnv component of pcPST is empty. - (This means we might "see" instances that we shouldn't "really" see; - but the Haskell Report is vague on what is meant to be visible, - so we just take the easy road here.) - - * Ditto for rules - - * The persistent renamer state - \begin{code} data PersistentCompilerState = PCS { - pcs_PIT :: !PackageIfaceTable, -- Domain = non-home-package modules - -- the mi_decls component is empty - - pcs_PTE :: !PackageTypeEnv, -- Domain = non-home-package modules - -- except that the InstEnv components is empty - - pcs_insts :: !PackageInstEnv, -- The total InstEnv accumulated from all - -- the non-home-package modules - - pcs_rules :: !PackageRuleBase, -- Ditto RuleEnv - - pcs_PRS :: !PersistentRenamerState + pcs_nc :: !NameCache, + pcs_EPS :: !ExternalPackageState } \end{code} -The persistent renamer state contains: - - * A name supply, which deals with allocating unique names to - (Module,OccName) original names, - - * A "holding pen" for declarations that have been read out of - interface files but not yet sucked in, renamed, and typechecked - \begin{code} type PackageTypeEnv = TypeEnv type PackageRuleBase = RuleBase type PackageInstEnv = InstEnv -data PersistentRenamerState - = PRS { prsOrig :: !NameSupply, - prsImpMods :: !ImportedModuleInfo, - - -- Holding pens for stuff that has been read in - -- but not yet slurped into the renamer - prsDecls :: !DeclsMap, - prsInsts :: !IfaceInsts, - prsRules :: !IfaceRules - } +data ExternalPackageState + = EPS { + eps_PIT :: !PackageIfaceTable, + -- The ModuleIFaces for modules in external packages + -- whose interfaces we have opened + -- The declarations in these interface files are held in + -- eps_decls, eps_insts, eps_rules (below), not in the + -- mi_decls fields of the iPIT. + -- What _is_ in the iPIT is: + -- * The Module + -- * Version info + -- * Its exports + -- * Fixities + -- * Deprecations + + eps_imp_mods :: !ImportedModuleInfo, + -- Modules that we know something about, because they are mentioned + -- in interface files, BUT which we have not loaded yet. + -- No module is both in here and in the PIT + + eps_PTE :: !PackageTypeEnv, -- Domain = external-package modules + + eps_inst_env :: !PackageInstEnv, -- The total InstEnv accumulated from + -- all the external-package modules + eps_rule_base :: !PackageRuleBase, -- Ditto RuleEnv + + + -- Holding pens for stuff that has been read in from file, + -- but not yet slurped into the renamer + eps_decls :: !DeclsMap, + -- A single, global map of Names to unslurped decls + eps_insts :: !IfaceInsts, + -- The as-yet un-slurped instance decls; this bag is depleted when we + -- slurp an instance decl so that we don't slurp the same one twice. + -- Each is 'gated' by the names that must be available before + -- this instance decl is needed. + eps_rules :: !IfaceRules, + -- Similar to instance decls, only for rules + + eps_inst_gates :: !NameSet -- Gates for instance decls + -- The instance gates must accumulate across + -- all invocations of the renamer; + -- see "the gating story" in RnIfaces.lhs + -- These names should all be from other packages; + -- for the home package we have all the instance + -- declarations anyhow + } \end{code} -The NameSupply makes sure that there is just one Unique assigned for +The NameCache makes sure that there is just one Unique assigned for each original name; i.e. (module-name, occ-name) pair. The Name is always stored as a Global, and has the SrcLoc of its binding location. Actually that's not quite right. When we first encounter the original @@ -651,8 +741,8 @@ encounter the occurrence, we may not know the details of the module, so we just store junk. Then when we find the binding site, we fix it up. \begin{code} -data NameSupply - = NameSupply { nsUniqs :: UniqSupply, +data NameCache + = NameCache { nsUniqs :: UniqSupply, -- Supply of uniques nsNames :: OrigNameCache, -- Ensures that one original name gets one unique @@ -672,7 +762,8 @@ invocations of the renamer, at least from Rename.checkOldIface to Rename.renameS And there's no harm in it persisting across multiple compilations. \begin{code} -type ImportedModuleInfo = FiniteMap ModuleName (WhetherHasOrphans, IsBootInterface) +type ImportedModuleInfo + = FiniteMap ModuleName (WhetherHasOrphans, IsBootInterface) \end{code} A DeclsMap contains a binding for each Name in the declaration @@ -699,11 +790,74 @@ type GateFn = (Name -> Bool) -> Bool -- Returns True <=> gate is open %************************************************************************ %* * +\subsection{Linkable stuff} +%* * +%************************************************************************ + +This stuff is in here, rather than (say) in Linker.lhs, because the Linker.lhs +stuff is the *dynamic* linker, and isn't present in a stage-1 compiler + +\begin{code} +data Linkable = LM { + linkableTime :: ClockTime, -- Time at which this linkable was built + -- (i.e. when the bytecodes were produced, + -- or the mod date on the files) + linkableModName :: ModuleName, -- Should be Module, but see below + linkableUnlinked :: [Unlinked] + } + +isObjectLinkable :: Linkable -> Bool +isObjectLinkable l = all isObject (linkableUnlinked l) + +instance Outputable Linkable where + ppr (LM when_made mod unlinkeds) + = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) + $$ nest 3 (ppr unlinkeds) + +------------------------------------------- +data Unlinked + = DotO FilePath + | DotA FilePath + | DotDLL FilePath + | BCOs CompiledByteCode + +#ifndef GHCI +data CompiledByteCode = NoByteCode +#endif + +instance Outputable Unlinked where + ppr (DotO path) = text "DotO" <+> text path + ppr (DotA path) = text "DotA" <+> text path + ppr (DotDLL path) = text "DotDLL" <+> text path +#ifdef GHCI + ppr (BCOs bcos) = text "BCOs" <+> ppr bcos +#else + ppr (BCOs bcos) = text "No byte code" +#endif + +isObject (DotO _) = True +isObject (DotA _) = True +isObject (DotDLL _) = True +isObject _ = False + +isInterpretable = not . isObject + +nameOfObject (DotO fn) = fn +nameOfObject (DotA fn) = fn +nameOfObject (DotDLL fn) = fn + +byteCodeOfObject (BCOs bc) = bc +\end{code} + + +%************************************************************************ +%* * \subsection{Provenance and export info} %* * %************************************************************************ A LocalRdrEnv is used for local bindings (let, where, lambda, case) +Also used in \begin{code} type LocalRdrEnv = RdrNameEnv Name @@ -721,14 +875,56 @@ type GlobalRdrEnv = RdrNameEnv [GlobalRdrElt] -- The list is because there may be name clashes -- These only get reported on lookup, not on construction -data GlobalRdrElt = GRE Name Provenance (Maybe DeprecTxt) - -- The Maybe DeprecTxt tells whether this name is deprecated +emptyGlobalRdrEnv = emptyRdrEnv + +data GlobalRdrElt + = GRE { gre_name :: Name, + gre_parent :: Name, -- Name of the "parent" structure + -- * the tycon of a data con + -- * the class of a class op + -- For others it's just the same as gre_name + gre_prov :: Provenance, -- Why it's in scope + gre_deprec :: Maybe DeprecTxt -- Whether this name is deprecated + } +instance Outputable GlobalRdrElt where + ppr gre = ppr (gre_name gre) <+> + parens (hsep [text "parent:" <+> ppr (gre_parent gre) <> comma, + pprNameProvenance gre]) pprGlobalRdrEnv env = vcat (map pp (rdrEnvToList env)) where - pp (rn, nps) = ppr rn <> colon <+> - vcat [ppr n <+> pprNameProvenance n p | (GRE n p _) <- nps] + pp (rn, gres) = ppr rn <> colon <+> + vcat [ ppr (gre_name gre) <+> pprNameProvenance gre + | gre <- gres] + +isLocalGRE :: GlobalRdrElt -> Bool +isLocalGRE (GRE {gre_prov = LocalDef}) = True +isLocalGRE other = False +\end{code} + +@unQualInScope@ returns a function that takes a @Name@ and tells whether +its unqualified name is in scope. This is put as a boolean flag in +the @Name@'s provenance to guide whether or not to print the name qualified +in error messages. + +\begin{code} +unQualInScope :: GlobalRdrEnv -> Name -> Bool +-- True if 'f' is in scope, and has only one binding, +-- and the thing it is bound to is the name we are looking for +-- (i.e. false if A.f and B.f are both in scope as unqualified 'f') +-- +-- Also checks for built-in syntax, which is always 'in scope' +-- +-- This fn is only efficient if the shared +-- partial application is used a lot. +unQualInScope env + = \n -> n `elemNameSet` unqual_names || isBuiltInSyntaxName n + where + unqual_names :: NameSet + unqual_names = foldRdrEnv add emptyNameSet env + add rdr_name [gre] unquals | isUnqual rdr_name = addOneToNameSet unquals (gre_name gre) + add _ _ unquals = unquals \end{code} The "provenance" of something says how it came to be in scope. @@ -788,10 +984,12 @@ hasBetterProv LocalDef _ = True hasBetterProv (NonLocalDef (UserImport _ _ _ )) (NonLocalDef ImplicitImport) = True hasBetterProv _ _ = False -pprNameProvenance :: Name -> Provenance -> SDoc -pprNameProvenance name LocalDef = ptext SLIT("defined at") <+> ppr (nameSrcLoc name) -pprNameProvenance name (NonLocalDef why) = sep [ppr_reason why, - nest 2 (ppr_defn (nameSrcLoc name))] +pprNameProvenance :: GlobalRdrElt -> SDoc +pprNameProvenance (GRE {gre_name = name, gre_prov = prov}) + = case prov of + LocalDef -> ptext SLIT("defined at") <+> ppr (nameSrcLoc name) + NonLocalDef why -> sep [ppr_reason why, + nest 2 (ppr_defn (nameSrcLoc name))] ppr_reason ImplicitImport = ptext SLIT("implicitly imported") ppr_reason (UserImport mod loc _) = ptext SLIT("imported from") <+> ppr mod <+> ptext SLIT("at") <+> ppr loc diff --git a/ghc/compiler/main/Interpreter.hs b/ghc/compiler/main/Interpreter.hs index d90ca29b19..cadec90649 100644 --- a/ghc/compiler/main/Interpreter.hs +++ b/ghc/compiler/main/Interpreter.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: Interpreter.hs,v 1.11 2000/12/19 12:36:12 sewardj Exp $ +-- $Id: Interpreter.hs,v 1.12 2002/09/13 15:02:35 simonpj Exp $ -- -- Interpreter subsystem wrapper -- @@ -12,12 +12,7 @@ module Interpreter ( module ByteCodeGen, module Linker #else - ClosureEnv, emptyClosureEnv, - ItblEnv, emptyItblEnv, - byteCodeGen, - HValue, - UnlinkedBCO, UnlinkedBCOExpr, - loadObjs, resolveObjs, + #endif ) where @@ -38,8 +33,7 @@ import Outputable -- NO! No interpreter; generate stubs for all the bits -- ------------------------------------------------------------ -type ClosureEnv = () -emptyClosureEnv = () +extendLinkEnv xs = return () type ItblEnv = () emptyItblEnv = () diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 8c55d4420e..1fb9ece5d6 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,7 +1,7 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.110 2002/09/06 14:35:44 simonmar Exp $ +-- $Id: Main.hs,v 1.111 2002/09/13 15:02:35 simonpj Exp $ -- -- GHC Driver program -- @@ -29,13 +29,13 @@ import Config ( cBooterVersion, cGhcUnregisterised, cProjectVersion ) import SysTools ( getPackageConfigPath, initSysTools, cleanTempFiles ) import Packages ( showPackages ) -import DriverPipeline ( doLink, doMkDLL, genPipeline, pipeLoop ) +import DriverPipeline ( staticLink, doMkDLL, genPipeline, pipeLoop ) import DriverState ( buildCoreToDo, buildStgToDo, - findBuildTag, getPackageInfo, unregFlags, + findBuildTag, getPackageInfo, getPackageConfigMap, + getPackageExtraGhcOpts, unregFlags, v_GhcMode, v_GhcModeFlag, GhcMode(..), - v_Cmdline_libraries, v_Keep_tmp_files, v_Ld_inputs, + v_Keep_tmp_files, v_Ld_inputs, v_Ways, v_OptLevel, v_Output_file, v_Output_hi, - v_Package_details, v_Ways, getPackageExtraGhcOpts, readPackageConf, verifyOutputFiles ) import DriverFlags ( buildStaticHscOpts, @@ -52,6 +52,7 @@ import CmdLineOpts ( dynFlag, restoreDynFlags, DynFlags(..), HscLang(..), v_Static_hsc_opts, defaultHscLang ) +import BasicTypes ( failed ) import Outputable import Util import Panic ( GhcException(..), panic ) @@ -239,7 +240,7 @@ main = when (verb >= 2) (hPutStrLn stderr ("Using package config file: " ++ conf_file)) - pkg_details <- readIORef v_Package_details + pkg_details <- getPackageConfigMap showPackages pkg_details when (verb >= 3) @@ -304,7 +305,7 @@ main = o_files <- mapM compileFile srcs when (mode == DoMkDependHS) endMkDependHS - when (mode == DoLink) (doLink o_files) + when (mode == DoLink) (staticLink o_files) when (mode == DoMkDLL) (doMkDLL o_files) @@ -319,8 +320,8 @@ beginMake fileish_args _ -> do dflags <- getDynFlags state <- cmInit Batch graph <- cmDepAnal state dflags mods - (_, ok, _) <- cmLoadModules state dflags graph - when (not ok) (exitWith (ExitFailure 1)) + (_, ok_flag, _) <- cmLoadModules state dflags graph + when (failed ok_flag) (exitWith (ExitFailure 1)) return () @@ -329,13 +330,11 @@ beginInteractive :: [String] -> IO () beginInteractive = throwDyn (CmdLineError "not built for interactive use") #else beginInteractive fileish_args - = do minus_ls <- readIORef v_Cmdline_libraries + = do state <- cmInit Interactive let (objs, mods) = partition objish_file fileish_args - libs = map Object objs ++ map DLL minus_ls - state <- cmInit Interactive - interactiveUI state mods libs + interactiveUI state mods objs #endif checkOptions :: [String] -> IO () diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index f2b908e2c7..9b151dde0e 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -6,8 +6,8 @@ \begin{code} module MkIface ( - showIface, mkFinalIface, - pprModDetails, pprIface, pprUsage, pprUsages, pprExports, + showIface, mkIface, mkUsageInfo, + pprIface, pprUsage, pprUsages, pprExports, ifaceTyThing, ) where @@ -17,54 +17,60 @@ import HsSyn import HsCore ( HsIdInfo(..), UfExpr(..), toUfExpr, toUfBndr ) import HsTypes ( toHsTyVars ) import TysPrim ( alphaTyVars ) -import BasicTypes ( NewOrData(..), Activation(..), +import BasicTypes ( NewOrData(..), Activation(..), FixitySig(..), Version, initialVersion, bumpVersion ) import NewDemand ( isTopSig ) -import RnMonad +import TcRnMonad import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl ) -import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..), - ModuleLocation(..), GhciMode(..), +import HscTypes ( VersionInfo(..), ModIface(..), HomeModInfo(..), + ModGuts(..), ModGuts, + GhciMode(..), HscEnv(..), FixityEnv, lookupFixity, collectFixities, IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, - TyThing(..), DFunId, TypeEnv, - GenAvailInfo, - WhatsImported(..), GenAvailInfo(..), - ImportVersion, Deprecations(..), - lookupVersion, typeEnvIds + TyThing(..), DFunId, + Avails, AvailInfo, GenAvailInfo(..), availName, + ExternalPackageState(..), + WhatsImported(..), ParsedIface(..), + ImportVersion, Deprecations(..), initialVersionInfo, + lookupVersion ) import CmdLineOpts -import Id ( idType, idInfo, isImplicitId, idCgInfo, - isLocalId, idName, - ) +import Id ( idType, idInfo, isImplicitId, idCgInfo ) import DataCon ( dataConWorkId, dataConSig, dataConFieldLabels, dataConStrictMarks ) import IdInfo -- Lots -import Var ( Var ) import CoreSyn ( CoreRule(..), IdCoreRule ) import CoreFVs ( ruleLhsFreeNames ) import CoreUnfold ( neverUnfold, unfoldingTemplate ) -import PprCore ( pprIdRules ) -import Name ( getName, toRdrName, isExternalName, +import Name ( getName, nameModule, nameModule_maybe, nameOccName, nameIsLocalOrFrom, Name, NamedThing(..) ) import NameEnv import NameSet -import OccName ( pprOccName ) -import TyCon +import OccName ( OccName, pprOccName ) +import TyCon ( DataConDetails(..), tyConTyVars, tyConDataCons, tyConTheta, + isFunTyCon, isPrimTyCon, isNewTyCon, isClassTyCon, + isSynTyCon, isAlgTyCon, isForeignTyCon, + getSynTyConDefn, tyConGenInfo, tyConDataConDetails, tyConArity ) import Class ( classExtraBigSig, classTyCon, DefMeth(..) ) import FieldLabel ( fieldLabelType ) -import TcType ( tcSplitSigmaTy, tidyTopType, deNoteType, namesOfDFunHead ) +import TcType ( tcSplitSigmaTy, tidyTopType, deNoteType, tyClsNamesOfDFunHead ) import SrcLoc ( noSrcLoc ) +import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule, + ModLocation(..), mkSysModuleNameFS, + ModuleEnv, emptyModuleEnv, foldModuleEnv, lookupModuleEnv, + extendModuleEnv_C, elemModuleSet, moduleEnvElts + ) import Outputable -import Module ( ModuleName ) -import Util ( sortLt, dropList ) +import Util ( sortLt, dropList, seqList ) import Binary ( getBinFileWithDict ) import BinIface ( writeBinIface ) import ErrUtils ( dumpIfSet_dyn ) +import FiniteMap import FastString import Monad ( when ) -import Maybe ( catMaybes ) +import Maybe ( catMaybes, isJust ) import IO ( putStrLn ) \end{code} @@ -101,7 +107,7 @@ showIface filename = do -- ppr pi_deprecs ])) where - ppr_fix (n,f) = ppr f <+> ppr n + ppr_fix (FixitySig n f _) = ppr f <+> ppr n ppr_inst i = ppr i <+> semi ppr_decl (v,d) = int v <+> ppr d <> semi \end{code} @@ -113,29 +119,39 @@ showIface filename = do %************************************************************************ \begin{code} - - - -mkFinalIface :: GhciMode - -> DynFlags - -> ModuleLocation - -> Maybe ModIface -- The old interface, if we have it - -> ModIface -- The new one, minus the decls and versions - -> ModDetails -- The ModDetails for this module - -> IO ModIface -- The new one, complete with decls and versions +mkIface :: HscEnv + -> ModLocation + -> Maybe ModIface -- The old interface, if we have it + -> ModGuts -- The compiled, tidied module + -> IO ModIface -- The new one, complete with decls and versions -- mkFinalIface -- a) completes the interface -- b) writes it out to a file if necessary -mkFinalIface ghci_mode dflags location maybe_old_iface - new_iface@ModIface{ mi_module=mod } - new_details@ModDetails{ md_insts=insts, - md_rules=rules, - md_types=types } - = do { - -- Add the new declarations, and the is-orphan flag - let iface_w_decls = new_iface { mi_decls = new_decls, - mi_orphan = orphan_mod } +mkIface hsc_env location maybe_old_iface + impl@ModGuts{ mg_module = this_mod, + mg_usages = usages, + mg_exports = exports, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_deprecs = deprecs, + mg_insts = insts, + mg_rules = rules, + mg_types = types } + = do { -- Sort the exports to make them easier to compare for versions + let { my_exports = groupAvails this_mod exports ; + + iface_w_decls = ModIface { mi_module = this_mod, + mi_package = opt_InPackage, + mi_version = initialVersionInfo, + mi_usages = usages, + mi_exports = my_exports, + mi_decls = new_decls, + mi_orphan = orphan_mod, + mi_boot = False, + mi_fixities = fix_env, + mi_globals = Just rdr_env, + mi_deprecs = deprecs } } -- Add version information ; let (final_iface, maybe_diffs) = _scc_ "versioninfo" addVersionInfo maybe_old_iface iface_w_decls @@ -152,6 +168,9 @@ mkFinalIface ghci_mode dflags location maybe_old_iface return final_iface } where + dflags = hsc_dflags hsc_env + ghci_mode = hsc_mode hsc_env + must_write_hi_file Nothing = False must_write_hi_file (Just _diffs) = ghci_mode /= Interactive -- We must write a new .hi file if there are some changes @@ -165,7 +184,7 @@ mkFinalIface ghci_mode dflags location maybe_old_iface inst_dcls = map ifaceInstance insts ty_cls_dcls = foldNameEnv ifaceTyThing_acc [] types rule_dcls = map ifaceRule rules - orphan_mod = isOrphanModule mod new_details + orphan_mod = isOrphanModule impl write_diffs :: DynFlags -> ModIface -> Maybe SDoc -> IO () write_diffs dflags new_iface Nothing @@ -178,12 +197,12 @@ write_diffs dflags new_iface (Just sdoc_diffs) \end{code} \begin{code} -isOrphanModule :: Module -> ModDetails -> Bool -isOrphanModule this_mod (ModDetails {md_insts = insts, md_rules = rules}) +isOrphanModule :: ModGuts -> Bool +isOrphanModule (ModGuts {mg_module = this_mod, mg_insts = insts, mg_rules = rules}) = any orphan_inst insts || any orphan_rule rules where -- A rule is an orphan if the LHS mentions nothing defined locally - orphan_inst dfun_id = no_locals (namesOfDFunHead (idType dfun_id)) + orphan_inst dfun_id = no_locals (tyClsNamesOfDFunHead (idType dfun_id)) -- A instance is an orphan if its head mentions nothing defined locally orphan_rule rule = no_locals (ruleLhsFreeNames rule) @@ -213,14 +232,11 @@ ifaceTyThing (AClass clas) = cls_decl tcdFDs = toHsFDs clas_fds, tcdSigs = map toClassOpSig op_stuff, tcdMeths = Nothing, - tcdSysNames = sys_names, tcdLoc = noSrcLoc } (clas_tyvars, clas_fds, sc_theta, sc_sels, op_stuff) = classExtraBigSig clas tycon = classTyCon clas data_con = head (tyConDataCons tycon) - sys_names = mkClassDeclSysNames (getName tycon, getName data_con, - getName (dataConWorkId data_con), map getName sc_sels) toClassOpSig (sel_id, def_meth) = ASSERT(sel_tyvars == clas_tyvars) @@ -241,14 +257,15 @@ ifaceTyThing (ATyCon tycon) = ty_decl tcdLoc = noSrcLoc } | isAlgTyCon tycon - = TyData { tcdND = new_or_data, - tcdCtxt = toHsContext (tyConTheta tycon), - tcdName = getName tycon, - tcdTyVars = toHsTyVars tyvars, - tcdCons = ifaceConDecls (tyConDataConDetails tycon), - tcdDerivs = Nothing, - tcdSysNames = map getName (tyConGenIds tycon), - tcdLoc = noSrcLoc } + = TyData { tcdND = new_or_data, + tcdCtxt = toHsContext (tyConTheta tycon), + tcdName = getName tycon, + tcdTyVars = toHsTyVars tyvars, + tcdCons = ifaceConDecls (tyConDataConDetails tycon), + tcdDerivs = Nothing, + tcdGeneric = Just (isJust (tyConGenInfo tycon)), + -- Just True <=> has generic stuff + tcdLoc = noSrcLoc } | isForeignTyCon tycon = ForeignType { tcdName = getName tycon, @@ -264,7 +281,7 @@ ifaceTyThing (ATyCon tycon) = ty_decl tcdTyVars = toHsTyVars (take (tyConArity tycon) alphaTyVars), tcdCons = Unknown, tcdDerivs = Nothing, - tcdSysNames = [], + tcdGeneric = Just False, tcdLoc = noSrcLoc } | otherwise = pprPanic "ifaceTyThing" (ppr tycon) @@ -279,7 +296,7 @@ ifaceTyThing (ATyCon tycon) = ty_decl ifaceConDecls (DataCons cs) = DataCons (map ifaceConDecl cs) ifaceConDecl data_con - = ConDecl (getName data_con) (getName (dataConWorkId data_con)) + = ConDecl (getName data_con) (toHsTyVars ex_tyvars) (toHsContext ex_theta) details noSrcLoc @@ -291,13 +308,13 @@ ifaceTyThing (ATyCon tycon) = ty_decl -- includes the existential dictionaries details | null field_labels = ASSERT( tycon == tycon1 && tyvars == tyvars1 ) - VanillaCon (zipWith BangType strict_marks (map toHsType arg_tys)) + PrefixCon (zipWith BangType strict_marks (map toHsType arg_tys)) | otherwise = RecCon (zipWith mk_field strict_marks field_labels) mk_field strict_mark field_label - = ([getName field_label], BangType strict_mark (toHsType (fieldLabelType field_label))) + = (getName field_label, BangType strict_mark (toHsType (fieldLabelType field_label))) ifaceTyThing (AnId id) = iface_sig where @@ -368,7 +385,7 @@ ifaceInstance dfun_id -- and this instance decl wouldn't get imported into a module -- that mentioned T but not Tibble. -ifaceRule :: IdCoreRule -> RuleDecl Name pat +ifaceRule :: IdCoreRule -> RuleDecl Name ifaceRule (id, BuiltinRule _ _) = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id) @@ -376,12 +393,231 @@ ifaceRule (id, Rule name act bndrs args rhs) = IfaceRule name act (map toUfBndr bndrs) (getName id) (map toUfExpr args) (toUfExpr rhs) noSrcLoc -bogusIfaceRule :: (NamedThing a) => a -> RuleDecl Name pat +bogusIfaceRule :: (NamedThing a) => a -> RuleDecl Name bogusIfaceRule id = IfaceRule FSLIT("bogus") NeverActive [] (getName id) [] (UfVar (getName id)) noSrcLoc \end{code} +%********************************************************* +%* * +\subsection{Keeping track of what we've slurped, and version numbers} +%* * +%********************************************************* + +mkUsageInfo figures out what the ``usage information'' for this +moudule is; that is, what it must record in its interface file as the +things it uses. + +We produce a line for every module B below the module, A, currently being +compiled: + import B <n> ; +to record the fact that A does import B indirectly. This is used to decide +to look to look for B.hi rather than B.hi-boot when compiling a module that +imports A. This line says that A imports B, but uses nothing in it. +So we'll get an early bale-out when compiling A if B's version changes. + +The usage information records: + +\begin{itemize} +\item (a) anything reachable from its body code +\item (b) any module exported with a @module Foo@ +\item (c) anything reachable from an exported item +\end{itemize} + +Why (b)? Because if @Foo@ changes then this module's export list +will change, so we must recompile this module at least as far as +making a new interface file --- but in practice that means complete +recompilation. + +Why (c)? Consider this: +\begin{verbatim} + module A( f, g ) where | module B( f ) where + import B( f ) | f = h 3 + g = ... | h = ... +\end{verbatim} + +Here, @B.f@ isn't used in A. Should we nevertheless record @B.f@ in +@A@'s usages? Our idea is that we aren't going to touch A.hi if it is +*identical* to what it was before. If anything about @B.f@ changes +than anyone who imports @A@ should be recompiled in case they use +@B.f@ (they'll get an early exit if they don't). So, if anything +about @B.f@ changes we'd better make sure that something in A.hi +changes, and the convenient way to do that is to record the version +number @B.f@ in A.hi in the usage list. If B.f changes that'll force a +complete recompiation of A, which is overkill but it's the only way to +write a new, slightly different, A.hi. + +But the example is tricker. Even if @B.f@ doesn't change at all, +@B.h@ may do so, and this change may not be reflected in @f@'s version +number. But with -O, a module that imports A must be recompiled if +@B.h@ changes! So A must record a dependency on @B.h@. So we treat +the occurrence of @B.f@ in the export list *just as if* it were in the +code of A, and thereby haul in all the stuff reachable from it. + + *** Conclusion: if A mentions B.f in its export list, + behave just as if A mentioned B.f in its source code, + and slurp in B.f and all its transitive closure *** + +[NB: If B was compiled with -O, but A isn't, we should really *still* +haul in all the unfoldings for B, in case the module that imports A *is* +compiled with -O. I think this is the case.] + +\begin{code} +mkUsageInfo :: HscEnv -> ExternalPackageState + -> ImportAvails -> Usages + -> [ImportVersion Name] + +mkUsageInfo hsc_env eps + (ImportAvails { imp_mods = dir_imp_mods }) + (Usages { usg_ext = pkg_mods, + usg_home = home_names }) + = let + hpt = hsc_HPT hsc_env + pit = eps_PIT eps + + import_all_mods = [moduleName m | (m,True) <- moduleEnvElts dir_imp_mods] + + -- mv_map groups together all the things imported and used + -- from a particular module in this package + -- We use a finite map because we want the domain + mv_map :: ModuleEnv [Name] + mv_map = foldNameSet add_mv emptyModuleEnv home_names + add_mv name mv_map = extendModuleEnv_C add_item mv_map mod [name] + where + mod = nameModule name + add_item names _ = name:names + + -- In our usage list we record + -- + -- a) Specifically: Detailed version info for imports + -- from modules in this package Gotten from iVSlurp plus + -- import_all_mods + -- + -- b) Everything: Just the module version for imports + -- from modules in other packages Gotten from iVSlurp plus + -- import_all_mods + -- + -- c) NothingAtAll: The name only of modules, Baz, in + -- this package that are 'below' us, but which we didn't need + -- at all (this is needed only to decide whether to open Baz.hi + -- or Baz.hi-boot higher up the tree). This happens when a + -- module, Foo, that we explicitly imported has 'import Baz' in + -- its interface file, recording that Baz is below Foo in the + -- module dependency hierarchy. We want to propagate this + -- info. These modules are in a combination of HIT/PIT and + -- iImpModInfo + -- + -- d) NothingAtAll: The name only of all orphan modules + -- we know of (this is needed so that anyone who imports us can + -- find the orphan modules) These modules are in a combination + -- of HIT/PIT and iImpModInfo + + import_info0 = foldModuleEnv mk_imp_info [] pit + import_info1 = foldModuleEnv (mk_imp_info . hm_iface) import_info0 hpt + import_info = not_even_opened_imports ++ import_info1 + + -- Recall that iImpModInfo describes modules that have + -- been mentioned in the import lists of interfaces we + -- have seen mentioned, but which we have not even opened when + -- compiling this module + not_even_opened_imports = + [ (mod_name, orphans, is_boot, NothingAtAll) + | (mod_name, (orphans, is_boot)) <- fmToList (eps_imp_mods eps)] + + + mk_imp_info :: ModIface -> [ImportVersion Name] -> [ImportVersion Name] + mk_imp_info iface so_far + + | Just ns <- lookupModuleEnv mv_map mod -- Case (a) + = go_for_it (Specifically mod_vers maybe_export_vers + (mk_import_items ns) rules_vers) + + | mod `elemModuleSet` pkg_mods -- Case (b) + = go_for_it (Everything mod_vers) + + | import_all_mod -- Case (a) and (b); the import-all part + = if is_home_pkg_mod then + go_for_it (Specifically mod_vers (Just export_vers) [] rules_vers) + -- Since the module isn't in the mv_map, presumably we + -- didn't actually import anything at all from it + else + go_for_it (Everything mod_vers) + + | is_home_pkg_mod || has_orphans -- Case (c) or (d) + = go_for_it NothingAtAll + + | otherwise = so_far + where + go_for_it exports = (mod_name, has_orphans, mi_boot iface, exports) : so_far + + mod = mi_module iface + mod_name = moduleName mod + is_home_pkg_mod = isHomeModule mod + version_info = mi_version iface + version_env = vers_decls version_info + mod_vers = vers_module version_info + rules_vers = vers_rules version_info + export_vers = vers_exports version_info + import_all_mod = mod_name `elem` import_all_mods + has_orphans = mi_orphan iface + + -- The sort is to put them into canonical order + mk_import_items ns = [(n,v) | n <- sortLt lt_occ ns, + let v = lookupVersion version_env n + ] + where + lt_occ n1 n2 = nameOccName n1 < nameOccName n2 + + maybe_export_vers | import_all_mod = Just (vers_exports version_info) + | otherwise = Nothing + in + + -- seq the list of ImportVersions returned: occasionally these + -- don't get evaluated for a while and we can end up hanging on to + -- the entire collection of Ifaces. + import_info `seqList` import_info +\end{code} + +\begin{code} +groupAvails :: Module -> Avails -> [(ModuleName, Avails)] + -- Group by module and sort by occurrence + -- This keeps the list in canonical order +groupAvails this_mod avails + = [ (mkSysModuleNameFS fs, sortLt lt avails) + | (fs,avails) <- fmToList groupFM + ] + where + groupFM :: FiniteMap FastString Avails + -- Deliberately use the FastString so we + -- get a canonical ordering + groupFM = foldl add emptyFM avails + + add env avail = addToFM_C combine env mod_fs [avail'] + where + mod_fs = moduleNameFS (moduleName avail_mod) + avail_mod = case nameModule_maybe (availName avail) of + Just m -> m + Nothing -> this_mod + combine old _ = avail':old + avail' = sortAvail avail + + a1 `lt` a2 = occ1 < occ2 + where + occ1 = nameOccName (availName a1) + occ2 = nameOccName (availName a2) + +sortAvail :: AvailInfo -> AvailInfo +-- Sort the sub-names into canonical order. +-- The canonical order has the "main name" at the beginning +-- (if it's there at all) +sortAvail (Avail n) = Avail n +sortAvail (AvailTC n ns) | n `elem` ns = AvailTC n (n : sortLt lt (filter (/= n) ns)) + | otherwise = AvailTC n ( sortLt lt ns) + where + n1 `lt` n2 = nameOccName n1 < nameOccName n2 +\end{code} + %************************************************************************ %* * \subsection{Checking if the new interface is up to date @@ -493,59 +729,7 @@ diffDecls (VersionInfo { vers_module = old_mod_vers, vers_decls = old_decls_vers \end{code} - -%************************************************************************ -%* * -\subsection{Writing ModDetails} -%* * -%************************************************************************ - -\begin{code} -pprModDetails :: ModDetails -> SDoc -pprModDetails (ModDetails { md_types = type_env, md_insts = dfun_ids, md_rules = rules }) - = vcat [ dump_types dfun_ids type_env - , dump_insts dfun_ids - , dump_rules rules] - -dump_types :: [Var] -> TypeEnv -> SDoc -dump_types dfun_ids type_env - = text "TYPE SIGNATURES" $$ nest 4 (dump_sigs ids) - where - ids = [id | id <- typeEnvIds type_env, want_sig id] - want_sig id | opt_PprStyle_Debug = True - | otherwise = isLocalId id && - isExternalName (idName id) && - not (id `elem` dfun_ids) - -- isLocalId ignores data constructors, records selectors etc - -- The isExternalName ignores local dictionary and method bindings - -- that the type checker has invented. User-defined things have - -- Global names. - -dump_insts :: [Var] -> SDoc -dump_insts [] = empty -dump_insts dfun_ids = text "INSTANCES" $$ nest 4 (dump_sigs dfun_ids) - -dump_sigs :: [Var] -> SDoc -dump_sigs ids - -- Print type signatures - -- Convert to HsType so that we get source-language style printing - -- And sort by RdrName - = vcat $ map ppr_sig $ sortLt lt_sig $ - [ (toRdrName id, toHsType (idType id)) - | id <- ids ] - where - lt_sig (n1,_) (n2,_) = n1 < n2 - ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t - -dump_rules :: [IdCoreRule] -> SDoc -dump_rules [] = empty -dump_rules rs = vcat [ptext SLIT("{-# RULES"), - nest 4 (pprIdRules rs), - ptext SLIT("#-}")] -\end{code} - - -%************************************************************************ +b%************************************************************************ %* * \subsection{Writing an interface file} %* * @@ -651,12 +835,12 @@ pprIfaceDecls version_map decls \end{code} \begin{code} -pprFixities :: NameEnv Fixity - -> [TyClDecl Name pat] +pprFixities :: FixityEnv + -> [TyClDecl Name] -> SDoc pprFixities fixity_map decls = hsep [ ppr fix <+> ppr n - | (n,fix) <- collectFixities fixity_map decls ] <> semi + | FixitySig n fix _ <- collectFixities fixity_map decls ] <> semi -- Disgusting to print these two together, but that's -- the way the interface parser currently expects them. diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs index 190a1f8a2b..74e65a7412 100644 --- a/ghc/compiler/main/Packages.lhs +++ b/ghc/compiler/main/Packages.lhs @@ -4,11 +4,18 @@ \section{Package manipulation} \begin{code} -module Packages ( PackageConfig(..), - defaultPackageConfig, - mungePackagePaths, - showPackages - ) +module Packages ( + PackageConfig(..), + defaultPackageConfig, + mungePackagePaths, packageDependents, + showPackages, + + PackageName, -- Instance of Outputable + mkPackageName, packageNameString, + preludePackage, rtsPackage, stdPackage, haskell98Package, -- :: PackageName + + PackageConfigMap, emptyPkgMap, extendPkgMap, lookupPkg + ) where #include "HsVersions.h" @@ -19,8 +26,16 @@ import CmdLineOpts ( dynFlag, verbosity ) import DriverUtil ( my_prefix_match ) import ErrUtils ( dumpIfSet ) import Outputable ( docToSDoc ) +import FastString +import UniqFM \end{code} +%********************************************************* +%* * +\subsection{Basic data types} +%* * +%********************************************************* + \begin{code} #define WANT_PRETTY #define INTERNAL_PRETTY @@ -29,9 +44,52 @@ import Outputable ( docToSDoc ) -- There's a blob of code shared with ghc-pkg, -- so we just include it from there +-- Primarily it defines +-- PackageConfig (a record) +-- PackageName (FastString) + #include "../utils/ghc-pkg/Package.hs" \end{code} +\begin{code} +type PackageName = FastString -- No encoding at all + +mkPackageName :: String -> PackageName +mkPackageName = mkFastString + +packageNameString :: PackageName -> String +packageNameString = unpackFS + +stdPackage, rtsPackage, preludePackage, haskell98Package :: PackageName +preludePackage = FSLIT("base") +stdPackage = FSLIT("std") -- Do we still have this? +rtsPackage = FSLIT("rts") +haskell98Package = FSLIT("haskell98") + +packageDependents :: PackageConfig -> [PackageName] +-- Impedence matcher, because PackageConfig has Strings +-- not PackageNames at the moment. Sigh. +packageDependents pkg = map mkPackageName (package_deps pkg) +\end{code} + +A PackageConfigMap maps a PackageName to a PackageConfig + +\begin{code} +type PackageConfigMap = UniqFM PackageConfig + +lookupPkg :: PackageConfigMap -> PackageName -> Maybe PackageConfig +emptyPkgMap :: PackageConfigMap + +emptyPkgMap = emptyUFM +lookupPkg = lookupUFM + +extendPkgMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap +extendPkgMap pkg_map new_pkgs + = foldl add pkg_map new_pkgs + where + add pkg_map p = addToUFM pkg_map (mkFastString (name p)) p +\end{code} + %********************************************************* %* * \subsection{Load the config file} @@ -64,11 +122,13 @@ mungePackagePaths top_dir ps = map munge_pkg ps %********************************************************* \begin{code} -showPackages :: [PackageConfig] -> IO () +showPackages :: PackageConfigMap -> IO () -- Show package info on console, if verbosity is >= 3 -showPackages ps +showPackages pkg_map = do { verb <- dynFlag verbosity ; dumpIfSet (verb >= 3) "Packages" (docToSDoc (vcat (map dumpPkgGuts ps))) } + where + ps = eltsUFM pkg_map \end{code} diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index bca9a7e9a1..64e7c5cad7 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -77,6 +77,7 @@ import qualified EXCEPTION as Exception ( catch ) import EXCEPTION ( catchAllIO ) #endif +import CString ( CString, peekCString ) import DATA_IOREF ( IORef, readIORef, writeIORef ) import DATA_INT @@ -102,9 +103,9 @@ import qualified Posix #else import List ( isPrefixOf ) import Util ( dropList ) -import MarshalArray +-- import Foreign.Marshal.Array import Foreign -import CString +-- import CString #endif #ifdef mingw32_HOST_OS diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index bacbee47e8..ce48739f14 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -33,11 +33,10 @@ import NameEnv ( filterNameEnv ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) import Type ( tidyTopType ) import Module ( Module, moduleName ) -import HscTypes ( PersistentCompilerState( pcs_PRS ), - PersistentRenamerState( prsOrig ), - NameSupply( nsNames, nsUniqs ), +import HscTypes ( PersistentCompilerState( pcs_nc ), + NameCache( nsNames, nsUniqs ), TypeEnv, extendTypeEnvList, typeEnvIds, - ModDetails(..), TyThing(..) + ModGuts(..), ModGuts, TyThing(..) ) import FiniteMap ( lookupFM, addToFM ) import Maybes ( orElse ) @@ -87,10 +86,10 @@ binder [Even non-exported things need system-wide Uniques because the byte-code generator builds a single Name->BCO symbol table.] - We use the NameSupply kept in the PersistentRenamerState as the + We use the NameCache kept in the PersistentCompilerState as the source of such system-wide uniques. - For external Ids, use the original-name cache in the NameSupply + For external Ids, use the original-name cache in the NameCache to ensure that the unique assigned is the same as the Id had in any previous compilation run. @@ -119,16 +118,17 @@ throughout, including in unfoldings. We also tidy binders in RHSs, so that they print nicely in interfaces. \begin{code} -tidyCorePgm :: DynFlags -> Module +tidyCorePgm :: DynFlags -> PersistentCompilerState -> CgInfoEnv -- Information from the back end, -- to be splatted into the IdInfo - -> ModDetails - -> IO (PersistentCompilerState, ModDetails) + -> ModGuts + -> IO (PersistentCompilerState, ModGuts) -tidyCorePgm dflags mod pcs cg_info_env - (ModDetails { md_types = env_tc, md_insts = insts_tc, - md_binds = binds_in, md_rules = orphans_in }) +tidyCorePgm dflags pcs cg_info_env + mod_impl@(ModGuts { mg_module = mod, + mg_types = env_tc, mg_insts = insts_tc, + mg_binds = binds_in, mg_rules = orphans_in }) = do { showPass dflags "Tidy Core" ; let ext_ids = findExternalSet binds_in orphans_in @@ -147,9 +147,7 @@ tidyCorePgm dflags mod pcs cg_info_env -- The second exported decl must 'get' the name 'f', so we -- have to put 'f' in the avoids list before we get to the first -- decl. tidyTopId then does a no-op on exported binders. - ; let prs = pcs_PRS pcs - orig_ns = prsOrig prs - + ; let orig_ns = pcs_nc pcs init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv) avoids = [getOccName name | bndr <- typeEnvIds env_tc, let name = idName bndr, @@ -167,8 +165,7 @@ tidyCorePgm dflags mod pcs cg_info_env ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules - ; let prs' = prs { prsOrig = orig_ns' } - pcs' = pcs { pcs_PRS = prs' } + ; let pcs' = pcs { pcs_nc = orig_ns' } ; let final_ids = [ id | bind <- tidy_binds @@ -184,17 +181,17 @@ tidyCorePgm dflags mod pcs cg_info_env ; let tidy_type_env = mkFinalTypeEnv env_tc final_ids tidy_dfun_ids = map lookup_dfun_id insts_tc - ; let tidy_details = ModDetails { md_types = tidy_type_env, - md_rules = tidy_rules, - md_insts = tidy_dfun_ids, - md_binds = tidy_binds } + ; let tidy_result = mod_impl { mg_types = tidy_type_env, + mg_rules = tidy_rules, + mg_insts = tidy_dfun_ids, + mg_binds = tidy_binds } ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds ; dumpIfSet_core dflags Opt_D_dump_simpl "Tidy Core Rules" (pprIdRules tidy_rules) - ; return (pcs', tidy_details) + ; return (pcs', tidy_result) } tidyCoreExpr :: CoreExpr -> IO CoreExpr @@ -369,10 +366,10 @@ addExternal (id,rhs) needed \begin{code} -type TopTidyEnv = (NameSupply, TidyOccEnv, VarEnv Var) +type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var) -- TopTidyEnv: when tidying we need to know --- * ns: The NameSupply, containing a unique supply and any pre-ordained Names. +-- * ns: The NameCache, containing a unique supply and any pre-ordained Names. -- These may have arisen because the -- renamer read in an interface file mentioning M.$wf, say, -- and assigned it unique r77. If, on this compilation, we've |