From 9af77fa423926fbda946b31e174173d0ec5ebac8 Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 13 Sep 2002 15:02:50 +0000 Subject: [PATCH] [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. --- ghc/compiler/Makefile | 19 +- ghc/compiler/absCSyn/AbsCSyn.lhs | 2 +- ghc/compiler/absCSyn/CLabel.lhs | 3 +- ghc/compiler/basicTypes/BasicTypes.lhs | 53 +- ghc/compiler/basicTypes/IdInfo.lhs | 9 +- ghc/compiler/basicTypes/Literal.lhs | 4 +- ghc/compiler/basicTypes/MkId.lhs | 53 +- ghc/compiler/basicTypes/Module.lhs | 95 +- ghc/compiler/basicTypes/Name.lhs | 88 +- ghc/compiler/basicTypes/NameEnv.lhs | 5 +- ghc/compiler/basicTypes/OccName.lhs | 14 +- ghc/compiler/basicTypes/PprEnv.lhs | 75 -- ghc/compiler/basicTypes/RdrName.lhs | 220 ++-- ghc/compiler/basicTypes/SrcLoc.lhs | 29 +- ghc/compiler/basicTypes/Var.lhs | 30 +- ghc/compiler/codeGen/CgCase.lhs | 2 +- ghc/compiler/codeGen/CgClosure.lhs | 2 +- ghc/compiler/codeGen/CgExpr.lhs | 2 +- ghc/compiler/codeGen/CgHeapery.lhs | 2 +- ghc/compiler/codeGen/CgLetNoEscape.lhs | 2 +- ghc/compiler/codeGen/CgMonad.lhs | 2 +- ghc/compiler/codeGen/CgRetConv.lhs | 2 +- ghc/compiler/codeGen/CgStackery.lhs | 2 +- ghc/compiler/codeGen/ClosureInfo.lhs | 2 +- ghc/compiler/codeGen/CodeGen.lhs | 45 +- ghc/compiler/compMan/CmLink.lhs | 326 ------ ghc/compiler/compMan/CmTypes.lhs | 105 -- ghc/compiler/compMan/CompManager.lhs | 661 ++++++----- ghc/compiler/coreSyn/CoreFVs.lhs | 8 +- ghc/compiler/coreSyn/CoreLint.lhs | 20 +- ghc/compiler/coreSyn/CorePrep.lhs | 14 +- ghc/compiler/coreSyn/CoreSyn.lhs | 18 +- ghc/compiler/coreSyn/MkExternalCore.lhs | 21 +- ghc/compiler/coreSyn/PprCore.lhs | 231 ++-- ghc/compiler/count_lines | 1 + ghc/compiler/deSugar/Check.lhs | 321 +++--- ghc/compiler/deSugar/Desugar.lhs | 152 +-- ghc/compiler/deSugar/DsBinds.lhs | 6 +- ghc/compiler/deSugar/DsExpr.lhs | 117 +- ghc/compiler/deSugar/DsForeign.lhs | 87 +- ghc/compiler/deSugar/DsListComp.lhs | 38 +- ghc/compiler/deSugar/DsMeta.hs | 789 +++++++++++++ ghc/compiler/deSugar/DsMonad.lhs | 194 ++-- ghc/compiler/deSugar/DsUtils.lhs | 85 +- ghc/compiler/deSugar/Match.lhs | 119 +- ghc/compiler/deSugar/MatchCon.lhs | 10 +- ghc/compiler/deSugar/MatchLit.lhs | 92 +- ghc/compiler/ghci/ByteCodeAsm.lhs | 531 +++++++++ ghc/compiler/ghci/ByteCodeFFI.lhs | 12 +- ghc/compiler/ghci/ByteCodeGen.lhs | 62 +- ghc/compiler/ghci/ByteCodeInstr.lhs | 2 +- ghc/compiler/ghci/ByteCodeItbls.lhs | 28 +- ghc/compiler/ghci/ByteCodeLink.lhs | 594 +--------- ghc/compiler/ghci/InteractiveUI.hs | 388 ++----- ghc/compiler/ghci/Linker.lhs | 807 ++++++++++++- ghc/compiler/ghci/ObjLink.lhs | 92 ++ ghc/compiler/hsSyn/Convert.lhs | 297 +++++ ghc/compiler/hsSyn/HsBinds.lhs | 70 +- ghc/compiler/hsSyn/HsCore.lhs | 38 +- ghc/compiler/hsSyn/HsDecls.lhs | 297 ++--- ghc/compiler/hsSyn/HsExpr.hi-boot | 6 +- ghc/compiler/hsSyn/HsExpr.hi-boot-5 | 12 +- ghc/compiler/hsSyn/HsExpr.hi-boot-6 | 18 +- ghc/compiler/hsSyn/HsExpr.lhs | 313 ++--- ghc/compiler/hsSyn/HsImpExp.lhs | 41 +- ghc/compiler/hsSyn/HsPat.lhs | 491 ++++---- ghc/compiler/hsSyn/HsSyn.lhs | 50 +- ghc/compiler/hsSyn/HsTypes.lhs | 74 +- ghc/compiler/main/BinIface.hs | 138 ++- ghc/compiler/main/CodeOutput.lhs | 57 +- ghc/compiler/main/Constants.lhs | 3 +- ghc/compiler/main/DriverFlags.hs | 7 +- ghc/compiler/main/DriverMkDepend.hs | 6 +- ghc/compiler/main/DriverPhases.hs | 2 +- ghc/compiler/main/DriverPipeline.hs | 494 ++++---- ghc/compiler/main/DriverState.hs | 93 +- ghc/compiler/main/DriverUtil.hs | 2 +- ghc/compiler/main/ErrUtils.lhs | 106 +- ghc/compiler/main/Finder.lhs | 33 +- ghc/compiler/main/GetImports.hs | 2 +- ghc/compiler/main/HscMain.lhs | 725 +++++------- ghc/compiler/main/HscStats.lhs | 10 +- ghc/compiler/main/HscTypes.lhs | 620 ++++++---- ghc/compiler/main/Interpreter.hs | 12 +- ghc/compiler/main/Main.hs | 25 +- ghc/compiler/main/MkIface.lhs | 424 +++++-- ghc/compiler/main/Packages.lhs | 74 +- ghc/compiler/main/SysTools.lhs | 5 +- ghc/compiler/main/TidyPgm.lhs | 45 +- ghc/compiler/nativeGen/AsmCodeGen.lhs | 2 +- ghc/compiler/ndpFlatten/FlattenInfo.hs | 6 +- ghc/compiler/ndpFlatten/FlattenMonad.hs | 24 +- ghc/compiler/ndpFlatten/Flattening.hs | 42 +- ghc/compiler/parser/Lex.lhs | 172 ++- ghc/compiler/parser/ParseUtil.lhs | 65 +- ghc/compiler/parser/Parser.y | 140 ++- ghc/compiler/parser/ParserCore.y | 21 +- ghc/compiler/parser/RdrHsSyn.lhs | 86 +- ghc/compiler/prelude/PrelInfo.lhs | 48 +- ghc/compiler/prelude/PrelNames.lhs | 1030 ++++++++++------- ghc/compiler/prelude/PrelRules.lhs | 2 +- ghc/compiler/prelude/PrimOp.lhs | 48 +- ghc/compiler/prelude/TysWiredIn.lhs | 15 +- ghc/compiler/rename/Rename.lhs | 1048 ----------------- ghc/compiler/rename/RnBinds.hi-boot | 5 - ghc/compiler/rename/RnBinds.hi-boot-5 | 3 - ghc/compiler/rename/RnBinds.hi-boot-6 | 6 - ghc/compiler/rename/RnBinds.lhs | 197 ++-- ghc/compiler/rename/RnEnv.lhs | 988 +++++++--------- ghc/compiler/rename/RnExpr.lhs | 762 ++++++------ ghc/compiler/rename/RnHiFiles.hi-boot-5 | 3 +- ghc/compiler/rename/RnHiFiles.hi-boot-6 | 4 +- ghc/compiler/rename/RnHiFiles.lhs | 667 ++++++----- ghc/compiler/rename/RnHsSyn.lhs | 51 +- ghc/compiler/rename/RnIfaces.lhs | 820 ++++++------- ghc/compiler/rename/RnMonad.lhs | 760 ------------ ghc/compiler/rename/RnNames.lhs | 684 +++++++---- ghc/compiler/rename/RnSource.hi-boot-5 | 12 + ghc/compiler/rename/RnSource.hi-boot-6 | 10 + ghc/compiler/rename/RnSource.lhs | 745 +++++++----- ghc/compiler/rename/RnTypes.lhs | 168 ++- ghc/compiler/simplCore/FloatOut.lhs | 20 +- ghc/compiler/simplCore/SetLevels.lhs | 44 +- ghc/compiler/simplCore/SimplCore.lhs | 70 +- ghc/compiler/specialise/SpecConstr.lhs | 2 +- ghc/compiler/specialise/Specialise.lhs | 2 +- ghc/compiler/stgSyn/CoreToStg.lhs | 2 +- ghc/compiler/stgSyn/StgLint.lhs | 17 +- ghc/compiler/stranal/DmdAnal.lhs | 6 +- ghc/compiler/typecheck/Inst.lhs | 419 +++---- ghc/compiler/typecheck/TcBinds.lhs | 272 +++-- ghc/compiler/typecheck/TcClassDcl.lhs | 179 +-- ghc/compiler/typecheck/TcDefaults.lhs | 34 +- ghc/compiler/typecheck/TcDeriv.lhs | 165 ++- ghc/compiler/typecheck/TcEnv.hi-boot | 5 - ghc/compiler/typecheck/TcEnv.hi-boot-5 | 3 - ghc/compiler/typecheck/TcEnv.hi-boot-6 | 3 - ghc/compiler/typecheck/TcEnv.lhs | 558 +++++---- ghc/compiler/typecheck/TcExpr.hi-boot | 4 +- ghc/compiler/typecheck/TcExpr.hi-boot-5 | 4 +- ghc/compiler/typecheck/TcExpr.hi-boot-6 | 4 +- ghc/compiler/typecheck/TcExpr.lhs | 828 ++++++------- ghc/compiler/typecheck/TcForeign.lhs | 113 +- ghc/compiler/typecheck/TcGenDeriv.lhs | 179 +-- ghc/compiler/typecheck/TcHsSyn.lhs | 1088 +++++++++--------- ghc/compiler/typecheck/TcIfaceSig.lhs | 215 ++-- ghc/compiler/typecheck/TcInstDcls.lhs | 272 ++--- ghc/compiler/typecheck/TcMType.lhs | 507 ++++---- ghc/compiler/typecheck/TcMatches.hi-boot | 4 +- ghc/compiler/typecheck/TcMatches.hi-boot-5 | 4 +- ghc/compiler/typecheck/TcMatches.hi-boot-6 | 4 +- ghc/compiler/typecheck/TcMatches.lhs | 255 ++-- ghc/compiler/typecheck/TcModule.lhs | 879 -------------- ghc/compiler/typecheck/TcMonad.lhs | 755 ------------ ghc/compiler/typecheck/TcMonoType.lhs | 276 ++--- ghc/compiler/typecheck/TcPat.lhs | 385 +++---- ghc/compiler/typecheck/TcRnDriver.lhs | 1215 ++++++++++++++++++++ ghc/compiler/typecheck/TcRnMonad.lhs | 722 ++++++++++++ ghc/compiler/typecheck/TcRnTypes.lhs | 832 ++++++++++++++ ghc/compiler/typecheck/TcRules.lhs | 89 +- ghc/compiler/typecheck/TcSimplify.lhs | 411 +++---- ghc/compiler/typecheck/TcSplice.hi-boot-6 | 7 + ghc/compiler/typecheck/TcSplice.lhs | 322 ++++++ ghc/compiler/typecheck/TcTyClsDecls.lhs | 260 +++-- ghc/compiler/typecheck/TcTyDecls.lhs | 98 +- ghc/compiler/typecheck/TcType.lhs | 53 +- ghc/compiler/typecheck/TcUnify.hi-boot | 2 +- ghc/compiler/typecheck/TcUnify.hi-boot-5 | 2 +- ghc/compiler/typecheck/TcUnify.hi-boot-6 | 2 +- ghc/compiler/typecheck/TcUnify.lhs | 296 +++-- ghc/compiler/types/FunDeps.lhs | 4 +- ghc/compiler/types/Generics.lhs | 14 +- ghc/compiler/types/InstEnv.lhs | 18 +- ghc/compiler/types/PprType.lhs | 3 + ghc/compiler/types/Type.lhs | 2 - ghc/compiler/utils/Binary.hs | 9 +- ghc/compiler/utils/Outputable.lhs | 60 +- ghc/compiler/utils/Panic.lhs | 8 +- ghc/compiler/utils/Pretty.lhs | 3 +- ghc/compiler/utils/StringBuffer.lhs | 20 +- ghc/docs/users_guide/glasgow_exts.sgml | 25 +- ghc/rts/Linker.c | 62 +- 182 files changed, 17066 insertions(+), 14967 deletions(-) delete mode 100644 ghc/compiler/basicTypes/PprEnv.lhs delete mode 100644 ghc/compiler/compMan/CmLink.lhs delete mode 100644 ghc/compiler/compMan/CmTypes.lhs create mode 100644 ghc/compiler/deSugar/DsMeta.hs create mode 100644 ghc/compiler/ghci/ByteCodeAsm.lhs create mode 100644 ghc/compiler/ghci/ObjLink.lhs create mode 100644 ghc/compiler/hsSyn/Convert.lhs delete mode 100644 ghc/compiler/rename/Rename.lhs delete mode 100644 ghc/compiler/rename/RnBinds.hi-boot delete mode 100644 ghc/compiler/rename/RnBinds.hi-boot-5 delete mode 100644 ghc/compiler/rename/RnBinds.hi-boot-6 delete mode 100644 ghc/compiler/rename/RnMonad.lhs create mode 100644 ghc/compiler/rename/RnSource.hi-boot-5 create mode 100644 ghc/compiler/rename/RnSource.hi-boot-6 delete mode 100644 ghc/compiler/typecheck/TcEnv.hi-boot delete mode 100644 ghc/compiler/typecheck/TcEnv.hi-boot-5 delete mode 100644 ghc/compiler/typecheck/TcEnv.hi-boot-6 delete mode 100644 ghc/compiler/typecheck/TcModule.lhs delete mode 100644 ghc/compiler/typecheck/TcMonad.lhs create mode 100644 ghc/compiler/typecheck/TcRnDriver.lhs create mode 100644 ghc/compiler/typecheck/TcRnMonad.lhs create mode 100644 ghc/compiler/typecheck/TcRnTypes.lhs create mode 100644 ghc/compiler/typecheck/TcSplice.hi-boot-6 create mode 100644 ghc/compiler/typecheck/TcSplice.lhs diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 531ec2a4c2..0a66f0c8c1 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.221 2002/09/06 14:35:43 simonmar Exp $ +# $Id: Makefile,v 1.222 2002/09/13 15:02:25 simonpj Exp $ TOP = .. @@ -101,11 +101,14 @@ CLEAN_FILES += $(CONFIG_HS) ALL_DIRS = \ utils basicTypes types hsSyn prelude rename typecheck deSugar coreSyn \ specialise simplCore stranal stgSyn simplStg codeGen absCSyn main \ - profiling parser usageSP cprAnalysis compMan ndpFlatten + profiling parser usageSP cprAnalysis compMan ndpFlatten # Make sure we include Config.hs even if it doesn't exist yet... ALL_SRCS += $(CONFIG_HS) +# HsGeneric.hs is not used just now +EXCLUDED_SRCS += hsSyn/HsGeneric.hs + ifeq ($(GhcWithNativeCodeGen),YES) ALL_DIRS += nativeGen else @@ -132,15 +135,17 @@ compiling_with_4xx = $(shell if (test $(GhcCanonVersion) -lt 500); then echo YES endif # Only include GHCi if we're bootstrapping with at least version 411 -ifeq "$(GhcWithInterpreter)" "YES" -ifeq "$(bootstrapped)" "YES" -SRC_HC_OPTS += -DGHCI -package readline +ifeq "$(GhcWithInterpreter) $(bootstrapped)" "YES YES" +# Yes, include the interepreter, readline, and Template Haskell extensions +SRC_HC_OPTS += -DGHCI -package readline -package haskell-src ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32" SRC_HC_OPTS += -package unix endif ALL_DIRS += ghci -endif -endif +else +# No interpreter, so exclude Template Haskell modules +EXCLUDED_SRCS += deSugar/DsMeta.hs typecheck/TcSplice.lhs hsSyn/Convert.lhs +endif # There are some C files to include in HS_PROG, so add these to HS_OBJS HS_OBJS += $(C_OBJS) diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index cfc6f2af0a..294888a107 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: AbsCSyn.lhs,v 1.49 2002/08/02 13:08:33 simonmar Exp $ +% $Id: AbsCSyn.lhs,v 1.50 2002/09/13 15:02:25 simonpj Exp $ % \section[AbstractC]{Abstract C: the last stop before machine code} diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 442dc01688..e91d94b8aa 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CLabel.lhs,v 1.54 2002/07/18 09:16:12 simonmar Exp $ +% $Id: CLabel.lhs,v 1.55 2002/09/13 15:02:26 simonpj Exp $ % \section[CLabel]{@CLabel@: Information to make C Labels} @@ -90,7 +90,6 @@ import TyCon ( TyCon ) import Unique ( pprUnique, Unique ) import PrimOp ( PrimOp ) import CostCentre ( CostCentre, CostCentreStack ) -import BasicTypes ( Version ) import Outputable import FastString \end{code} diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index 62a68a948b..1f74e7f213 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -20,7 +20,7 @@ module BasicTypes( Unused, unused, - Fixity(..), FixityDirection(..), + FixitySig(..), Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence, arrowFixity, negateFixity, negatePrecedence, compareFixity, @@ -46,12 +46,15 @@ module BasicTypes( StrictnessMark(..), isMarkedUnboxed, isMarkedStrict, CompilerPhase, - Activation(..), isActive, isNeverActive, isAlwaysActive + Activation(..), isActive, isNeverActive, isAlwaysActive, + + SuccessFlag(..), succeeded, failed, successIf ) where #include "HsVersions.h" import Outputable +import SrcLoc \end{code} %************************************************************************ @@ -137,21 +140,34 @@ mapIPName f (Linear n) = Linear (f n) %************************************************************************ \begin{code} +------------------------ +data FixitySig name = FixitySig name Fixity SrcLoc + +instance Eq name => Eq (FixitySig name) where + (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2 + +instance Outputable name => Outputable (FixitySig name) where + ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name] + +------------------------ data Fixity = Fixity Int FixityDirection -data FixityDirection = InfixL | InfixR | InfixN - deriving(Eq) instance Outputable Fixity where ppr (Fixity prec dir) = hcat [ppr dir, space, int prec] +instance Eq Fixity where -- Used to determine if two fixities conflict + (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2 + +------------------------ +data FixityDirection = InfixL | InfixR | InfixN + deriving(Eq) + instance Outputable FixityDirection where ppr InfixL = ptext SLIT("infixl") ppr InfixR = ptext SLIT("infixr") ppr InfixN = ptext SLIT("infix") -instance Eq Fixity where -- Used to determine if two fixities conflict - (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2 - +------------------------ maxPrecedence = (9::Int) defaultFixity = Fixity maxPrecedence InfixL @@ -405,6 +421,28 @@ instance Outputable StrictnessMark where \end{code} +%************************************************************************ +%* * +\subsection{Success flag} +%* * +%************************************************************************ + +\begin{code} +data SuccessFlag = Succeeded | Failed + +successIf :: Bool -> SuccessFlag +successIf True = Succeeded +successIf False = Failed + +succeeded, failed :: SuccessFlag -> Bool +succeeded Succeeded = True +succeeded Failed = False + +failed Succeeded = False +failed Failed = True +\end{code} + + %************************************************************************ %* * \subsection{Activation} @@ -443,3 +481,4 @@ isNeverActive act = False isAlwaysActive AlwaysActive = True isAlwaysActive other = False \end{code} + diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index a251c7e5ac..06444e3a8c 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -25,7 +25,7 @@ module IdInfo ( -- New demand and strictness info newStrictnessInfo, setNewStrictnessInfo, - newDemandInfo, setNewDemandInfo, + newDemandInfo, setNewDemandInfo, pprNewStrictness, -- Strictness; imported from Demand StrictnessInfo(..), @@ -94,12 +94,12 @@ import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBrea import DataCon ( DataCon ) import ForeignCall ( ForeignCall ) import FieldLabel ( FieldLabel ) -import Type ( usOnce, usMany ) +import Type ( usOnce ) import Demand hiding( Demand, seqDemand ) import qualified Demand import NewDemand import Outputable -import Util ( seqList, listLengthCmp ) +import Util ( listLengthCmp ) import Maybe ( isJust ) import List ( replicate ) @@ -153,6 +153,9 @@ setAllStrictnessInfo info (Just sig) seqNewStrictnessInfo Nothing = () seqNewStrictnessInfo (Just ty) = seqStrictSig ty +pprNewStrictness Nothing = empty +pprNewStrictness (Just sig) = ftext FSLIT("Str:") <+> ppr sig + #ifdef OLD_STRICTNESS oldStrictnessFromNew :: StrictSig -> Demand.StrictnessInfo oldStrictnessFromNew sig = mkStrictnessInfo (map oldDemand dmds, isBotRes res_info) diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index 773ff74ffe..1b794a6faa 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -42,8 +42,8 @@ import Util ( thenCmp ) import Ratio ( numerator ) import FastString ( uniqueOfFS, lengthFS ) -import Int ( Int8, Int16, Int32 ) -import Word ( Word8, Word16, Word32 ) +import DATA_INT ( Int8, Int16, Int32 ) +import DATA_WORD ( Word8, Word16, Word32 ) import Char ( ord, chr ) \end{code} diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 954ada9a46..60e0c8da07 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -49,7 +49,6 @@ import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkTyConApp, isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType, tcSplitFunTys, tcSplitForAllTys, mkPredTy ) -import Module ( Module ) import CoreUtils ( exprType ) import CoreUnfold ( mkTopUnfolding, mkCompulsoryUnfolding, mkOtherCon ) import Literal ( Literal(..), nullAddrLit ) @@ -58,8 +57,7 @@ import TyCon ( TyCon, isNewTyCon, tyConTyVars, tyConDataCons, import Class ( Class, classTyCon, classTyVars, classSelIds ) import Var ( Id, TyVar, Var ) import VarSet ( isEmptyVarSet ) -import Name ( mkWiredInName, mkFCallName, Name ) -import OccName ( mkVarOcc ) +import Name ( mkFCallName, Name ) import PrimOp ( PrimOp(DataToTagOp), primOpSig, mkPrimOpIdName ) import ForeignCall ( ForeignCall ) import DataCon ( DataCon, @@ -98,7 +96,6 @@ import FastString import ListSetOps ( assoc, assocMaybe ) import UnicodeUtil ( stringToUtf8 ) import List ( nubBy ) -import Char ( ord ) \end{code} %************************************************************************ @@ -811,7 +808,7 @@ another gun with which to shoot yourself in the foot. \begin{code} -- unsafeCoerce# :: forall a b. a -> b unsafeCoerceId - = pcMiscPrelId unsafeCoerceIdKey gHC_PRIM FSLIT("unsafeCoerce#") ty info + = pcMiscPrelId unsafeCoerceName ty info where info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs @@ -826,13 +823,13 @@ unsafeCoerceId -- The reason is is here is because we don't provide -- a way to write this literal in Haskell. nullAddrId - = pcMiscPrelId nullAddrIdKey gHC_PRIM FSLIT("nullAddr#") addrPrimTy info + = pcMiscPrelId nullAddrName addrPrimTy info where info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) seqId - = pcMiscPrelId seqIdKey gHC_PRIM FSLIT("seq") ty info + = pcMiscPrelId seqName ty info where info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs @@ -849,7 +846,7 @@ seqId -- the info in PrelBase.hi. This is important, because the strictness -- analyser will spot it as strict! lazyId - = pcMiscPrelId lazyIdKey pREL_BASE FSLIT("lazy") ty info + = pcMiscPrelId lazyIdName ty info where info = noCafIdInfo ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy alphaTy) @@ -865,7 +862,7 @@ evaluate its argument and call the dataToTag# primitive. \begin{code} getTagId - = pcMiscPrelId getTagIdKey gHC_PRIM FSLIT("getTag#") ty info + = pcMiscPrelId getTagName ty info where info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs -- We don't provide a defn for this; you must inline it @@ -890,8 +887,7 @@ This comes up in strictness analysis \begin{code} realWorldPrimId -- :: State# RealWorld - = pcMiscPrelId realWorldPrimIdKey gHC_PRIM FSLIT("realWorld#") - realWorldStatePrimTy + = pcMiscPrelId realWorldName realWorldStatePrimTy (noCafIdInfo `setUnfoldingInfo` mkOtherCon []) -- The mkOtherCon makes it look that realWorld# is evaluated -- which in turn makes Simplify.interestingArg return True, @@ -937,22 +933,21 @@ mkRuntimeErrorApp err_id res_ty err_msg where err_string = Lit (MachStr (mkFastString (stringToUtf8 err_msg))) -rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrIdKey FSLIT("recSelError") -rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorIdKey FSLIT("runtimeError") - -iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorIdKey FSLIT("irrefutPatError") -rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorIdKey FSLIT("recConError") -nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorIdKey FSLIT("nonExhaustiveGuardsError") -pAT_ERROR_ID = mkRuntimeErrorId patErrorIdKey FSLIT("patError") -nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorIdKey FSLIT("noMethodBindingError") +rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName +rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName +iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName +rEC_CON_ERROR_ID = mkRuntimeErrorId recConErrorName +nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName +pAT_ERROR_ID = mkRuntimeErrorId patErrorName +nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName -- The runtime error Ids take a UTF8-encoded string as argument -mkRuntimeErrorId key name = pc_bottoming_Id key pREL_ERR name runtimeErrorTy -runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) +mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy +runtimeErrorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTy addrPrimTy openAlphaTy) \end{code} \begin{code} -eRROR_ID = pc_bottoming_Id errorIdKey pREL_ERR FSLIT("error") errorTy +eRROR_ID = pc_bottoming_Id errorName errorTy errorTy :: Type errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy) @@ -969,21 +964,17 @@ errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] openAlphaTy %************************************************************************ \begin{code} -pcMiscPrelId :: Unique{-IdKey-} -> Module -> FastString -> Type -> IdInfo -> Id -pcMiscPrelId key mod str ty info - = let - name = mkWiredInName mod (mkVarOcc str) key - imp = mkVanillaGlobal name ty info -- the usual case... - in - imp +pcMiscPrelId :: Name -> Type -> IdInfo -> Id +pcMiscPrelId name ty info + = mkVanillaGlobal name ty info -- We lie and say the thing is imported; otherwise, we get into -- a mess with dependency analysis; e.g., core2stg may heave in -- random calls to GHCbase.unpackPS__. If GHCbase is the module -- being compiled, then it's just a matter of luck if the definition -- will be in "the right place" to be in scope. -pc_bottoming_Id key mod name ty - = pcMiscPrelId key mod name ty bottoming_info +pc_bottoming_Id name ty + = pcMiscPrelId name ty bottoming_info where bottoming_info = hasCafIdInfo `setAllStrictnessInfo` Just strict_sig -- Do *not* mark them as NoCafRefs, because they can indeed have diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index 0387f97237..d7d90f6733 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -41,8 +41,8 @@ module Module ( Module, -- Abstract, instance of Eq, Ord, Outputable - , PackageName -- = FastString; instance of Outputable, Uniquable - , preludePackage -- :: PackageName + , ModLocation(..), + , showModMsg , ModuleName , pprModuleName -- :: ModuleName -> SDoc @@ -59,7 +59,6 @@ module Module , mkVanillaModule -- :: ModuleName -> Module , isVanillaModule -- :: Module -> Bool , mkPrelModule -- :: UserString -> Module - , mkModule -- :: ModuleName -> PackageName -> Module , mkHomeModule -- :: ModuleName -> Module , isHomeModule -- :: Module -> Bool , mkPackageModule -- :: ModuleName -> Module @@ -70,15 +69,13 @@ module Module , pprModule, - -- Where to find a .hi file - , WhereFrom(..) - , ModuleEnv, , elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv , moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv - , lookupModuleEnvByName, extendModuleEnv_C + , extendModuleEnv_C + , lookupModuleEnvByName, extendModuleEnvByName, unitModuleEnvByName , ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet @@ -87,9 +84,11 @@ module Module #include "HsVersions.h" import OccName import Outputable +import Packages ( PackageName, preludePackage ) import CmdLineOpts ( opt_InPackage ) import FastString ( FastString ) import Unique ( Uniquable(..) ) +import Maybes ( expectJust ) import UniqFM import UniqSet import Binary @@ -134,11 +133,6 @@ data PackageInfo -- Later on (in RnEnv.newTopBinder) we'll update the cache -- to have the right PackageName -type PackageName = FastString -- No encoding at all - -preludePackage :: PackageName -preludePackage = FSLIT("base") - packageInfoPackage :: PackageInfo -> PackageName packageInfoPackage ThisPackage = opt_InPackage packageInfoPackage DunnoYet = FSLIT("") @@ -152,28 +146,44 @@ instance Outputable PackageInfo where %************************************************************************ %* * -\subsection{Where from} +\subsection{Module locations} %* * %************************************************************************ -The @WhereFrom@ type controls where the renamer looks for an interface file - \begin{code} -data WhereFrom = ImportByUser -- Ordinary user import: look for M.hi - | ImportByUserSource -- User {- SOURCE -}: look for M.hi-boot - | ImportBySystem -- Non user import. Look for M.hi if M is in - -- the module this module depends on, or is a system-ish module; - -- M.hi-boot otherwise - | ImportByCmdLine -- The user typed a qualified name at - -- the GHCi prompt, try to demand-load - -- the interface. - -instance Outputable WhereFrom where - ppr ImportByUser = empty - ppr ImportByUserSource = ptext SLIT("{- SOURCE -}") - ppr ImportBySystem = ptext SLIT("{- SYSTEM IMPORT -}") +data ModLocation + = ModLocation { + 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 ModLocation where + ppr = text . show + +-- Rather a gruesome function to have in Module + +showModMsg :: Bool -> Module -> ModLocation -> 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 \end{code} +For a module in another package, the hs_file and obj_file +components of ModLocation are undefined. + +The locations specified by a ModLocation may or may not +correspond to actual files yet: for example, even if the object +file doesn't exist, the ModLocation still contains the path to +where the object file will reside if/when it is created. + %************************************************************************ %* * @@ -255,21 +265,22 @@ pprModule :: Module -> SDoc pprModule (Module mod p) = getPprStyle $ \ sty -> if debugStyle sty then -- Print the package too - ppr p <> dot <> pprModuleName mod + -- Don't use '.' because it gets confused + -- with module names + brackets (ppr p) <> pprModuleName mod else pprModuleName mod \end{code} \begin{code} -mkModule :: ModuleName -- Name of the module - -> PackageName - -> Module -mkModule mod_nm pack_name +mkPrelModule :: ModuleName -> Module +mkPrelModule mod_nm = Module mod_nm pack_info where - pack_info | pack_name == opt_InPackage = ThisPackage - | otherwise = AnotherPackage + pack_info + | opt_InPackage == preludePackage = ThisPackage + | otherwise = AnotherPackage mkHomeModule :: ModuleName -> Module mkHomeModule mod_nm = Module mod_nm ThisPackage @@ -291,9 +302,6 @@ isVanillaModule :: Module -> Bool isVanillaModule (Module nm DunnoYet) = True isVanillaModule _ = False -mkPrelModule :: ModuleName -> Module -mkPrelModule name = mkModule name preludePackage - moduleString :: Module -> EncodedString moduleString (Module (ModuleName fs) _) = unpackFS fs @@ -318,6 +326,9 @@ printModulePrefix _ = True \begin{code} type ModuleEnv elt = UniqFM elt +-- A ModuleName and Module have the same Unique, +-- so both will work as keys. +-- The 'ByName' variants work on ModuleNames emptyModuleEnv :: ModuleEnv a mkModuleEnv :: [(Module, a)] -> ModuleEnv a @@ -335,13 +346,18 @@ moduleEnvElts :: ModuleEnv a -> [a] isEmptyModuleEnv :: ModuleEnv a -> Bool lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a -lookupModuleEnvByName:: ModuleEnv a -> ModuleName -> Maybe a lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a elemModuleEnv :: Module -> ModuleEnv a -> Bool foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b +-- The ByName variants +lookupModuleEnvByName :: ModuleEnv a -> ModuleName -> Maybe a +unitModuleEnvByName :: ModuleName -> a -> ModuleEnv a +extendModuleEnvByName :: ModuleEnv a -> ModuleName -> a -> ModuleEnv a + elemModuleEnv = elemUFM extendModuleEnv = addToUFM +extendModuleEnvByName = addToUFM extendModuleEnv_C = addToUFM_C extendModuleEnvList = addListToUFM plusModuleEnv_C = plusUFM_C @@ -356,6 +372,7 @@ mkModuleEnv = listToUFM emptyModuleEnv = emptyUFM moduleEnvElts = eltsUFM unitModuleEnv = unitUFM +unitModuleEnvByName = unitUFM isEmptyModuleEnv = isNullUFM foldModuleEnv = foldUFM \end{code} diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 035a499b4c..a8117fbb55 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -17,31 +17,28 @@ module Name ( nameUnique, setNameUnique, nameOccName, nameModule, nameModule_maybe, - setNameOcc, nameRdrName, setNameModuleAndLoc, - toRdrName, hashName, - externaliseName, localiseName, + setNameOcc, setNameModuleAndLoc, + hashName, externaliseName, localiseName, - nameSrcLoc, + nameSrcLoc, eqNameByOcc, isSystemName, isInternalName, isExternalName, - isTyVarName, isDllName, + isTyVarName, isDllName, isWiredInName, nameIsLocalOrFrom, isHomePackageName, -- Class NamedThing and overloaded friends NamedThing(..), - getSrcLoc, getOccString, toRdrName + getSrcLoc, getOccString ) where #include "HsVersions.h" import OccName -- All of it -import Module ( Module, moduleName, mkVanillaModule, isHomeModule ) -import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule ) +import Module ( Module, ModuleName, moduleName, mkVanillaModule, isHomeModule ) import CmdLineOpts ( opt_Static ) -import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc ) +import SrcLoc ( noSrcLoc, isWiredInLoc, wiredInSrcLoc, SrcLoc ) import Unique ( Unique, Uniquable(..), getKey, pprUnique ) import FastTypes -import Binary import Outputable \end{code} @@ -108,12 +105,6 @@ nameSrcLoc :: Name -> SrcLoc nameUnique name = n_uniq name nameOccName name = n_occ name nameSrcLoc name = n_loc name - -nameModule (Name { n_sort = External mod }) = mod -nameModule name = pprPanic "nameModule" (ppr name) - -nameModule_maybe (Name { n_sort = External mod }) = Just mod -nameModule_maybe name = Nothing \end{code} \begin{code} @@ -122,9 +113,18 @@ isInternalName :: Name -> Bool isExternalName :: Name -> Bool isSystemName :: Name -> Bool isHomePackageName :: Name -> Bool +isWiredInName :: Name -> Bool + +isWiredInName name = isWiredInLoc (n_loc name) isExternalName (Name {n_sort = External _}) = True -isExternalName other = False +isExternalName other = False + +nameModule (Name { n_sort = External mod }) = mod +nameModule name = pprPanic "nameModule" (ppr name) + +nameModule_maybe (Name { n_sort = External mod }) = Just mod +nameModule_maybe name = Nothing isInternalName name = not (isExternalName name) @@ -142,6 +142,18 @@ isTyVarName name = isTvOcc (nameOccName name) isSystemName (Name {n_sort = System}) = True isSystemName other = False + +eqNameByOcc :: Name -> Name -> Bool +-- Compare using the strings, not the unique +-- See notes with HsCore.eq_ufVar +eqNameByOcc (Name {n_sort = sort1, n_occ = occ1}) + (Name {n_sort = sort2, n_occ = occ2}) + = sort1 `eq_sort` sort2 && occ1 == occ2 + where + eq_sort (External m1) (External m2) = moduleName m1 == moduleName m2 + eq_sort (External _) _ = False + eq_sort _ (External _) = False + eq_sort _ _ = True \end{code} @@ -167,14 +179,12 @@ mkExternalName :: Unique -> Module -> OccName -> SrcLoc -> Name mkExternalName uniq mod occ loc = Name { n_uniq = uniq, n_sort = External mod, n_occ = occ, n_loc = loc } -mkKnownKeyExternalName :: RdrName -> Unique -> Name -mkKnownKeyExternalName rdr_name uniq - = mkExternalName uniq (mkVanillaModule (rdrNameModule rdr_name)) - (rdrNameOcc rdr_name) - builtinSrcLoc +mkKnownKeyExternalName :: ModuleName -> OccName -> Unique -> Name +mkKnownKeyExternalName mod occ uniq + = mkExternalName uniq (mkVanillaModule mod) occ noSrcLoc mkWiredInName :: Module -> OccName -> Unique -> Name -mkWiredInName mod occ uniq = mkExternalName uniq mod occ builtinSrcLoc +mkWiredInName mod occ uniq = mkExternalName uniq mod occ wiredInSrcLoc mkSystemName :: Unique -> UserFS -> Name mkSystemName uniq fs = Name { n_uniq = uniq, n_sort = System, @@ -236,13 +246,6 @@ setNameModuleAndLoc name mod loc = name {n_sort = set (n_sort name), n_loc = loc \begin{code} hashName :: Name -> Int hashName name = iBox (getKey (nameUnique name)) - - -nameRdrName :: Name -> RdrName --- Makes a qualified name for top-level (External) names, --- whether locally defined or not and an unqualified name just for Internals -nameRdrName (Name { n_occ = occ, n_sort = External mod }) = mkRdrOrig (moduleName mod) occ -nameRdrName (Name { n_occ = occ }) = mkRdrUnqual occ \end{code} @@ -275,26 +278,6 @@ instance NamedThing Name where getName n = n \end{code} -%************************************************************************ -%* * -\subsection{Binary output} -%* * -%************************************************************************ - -\begin{code} -instance Binary Name where - -- we must print these as RdrNames, because that's how they will be read in - put_ bh Name {n_sort = sort, n_uniq = uniq, n_occ = occ} = - case sort of - External mod - | this_mod == mod -> put_ bh (mkRdrUnqual occ) - | otherwise -> put_ bh (mkRdrOrig (moduleName mod) occ) - where (this_mod,_,_,_) = getUserData bh - _ -> do - put_ bh (mkRdrUnqual occ) - - get bh = error "can't Binary.get a Name" -\end{code} %************************************************************************ %* * @@ -307,6 +290,9 @@ instance Outputable Name where -- When printing interfaces, all Internals have been given nice print-names ppr name = pprName name +instance OutputableBndr Name where + pprBndr _ name = pprName name + pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) = getPprStyle $ \ sty -> case sort of @@ -355,10 +341,8 @@ class NamedThing a where \begin{code} getSrcLoc :: NamedThing a => a -> SrcLoc getOccString :: NamedThing a => a -> String -toRdrName :: NamedThing a => a -> RdrName getSrcLoc = nameSrcLoc . getName getOccString = occNameString . getOccName -toRdrName = nameRdrName . getName \end{code} diff --git a/ghc/compiler/basicTypes/NameEnv.lhs b/ghc/compiler/basicTypes/NameEnv.lhs index 06cf190953..fe3bcb3d59 100644 --- a/ghc/compiler/basicTypes/NameEnv.lhs +++ b/ghc/compiler/basicTypes/NameEnv.lhs @@ -7,8 +7,9 @@ module NameEnv ( NameEnv, mkNameEnv, emptyNameEnv, unitNameEnv, nameEnvElts, - extendNameEnv_C, extendNameEnv, foldNameEnv, filterNameEnv, - plusNameEnv, plusNameEnv_C, extendNameEnv, extendNameEnvList, + extendNameEnv_C, extendNameEnv, extendNameEnvList, + foldNameEnv, filterNameEnv, + plusNameEnv, plusNameEnv_C, lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, delListFromNameEnv, elemNameEnv ) where diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index e2a4b8f816..dfcc6d2ab8 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -623,22 +623,22 @@ isLexSym cs = isLexConSym cs || isLexVarSym cs ------------- isLexConId cs -- Prefix type or data constructors - | nullFastString cs = False -- e.g. "Foo", "[]", "(,)" + | nullFastString cs = False -- e.g. "Foo", "[]", "(,)" | cs == FSLIT("[]") = True | otherwise = startsConId (headFS cs) isLexVarId cs -- Ordinary prefix identifiers - | nullFastString cs = False -- e.g. "x", "_x" - | otherwise = startsVarId (headFS cs) + | nullFastString cs = False -- e.g. "x", "_x" + | otherwise = startsVarId (headFS cs) isLexConSym cs -- Infix type or data constructors - | nullFastString cs = False -- e.g. ":-:", ":", "->" + | nullFastString cs = False -- e.g. ":-:", ":", "->" | cs == FSLIT("->") = True - | otherwise = startsConSym (headFS cs) + | otherwise = startsConSym (headFS cs) isLexVarSym cs -- Infix identifiers - | nullFastString cs = False -- e.g. "+" - | otherwise = startsVarSym (headFS cs) + | nullFastString cs = False -- e.g. "+" + | otherwise = startsVarSym (headFS cs) ------------- startsVarSym, startsVarId, startsConSym, startsConId :: Char -> Bool diff --git a/ghc/compiler/basicTypes/PprEnv.lhs b/ghc/compiler/basicTypes/PprEnv.lhs deleted file mode 100644 index 36293f3688..0000000000 --- a/ghc/compiler/basicTypes/PprEnv.lhs +++ /dev/null @@ -1,75 +0,0 @@ -% -% (c) The AQUA Project, Glasgow University, 1996-1998 -% -\section[PprEnv]{The @PprEnv@ type} - -\begin{code} -module PprEnv ( - PprEnv, -- - BindingSite(..), - - initPprEnv, - - pBndr, pOcc, pSCC, - pTy, pTyVarO - ) where - -#include "HsVersions.h" - -import Var ( Id, TyVar ) -import CostCentre ( CostCentre ) -import Type ( Type ) -import Outputable -\end{code} - -%************************************************************************ -%* * -\subsection{Public interfaces for Core printing (excluding instances)} -%* * -%************************************************************************ - -\begin{code} -data PprEnv bndr - = PE { - pSCC :: CostCentre -> SDoc, - - pTyVarO :: TyVar -> SDoc, -- to print tyvar occurrences - pTy :: Type -> SDoc, -- to print types - - pBndr :: BindingSite -> bndr -> SDoc, -- to print value binders - pOcc :: Id -> SDoc -- to print value occurrences - } -\end{code} - -@BindingSite@ is used to tell the thing that prints binder what -language construct is binding the identifier. - -\begin{code} -data BindingSite = LambdaBind | CaseBind | LetBind -\end{code} - -\begin{code} -initPprEnv - :: Maybe (CostCentre -> SDoc) - -> Maybe (TyVar -> SDoc) - -> Maybe (Type -> SDoc) - -> Maybe (BindingSite -> bndr -> SDoc) - -> Maybe (Id -> SDoc) - -> PprEnv bndr - --- you can specify all the printers individually; if --- you don't specify one, you get bottom - -initPprEnv c tvo ty bndr occ - = PE (demaybe c) - (demaybe tvo) - (demaybe ty) - (demaybe bndr) - (demaybe occ) - where - demaybe Nothing = bottom - demaybe (Just x) = x - - bottom = panic "PprEnv.initPprEnv: unspecified printing function" -\end{code} - diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index 41105289b1..fe9843010b 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -10,14 +10,16 @@ module RdrName ( RdrName, -- Construction - mkRdrUnqual, mkRdrQual, mkRdrOrig, mkRdrUnqual, - mkUnqual, mkQual, mkIfaceOrig, mkOrig, + mkRdrUnqual, mkRdrQual, + mkUnqual, mkQual, mkOrig, mkIfaceOrig, + nameRdrName, getRdrName, qualifyRdrName, unqualifyRdrName, mkRdrNameWkr, dummyRdrVarName, dummyRdrTcName, -- Destruction - rdrNameModule, rdrNameOcc, setRdrNameOcc, - isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isUnqual, isOrig, + rdrNameModule, rdrNameOcc, setRdrNameSpace, + isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isUnqual, + isOrig, isExact, isExact_maybe, -- Environment RdrNameEnv, @@ -32,13 +34,15 @@ module RdrName ( import OccName ( NameSpace, tcName, OccName, UserFS, EncodedFS, - mkSysOccFS, - mkOccFS, mkVarOcc, + mkSysOccFS, setOccNameSpace, + mkOccFS, mkVarOcc, occNameFlavour, isDataOcc, isTvOcc, isTcOcc, mkWorkerOcc ) import Module ( ModuleName, mkSysModuleNameFS, mkModuleNameFS ) +import Name ( Name, NamedThing(getName), nameModule, nameOccName ) +import Module ( moduleName ) import FiniteMap import Outputable import Binary @@ -53,21 +57,27 @@ import Util ( thenCmp ) %************************************************************************ \begin{code} -data RdrName = RdrName Qual OccName - {-! derive: Binary !-} - -data Qual - = Unqual - - | Qual ModuleName -- A qualified name written by the user in source code - -- The module isn't necessarily the module where - -- the thing is defined; just the one from which it - -- is imported - - | Orig ModuleName -- This is an *original* name; the module is the place - -- where the thing was defined - {-! derive: Binary !-} - +data RdrName + = Unqual OccName + -- Used for ordinary, unqualified occurrences + + | Qual ModuleName OccName + -- A qualified name written by the user in + -- *source* code. The module isn't necessarily + -- the module where the thing is defined; + -- just the one from which it is imported + + | Orig ModuleName OccName + -- An original name; the module is the *defining* module. + -- This is used when GHC generates code that will be fed + -- into the renamer (e.g. from deriving clauses), but where + -- we want to say "Use Prelude.map dammit". + + | Exact Name + -- We know exactly the Name. This is used + -- (a) when the parser parses built-in syntax like "[]" + -- and "(,)", but wants a RdrName from it + -- (b) possibly, by the meta-programming stuff \end{code} @@ -79,52 +89,71 @@ data Qual \begin{code} rdrNameModule :: RdrName -> ModuleName -rdrNameModule (RdrName (Qual m) _) = m -rdrNameModule (RdrName (Orig m) _) = m -rdrNameModule n = pprPanic "rdrNameModule" (ppr n) +rdrNameModule (Qual m _) = m +rdrNameModule (Orig m _) = m +rdrNameModule (Exact n) = moduleName (nameModule n) +rdrNameModule (Unqual n) = pprPanic "rdrNameModule" (ppr n) rdrNameOcc :: RdrName -> OccName -rdrNameOcc (RdrName _ occ) = occ - -setRdrNameOcc :: RdrName -> OccName -> RdrName -setRdrNameOcc (RdrName q _) occ = RdrName q occ +rdrNameOcc (Qual _ occ) = occ +rdrNameOcc (Unqual occ) = occ +rdrNameOcc (Orig _ occ) = occ +rdrNameOcc (Exact name) = nameOccName name + +setRdrNameSpace :: RdrName -> NameSpace -> RdrName +-- This rather gruesome function is used mainly by the parser +-- When parsing data T a = T | T1 Int +-- we parse the data constructors as *types* because of parser ambiguities, +-- so then we need to change the *type constr* to a *data constr* +-- +-- The original-name case *can* occur when parsing +-- data [] a = [] | a : [a] +-- For the orig-name case we return an unqualified name. +setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace occ ns) +setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace occ ns) +setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace occ ns) +setRdrNameSpace (Exact n) ns = Unqual (setOccNameSpace (nameOccName n) ns) \end{code} \begin{code} -- These two are the basic constructors mkRdrUnqual :: OccName -> RdrName -mkRdrUnqual occ = RdrName Unqual occ +mkRdrUnqual occ = Unqual occ mkRdrQual :: ModuleName -> OccName -> RdrName -mkRdrQual mod occ = RdrName (Qual mod) occ +mkRdrQual mod occ = Qual mod occ -mkRdrOrig :: ModuleName -> OccName -> RdrName -mkRdrOrig mod occ = RdrName (Orig mod) occ +mkOrig :: ModuleName -> OccName -> RdrName +mkOrig mod occ = Orig mod occ mkIfaceOrig :: NameSpace -> (EncodedFS, EncodedFS) -> RdrName -mkIfaceOrig ns (m,n) = RdrName (Orig (mkSysModuleNameFS m)) (mkSysOccFS ns n) +mkIfaceOrig ns (m,n) = Qual (mkSysModuleNameFS m) (mkSysOccFS ns n) -- These two are used when parsing source files -- They do encode the module and occurrence names mkUnqual :: NameSpace -> UserFS -> RdrName -mkUnqual sp n = RdrName Unqual (mkOccFS sp n) +mkUnqual sp n = Unqual (mkOccFS sp n) mkQual :: NameSpace -> (UserFS, UserFS) -> RdrName -mkQual sp (m, n) = RdrName (Qual (mkModuleNameFS m)) (mkOccFS sp n) +mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccFS sp n) + +getRdrName :: NamedThing thing => thing -> RdrName +getRdrName name = Exact (getName name) -mkOrig :: NameSpace -> ModuleName -> UserFS -> RdrName -mkOrig sp mod n = RdrName (Orig mod) (mkOccFS sp n) +nameRdrName :: Name -> RdrName +nameRdrName name = Exact name qualifyRdrName :: ModuleName -> RdrName -> RdrName -- Sets the module name of a RdrName, even if it has one already -qualifyRdrName mod (RdrName _ occ) = RdrName (Qual mod) occ +qualifyRdrName mod rn = Qual mod (rdrNameOcc rn) unqualifyRdrName :: RdrName -> RdrName -unqualifyRdrName (RdrName _ occ) = RdrName Unqual occ +unqualifyRdrName rdr_name = Unqual (rdrNameOcc rdr_name) mkRdrNameWkr :: RdrName -> RdrName -- Worker-ify it -mkRdrNameWkr (RdrName qual occ) = RdrName qual (mkWorkerOcc occ) +mkRdrNameWkr rdr_name = Qual (rdrNameModule rdr_name) + (mkWorkerOcc (rdrNameOcc rdr_name)) \end{code} \begin{code} @@ -133,24 +162,30 @@ mkRdrNameWkr (RdrName qual occ) = RdrName qual (mkWorkerOcc occ) -- the renamer. We can't just put "error..." because -- we sometimes want to print out stuff after reading but -- before renaming -dummyRdrVarName = RdrName Unqual (mkVarOcc FSLIT("V-DUMMY")) -dummyRdrTcName = RdrName Unqual (mkOccFS tcName FSLIT("TC-DUMMY")) +dummyRdrVarName = Unqual (mkVarOcc FSLIT("V-DUMMY")) +dummyRdrTcName = Unqual (mkOccFS tcName FSLIT("TC-DUMMY")) \end{code} \begin{code} -isRdrDataCon (RdrName _ occ) = isDataOcc occ -isRdrTyVar (RdrName _ occ) = isTvOcc occ -isRdrTc (RdrName _ occ) = isTcOcc occ +isRdrDataCon rn = isDataOcc (rdrNameOcc rn) +isRdrTyVar rn = isTvOcc (rdrNameOcc rn) +isRdrTc rn = isTcOcc (rdrNameOcc rn) -isUnqual (RdrName Unqual _) = True -isUnqual other = False +isUnqual (Unqual _) = True +isUnqual other = False -isQual (RdrName (Qual _) _) = True -isQual _ = False +isQual (Qual _ _) = True +isQual _ = False -isOrig (RdrName (Orig _) _) = True -isOrig other = False +isOrig (Orig _ _) = True +isOrig _ = False + +isExact (Exact _) = True +isExact other = False + +isExact_maybe (Exact n) = Just n +isExact_maybe other = Nothing \end{code} @@ -162,13 +197,19 @@ isOrig other = False \begin{code} instance Outputable RdrName where - ppr (RdrName qual occ) = pp_qual qual <> ppr occ - where - pp_qual Unqual = empty - pp_qual (Qual mod) = ppr mod <> dot - pp_qual (Orig mod) = ppr mod <> dot + ppr (Exact name) = ppr name + ppr (Unqual occ) = ppr occ <+> ppr_name_space occ + ppr (Qual mod occ) = ppr mod <> dot <> ppr occ <+> ppr_name_space occ + ppr (Orig mod occ) = ppr mod <> dot <> ppr occ <+> ppr_name_space occ + +ppr_name_space occ = ifPprDebug (parens (text (occNameFlavour occ))) -pprUnqualRdrName (RdrName qual occ) = ppr occ +instance OutputableBndr RdrName where + pprBndr _ n + | isTvOcc (rdrNameOcc n) = char '@' <+> ppr n + | otherwise = ppr n + +pprUnqualRdrName rdr_name = ppr (rdrNameOcc rdr_name) instance Eq RdrName where a == b = case (a `compare` b) of { EQ -> True; _ -> False } @@ -180,16 +221,20 @@ instance Ord RdrName where a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - compare (RdrName q1 o1) (RdrName q2 o2) - = (o1 `compare` o2) `thenCmp` - (q1 `cmpQual` q2) - -cmpQual Unqual Unqual = EQ -cmpQual (Qual m1) (Qual m2) = m1 `compare` m2 -cmpQual (Orig m1) (Orig m2) = m1 `compare` m2 -cmpQual Unqual _ = LT -cmpQual (Qual _) (Orig _) = LT -cmpQual _ _ = GT + -- Unqual < Qual < Orig < Exact + compare (Qual m1 o1) (Qual m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Orig m1 o1) (Orig m2 o2) = (o1 `compare` o2) `thenCmp` (m1 `compare` m2) + compare (Unqual o1) (Unqual o2) = o1 `compare` o2 + compare (Exact n1) (Exact n2) = n1 `compare` n2 + + compare (Unqual _) _ = LT + + compare (Qual _ _) (Orig _ _) = LT + compare (Qual _ _) (Exact _) = LT + + compare (Orig _ _) (Exact _) = LT + + compare _ _ = GT \end{code} @@ -221,35 +266,34 @@ rdrEnvToList = fmToList elemRdrEnv = elemFM foldRdrEnv = foldFM \end{code} + \begin{code} -{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-} instance Binary RdrName where - put_ bh (RdrName aa ab) = do + put_ bh (Unqual aa) = do + putByte bh 0 put_ bh aa - put_ bh ab - get bh = do - aa <- get bh - ab <- get bh - return (RdrName aa ab) -instance Binary Qual where - put_ bh Unqual = do - putByte bh 0 - put_ bh (Qual aa) = do + put_ bh (Qual aa ab) = do putByte bh 1 put_ bh aa - put_ bh (Orig ab) = do + put_ bh ab + + put_ bh (Orig aa ab) = do putByte bh 2 + put_ bh aa put_ bh ab - get bh = do - h <- getByte bh - case h of - 0 -> do return Unqual - 1 -> do aa <- get bh - return (Qual aa) - _ -> do ab <- get bh - return (Orig ab) --- Imported from other files :- + put_ bh (Exact n) = pprPanic "No Binary instance for RdrName.Exact" (ppr n) + get bh = do + h <- getByte bh + case h of + 0 -> do aa <- get bh + return (Unqual aa) + 1 -> do aa <- get bh + ab <- get bh + return (Qual aa ab) + _ -> do aa <- get bh + ab <- get bh + return (Orig aa ab) \end{code} diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index e219b4c30c..c3249dfd27 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -11,11 +11,11 @@ module SrcLoc ( SrcLoc, -- Abstract - mkSrcLoc, isGoodSrcLoc, + mkSrcLoc, isGoodSrcLoc, isWiredInLoc, noSrcLoc, -- "I'm sorry, I haven't a clue" importedSrcLoc, -- Unknown place in an interface - builtinSrcLoc, -- Something wired into the compiler + wiredInSrcLoc, -- Something wired into the compiler generatedSrcLoc, -- Code generated within the compiler incSrcLine, replaceSrcLine, @@ -45,12 +45,16 @@ We keep information about the {\em definition} point for each entity; this is the obvious stuff: \begin{code} data SrcLoc - = SrcLoc FastString -- A precise location (file name) + = WiredInLoc -- Used exclusively for Ids and TyCons + -- that are totally wired in to the + -- compiler. That supports the + -- occasionally-useful predicate + -- isWiredInName + + | SrcLoc FastString -- A precise location (file name) FastInt | UnhelpfulSrcLoc FastString -- Just a general indication - - | NoSrcLoc \end{code} Note that an entity might be imported via more than one route, and @@ -67,14 +71,17 @@ rare case. Things to make 'em: \begin{code} mkSrcLoc x y = SrcLoc x (iUnbox y) -noSrcLoc = NoSrcLoc +wiredInSrcLoc = WiredInLoc +noSrcLoc = UnhelpfulSrcLoc FSLIT("") importedSrcLoc = UnhelpfulSrcLoc FSLIT("") -builtinSrcLoc = UnhelpfulSrcLoc FSLIT("") generatedSrcLoc = UnhelpfulSrcLoc FSLIT("") isGoodSrcLoc (SrcLoc _ _) = True isGoodSrcLoc other = False +isWiredInLoc WiredInLoc = True +isWiredInLoc other = False + srcLocFile :: SrcLoc -> FastString srcLocFile (SrcLoc fname _) = fname @@ -105,13 +112,13 @@ instance Eq SrcLoc where instance Ord SrcLoc where compare = cmpSrcLoc -cmpSrcLoc NoSrcLoc NoSrcLoc = EQ -cmpSrcLoc NoSrcLoc other = LT +cmpSrcLoc WiredInLoc WiredInLoc = EQ +cmpSrcLoc WiredInLoc other = LT cmpSrcLoc (UnhelpfulSrcLoc s1) (UnhelpfulSrcLoc s2) = s1 `compare` s2 cmpSrcLoc (UnhelpfulSrcLoc s1) other = GT -cmpSrcLoc (SrcLoc s1 l1) NoSrcLoc = GT +cmpSrcLoc (SrcLoc s1 l1) WiredInLoc = GT cmpSrcLoc (SrcLoc s1 l1) (UnhelpfulSrcLoc _) = LT cmpSrcLoc (SrcLoc s1 l1) (SrcLoc s2 l2) = (s1 `compare` s2) `thenCmp` (l1 `cmpline` l2) where @@ -132,5 +139,5 @@ instance Outputable SrcLoc where -- so emacs can find the file ppr (UnhelpfulSrcLoc s) = ftext s - ppr NoSrcLoc = ptext SLIT("") + ppr WiredInLoc = ptext SLIT("") \end{code} diff --git a/ghc/compiler/basicTypes/Var.lhs b/ghc/compiler/basicTypes/Var.lhs index e317315bba..d303372c7c 100644 --- a/ghc/compiler/basicTypes/Var.lhs +++ b/ghc/compiler/basicTypes/Var.lhs @@ -14,7 +14,7 @@ module Var ( tyVarName, tyVarKind, setTyVarName, setTyVarUnique, mkTyVar, mkSysTyVar, - newMutTyVar, readMutTyVar, writeMutTyVar, makeTyVarImmutable, + mkMutTyVar, mutTyVarRef, makeTyVarImmutable, -- Ids Id, DictId, @@ -47,7 +47,7 @@ import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey ) import FastTypes import Outputable -import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef ) +import DATA_IOREF ( IORef ) \end{code} @@ -197,21 +197,17 @@ mkSysTyVar uniq kind = Var { varName = name where name = mkSystemTvNameEncoded uniq FSLIT("t") -newMutTyVar :: Name -> Kind -> TyVarDetails -> IO TyVar -newMutTyVar name kind details - = do loc <- newIORef Nothing - return (Var { varName = name - , realUnique = getKey (nameUnique name) - , varType = kind - , varDetails = MutTyVar loc details - , varInfo = pprPanic "newMutTyVar" (ppr name) - }) - -readMutTyVar :: TyVar -> IO (Maybe Type) -readMutTyVar (Var {varDetails = MutTyVar loc _}) = readIORef loc - -writeMutTyVar :: TyVar -> Maybe Type -> IO () -writeMutTyVar (Var {varDetails = MutTyVar loc _}) val = writeIORef loc val +mkMutTyVar :: Name -> Kind -> TyVarDetails -> IORef (Maybe Type) -> TyVar +mkMutTyVar name kind details ref + = Var { varName = name + , realUnique = getKey (nameUnique name) + , varType = kind + , varDetails = MutTyVar ref details + , varInfo = pprPanic "newMutTyVar" (ppr name) + } + +mutTyVarRef :: TyVar -> IORef (Maybe Type) +mutTyVarRef (Var {varDetails = MutTyVar loc _}) = loc makeTyVarImmutable :: TyVar -> TyVar makeTyVarImmutable tyvar = tyvar { varDetails = TyVar} diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index fbc037ef5a..404e38510e 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.59 2002/09/04 10:00:45 simonmar Exp $ +% $Id: CgCase.lhs,v 1.60 2002/09/13 15:02:27 simonpj Exp $ % %******************************************************** %* * diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 43b4146a56..2a6d941ee5 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgClosure.lhs,v 1.57 2002/04/29 14:03:41 simonmar Exp $ +% $Id: CgClosure.lhs,v 1.58 2002/09/13 15:02:27 simonpj Exp $ % \section[CgClosure]{Code generation for closures} diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index 519cb652b5..a7cbef26e9 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.50 2002/08/02 13:08:34 simonmar Exp $ +% $Id: CgExpr.lhs,v 1.51 2002/09/13 15:02:28 simonpj Exp $ % %******************************************************** %* * diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 0d8e4d2de8..d41fcaf6b0 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgHeapery.lhs,v 1.33 2002/09/04 10:00:46 simonmar Exp $ +% $Id: CgHeapery.lhs,v 1.34 2002/09/13 15:02:28 simonpj Exp $ % \section[CgHeapery]{Heap management functions} diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs index db8dbcd5b2..521dc5cdd3 100644 --- a/ghc/compiler/codeGen/CgLetNoEscape.lhs +++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1993-1998 % -% $Id: CgLetNoEscape.lhs,v 1.17 2002/09/04 10:00:46 simonmar Exp $ +% $Id: CgLetNoEscape.lhs,v 1.18 2002/09/13 15:02:28 simonpj Exp $ % %******************************************************** %* * diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index 5c24825a9e..937c879758 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgMonad.lhs,v 1.34 2002/04/29 14:03:42 simonmar Exp $ +% $Id: CgMonad.lhs,v 1.35 2002/09/13 15:02:28 simonpj Exp $ % \section[CgMonad]{The code generation monad} diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index cfb18bc7e5..825d748c05 100644 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP Project, Glasgow University, 1992-1998 % -% $Id: CgRetConv.lhs,v 1.32 2002/08/02 13:08:34 simonmar Exp $ +% $Id: CgRetConv.lhs,v 1.33 2002/09/13 15:02:28 simonpj Exp $ % \section[CgRetConv]{Return conventions for the code generator} diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs index cae8586b7c..58733cef55 100644 --- a/ghc/compiler/codeGen/CgStackery.lhs +++ b/ghc/compiler/codeGen/CgStackery.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgStackery.lhs,v 1.21 2002/08/29 15:44:13 simonmar Exp $ +% $Id: CgStackery.lhs,v 1.22 2002/09/13 15:02:29 simonpj Exp $ % \section[CgStackery]{Stack management functions} diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 5840881330..d74a96d15e 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: ClosureInfo.lhs,v 1.52 2002/04/29 14:03:43 simonmar Exp $ +% $Id: ClosureInfo.lhs,v 1.53 2002/09/13 15:02:29 simonpj Exp $ % \section[ClosureInfo]{Data structures which describe closures} diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 76aa521612..51988973ff 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -31,7 +31,6 @@ import AbsCSyn import PrelNames ( gHC_PRIM ) import CLabel ( CLabel, mkSRTLabel, mkClosureLabel, mkPlainModuleInitLabel, mkModuleInitLabel ) - import PprAbsC ( dumpRealC ) import AbsCUtils ( mkAbstractCs, flattenAbsC ) import CgBindery ( CgIdInfo, addBindC, addBindsC, getCAddrModeAndInfo ) @@ -41,14 +40,15 @@ import CgConTbls ( genStaticConBits ) import ClosureInfo ( mkClosureLFInfo ) import CmdLineOpts ( DynFlags, DynFlag(..), opt_SccProfilingOn, opt_EnsureSplittableC ) +import HscTypes ( ModGuts(..), ModGuts, ForeignStubs(..), + typeEnvTyCons ) import CostCentre ( CollectedCCs ) import Id ( Id, idName, setIdName ) import Name ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalName ) import OccName ( mkLocalOcc ) -import Module ( Module ) import PrimRep ( PrimRep(..) ) -import TyCon ( TyCon, isDataTyCon ) -import BasicTypes ( TopLevelFlag(..), Version ) +import TyCon ( isDataTyCon ) +import BasicTypes ( TopLevelFlag(..) ) import UniqSupply ( mkSplitUniqSupply ) import ErrUtils ( dumpIfSet_dyn, showPass ) import Panic ( assertPanic ) @@ -62,29 +62,27 @@ import DATA_IOREF ( readIORef ) \begin{code} codeGen :: DynFlags - -> Module -- Module name - -> [Module] -- Import names + -> ModGuts -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. - -> [Id] -- foreign-exported binders - -> [TyCon] -- Local tycons, including ones from classes -> [(StgBinding,[Id])] -- Bindings to convert, with SRTs -> IO AbstractC -- Output -codeGen dflags mod_name imported_modules cost_centre_info fe_binders - tycons stg_binds +codeGen dflags + mod_impl@(ModGuts { mg_module = mod_name, mg_types = type_env }) + cost_centre_info stg_binds = do showPass dflags "CodeGen" fl_uniqs <- mkSplitUniqSupply 'f' way <- readIORef v_Build_tag let + tycons = typeEnvTyCons type_env data_tycons = filter isDataTyCon tycons cinfo = MkCompInfo mod_name datatype_stuff = genStaticConBits cinfo data_tycons code_stuff = initC cinfo (mapCs cgTopBinding stg_binds) - init_stuff = mkModuleInit fe_binders mod_name way - imported_modules cost_centre_info + init_stuff = mkModuleInit way cost_centre_info mod_impl abstractC = mkAbstractCs [ maybeSplitCode, init_stuff, @@ -108,13 +106,14 @@ codeGen dflags mod_name imported_modules cost_centre_info fe_binders \begin{code} mkModuleInit - :: [Id] -- foreign exported functions - -> Module -- module name - -> String -- the "way" - -> [Module] -- import names + :: String -- the "way" -> CollectedCCs -- cost centre info + -> ModGuts -> AbstractC -mkModuleInit fe_binders mod way imps cost_centre_info +mkModuleInit way cost_centre_info + (ModGuts { mg_module = mod, + mg_foreign = ForeignStubs _ _ _ fe_binders, + mg_dir_imps = imported_modules }) = let register_fes = map (\f -> CMacroStmt REGISTER_FOREIGN_EXPORT [f]) fe_labels @@ -125,13 +124,13 @@ mkModuleInit fe_binders mod way imps cost_centre_info (cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info -- we don't want/need to init GHC.Prim, so filter it out - mk_import_register imp - | imp == gHC_PRIM = AbsCNop - | otherwise = CMacroStmt REGISTER_IMPORT [ - CLbl (mkModuleInitLabel imp way) AddrRep - ] + mk_import_register mod + | mod == gHC_PRIM = AbsCNop + | otherwise = CMacroStmt REGISTER_IMPORT [ + CLbl (mkModuleInitLabel mod way) AddrRep + ] - register_imports = map mk_import_register imps + register_imports = map mk_import_register imported_modules in mkAbstractCs [ cc_decls, diff --git a/ghc/compiler/compMan/CmLink.lhs b/ghc/compiler/compMan/CmLink.lhs deleted file mode 100644 index 03b0a49545..0000000000 --- a/ghc/compiler/compMan/CmLink.lhs +++ /dev/null @@ -1,326 +0,0 @@ -% -% (c) The University of Glasgow, 2001 -% -\section[CmLink]{The compilation manager's linker} - -\begin{code} -module CmLink ( - LinkResult(..), link, unload, - - filterModuleLinkables, - findModuleLinkable_maybe, - - PersistentLinkerState{-abstractly!-}, emptyPLS, - -#ifdef GHCI - delListFromClosureEnv, - addListToClosureEnv, - linkExpr -#endif - ) where - - -#include "HsVersions.h" - -#ifdef GHCI -import ByteCodeLink ( linkIModules, linkIExpr ) -import Interpreter -import Name ( Name ) -import FiniteMap -import ErrUtils ( showPass ) -import DATA_IOREF ( readIORef, writeIORef ) -#endif - -import DriverPipeline -import CmTypes -import HscTypes ( GhciMode(..) ) -import Module ( ModuleName ) -import Outputable -import CmdLineOpts ( DynFlags(..) ) -import Util - -#ifdef GHCI -import Control.Exception ( block ) -#endif - -import DATA_IOREF ( IORef ) - -import List -import Monad -import IO - --- --------------------------------------------------------------------------- --- The Linker's state - --- The PersistentLinkerState maps Names to actual closures (for --- interpreted code only), for use during linking. - -data PersistentLinkerState - = PersistentLinkerState { - -#ifdef GHCI - -- Current global mapping from RdrNames to closure addresses - closure_env :: ClosureEnv, - - -- the current global mapping from RdrNames of DataCons to - -- info table addresses. - -- When a new Unlinked is linked into the running image, or an existing - -- module in the image is replaced, the itbl_env must be updated - -- appropriately. - itbl_env :: ItblEnv, - - -- the currently loaded interpreted modules - bcos_loaded :: [Linkable] - -#else - dummy :: () -- sigh, can't have an empty record -#endif - - } - -emptyPLS :: IO PersistentLinkerState -#ifdef GHCI -emptyPLS = return (PersistentLinkerState { closure_env = emptyFM, - itbl_env = emptyFM, - bcos_loaded = [] }) -#else -emptyPLS = return (PersistentLinkerState {dummy=()}) -#endif - --- We also keep track of which object modules are currently loaded --- into the dynamic linker, so that we can unload them again later. --- --- This state *must* match the actual state of the dyanmic linker at --- all times, which is why we keep it private here and don't --- put it in the PersistentLinkerState. --- -GLOBAL_VAR(v_ObjectsLoaded, [], [Linkable]) - - --- --------------------------------------------------------------------------- --- Utils - -findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable -findModuleLinkable_maybe lis mod - = case [LM time nm us | LM time nm us <- lis, nm == mod] of - [] -> Nothing - [li] -> Just li - many -> pprPanic "findModuleLinkable" (ppr mod) - -filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable] -filterModuleLinkables p [] = [] -filterModuleLinkables p (li:lis) - = case li of - LM _ modnm _ -> if p modnm then retain else dump - where - dump = filterModuleLinkables p lis - retain = li : dump - -#ifdef GHCI -linkableInSet :: Linkable -> [Linkable] -> Bool -linkableInSet l objs_loaded = - case findModuleLinkable_maybe objs_loaded (linkableModName l) of - Nothing -> False - Just m -> linkableTime l == linkableTime m - --- These two are used to add/remove entries from the closure env for --- new bindings made at the prompt. -delListFromClosureEnv :: PersistentLinkerState -> [Name] - -> IO PersistentLinkerState -delListFromClosureEnv pls names - = return pls{ closure_env = delListFromFM (closure_env pls) names } - -addListToClosureEnv :: PersistentLinkerState -> [(Name,HValue)] - -> IO PersistentLinkerState -addListToClosureEnv pls new_bindings - = return pls{ closure_env = addListToFM (closure_env pls) new_bindings } -#endif - --- --------------------------------------------------------------------------- --- Unloading old objects ready for a new compilation sweep. --- --- The compilation manager provides us with a list of linkables that it --- considers "stable", i.e. won't be recompiled this time around. For --- each of the modules current linked in memory, --- --- * if the linkable is stable (and it's the same one - the --- user may have recompiled the module on the side), we keep it, --- --- * otherwise, we unload it. --- --- * we also implicitly unload all temporary bindings at this point. - -unload :: GhciMode - -> DynFlags - -> [Linkable] -- stable linkables - -> PersistentLinkerState - -> IO PersistentLinkerState - -unload Batch dflags linkables pls = return pls - -#ifdef GHCI -unload Interactive dflags linkables pls - = block $ do -- block, so we're safe from Ctrl-C in here - objs_loaded <- readIORef v_ObjectsLoaded - objs_loaded' <- filterM (maybeUnload objs_to_keep) objs_loaded - writeIORef v_ObjectsLoaded objs_loaded' - - bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls) - - let objs_retained = map linkableModName objs_loaded' - bcos_retained = map linkableModName bcos_loaded' - itbl_env' = filterNameMap bcos_retained (itbl_env pls) - closure_env' = filterNameMap bcos_retained (closure_env pls) - - let verb = verbosity dflags - when (verb >= 3) $ do - hPutStrLn stderr (showSDoc - (text "CmLink.unload: retaining objs" <+> ppr objs_retained)) - hPutStrLn stderr (showSDoc - (text "CmLink.unload: retaining bcos" <+> ppr bcos_retained)) - - return pls{ itbl_env = itbl_env', - closure_env = closure_env', - bcos_loaded = bcos_loaded' } - where - (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables - - maybeUnload :: [Linkable] -> Linkable -> IO Bool - maybeUnload keep_linkables l@(LM time mod objs) - | linkableInSet l linkables - = return True - | otherwise - = do mapM_ unloadObj [ f | DotO f <- objs ] - return False -#else -unload Interactive dflags linkables pls = panic "CmLink.unload: no interpreter" -#endif - ------------------------------------------------------------------------------ --- Linking - -data LinkResult - = LinkOK PersistentLinkerState - | LinkFailed PersistentLinkerState - -link :: GhciMode -- interactive or batch - -> DynFlags -- dynamic flags - -> Bool -- attempt linking in batch mode? - -> [Linkable] - -> PersistentLinkerState - -> IO LinkResult - --- 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 pls1 - = do let verb = verbosity dflags - when (verb >= 3) $ do - hPutStrLn stderr "CmLink.link: linkables are ..." - hPutStrLn stderr (showSDoc (vcat (map ppr linkables))) - res <- link' mode dflags batch_attempt_linking linkables pls1 - when (verb >= 3) $ - hPutStrLn stderr "CmLink.link: done" - return res - -link' Batch dflags batch_attempt_linking linkables pls1 - | batch_attempt_linking - = do let o_files = concatMap getOfiles linkables - when (verb >= 1) $ - hPutStrLn stderr "ghc: linking ..." - -- don't showPass in Batch mode; doLink will do that for us. - doLink o_files - -- doLink only returns if it succeeds - return (LinkOK pls1) - | otherwise - = do when (verb >= 3) $ do - hPutStrLn stderr "CmLink.link(batch): upsweep (partially) failed OR" - hPutStrLn stderr " Main.main not exported; not linking." - return (LinkOK pls1) - where - verb = verbosity dflags - getOfiles (LM _ _ us) = map nameOfObject (filter isObject us) - -#ifdef GHCI -link' Interactive dflags batch_attempt_linking linkables pls - = do showPass dflags "Linking" - block $ do -- don't want to be interrupted by ^C in here - - -- Always load objects first. Objects aren't allowed to - -- depend on BCOs. - let (objs, bcos) = partition isObjectLinkable - (concatMap partitionLinkable linkables) - - objs_loaded <- readIORef v_ObjectsLoaded - objs_loaded' <- linkObjs objs objs_loaded - writeIORef v_ObjectsLoaded objs_loaded' - - -- resolve symbols within the object files - ok <- resolveObjs - -- if resolving failed, unload all our object modules and - -- carry on. - if (not ok) - then do pls <- unload Interactive dflags [] pls - return (LinkFailed pls) - else do - - -- finally link the interpreted linkables - linkBCOs bcos [] pls -#endif - ------------------------------------------------------------------------------ --- Linker for interactive mode - -#ifdef GHCI -linkObjs [] objs_loaded = return objs_loaded -linkObjs (l@(LM _ m uls) : ls) objs_loaded - | linkableInSet l objs_loaded = linkObjs ls objs_loaded -- already loaded - | otherwise = do mapM_ loadObj [ file | DotO file <- uls ] - linkObjs ls (l:objs_loaded) - -linkBCOs [] ul_trees pls = linkFinish pls ul_trees -linkBCOs (l@(LM _ m uls) : ls) ul_trees pls - | linkableInSet l (bcos_loaded pls) - = linkBCOs ls ul_trees pls - | otherwise - = linkBCOs ls (uls++ul_trees) pls{bcos_loaded = l : bcos_loaded pls} - --- link all the interpreted code in one go. -linkFinish pls ul_bcos = do - - let stuff = [ (bcos,itbls) | BCOs bcos itbls <- ul_bcos ] - - (ibinds, new_itbl_env, new_closure_env) <- - linkIModules (itbl_env pls) (closure_env pls) stuff - - let new_pls = pls { closure_env = new_closure_env, - itbl_env = new_itbl_env - } - return (LinkOK new_pls) -#endif - --- --------------------------------------------------------------------------- --- Link a single expression - -#ifdef GHCI -linkExpr :: PersistentLinkerState -> UnlinkedBCOExpr -> IO HValue -linkExpr PersistentLinkerState{ itbl_env = ie, closure_env = ce } bcos - = linkIExpr ie ce bcos -#endif -\end{code} diff --git a/ghc/compiler/compMan/CmTypes.lhs b/ghc/compiler/compMan/CmTypes.lhs deleted file mode 100644 index fd3cbfc343..0000000000 --- a/ghc/compiler/compMan/CmTypes.lhs +++ /dev/null @@ -1,105 +0,0 @@ -% -% (c) The University of Glasgow, 2000 -% -\section[CmTypes]{Types for the compilation manager} - -\begin{code} -module CmTypes ( - Unlinked(..), isObject, nameOfObject, isInterpretable, - Linkable(..), isObjectLinkable, partitionLinkable, - ModSummary(..), ms_allimps, pprSummaryTime, modSummaryName, - ) where - -import Interpreter -import HscTypes -import Module -import Outputable - -import Time ( ClockTime ) - - -data Unlinked - = DotO FilePath - | DotA FilePath - | DotDLL FilePath - | BCOs [UnlinkedBCO] ItblEnv -- bunch of interpretable bindings, + - -- a mapping from DataCons to their itbls - -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 - ppr (BCOs bcos _) = text "BCOs" <+> ppr bcos - -isObject (DotO _) = True -isObject (DotA _) = True -isObject (DotDLL _) = True -isObject _ = False - -nameOfObject (DotO fn) = fn -nameOfObject (DotA fn) = fn -nameOfObject (DotDLL fn) = fn - -isInterpretable = not . isObject - -data Linkable = LM { - linkableTime :: ClockTime, - linkableModName :: ModuleName, -- should be Module, but see below - linkableUnlinked :: [Unlinked] - } - -isObjectLinkable :: Linkable -> Bool -isObjectLinkable l = all isObject (linkableUnlinked l) - --- HACK to support f-x-dynamic in the interpreter; no other purpose -partitionLinkable :: Linkable -> [Linkable] -partitionLinkable li - = let li_uls = linkableUnlinked li - li_uls_obj = filter isObject li_uls - li_uls_bco = filter isInterpretable li_uls - in - case (li_uls_obj, li_uls_bco) of - (objs@(_:_), bcos@(_:_)) - -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}] - other - -> [li] - -instance Outputable Linkable where - ppr (LM when_made mod unlinkeds) - = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) - $$ nest 3 (ppr unlinkeds) - --- The ModuleLocation contains both the original source filename and the --- filename of the cleaned-up source file after all preprocessing has been --- done. The point is that the summariser will have to cpp/unlit/whatever --- all files anyway, and there's no point in doing this twice -- just --- park the result in a temp file, put the name of it in the location, --- and let @compile@ read from that file on the way back up. -data ModSummary - = ModSummary { - ms_mod :: Module, -- name, package - ms_location :: ModuleLocation, -- location - ms_srcimps :: [ModuleName], -- source imports - ms_imps :: [ModuleName], -- non-source imports - ms_hs_date :: ClockTime -- timestamp of summarised file - } - -instance Outputable ModSummary where - ppr ms - = sep [text "ModSummary {", - nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), - text "ms_mod =" <+> ppr (ms_mod ms) <> comma, - text "ms_imps =" <+> ppr (ms_imps ms), - text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), - char '}' - ] - -pprSummaryTime ms - = text "ms_hs_date = " <> parens (text (show (ms_hs_date ms))) - -ms_allimps ms - = ms_srcimps ms ++ ms_imps ms - -modSummaryName :: ModSummary -> ModuleName -modSummaryName = moduleName . ms_mod -\end{code} diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index dbf82f1531..64b332e6e2 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -6,7 +6,7 @@ \begin{code} {-# OPTIONS -fvia-C #-} module CompManager ( - ModuleGraph, + ModuleGraph, ModSummary(..), CmState, emptyCmState, -- abstract @@ -43,63 +43,57 @@ module CompManager ( cmCompileExpr, -- :: CmState -> DynFlags -> String -- -> IO (CmState, Maybe HValue) - cmGetModuleGraph, -- :: CmState -> ModuleGraph - cmGetLinkables, -- :: CmState -> [Linkable] + cmGetModInfo, -- :: CmState -> (ModuleGraph, HomePackageTable) + findModuleLinkable_maybe, -- Exported to InteractiveUI cmGetBindings, -- :: CmState -> [TyThing] cmGetPrintUnqual, -- :: CmState -> PrintUnqualified -#endif - -- utils - showModMsg, -- + sandboxIO -- Should be somewhere else +#endif ) where #include "HsVersions.h" -import CmLink -import CmTypes -import DriverPipeline +import DriverPipeline ( CompResult(..), preprocess, compile, link ) import DriverState ( v_Output_file ) import DriverPhases import DriverUtil import Finder -#ifdef GHCI -import HscMain ( initPersistentCompilerState, hscThing, - hscModuleContents ) -#else import HscMain ( initPersistentCompilerState ) -#endif -import HscTypes hiding ( moduleNameToModule ) -import Name ( Name, NamedThing(..), nameRdrName, nameModule, - isHomePackageName, isExternalName ) +import HscTypes hiding ( moduleNameToModule ) import NameEnv import PrelNames ( gHC_PRIM_Name ) -import Rename ( mkGlobalContext ) -import RdrName ( emptyRdrEnv ) -import Module +import Module ( Module, ModuleName, moduleName, mkModuleName, isHomeModule, + ModuleEnv, lookupModuleEnvByName, mkModuleEnv, moduleEnvElts, + extendModuleEnvList, extendModuleEnv, + moduleNameUserString, + ModLocation(..) ) import GetImports import UniqFM -import Unique ( Uniquable ) import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs ) import ErrUtils ( showPass ) import SysTools ( cleanTempFilesExcept ) +import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Util import Outputable import Panic import CmdLineOpts ( DynFlags(..), getDynFlags ) -import Maybes ( expectJust ) +import Maybes ( expectJust, orElse ) import DATA_IOREF ( readIORef ) #ifdef GHCI -import RdrName ( lookupRdrEnv ) -import Id ( idType, idName ) +import HscMain ( hscThing, hscStmt, hscTcExpr ) +import Module ( moduleUserString ) +import TcRnDriver ( mkGlobalContext, getModuleContents ) +import Name ( Name, NamedThing(..), isExternalName ) +import Id ( idType ) import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) -import BasicTypes ( Fixity, defaultFixity ) -import Interpreter ( HValue ) -import HscMain ( hscStmt ) +import BasicTypes ( Fixity, FixitySig(..), defaultFixity ) +import Linker ( HValue, unload, extendLinkEnv ) import GHC.Exts ( unsafeCoerce# ) import Foreign import Control.Exception as Exception ( Exception, try ) @@ -113,6 +107,7 @@ import IO import Monad import List ( nub ) import Maybe +import Time ( ClockTime ) \end{code} @@ -120,62 +115,76 @@ import Maybe -- Persistent state for the entire system data CmState = CmState { - hst :: HomeSymbolTable, -- home symbol table - hit :: HomeIfaceTable, -- home interface table - ui :: UnlinkedImage, -- the unlinked images - mg :: ModuleGraph, -- the module graph gmode :: GhciMode, -- NEVER CHANGES - ic :: InteractiveContext, -- command-line binding info - pcs :: PersistentCompilerState, -- compile's persistent state - pls :: PersistentLinkerState -- link's persistent state + hpt :: HomePackageTable, -- Info about home package module + mg :: ModuleGraph, -- the module graph + ic :: InteractiveContext, -- command-line binding info + + pcs :: PersistentCompilerState -- compile's persistent state } +cmGetModInfo cmstate = (mg cmstate, hpt cmstate) +cmGetBindings cmstate = nameEnvElts (ic_type_env (ic cmstate)) +cmGetPrintUnqual cmstate = icPrintUnqual (ic cmstate) + emptyCmState :: GhciMode -> IO CmState emptyCmState gmode = do pcs <- initPersistentCompilerState - pls <- emptyPLS - return (CmState { hst = emptySymbolTable, - hit = emptyIfaceTable, - ui = emptyUI, + return (CmState { hpt = emptyHomePackageTable, mg = emptyMG, gmode = gmode, ic = emptyInteractiveContext, - pcs = pcs, - pls = pls }) - -emptyInteractiveContext - = InteractiveContext { ic_toplev_scope = [], - ic_exports = [], - ic_rn_gbl_env = emptyRdrEnv, - ic_print_unqual = alwaysQualify, - ic_rn_local_env = emptyRdrEnv, - ic_type_env = emptyTypeEnv } - --- CM internal types -type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really) -emptyUI :: UnlinkedImage -emptyUI = [] - -type ModuleGraph = [ModSummary] -- the module graph, topologically sorted -emptyMG :: ModuleGraph -emptyMG = [] - ------------------------------------------------------------------------------ --- Produce an initial CmState. + pcs = pcs }) cmInit :: GhciMode -> IO CmState cmInit mode = emptyCmState mode ------------------------------------------------------------------------------ --- Grab information from the CmState -cmGetModuleGraph = mg -cmGetLinkables = ui +------------------------------------------------------------------- +-- The unlinked image +-- +-- The compilation manager keeps a list of compiled, but as-yet unlinked +-- binaries (byte code or object code). Even when it links bytecode +-- it keeps the unlinked version so it can re-link it later without +-- recompiling. -cmGetBindings cmstate = nameEnvElts (ic_type_env (ic cmstate)) -cmGetPrintUnqual cmstate = ic_print_unqual (ic cmstate) +type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really) +emptyUI :: UnlinkedImage +emptyUI = [] +findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable +findModuleLinkable_maybe lis mod + = case [LM time nm us | LM time nm us <- lis, nm == mod] of + [] -> Nothing + [li] -> Just li + many -> pprPanic "findModuleLinkable" (ppr mod) + +filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable] +filterModuleLinkables p [] = [] +filterModuleLinkables p (li:lis) + = case li of + LM _ modnm _ -> if p modnm then retain else dump + where + dump = filterModuleLinkables p lis + retain = li : dump + +linkableInSet :: Linkable -> [Linkable] -> Bool +linkableInSet l objs_loaded = + case findModuleLinkable_maybe objs_loaded (linkableModName l) of + Nothing -> False + Just m -> linkableTime l == linkableTime m +\end{code} + + +%************************************************************************ +%* * + GHCI stuff +%* * +%************************************************************************ + +\begin{code} +#ifdef GHCI ----------------------------------------------------------------------------- -- Setting the context doesn't throw away any bindings; the bindings -- we've built up in the InteractiveContext simply move to the new @@ -187,34 +196,39 @@ cmSetContext -> [String] -- and the just the exports from these -> IO CmState cmSetContext cmstate dflags toplevs exports = do - let CmState{ hit=hit, hst=hst, pcs=pcs, ic=old_ic } = cmstate + let CmState{ hpt=hpt, pcs=pcs, ic=old_ic } = cmstate + hsc_env = HscEnv { hsc_mode = Interactive, hsc_dflags = dflags, + hsc_HPT = hpt } - toplev_mods <- mapM (getTopLevModule hit) (map mkModuleName toplevs) - export_mods <- mapM (moduleNameToModule hit) (map mkModuleName exports) + toplev_mods <- mapM (getTopLevModule hpt) (map mkModuleName toplevs) + export_mods <- mapM (moduleNameToModule hpt) (map mkModuleName exports) - (new_pcs, print_unqual, maybe_env) - <- mkGlobalContext dflags hit hst pcs toplev_mods export_mods + (new_pcs, maybe_env) + <- mkGlobalContext hsc_env pcs toplev_mods export_mods case maybe_env of - Nothing -> return cmstate + Nothing -> return cmstate Just env -> return cmstate{ pcs = new_pcs, ic = old_ic{ ic_toplev_scope = toplev_mods, ic_exports = export_mods, - ic_rn_gbl_env = env, - ic_print_unqual = print_unqual } } + ic_rn_gbl_env = env } } + +getTopLevModule hpt mn = + case lookupModuleEnvByName hpt mn of + + Just mod_info + | isJust (mi_globals iface) -> return (mi_module iface) + where + iface = hm_iface mod_info -getTopLevModule hit mn = - case lookupModuleEnvByName hit mn of - Just iface - | Just _ <- mi_globals iface -> return (mi_module iface) _other -> throwDyn (CmdLineError ( "cannot enter the top-level scope of a compiled module (module `" ++ moduleNameUserString mn ++ "')")) -moduleNameToModule :: HomeIfaceTable -> ModuleName -> IO Module -moduleNameToModule hit mn = do - case lookupModuleEnvByName hit mn of - Just iface -> return (mi_module iface) +moduleNameToModule :: HomePackageTable -> ModuleName -> IO Module +moduleNameToModule hpt mn = do + case lookupModuleEnvByName hpt mn of + Just mod_info -> return (mi_module (hm_iface mod_info)) _not_a_home_module -> do maybe_stuff <- findModule mn case maybe_stuff of @@ -229,8 +243,8 @@ cmGetContext CmState{ic=ic} = cmModuleIsInterpreted :: CmState -> String -> IO Bool cmModuleIsInterpreted cmstate str - = case lookupModuleEnvByName (hit cmstate) (mkModuleName str) of - Just iface -> return (not (isNothing (mi_globals iface))) + = case lookupModuleEnvByName (hpt cmstate) (mkModuleName str) of + Just details -> return (isJust (mi_globals (hm_iface details))) _not_a_home_module -> return False ----------------------------------------------------------------------------- @@ -239,113 +253,82 @@ cmModuleIsInterpreted cmstate str -- A string may refer to more than one TyThing (eg. a constructor, -- and type constructor), so we return a list of all the possible TyThings. -#ifdef GHCI cmInfoThing :: CmState -> DynFlags -> String -> IO (CmState, [(TyThing,Fixity)]) cmInfoThing cmstate dflags id - = do (new_pcs, things) <- hscThing dflags hst hit pcs icontext id + = do (new_pcs, things) <- hscThing hsc_env pcs icontext id let pairs = map (\x -> (x, getFixity new_pcs (getName x))) things return (cmstate{ pcs=new_pcs }, pairs) where - CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate - + CmState{ hpt=hpt, pcs=pcs, ic=icontext } = cmstate + hsc_env = HscEnv { hsc_mode = Interactive, + hsc_dflags = dflags, + hsc_HPT = hpt } + pit = eps_PIT (pcs_EPS pcs) getFixity :: PersistentCompilerState -> Name -> Fixity getFixity pcs name | isExternalName name, - Just iface <- lookupModuleEnv iface_table (nameModule name), - Just fixity <- lookupNameEnv (mi_fixities iface) name - = fixity + Just iface <- lookupIface hpt pit name, + Just (FixitySig _ fixity _) <- lookupNameEnv (mi_fixities iface) name + = fixity | otherwise - = defaultFixity - where iface_table | isHomePackageName name = hit - | otherwise = pcs_PIT pcs -#endif + = defaultFixity -- --------------------------------------------------------------------------- -- cmBrowseModule: get all the TyThings defined in a module -#ifdef GHCI cmBrowseModule :: CmState -> DynFlags -> String -> Bool -> IO (CmState, [TyThing]) cmBrowseModule cmstate dflags str exports_only = do let mn = mkModuleName str - mod <- moduleNameToModule hit mn + mod <- moduleNameToModule hpt mn (pcs1, maybe_ty_things) - <- hscModuleContents dflags hst hit pcs mod exports_only + <- getModuleContents hsc_env pcs mod exports_only case maybe_ty_things of Nothing -> return (cmstate{pcs=pcs1}, []) Just ty_things -> return (cmstate{pcs=pcs1}, ty_things) where - CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate -#endif + hsc_env = HscEnv { hsc_mode = Interactive, hsc_dflags = dflags, + hsc_HPT = hpt } + CmState{ hpt=hpt, pcs=pcs, ic=icontext } = cmstate ----------------------------------------------------------------------------- -- cmRunStmt: Run a statement/expr. -#ifdef GHCI data CmRunResult = CmRunOk [Name] -- names bound by this evaluation | CmRunFailed | CmRunException Exception -- statement raised an exception cmRunStmt :: CmState -> DynFlags -> String -> IO (CmState, CmRunResult) -cmRunStmt cmstate@CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } +cmRunStmt cmstate@CmState{ hpt=hpt, pcs=pcs, ic=icontext } dflags expr = do - let InteractiveContext { - ic_rn_local_env = rn_env, - ic_type_env = type_env } = icontext - + let hsc_env = HscEnv { hsc_mode = Interactive, + hsc_dflags = dflags, + hsc_HPT = hpt } + (new_pcs, maybe_stuff) - <- hscStmt dflags hst hit pcs icontext expr False{-stmt-} + <- hscStmt hsc_env pcs icontext expr case maybe_stuff of Nothing -> return (cmstate{ pcs=new_pcs }, CmRunFailed) - Just (ids, _, bcos) -> do - - -- update the interactive context - let - names = map idName ids - - -- these names have just been shadowed - shadowed = [ n | r <- map nameRdrName names, - Just n <- [lookupRdrEnv rn_env r] ] - - new_rn_env = extendLocalRdrEnv rn_env names - - -- remove any shadowed bindings from the type_env - filtered_type_env = delListFromNameEnv type_env shadowed - - new_type_env = extendNameEnvList filtered_type_env - [ (getName id, AnId id) | id <- ids] + Just (new_ic, names, hval) -> do - new_ic = icontext { ic_rn_local_env = new_rn_env, - ic_type_env = new_type_env } - - -- link it - hval <- linkExpr pls bcos - - -- run it! let thing_to_run = unsafeCoerce# hval :: IO [HValue] either_hvals <- sandboxIO thing_to_run + case either_hvals of - Left err - -> do hPutStrLn stderr ("unknown failure, code " ++ show err) - return ( cmstate{ pcs=new_pcs, ic=new_ic }, CmRunFailed ) - - Right maybe_hvals -> - case maybe_hvals of - Left e -> - return ( cmstate{ pcs=new_pcs, ic=new_ic }, - CmRunException e ) - Right hvals -> do - -- Get the newly bound things, and bind them. - -- Don't forget to delete any shadowed bindings from the - -- closure_env, lest we end up with a space leak. - pls <- delListFromClosureEnv pls shadowed - new_pls <- addListToClosureEnv pls (zip names hvals) - - return (cmstate{ pcs=new_pcs, pls=new_pls, ic=new_ic }, - CmRunOk names) + Left e -> do + return ( cmstate{ pcs=new_pcs, ic=new_ic }, + CmRunException e ) + Right hvals -> do + -- Get the newly bound things, and bind them. + -- Don't need to delete any shadowed bindings; + -- the new ones override the old ones. + extendLinkEnv (zip names hvals) + + return (cmstate{ pcs=new_pcs, ic=new_ic }, + CmRunOk names) -- We run the statement in a "sandbox" to protect the rest of the @@ -353,10 +336,8 @@ cmRunStmt cmstate@CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } -- consists of just wrapping it in an exception handler, but see below -- for another version. -sandboxIO :: IO a -> IO (Either Int (Either Exception a)) -sandboxIO thing = do - r <- Exception.try thing - return (Right r) +sandboxIO :: IO a -> IO (Either Exception a) +sandboxIO thing = Exception.try thing {- -- This version of sandboxIO runs the expression in a completely new @@ -364,6 +345,8 @@ sandboxIO thing = do -- won't be delivered to the new thread, instead they'll be delivered -- to the (blocked) GHCi main thread. +-- SLPJ: when re-enabling this, reflect a wrong-stat error as an exception + sandboxIO :: IO a -> IO (Either Int (Either Exception a)) sandboxIO thing = do st_thing <- newStablePtr (Exception.try thing) @@ -382,103 +365,121 @@ foreign import "rts_evalStableIO" {- safe -} rts_evalStableIO :: StablePtr (IO a) -> Ptr (StablePtr a) -> IO CInt -- more informative than the C type! -} -#endif ----------------------------------------------------------------------------- -- cmTypeOfExpr: returns a string representing the type of an expression -#ifdef GHCI cmTypeOfExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe String) cmTypeOfExpr cmstate dflags expr - = do (new_pcs, maybe_stuff) - <- hscStmt dflags hst hit pcs ic expr True{-just an expr-} + = do (new_pcs, maybe_stuff) <- hscTcExpr hsc_env pcs ic expr let new_cmstate = cmstate{pcs = new_pcs} case maybe_stuff of Nothing -> return (new_cmstate, Nothing) - Just (_, ty, _) -> return (new_cmstate, Just str) + Just ty -> return (new_cmstate, Just str) where - str = showSDocForUser unqual (ppr tidy_ty) - unqual = ic_print_unqual ic + str = showSDocForUser unqual (text expr <+> dcolon <+> ppr tidy_ty) + unqual = icPrintUnqual ic tidy_ty = tidyType emptyTidyEnv ty where - CmState{ hst=hst, hit=hit, pcs=pcs, ic=ic } = cmstate -#endif + CmState{ hpt=hpt, pcs=pcs, ic=ic } = cmstate + hsc_env = HscEnv { hsc_mode = Interactive, + hsc_dflags = dflags, + hsc_HPT = hpt } + + ----------------------------------------------------------------------------- -- cmTypeOfName: returns a string representing the type of a name. -#ifdef GHCI cmTypeOfName :: CmState -> Name -> IO (Maybe String) -cmTypeOfName CmState{ hit=hit, pcs=pcs, ic=ic } name - = case lookupNameEnv (ic_type_env ic) name of +cmTypeOfName CmState{ pcs=pcs, ic=ic } name + = do + hPutStrLn stderr ("cmTypeOfName: " ++ showSDoc (ppr name)) + case lookupNameEnv (ic_type_env ic) name of Nothing -> return Nothing Just (AnId id) -> return (Just str) where - unqual = ic_print_unqual ic + unqual = icPrintUnqual ic ty = tidyType emptyTidyEnv (idType id) str = showSDocForUser unqual (ppr ty) _ -> panic "cmTypeOfName" -#endif ----------------------------------------------------------------------------- -- cmCompileExpr: compile an expression and deliver an HValue -#ifdef GHCI cmCompileExpr :: CmState -> DynFlags -> String -> IO (CmState, Maybe HValue) cmCompileExpr cmstate dflags expr = do - let InteractiveContext { - ic_rn_local_env = rn_env, - ic_type_env = type_env } = icontext - + let hsc_env = HscEnv { hsc_mode = Interactive, + hsc_dflags = dflags, + hsc_HPT = hpt } + (new_pcs, maybe_stuff) - <- hscStmt dflags hst hit pcs icontext - ("let __cmCompileExpr = "++expr) False{-stmt-} + <- hscStmt hsc_env pcs icontext + ("let __cmCompileExpr = "++expr) case maybe_stuff of Nothing -> return (cmstate{ pcs=new_pcs }, Nothing) - Just (ids, _, bcos) -> do + Just (new_ic, names, hval) -> do - -- link it - hval <- linkExpr pls bcos + -- Run it! + hvals <- (unsafeCoerce# hval) :: IO [HValue] - -- run it! - let thing_to_run = unsafeCoerce# hval :: IO [HValue] - hvals <- thing_to_run - - case (ids,hvals) of - ([id],[hv]) -> return (cmstate{ pcs=new_pcs }, Just hv) - _ -> panic "cmCompileExpr" + case (names,hvals) of + ([n],[hv]) -> return (cmstate{ pcs=new_pcs }, Just hv) + _ -> panic "cmCompileExpr" where - CmState{ hst=hst, hit=hit, pcs=pcs, pls=pls, ic=icontext } = cmstate -#endif + CmState{ hpt=hpt, pcs=pcs, ic=icontext } = cmstate +#endif /* GHCI */ +\end{code} + + +%************************************************************************ +%* * + Loading and unloading +%* * +%************************************************************************ +\begin{code} ----------------------------------------------------------------------------- -- Unload the compilation manager's state: everything it knows about the -- current collection of modules in the Home package. cmUnload :: CmState -> DynFlags -> IO CmState -cmUnload state@CmState{ gmode=mode, pls=pls, pcs=pcs } dflags +cmUnload state@CmState{ gmode=mode, pcs=pcs } dflags = do -- Throw away the old home dir cache emptyHomeDirCache -- Unload everything the linker knows about - new_pls <- CmLink.unload mode dflags [] pls + cm_unload mode dflags [] -- Start with a fresh CmState, but keep the PersistentCompilerState new_state <- cmInit mode - return new_state{ pcs=pcs, pls=new_pls } + return new_state{ pcs=pcs } + +cm_unload Batch dflags linkables = return () + +#ifdef GHCI +cm_unload Interactive dflags linkables = Linker.unload dflags linkables +#else +cm_unload Interactive dflags linkables = panic "unload: no interpreter" +#endif ----------------------------------------------------------------------------- -- Trace dependency graph -- This is a seperate pass so that the caller can back off and keep --- the current state if the downsweep fails. +-- the current state if the downsweep fails. Typically the caller +-- might go cmDepAnal +-- cmUnload +-- cmLoadModules +-- He wants to do the dependency analysis before the unload, so that +-- if the former fails he can use the later cmDepAnal :: CmState -> DynFlags -> [FilePath] -> IO ModuleGraph cmDepAnal cmstate dflags rootnames @@ -494,22 +495,17 @@ cmDepAnal cmstate dflags rootnames -- a module name, try and bring the module up to date, probably changing -- the system state at the same time. -cmLoadModules :: CmState - -> DynFlags - -> ModuleGraph - -> IO (CmState, -- new state - Bool, -- was successful - [String]) -- list of modules loaded +cmLoadModules :: CmState -- The HPT may not be as up to date + -> DynFlags -- as the ModuleGraph + -> ModuleGraph -- Bang up to date + -> IO (CmState, -- new state + SuccessFlag, -- was successful + [String]) -- list of modules loaded cmLoadModules cmstate1 dflags mg2unsorted = do -- version 1's are the original, before downsweep - let pls1 = pls cmstate1 let pcs1 = pcs cmstate1 - let hst1 = hst cmstate1 - let hit1 = hit cmstate1 - -- similarly, ui1 is the (complete) set of linkables from - -- the previous pass, if any. - let ui1 = ui cmstate1 + let hpt1 = hpt cmstate1 let ghci_mode = gmode cmstate1 -- this never changes @@ -531,20 +527,20 @@ cmLoadModules cmstate1 dflags mg2unsorted let mg2 = topological_sort False mg2unsorted -- ... whereas this takes them into account. Used for -- backing out partially complete cycles following a failed - -- upsweep, and for removing from hst/hit all the modules + -- upsweep, and for removing from hpt all the modules -- not in strict downwards closure, during calls to compile. let mg2_with_srcimps = topological_sort True mg2unsorted -- Sort out which linkables we wish to keep in the unlinked image. -- See getValidLinkables below for details. (valid_old_linkables, new_linkables) - <- getValidLinkables ghci_mode ui1 + <- getValidLinkables ghci_mode (hptLinkables hpt1) mg2unsorted_names mg2_with_srcimps -- putStrLn (showSDoc (vcat [ppr valid_old_linkables, ppr new_linkables])) - -- uniq of ModuleName is the same as Module, fortunately... - let hit2 = delListFromUFM hit1 (map linkableModName new_linkables) + -- Uniq of ModuleName is the same as Module, fortunately... + let hpt2 = delListFromUFM hpt1 (map linkableModName new_linkables) -- When (verb >= 2) $ -- putStrLn (showSDoc (text "Valid linkables:" @@ -574,9 +570,9 @@ cmLoadModules cmstate1 dflags mg2unsorted putStrLn (showSDoc (text "Stable modules:" <+> sep (map (text.moduleNameUserString) stable_mods))) - -- unload any modules which are going to be re-linked this + -- Unload any modules which are going to be re-linked this -- time around. - pls2 <- CmLink.unload ghci_mode dflags stable_linkables pls1 + cm_unload ghci_mode dflags stable_linkables -- we can now glom together our linkable sets let valid_linkables = valid_old_linkables ++ new_linkables @@ -601,25 +597,24 @@ cmLoadModules cmstate1 dflags mg2unsorted -- Now do the upsweep, calling compile for each module in -- turn. Final result is version 3 of everything. - let threaded2 = CmThreaded pcs1 hst1 hit2 + let threaded2 = CmThreaded pcs1 hpt2 -- clean up between compilations let cleanup = cleanTempFilesExcept verb (ppFilesFromSummaries (flattenSCCs mg2)) - (upsweep_complete_success, threaded3, modsUpswept, newLis) + (upsweep_ok, threaded3, modsUpswept) <- upsweep_mods ghci_mode dflags valid_linkables reachable_from threaded2 cleanup upsweep_these - let ui3 = add_to_ui valid_linkables newLis - let (CmThreaded pcs3 hst3 hit3) = threaded3 + let (CmThreaded pcs3 hpt3) = threaded3 -- At this point, modsUpswept and newLis should have the same -- length, so there is one new (or old) linkable for each -- mod which was processed (passed to compile). -- Make modsDone be the summaries for each home module now - -- available; this should equal the domains of hst3 and hit3. + -- available; this should equal the domain of hpt3. -- (NOT STRICTLY TRUE if an interactive session was started -- with some object on disk ???) -- Get in in a roughly top .. bottom order (hence reverse). @@ -629,7 +624,7 @@ cmLoadModules cmstate1 dflags mg2unsorted -- Try and do linking in some form, depending on whether the -- upsweep was completely or only partially successful. - if upsweep_complete_success + if succeeded upsweep_ok then -- Easy; just relink it all. @@ -647,10 +642,10 @@ cmLoadModules cmstate1 dflags mg2unsorted hPutStrLn stderr "Warning: output was redirected with -o, but no output will be generated\nbecause there is no Main module." -- link everything together - linkresult <- link ghci_mode dflags a_root_is_Main ui3 pls2 + linkresult <- link ghci_mode dflags a_root_is_Main (hptLinkables hpt3) - cmLoadFinish True linkresult - hst3 hit3 ui3 modsDone ghci_mode pcs3 + cmLoadFinish Succeeded linkresult + hpt3 modsDone ghci_mode pcs3 else -- Tricky. We need to back out the effects of compiling any @@ -668,34 +663,32 @@ cmLoadModules cmstate1 dflags mg2unsorted = filter ((`notElem` mods_to_zap_names).modSummaryName) modsDone - let (hst4, hit4, ui4) - = retainInTopLevelEnvs (map modSummaryName mods_to_keep) - (hst3,hit3,ui3) + let hpt4 = retainInTopLevelEnvs (map modSummaryName mods_to_keep) hpt3 - -- clean up after ourselves + -- Clean up after ourselves cleanTempFilesExcept verb (ppFilesFromSummaries mods_to_keep) - -- link everything together - linkresult <- link ghci_mode dflags False ui4 pls2 + -- Link everything together + linkresult <- link ghci_mode dflags False (hptLinkables hpt4) - cmLoadFinish False linkresult - hst4 hit4 ui4 mods_to_keep ghci_mode pcs3 + cmLoadFinish Failed linkresult + hpt4 mods_to_keep ghci_mode pcs3 -- Finish up after a cmLoad. -- If the link failed, unload everything and return. -cmLoadFinish ok (LinkFailed pls) hst hit ui mods ghci_mode pcs = do - dflags <- getDynFlags - new_pls <- CmLink.unload ghci_mode dflags [] pls +cmLoadFinish ok Failed hpt mods ghci_mode pcs = do + dflags <- getDynFlags + cm_unload ghci_mode dflags [] new_state <- cmInit ghci_mode - return (new_state{ pcs=pcs, pls=new_pls }, False, []) + return (new_state{ pcs=pcs }, Failed, []) -- Empty the interactive context and set the module context to the topmost -- newly loaded module, or the Prelude if none were loaded. -cmLoadFinish ok (LinkOK pls) hst hit ui mods ghci_mode pcs - = do let new_cmstate = CmState{ hst=hst, hit=hit, ui=ui, mg=mods, - gmode=ghci_mode, pcs=pcs, pls=pls, +cmLoadFinish ok Succeeded hpt mods ghci_mode pcs + = do let new_cmstate = CmState{ hpt=hpt, mg=mods, + gmode=ghci_mode, pcs=pcs, ic = emptyInteractiveContext } mods_loaded = map (moduleNameUserString.modSummaryName) mods @@ -791,8 +784,14 @@ getValidLinkablesSCC mode old_linkables all_home_mods new_linkables scc0 getValidLinkable :: [Linkable] -> Bool -> [(Linkable,Bool)] -> ModSummary -> IO [(Linkable,Bool)] - -- True <=> linkable is new + -- True <=> linkable is new; i.e. freshly discovered on the disk + -- presumably generated 'on the side' + -- by a separate GHC run getValidLinkable old_linkables objects_allowed new_linkables summary + -- 'objects_allowed' says whether we permit this module to + -- have a .o-file linkable. We only permit it if all the + -- modules it depends on also have .o files; a .o file can't + -- link to a bytecode module = do let mod_name = modSummaryName summary maybe_disk_linkable @@ -859,6 +858,11 @@ maybe_getFileLinkable mod obj_fn then return (Just (LM obj_time mod [DotO obj_fn, DotO stub_fn])) else return (Just (LM obj_time mod [DotO obj_fn])) +hptLinkables :: HomePackageTable -> [Linkable] +-- Get all the linkables from the home package table, one for each module +-- Once the HPT is up to date, these are the ones we should link +hptLinkables hpt = map hm_linkable (moduleEnvElts hpt) + ----------------------------------------------------------------------------- -- Do a pre-upsweep without use of "compile", to establish a @@ -867,7 +871,7 @@ maybe_getFileLinkable mod obj_fn -- a stable module: -- * has a valid linkable (see getValidLinkables above) -- * depends only on stable modules --- * has an interface in the HIT (interactive mode only) +-- * has an interface in the HPT (interactive mode only) preUpsweep :: [Linkable] -- new valid linkables -> [ModuleName] -- names of all mods encountered in downsweep @@ -936,69 +940,53 @@ findPartiallyCompletedCycles modsDone theGraph else chewed_rest --- Add the given (LM-form) Linkables to the UI, overwriting previous --- versions if they exist. -add_to_ui :: UnlinkedImage -> [Linkable] -> UnlinkedImage -add_to_ui ui lis - = filter (not_in lis) ui ++ lis - where - not_in :: [Linkable] -> Linkable -> Bool - not_in lis li - = all (\l -> linkableModName l /= mod) lis - where mod = linkableModName li - - data CmThreaded -- stuff threaded through individual module compilations - = CmThreaded PersistentCompilerState HomeSymbolTable HomeIfaceTable + = CmThreaded PersistentCompilerState HomePackageTable -- Compile multiple modules, stopping as soon as an error appears. -- There better had not be any cyclic groups here -- we check for them. upsweep_mods :: GhciMode -> DynFlags - -> UnlinkedImage -- valid linkables + -> [Linkable] -- Valid linkables -> (ModuleName -> [ModuleName]) -- to construct downward closures - -> CmThreaded -- PCS & HST & HIT + -> CmThreaded -- PCS & HPT -> IO () -- how to clean up unwanted tmp files -> [SCC ModSummary] -- mods to do (the worklist) -- ...... RETURNING ...... - -> IO (Bool{-complete success?-}, - CmThreaded, - [ModSummary], -- mods which succeeded - [Linkable]) -- new linkables + -> IO (SuccessFlag, + CmThreaded, -- Includes linkables + [ModSummary]) -- Mods which succeeded upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup [] - = return (True, threaded, [], []) + = return (Succeeded, threaded, []) upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup ((CyclicSCC ms):_) = do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++ unwords (map (moduleNameUserString.modSummaryName) ms)) - return (False, threaded, [], []) + return (Failed, threaded, []) upsweep_mods ghci_mode dflags oldUI reachable_from threaded cleanup ((AcyclicSCC mod):mods) = do --case threaded of - -- CmThreaded pcsz hstz hitz - -- -> putStrLn ("UPSWEEP_MOD: hit = " ++ show (map (moduleNameUserString.moduleName.mi_module) (eltsUFM hitz))) + -- CmThreaded pcsz hptz + -- -> putStrLn ("UPSWEEP_MOD: hpt = " ++ + -- show (map (moduleNameUserString.moduleName.mi_module.hm_iface) (eltsUFM hptz))) - (threaded1, maybe_linkable) - <- upsweep_mod ghci_mode dflags oldUI threaded mod - (reachable_from (modSummaryName mod)) + (ok_flag, threaded1) <- upsweep_mod ghci_mode dflags oldUI threaded mod + (reachable_from (modSummaryName mod)) - -- remove unwanted tmp files between compilations - cleanup + cleanup -- Remove unwanted tmp files between compilations - case maybe_linkable of - Just linkable - -> -- No errors; do the rest - do (restOK, threaded2, modOKs, linkables) + if failed ok_flag then + return (Failed, threaded1, []) + else do + (restOK, threaded2, modOKs) <- upsweep_mods ghci_mode dflags oldUI reachable_from threaded1 cleanup mods - return (restOK, threaded2, mod:modOKs, linkable:linkables) - Nothing -- we got a compilation error; give up now - -> return (False, threaded1, [], []) + return (restOK, threaded2, mod:modOKs) -- Compile a single module. Always produce a Linkable for it if @@ -1009,39 +997,39 @@ upsweep_mod :: GhciMode -> CmThreaded -> ModSummary -> [ModuleName] - -> IO (CmThreaded, Maybe Linkable) + -> IO (SuccessFlag, CmThreaded) upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me = do - let mod_name = modSummaryName summary1 + let this_mod = ms_mod summary1 + location = ms_location summary1 + mod_name = moduleName this_mod - let (CmThreaded pcs1 hst1 hit1) = threaded1 - let old_iface = lookupUFM hit1 mod_name + let (CmThreaded pcs1 hpt1) = threaded1 + let mb_old_iface = case lookupModuleEnvByName hpt1 mod_name of + Just mod_info -> Just (hm_iface mod_info) + Nothing -> Nothing let maybe_old_linkable = findModuleLinkable_maybe oldUI mod_name + source_unchanged = isJust maybe_old_linkable - source_unchanged = isJust maybe_old_linkable - - reachable_only = filter (/= (modSummaryName summary1)) - reachable_inc_me + reachable_only = filter (/= mod_name) reachable_inc_me - -- in interactive mode, all home modules below us *must* have an - -- interface in the HIT. We never demand-load home interfaces in + -- In interactive mode, all home modules below us *must* have an + -- interface in the HPT. We never demand-load home interfaces in -- interactive mode. - (hst1_strictDC, hit1_strictDC, []) - = ASSERT(ghci_mode == Batch || - all (`elemUFM` hit1) reachable_only) - retainInTopLevelEnvs reachable_only (hst1,hit1,[]) + hpt1_strictDC + = ASSERT(ghci_mode == Batch || all (`elemUFM` hpt1) reachable_only) + retainInTopLevelEnvs reachable_only hpt1 - old_linkable - = expectJust "upsweep_mod:old_linkable" maybe_old_linkable + old_linkable = expectJust "upsweep_mod:old_linkable" maybe_old_linkable have_object | Just l <- maybe_old_linkable, isObjectLinkable l = True | otherwise = False - compresult <- compile ghci_mode summary1 source_unchanged - have_object old_iface hst1_strictDC hit1_strictDC pcs1 + compresult <- compile ghci_mode this_mod location source_unchanged + have_object mb_old_iface hpt1_strictDC pcs1 case compresult of @@ -1049,37 +1037,28 @@ upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_inc_me -- linkable (depending on whether compilation was actually performed -- or not). CompOK pcs2 new_details new_iface maybe_new_linkable - -> do let hst2 = addToUFM hst1 mod_name new_details - hit2 = addToUFM hit1 mod_name new_iface - threaded2 = CmThreaded pcs2 hst2 hit2 - - return (threaded2, if isJust maybe_new_linkable - then maybe_new_linkable - else Just old_linkable) - - -- Compilation failed. compile may still have updated - -- the PCS, tho. - CompErrs pcs2 - -> do let threaded2 = CmThreaded pcs2 hst1 hit1 - return (threaded2, Nothing) - --- Filter modules in the top level envs (HST, HIT, UI). -retainInTopLevelEnvs :: [ModuleName] - -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage) - -> (HomeSymbolTable, HomeIfaceTable, UnlinkedImage) -retainInTopLevelEnvs keep_these (hst, hit, ui) - = (retainInUFM hst keep_these, - retainInUFM hit keep_these, - filterModuleLinkables (`elem` keep_these) ui - ) - where - retainInUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt - retainInUFM ufm keys_to_keep - = listToUFM (concatMap (maybeLookupUFM ufm) keys_to_keep) - maybeLookupUFM ufm u - = case lookupUFM ufm u of Nothing -> []; Just val -> [(u, val)] + -> do let + new_linkable = maybe_new_linkable `orElse` old_linkable + new_info = HomeModInfo { hm_iface = new_iface, + hm_details = new_details, + hm_linkable = new_linkable } + hpt2 = extendModuleEnv hpt1 this_mod new_info + + return (Succeeded, CmThreaded pcs2 hpt2) + + -- Compilation failed. Compile may still have updated the PCS, tho. + CompErrs pcs2 -> return (Failed, CmThreaded pcs2 hpt1) + +-- Filter modules in the HPT +retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable +retainInTopLevelEnvs keep_these hpt + = listToUFM (concatMap (maybeLookupUFM hpt) keep_these) + where + maybeLookupUFM ufm u = case lookupUFM ufm u of + Nothing -> [] + Just val -> [(u, val)] --- Needed to clean up HIT and HST so that we don't get duplicates in inst env +-- Needed to clean up HPT so that we don't get duplicates in inst env downwards_closure_of_module :: [ModSummary] -> ModuleName -> [ModuleName] downwards_closure_of_module summaries root = let toEdge :: ModSummary -> (ModuleName,[ModuleName]) @@ -1259,7 +1238,7 @@ summariseFile file srcimps the_imps src_timestamp) -- Summarise a module, and pick up source and timestamp. -summarise :: Module -> ModuleLocation -> Maybe ModSummary +summarise :: Module -> ModLocation -> Maybe ModSummary -> IO (Maybe ModSummary) summarise mod location old_summary | not (isHomeModule mod) = return Nothing @@ -1309,3 +1288,49 @@ multiRootsErr mod files text "is defined in multiple files:" <+> sep (map text files)))) \end{code} + + +%************************************************************************ +%* * + The ModSummary Type +%* * +%************************************************************************ + +\begin{code} +-- The ModLocation contains both the original source filename and the +-- filename of the cleaned-up source file after all preprocessing has been +-- done. The point is that the summariser will have to cpp/unlit/whatever +-- all files anyway, and there's no point in doing this twice -- just +-- park the result in a temp file, put the name of it in the location, +-- and let @compile@ read from that file on the way back up. + + +type ModuleGraph = [ModSummary] -- the module graph, topologically sorted + +emptyMG :: ModuleGraph +emptyMG = [] + +data ModSummary + = ModSummary { + ms_mod :: Module, -- name, package + ms_location :: ModLocation, -- location + ms_srcimps :: [ModuleName], -- source imports + ms_imps :: [ModuleName], -- non-source imports + ms_hs_date :: ClockTime -- timestamp of summarised file + } + +instance Outputable ModSummary where + ppr ms + = sep [text "ModSummary {", + nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), + text "ms_mod =" <+> ppr (ms_mod ms) <> comma, + text "ms_imps =" <+> ppr (ms_imps ms), + text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), + char '}' + ] + +ms_allimps ms = ms_srcimps ms ++ ms_imps ms + +modSummaryName :: ModSummary -> ModuleName +modSummaryName = moduleName . ms_mod +\end{code} diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index 6b5ca3aa54..9d66e5073d 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -27,7 +27,7 @@ import NameSet import VarSet import Var ( Var, isId, isLocalVar, varName ) import Type ( tyVarsOfType ) -import TcType ( namesOfType ) +import TcType ( tyClsNamesOfType ) import Util ( mapAndUnzip ) import Outputable \end{code} @@ -164,9 +164,9 @@ ruleLhsFreeNames (fn, Rule _ _ tpl_vars tpl_args rhs) = addOneToNameSet (exprsFreeNames tpl_args `del_binders` tpl_vars) (varName fn) exprFreeNames :: CoreExpr -> NameSet -exprFreeNames (Var v) = unitNameSet (varName v) -exprFreeNames (Lit _) = emptyNameSet -exprFreeNames (Type ty) = namesOfType ty +exprFreeNames (Var v) = unitNameSet (varName v) +exprFreeNames (Lit _) = emptyNameSet +exprFreeNames (Type ty) = tyClsNamesOfType ty -- Don't need free tyvars exprFreeNames (App e1 e2) = exprFreeNames e1 `unionNameSets` exprFreeNames e2 exprFreeNames (Lam v e) = exprFreeNames e `delFromNameSet` varName v exprFreeNames (Note n e) = exprFreeNames e diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 7b1b39e8d0..a5785ac131 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -27,8 +27,7 @@ import Subst ( substTyWith ) import Name ( getSrcLoc ) import PprCore import ErrUtils ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass, - ErrMsg, addErrLocHdrLine, pprBagOfErrors, - WarnMsg, pprBagOfWarnings) + addErrLocHdrLine ) import SrcLoc ( SrcLoc, noSrcLoc ) import Type ( Type, tyVarsOfType, eqType, splitFunTy_maybe, mkTyVarTy, @@ -481,9 +480,9 @@ lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL` \begin{code} type LintM a = [LintLocInfo] -- Locations -> IdSet -- Local vars in scope - -> Bag ErrMsg -- Error messages so far - -> Bag WarnMsg -- Warning messages so far - -> (Maybe a, Bag ErrMsg, Bag WarnMsg) -- Result and error/warning messages (if any) + -> Bag Message -- Error messages so far + -> Bag Message -- Warning messages so far + -> (Maybe a, Bag Message, Bag Message) -- Result and error/warning messages (if any) data LintLocInfo = RhsOf Id -- The variable bound @@ -498,11 +497,12 @@ data LintLocInfo initL :: LintM a -> (Maybe Message {- errors -}, Maybe Message {- warnings -}) initL m = case m [] emptyVarSet emptyBag emptyBag of - (_, errs, warns) -> (ifNonEmptyBag errs pprBagOfErrors, - ifNonEmptyBag warns pprBagOfWarnings) + (_, errs, warns) -> (ifNonEmptyBag errs, + ifNonEmptyBag warns) where - ifNonEmptyBag bag f | isEmptyBag bag = Nothing - | otherwise = Just (f bag) + ifNonEmptyBag bag + | isEmptyBag bag = Nothing + | otherwise = Just (vcat (punctuate (text "") (bagToList bag))) returnL :: a -> LintM a returnL r loc scope errs warns = (Just r, errs, warns) @@ -537,7 +537,7 @@ checkL False msg = addErrL msg addErrL :: Message -> LintM a addErrL msg loc scope errs warns = (Nothing, addErr errs msg loc, warns) -addErr :: Bag ErrMsg -> Message -> [LintLocInfo] -> Bag ErrMsg +addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message -- errors or warnings, actually... they're the same type. addErr errs_so_far msg locs = ASSERT( notNull locs ) diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index 8621ae1c2e..e55bca842e 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -25,7 +25,7 @@ import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, isLocalId, hasNoBinding, idNewStrictness, isDataConId_maybe, idUnfolding ) -import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts ) +import HscTypes ( ModGuts(..), ModGuts, implicitTyThingIds, typeEnvElts ) import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, RecFlag(..), isNonRec ) @@ -96,23 +96,23 @@ any trivial or useless bindings. -- ----------------------------------------------------------------------------- \begin{code} -corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails -corePrepPgm dflags mod_details +corePrepPgm :: DynFlags -> ModGuts -> IO ModGuts +corePrepPgm dflags mod_impl = do showPass dflags "CorePrep" us <- mkSplitUniqSupply 's' - let implicit_binds = mkImplicitBinds (md_types mod_details) + let implicit_binds = mkImplicitBinds (mg_types mod_impl) -- NB: we must feed mkImplicitBinds through corePrep too -- so that they are suitably cloned and eta-expanded binds_out = initUs_ us ( - corePrepTopBinds (md_binds mod_details) `thenUs` \ floats1 -> - corePrepTopBinds implicit_binds `thenUs` \ floats2 -> + corePrepTopBinds (mg_binds mod_impl) `thenUs` \ floats1 -> + corePrepTopBinds implicit_binds `thenUs` \ floats2 -> returnUs (deFloatTop (floats1 `appOL` floats2)) ) endPass dflags "CorePrep" Opt_D_dump_prep binds_out - return (mod_details { md_binds = binds_out }) + return (mod_impl { mg_binds = binds_out }) corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr corePrepExpr dflags expr diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index f603969a63..12f750f12a 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -7,7 +7,7 @@ module CoreSyn ( Expr(..), Alt, Bind(..), AltCon(..), Arg, Note(..), CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr, - TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, + TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), mkLets, mkLams, mkApps, mkTyApps, mkValApps, mkVarApps, @@ -343,12 +343,18 @@ type CoreAlt = Alt CoreBndr Binders are ``tagged'' with a \tr{t}: \begin{code} -type Tagged t = (CoreBndr, t) +data TaggedBndr t = TB CoreBndr t -- TB for "tagged binder" -type TaggedBind t = Bind (Tagged t) -type TaggedExpr t = Expr (Tagged t) -type TaggedArg t = Arg (Tagged t) -type TaggedAlt t = Alt (Tagged t) +type TaggedBind t = Bind (TaggedBndr t) +type TaggedExpr t = Expr (TaggedBndr t) +type TaggedArg t = Arg (TaggedBndr t) +type TaggedAlt t = Alt (TaggedBndr t) + +instance Outputable b => Outputable (TaggedBndr b) where + ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>' + +instance Outputable b => OutputableBndr (TaggedBndr b) where + pprBndr _ b = ppr b -- Simple \end{code} diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index bab0c159cf..6bb2f30f6c 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -31,28 +31,27 @@ import CmdLineOpts import IO import FastString -emitExternalCore :: DynFlags -> ModIface -> ModDetails -> IO () -emitExternalCore dflags iface details +emitExternalCore :: DynFlags -> ModGuts -> IO () +emitExternalCore dflags mod_impl | opt_EmitExternalCore = (do handle <- openFile corename WriteMode - hPutStr handle (show (mkExternalCore iface details)) + hPutStr handle (show (mkExternalCore mod_impl)) hClose handle) `catch` (\err -> pprPanic "Failed to open or write external core output file" (text corename)) where corename = extCoreName dflags -emitExternalCore _ _ _ +emitExternalCore _ _ | otherwise = return () -mkExternalCore :: ModIface -> ModDetails -> C.Module -mkExternalCore (ModIface {mi_module=mi_module,mi_exports=mi_exports}) - (ModDetails {md_types=md_types,md_binds=md_binds}) = - C.Module mname tdefs vdefs +mkExternalCore :: ModGuts -> C.Module +mkExternalCore (ModGuts {mg_module=this_mod, mg_types = type_env, mg_binds = binds}) + = C.Module mname tdefs vdefs where - mname = make_mid mi_module - tdefs = foldr collect_tdefs [] (typeEnvTyCons md_types) - vdefs = map make_vdef md_binds + mname = make_mid this_mod + tdefs = foldr collect_tdefs [] (typeEnvTyCons type_env) + vdefs = map make_vdef binds collect_tdefs :: TyCon -> [C.Tdef] -> [C.Tdef] collect_tdefs tcon tdefs diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 3c65bacaa4..061975e599 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -9,8 +9,7 @@ \begin{code} module PprCore ( - pprCoreExpr, pprParendExpr, - pprCoreBinding, pprCoreBindings, pprIdBndr, + pprCoreExpr, pprParendExpr, pprIdBndr, pprCoreBinding, pprCoreBindings, pprCoreAlt, pprIdRules, pprCoreRule ) where @@ -19,6 +18,7 @@ module PprCore ( import CoreSyn import CostCentre ( pprCostCentreCore ) +import Var ( Var ) import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity, idInfo, idInlinePragma, idOccInfo, #ifdef OLD_STRICTNESS @@ -30,19 +30,18 @@ import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity, import Var ( isTyVar ) import IdInfo ( IdInfo, megaSeqIdInfo, arityInfo, ppArityInfo, - specInfo, ppStrictnessInfo, + specInfo, pprNewStrictness, workerInfo, ppWorkerInfo, newStrictnessInfo, #ifdef OLD_STRICTNESS cprInfo, ppCprInfo, - strictnessInfo, + strictnessInfo, ppStrictnessInfo, #endif ) import DataCon ( dataConTyCon ) import TyCon ( tupleTyConBoxity, isTupleTyCon ) -import PprType ( pprParendType, pprTyVarBndr ) +import PprType ( pprParendType, pprType, pprTyVarBndr ) import BasicTypes ( tupleParens ) -import PprEnv import Util ( lengthIs ) import Outputable \end{code} @@ -53,68 +52,24 @@ import Outputable %* * %************************************************************************ -@pprCoreBinding@ and @pprCoreExpr@ let you give special printing -function for ``major'' val_bdrs (those next to equal signs :-), -``minor'' ones (lambda-bound, case-bound), and bindees. They would -usually be called through some intermediary. - -The binder/occ printers take the default ``homogenized'' (see -@PprEnv@...) @Doc@ and the binder/occ. They can either use the -homogenized one, or they can ignore it completely. In other words, -the things passed in act as ``hooks'', getting the last word on how to -print something. - @pprParendCoreExpr@ puts parens around non-atomic Core expressions. -Un-annotated core dumps -~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -pprCoreBindings :: [CoreBind] -> SDoc -pprCoreBinding :: CoreBind -> SDoc -pprCoreExpr :: CoreExpr -> SDoc -pprParendExpr :: CoreExpr -> SDoc - -pprCoreBindings = pprTopBinds pprCoreEnv -pprCoreBinding = pprTopBind pprCoreEnv -pprCoreExpr = ppr_noparend_expr pprCoreEnv -pprParendExpr = ppr_parend_expr pprCoreEnv -pprArg = ppr_arg pprCoreEnv -pprCoreAlt = ppr_alt pprCoreEnv - -pprCoreEnv = initCoreEnv pprCoreBinder -\end{code} +pprCoreBindings :: OutputableBndr b => [Bind b] -> SDoc +pprCoreBinding :: OutputableBndr b => Bind b -> SDoc +pprCoreExpr :: OutputableBndr b => Expr b -> SDoc +pprParendExpr :: OutputableBndr b => Expr b -> SDoc -Printer for unfoldings in interfaces -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -\begin{code} -instance Outputable b => Outputable (Bind b) where - ppr bind = ppr_bind pprGenericEnv bind +pprCoreBindings = pprTopBinds +pprCoreBinding = pprTopBind -instance Outputable b => Outputable (Expr b) where - ppr expr = ppr_noparend_expr pprGenericEnv expr +instance OutputableBndr b => Outputable (Bind b) where + ppr bind = ppr_bind bind -pprGenericEnv :: Outputable b => PprEnv b -pprGenericEnv = initCoreEnv (\site -> ppr) +instance OutputableBndr b => Outputable (Expr b) where + ppr expr = pprCoreExpr expr \end{code} -%************************************************************************ -%* * -\subsection{Instance declarations for Core printing} -%* * -%************************************************************************ - - -\begin{code} -initCoreEnv pbdr - = initPprEnv - (Just pprCostCentreCore) -- Cost centres - - (Just ppr) -- tyvar occs - (Just pprParendType) -- types - - (Just pbdr) (Just ppr) -- value vars - -- Use pprIdBndr for this last one as a debugging device. -\end{code} %************************************************************************ %* * @@ -123,64 +78,64 @@ initCoreEnv pbdr %************************************************************************ \begin{code} -pprTopBinds pe binds = vcat (map (pprTopBind pe) binds) +pprTopBinds binds = vcat (map pprTopBind binds) -pprTopBind pe (NonRec binder expr) - = ppr_binding_pe pe (binder,expr) $$ text "" +pprTopBind (NonRec binder expr) + = ppr_binding (binder,expr) $$ text "" -pprTopBind pe (Rec binds) +pprTopBind (Rec binds) = vcat [ptext SLIT("Rec {"), - vcat (map (ppr_binding_pe pe) binds), + vcat (map ppr_binding binds), ptext SLIT("end Rec }"), text ""] \end{code} \begin{code} -ppr_bind :: PprEnv b -> Bind b -> SDoc +ppr_bind :: OutputableBndr b => Bind b -> SDoc -ppr_bind pe (NonRec val_bdr expr) = ppr_binding_pe pe (val_bdr, expr) -ppr_bind pe (Rec binds) = vcat (map pp binds) - where - pp bind = ppr_binding_pe pe bind <> semi +ppr_bind (NonRec val_bdr expr) = ppr_binding (val_bdr, expr) +ppr_bind (Rec binds) = vcat (map pp binds) + where + pp bind = ppr_binding bind <> semi -ppr_binding_pe :: PprEnv b -> (b, Expr b) -> SDoc -ppr_binding_pe pe (val_bdr, expr) - = sep [pBndr pe LetBind val_bdr, - nest 2 (equals <+> ppr_noparend_expr pe expr)] +ppr_binding :: OutputableBndr b => (b, Expr b) -> SDoc +ppr_binding (val_bdr, expr) + = pprBndr LetBind val_bdr $$ + (ppr val_bdr <+> equals <+> pprCoreExpr expr) \end{code} \begin{code} -ppr_parend_expr pe expr = ppr_expr parens pe expr -ppr_noparend_expr pe expr = ppr_expr noParens pe expr +pprParendExpr expr = ppr_expr parens expr +pprCoreExpr expr = ppr_expr noParens expr noParens :: SDoc -> SDoc noParens pp = pp \end{code} \begin{code} -ppr_expr :: (SDoc -> SDoc) -> PprEnv b -> Expr b -> SDoc +ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc -- The function adds parens in context that need -- an atomic value (e.g. function args) -ppr_expr add_par pe (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd +ppr_expr add_par (Type ty) = add_par (ptext SLIT("TYPE") <+> ppr ty) -- Wierd -ppr_expr add_par pe (Var name) = pOcc pe name -ppr_expr add_par pe (Lit lit) = ppr lit +ppr_expr add_par (Var name) = ppr name +ppr_expr add_par (Lit lit) = ppr lit -ppr_expr add_par pe expr@(Lam _ _) +ppr_expr add_par expr@(Lam _ _) = let (bndrs, body) = collectBinders expr in add_par $ - hang (ptext SLIT("\\") <+> sep (map (pBndr pe LambdaBind) bndrs) <+> arrow) - 2 (ppr_noparend_expr pe body) + hang (ptext SLIT("\\") <+> sep (map (pprBndr LambdaBind) bndrs) <+> arrow) + 2 (pprCoreExpr body) -ppr_expr add_par pe expr@(App fun arg) +ppr_expr add_par expr@(App fun arg) = case collectArgs expr of { (fun, args) -> let - pp_args = sep (map (ppr_arg pe) args) + pp_args = sep (map pprArg args) val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples - pp_tup_args = sep (punctuate comma (map (ppr_arg pe) val_args)) + pp_tup_args = sep (punctuate comma (map pprArg val_args)) in case fun of Var f -> case isDataConId_maybe f of @@ -192,109 +147,111 @@ ppr_expr add_par pe expr@(App fun arg) tc = dataConTyCon dc saturated = val_args `lengthIs` idArity f - other -> add_par (hang (pOcc pe f) 2 pp_args) + other -> add_par (hang (ppr f) 2 pp_args) - other -> add_par (hang (ppr_parend_expr pe fun) 2 pp_args) + other -> add_par (hang (pprParendExpr fun) 2 pp_args) } -ppr_expr add_par pe (Case expr var [(con,args,rhs)]) +ppr_expr add_par (Case expr var [(con,args,rhs)]) = add_par $ - sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr, + sep [sep [ptext SLIT("case") <+> pprCoreExpr expr, hsep [ptext SLIT("of"), ppr_bndr var, char '{', - ppr_case_pat pe con args + ppr_case_pat con args ]], - ppr_noparend_expr pe rhs, + pprCoreExpr rhs, char '}' ] where - ppr_bndr = pBndr pe CaseBind + ppr_bndr = pprBndr CaseBind -ppr_expr add_par pe (Case expr var alts) +ppr_expr add_par (Case expr var alts) = add_par $ - sep [sep [ptext SLIT("case") <+> ppr_noparend_expr pe expr, + sep [sep [ptext SLIT("case") <+> pprCoreExpr expr, ptext SLIT("of") <+> ppr_bndr var <+> char '{'], - nest 2 (sep (punctuate semi (map (ppr_alt pe) alts))), + nest 2 (sep (punctuate semi (map pprCoreAlt alts))), char '}' ] where - ppr_bndr = pBndr pe CaseBind + ppr_bndr = pprBndr CaseBind -- special cases: let ... in let ... -- ("disgusting" SLPJ) -ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) +{- +ppr_expr add_par (Let bind@(NonRec val_bdr rhs@(Let _ _)) body) = add_par $ vcat [ - hsep [ptext SLIT("let {"), pBndr pe LetBind val_bdr, equals], - nest 2 (ppr_noparend_expr pe rhs), + hsep [ptext SLIT("let {"), (pprBndr LetBind val_bdr $$ ppr val_bndr), equals], + nest 2 (pprCoreExpr rhs), ptext SLIT("} in"), - ppr_noparend_expr pe body ] + pprCoreExpr body ] +-} -ppr_expr add_par pe (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) +ppr_expr add_par (Let bind@(NonRec val_bdr rhs) expr@(Let _ _)) = add_par (hang (ptext SLIT("let {")) - 2 (hsep [hang (hsep [pBndr pe LetBind val_bdr, equals]) - 2 (ppr_noparend_expr pe rhs), - ptext SLIT("} in")]) + 2 (hsep [ppr_binding (val_bdr,rhs), + ptext SLIT("} in")]) $$ - ppr_noparend_expr pe expr) + pprCoreExpr expr) -- general case (recursive case, too) -ppr_expr add_par pe (Let bind expr) +ppr_expr add_par (Let bind expr) = add_par $ - sep [hang (ptext keyword) 2 (ppr_bind pe bind), - hang (ptext SLIT("} in ")) 2 (ppr_noparend_expr pe expr)] + sep [hang (ptext keyword) 2 (ppr_bind bind), + hang (ptext SLIT("} in ")) 2 (pprCoreExpr expr)] where keyword = case bind of Rec _ -> SLIT("__letrec {") NonRec _ _ -> SLIT("let {") -ppr_expr add_par pe (Note (SCC cc) expr) - = add_par (sep [pSCC pe cc, ppr_noparend_expr pe expr]) +ppr_expr add_par (Note (SCC cc) expr) + = add_par (sep [pprCostCentreCore cc, pprCoreExpr expr]) #ifdef DEBUG -ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr) +ppr_expr add_par (Note (Coerce to_ty from_ty) expr) = add_par $ getPprStyle $ \ sty -> if debugStyle sty then - sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty], - ppr_parend_expr pe expr] + sep [ptext SLIT("__coerce") <+> + sep [pprParendType to_ty, pprParendType from_ty], + pprParendExpr expr] else - sep [hsep [ptext SLIT("__coerce"), pTy pe to_ty], - ppr_parend_expr pe expr] + sep [hsep [ptext SLIT("__coerce"), pprParendType to_ty], + pprParendExpr expr] #else -ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr) +ppr_expr add_par (Note (Coerce to_ty from_ty) expr) = add_par $ - sep [sep [ptext SLIT("__coerce"), nest 2 (pTy pe to_ty)], - ppr_parend_expr pe expr] + sep [sep [ptext SLIT("__coerce"), nest 2 (pprParendType to_ty)], + pprParendExpr expr] #endif -ppr_expr add_par pe (Note InlineCall expr) - = add_par (ptext SLIT("__inline_call") <+> ppr_parend_expr pe expr) +ppr_expr add_par (Note InlineCall expr) + = add_par (ptext SLIT("__inline_call") <+> pprParendExpr expr) -ppr_expr add_par pe (Note InlineMe expr) - = add_par $ ptext SLIT("__inline_me") <+> ppr_parend_expr pe expr +ppr_expr add_par (Note InlineMe expr) + = add_par $ ptext SLIT("__inline_me") <+> pprParendExpr expr -ppr_alt pe (con, args, rhs) - = hang (ppr_case_pat pe con args) 2 (ppr_noparend_expr pe rhs) +pprCoreAlt (con, args, rhs) + = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs) -ppr_case_pat pe con@(DataAlt dc) args +ppr_case_pat con@(DataAlt dc) args | isTupleTyCon tc = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow where - ppr_bndr = pBndr pe CaseBind + ppr_bndr = pprBndr CaseBind tc = dataConTyCon dc -ppr_case_pat pe con args +ppr_case_pat con args = ppr con <+> hsep (map ppr_bndr args) <+> arrow where - ppr_bndr = pBndr pe CaseBind + ppr_bndr = pprBndr CaseBind -ppr_arg pe (Type ty) = ptext SLIT("@") <+> pTy pe ty -ppr_arg pe expr = ppr_parend_expr pe expr +pprArg (Type ty) = ptext SLIT("@") <+> pprParendType ty +pprArg expr = pprParendExpr expr arrow = ptext SLIT("->") \end{code} @@ -303,9 +260,12 @@ Other printing bits-and-bobs used with the general @pprCoreBinding@ and @pprCoreExpr@ functions. \begin{code} --- Used for printing dump info +instance OutputableBndr Var where + pprBndr = pprCoreBinder + +pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder LetBind binder - = vcat [sig, pprIdDetails binder, pragmas, ppr binder] + = vcat [sig, pprIdDetails binder, pragmas] where sig = pprTypedBinder binder pragmas = ppIdInfo binder (idInfo binder) @@ -322,12 +282,13 @@ pprUntypedBinder binder pprTypedBinder binder | isTyVar binder = ptext SLIT("@") <+> pprTyVarBndr binder - | otherwise = pprIdBndr binder <+> dcolon <+> pprParendType (idType binder) + | otherwise = pprIdBndr binder <+> dcolon <+> pprType (idType binder) -- The space before the :: is important; it helps the lexer -- when reading inferfaces. Otherwise it would lex "a::b" as one thing. -- -- It's important that the type is parenthesised too, at least when -- printing interfaces, because we get \ x::(a->b) y::(c->d) -> ... + -- [Jun 2002: interfaces are now binary, so this doesn't matter] -- pprIdBndr does *not* print the type -- When printing any Id binder in debug mode, we print its inline pragma and one-shot-ness @@ -358,7 +319,7 @@ ppIdInfo b info ppStrictnessInfo s, ppCprInfo m, #endif - ppr (newStrictnessInfo info), + pprNewStrictness (newStrictnessInfo info), vcat (map (pprCoreRule (ppr b)) (rulesRules p)) -- Inline pragma, occ, demand, lbvar info -- printed out with all binders (when debug is on); diff --git a/ghc/compiler/count_lines b/ghc/compiler/count_lines index 8c7905c4ea..aebf0c4080 100644 --- a/ghc/compiler/count_lines +++ b/ghc/compiler/count_lines @@ -54,6 +54,7 @@ printf "\n%-20s %6d %6d\n\n\n", 'TOTAL:', $tot, $totcmts; $tot = 0; $totcmts = 0; +printf "\n Code Comments\n" foreach $m (sort (keys %ModCount)) { printf "%-20s %6d %6d\n", $m, $ModCount{$m}, $ModComments{$m}; $tot += $ModCount{$m}; diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 1f64cf69c7..2fc2e8e089 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -11,17 +11,14 @@ module Check ( check , ExhaustivePat ) where import HsSyn -import TcHsSyn ( TypecheckedPat, outPatType ) -import TcType ( tcTyConAppTyCon, tcTyConAppArgs ) +import TcHsSyn ( TypecheckedPat, hsPatType ) +import TcType ( tcTyConAppTyCon ) import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet, CanItFail(..), tidyLitPat, tidyNPat, ) import Id ( idType ) -import DataCon ( DataCon, dataConTyCon, dataConArgTys, - dataConSourceArity, dataConFieldLabels ) +import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConFieldLabels ) import Name ( Name, mkInternalName, getOccName, isDataSymOcc, getName, mkVarOcc ) -import TcType ( mkTyVarTys ) -import TysPrim ( charPrimTy ) import TysWiredIn import PrelNames ( unboundKey ) import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon ) @@ -134,29 +131,27 @@ untidy_pars :: WarningPat -> WarningPat untidy_pars p = untidy True p untidy :: NeedPars -> WarningPat -> WarningPat -untidy _ p@WildPatIn = p -untidy _ p@(VarPatIn name) = p -untidy _ (LitPatIn lit) = LitPatIn (untidy_lit lit) -untidy _ p@(ConPatIn name []) = p -untidy b (ConPatIn name pats) = - pars b (ConPatIn name (map untidy_pars pats)) -untidy b (ConOpPatIn pat1 name fixity pat2) = - pars b (ConOpPatIn (untidy_pars pat1) name fixity (untidy_pars pat2)) -untidy _ (ListPatIn pats) = ListPatIn (map untidy_no_pars pats) -untidy _ (PArrPatIn pats) = - panic "Check.untidy: Shouldn't get a parallel array here!" -untidy _ (TuplePatIn pats boxed) = TuplePatIn (map untidy_no_pars pats) boxed - -untidy _ pat = pprPanic "Check.untidy: SigPatIn" (ppr pat) +untidy _ p@(WildPat _) = p +untidy _ p@(VarPat name) = p +untidy _ (LitPat lit) = LitPat (untidy_lit lit) +untidy _ p@(ConPatIn name (PrefixCon [])) = p +untidy b (ConPatIn name ps) = pars b (ConPatIn name (untidy_con ps)) +untidy _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty +untidy _ (TuplePat pats boxed) = TuplePat (map untidy_no_pars pats) boxed +untidy _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!" +untidy _ (SigPatIn _ _) = panic "Check.untidy: SigPat" + +untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats) +untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2) +untidy_con (RecCon bs) = RecCon [(f,untidy_pars p) | (f,p) <- bs] pars :: NeedPars -> WarningPat -> WarningPat -pars True p = ParPatIn p +pars True p = ParPat p pars _ p = p untidy_lit :: HsLit -> HsLit untidy_lit (HsCharPrim c) = HsChar c ---untidy_lit (HsStringPrim s) = HsString s -untidy_lit lit = lit +untidy_lit lit = lit \end{code} This equation is the same that check, the only difference is that the @@ -205,13 +200,14 @@ check' qs@((EqnInfo n ctx ps result):_) | literals = split_by_literals qs | constructors = split_by_constructor qs | only_vars = first_column_only_vars qs - | otherwise = panic "Check.check': Not implemented :-(" + | otherwise = pprPanic "Check.check': Not implemented :-(" (ppr first_pats) where -- Note: RecPats will have been simplified to ConPats -- at this stage. - constructors = or (map is_con qs) - literals = or (map is_lit qs) - only_vars = and (map is_var qs) + first_pats = ASSERT2( okGroup qs, pprGroup qs ) map firstPat qs + constructors = any is_con first_pats + literals = any is_lit first_pats + only_vars = all is_var first_pats -- npat = or (map is_npat qs) -- nplusk = or (map is_nplusk qs) \end{code} @@ -252,7 +248,8 @@ process_literals used_lits qs | otherwise = (pats_default,indexs_default) where (pats,indexs) = process_explicit_literals used_lits qs - default_eqns = (map remove_var (filter is_var qs)) + default_eqns = ASSERT2( okGroup qs, pprGroup qs ) + map remove_var (filter (is_var . firstPat) qs) (pats',indexs') = check' default_eqns pats_default = [(new_wild_pat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats indexs_default = unionUniqSets indexs' indexs @@ -267,13 +264,14 @@ construct_literal_matrix lit qs = (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs) where (pats,indexs) = (check' (remove_first_column_lit lit qs)) - new_lit = LitPatIn lit + new_lit = LitPat lit remove_first_column_lit :: HsLit -> [EquationInfo] -> [EquationInfo] -remove_first_column_lit lit qs = - map shift_pat (filter (is_var_lit lit) qs) +remove_first_column_lit lit qs + = ASSERT2( okGroup qs, pprGroup qs ) + map shift_pat (filter (is_var_lit lit . firstPat) qs) where shift_pat (EqnInfo n ctx [] result) = panic "Check.shift_var: no patterns" shift_pat (EqnInfo n ctx (_:ps) result) = EqnInfo n ctx ps result @@ -328,7 +326,7 @@ need_default_case used_cons unused_cons qs | otherwise = (pats_default,indexs_default) where (pats,indexs) = no_need_default_case used_cons qs - default_eqns = (map remove_var (filter is_var qs)) + default_eqns = ASSERT2( okGroup qs, pprGroup qs ) map remove_var (filter (is_var . firstPat) qs) (pats',indexs') = check' default_eqns pats_default = [(make_whole_con c:ps,constraints) | c <- unused_cons, (ps,constraints) <- pats'] ++ pats @@ -361,11 +359,12 @@ is transformed in: remove_first_column :: TypecheckedPat -- Constructor -> [EquationInfo] -> [EquationInfo] -remove_first_column (ConPat con _ _ _ con_pats) qs = - map shift_var (filter (is_var_con con) qs) +remove_first_column (ConPatOut con (PrefixCon con_pats) _ _ _) qs + = ASSERT2( okGroup qs, pprGroup qs ) + map shift_var (filter (is_var_con con . firstPat) qs) where - new_wilds = [WildPat (outPatType arg_pat) | arg_pat <- con_pats] - shift_var (EqnInfo n ctx (ConPat _ _ _ _ ps':ps) result) = + new_wilds = [WildPat (hsPatType arg_pat) | arg_pat <- con_pats] + shift_var (EqnInfo n ctx (ConPatOut _ (PrefixCon ps') _ _ _:ps) result) = EqnInfo n ctx (ps'++ps) result shift_var (EqnInfo n ctx (WildPat _ :ps) result) = EqnInfo n ctx (new_wilds ++ ps) result @@ -373,7 +372,7 @@ remove_first_column (ConPat con _ _ _ con_pats) qs = make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat make_row_vars used_lits (EqnInfo _ _ pats _ ) = - (VarPatIn new_var:takeList (tail pats) (repeat new_wild_pat),[(new_var,used_lits)]) + (VarPat new_var:takeList (tail pats) (repeat new_wild_pat),[(new_var,used_lits)]) where new_var = hash_x hash_x = mkInternalName unboundKey {- doesn't matter much -} @@ -384,7 +383,7 @@ make_row_vars_for_constructor :: EquationInfo -> [WarningPat] make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat new_wild_pat) compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool -compare_cons (ConPat id1 _ _ _ _) (ConPat id2 _ _ _ _) = id1 == id2 +compare_cons (ConPatOut id1 _ _ _ _) (ConPatOut id2 _ _ _ _) = id1 == id2 remove_dups :: [TypecheckedPat] -> [TypecheckedPat] remove_dups [] = [] @@ -392,7 +391,7 @@ remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups xs | otherwise = x : remove_dups xs get_used_cons :: [EquationInfo] -> [TypecheckedPat] -get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPat _ _ _ _ _):_) _) <- qs ] +get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPatOut _ _ _ _ _):_) _) <- qs ] remove_dups' :: [HsLit] -> [HsLit] remove_dups' [] = [] @@ -407,9 +406,9 @@ get_used_lits qs = remove_dups' all_literals get_used_lits' :: [EquationInfo] -> [HsLit] get_used_lits' [] = [] -get_used_lits' ((EqnInfo _ _ ((LitPat lit _):_) _):qs) = +get_used_lits' ((EqnInfo _ _ ((LitPat lit):_) _):qs) = lit : get_used_lits qs -get_used_lits' ((EqnInfo _ _ ((NPat lit _ _):_) _):qs) = +get_used_lits' ((EqnInfo _ _ ((NPatOut lit _ _):_) _):qs) = lit : get_used_lits qs get_used_lits' (q:qs) = get_used_lits qs @@ -417,11 +416,11 @@ get_used_lits' (q:qs) = get_unused_cons :: [TypecheckedPat] -> [DataCon] get_unused_cons used_cons = unused_cons where - (ConPat _ ty _ _ _) = head used_cons - ty_con = tcTyConAppTyCon ty -- Newtype observable - all_cons = tyConDataCons ty_con - used_cons_as_id = map (\ (ConPat d _ _ _ _) -> d) used_cons - unused_cons = uniqSetToList + (ConPatOut _ _ ty _ _) = head used_cons + ty_con = tcTyConAppTyCon ty -- Newtype observable + all_cons = tyConDataCons ty_con + used_cons_as_id = map (\ (ConPatOut d _ _ _ _) -> d) used_cons + unused_cons = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) all_vars :: [TypecheckedPat] -> Bool @@ -434,37 +433,56 @@ remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result remove_var _ = panic "Check.remove_var: equation does not begin with a variable" -is_con :: EquationInfo -> Bool -is_con (EqnInfo _ _ ((ConPat _ _ _ _ _):_) _) = True -is_con _ = False - -is_lit :: EquationInfo -> Bool -is_lit (EqnInfo _ _ ((LitPat _ _):_) _) = True -is_lit (EqnInfo _ _ ((NPat _ _ _):_) _) = True -is_lit _ = False - -is_npat :: EquationInfo -> Bool -is_npat (EqnInfo _ _ ((NPat _ _ _):_) _) = True -is_npat _ = False - -is_nplusk :: EquationInfo -> Bool -is_nplusk (EqnInfo _ _ ((NPlusKPat _ _ _ _ _):_) _) = True -is_nplusk _ = False - -is_var :: EquationInfo -> Bool -is_var (EqnInfo _ _ ((WildPat _):_) _) = True -is_var _ = False - -is_var_con :: DataCon -> EquationInfo -> Bool -is_var_con con (EqnInfo _ _ ((WildPat _):_) _) = True -is_var_con con (EqnInfo _ _ ((ConPat id _ _ _ _):_) _) | id == con = True -is_var_con con _ = False - -is_var_lit :: HsLit -> EquationInfo -> Bool -is_var_lit lit (EqnInfo _ _ ((WildPat _):_) _) = True -is_var_lit lit (EqnInfo _ _ ((LitPat lit' _):_) _) | lit == lit' = True -is_var_lit lit (EqnInfo _ _ ((NPat lit' _ _):_) _) | lit == lit' = True -is_var_lit lit _ = False +----------------------- +eqnPats :: EquationInfo -> [TypecheckedPat] +eqnPats (EqnInfo _ _ ps _) = ps + +firstPat :: EquationInfo -> TypecheckedPat +firstPat eqn_info = head (eqnPats eqn_info) + +okGroup :: [EquationInfo] -> Bool +-- True if all equations have at least one pattern, and +-- all have the same number of patterns +okGroup [] = True +okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es] + where + n_pats = length (eqnPats e) + +-- Half-baked print +pprGroup es = vcat (map pprEqnInfo es) +pprEqnInfo e = ppr (eqnPats e) + +is_con :: TypecheckedPat -> Bool +is_con (ConPatOut _ _ _ _ _) = True +is_con _ = False + +is_lit :: TypecheckedPat -> Bool +is_lit (LitPat _) = True +is_lit (NPatOut _ _ _) = True +is_lit _ = False + +is_npat :: TypecheckedPat -> Bool +is_npat (NPatOut _ _ _) = True +is_npat _ = False + +is_nplusk :: TypecheckedPat -> Bool +is_nplusk (NPlusKPatOut _ _ _ _) = True +is_nplusk _ = False + +is_var :: TypecheckedPat -> Bool +is_var (WildPat _) = True +is_var _ = False + +is_var_con :: DataCon -> TypecheckedPat -> Bool +is_var_con con (WildPat _) = True +is_var_con con (ConPatOut id _ _ _ _) | id == con = True +is_var_con con _ = False + +is_var_lit :: HsLit -> TypecheckedPat -> Bool +is_var_lit lit (WildPat _) = True +is_var_lit lit (LitPat lit') | lit == lit' = True +is_var_lit lit (NPatOut lit' _ _) | lit == lit' = True +is_var_lit lit _ = False \end{code} The difference beteewn @make_con@ and @make_whole_con@ is that @@ -507,59 +525,47 @@ not the second. \fbox{\ ???\ } \begin{code} isInfixCon con = isDataSymOcc (getOccName con) -is_nil (ConPatIn con []) = con == getName nilDataCon -is_nil _ = False +is_nil (ConPatIn con (PrefixCon [])) = con == getName nilDataCon +is_nil _ = False -is_list (ListPatIn _) = True +is_list (ListPat _ _) = True is_list _ = False return_list id q = id == consDataCon && (is_nil q || is_list q) -make_list p q | is_nil q = ListPatIn [p] -make_list p (ListPatIn ps) = ListPatIn (p:ps) -make_list _ _ = panic "Check.make_list: Invalid argument" +make_list p q | is_nil q = ListPat [p] placeHolderType +make_list p (ListPat ps ty) = ListPat (p:ps) ty +make_list _ _ = panic "Check.make_list: Invalid argument" make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat -make_con (ConPat id _ _ _ _) (p:q:ps, constraints) +make_con (ConPatOut id _ _ _ _) (p:q:ps, constraints) | return_list id q = (make_list p q : ps, constraints) - | isInfixCon id = ((ConOpPatIn p name fixity q) : ps, constraints) - where name = getName id - fixity = panic "Check.make_con: Guessing fixity" + | isInfixCon id = (ConPatIn (getName id) (InfixCon p q) : ps, constraints) -make_con (ConPat id _ _ _ pats) (ps, constraints) - | isTupleTyCon tc = (TuplePatIn pats_con (tupleTyConBoxity tc) : rest_pats, constraints) - | otherwise = (ConPatIn name pats_con : rest_pats, constraints) - where name = getName id - (pats_con, rest_pats) = splitAtList pats ps - tc = dataConTyCon id +make_con (ConPatOut id (PrefixCon pats) _ _ _) (ps, constraints) + | isTupleTyCon tc = (TuplePat pats_con (tupleTyConBoxity tc) : rest_pats, constraints) + | isPArrFakeCon id = (PArrPat pats_con placeHolderType : rest_pats, constraints) + | otherwise = (ConPatIn name (PrefixCon pats_con) : rest_pats, constraints) + where + name = getName id + (pats_con, rest_pats) = splitAtList pats ps + tc = dataConTyCon id -- reconstruct parallel array pattern -- -- * don't check for the type only; we need to make sure that we are really -- dealing with one of the fake constructors and not with the real -- representation --- -make_con (ConPat id _ _ _ pats) (ps, constraints) - | isPArrFakeCon id = (PArrPatIn patsCon : restPats, constraints) - | otherwise = (ConPatIn name patsCon : restPats, constraints) - where - name = getName id - (patsCon, restPats) = splitAtList pats ps - tc = dataConTyCon id - make_whole_con :: DataCon -> WarningPat -make_whole_con con | isInfixCon con = ConOpPatIn new_wild_pat name fixity new_wild_pat - | otherwise = ConPatIn name pats +make_whole_con con | isInfixCon con = ConPatIn name (InfixCon new_wild_pat new_wild_pat) + | otherwise = ConPatIn name (PrefixCon pats) where - fixity = panic "Check.make_whole_con: Guessing fixity" name = getName con - arity = dataConSourceArity con - pats = replicate arity new_wild_pat - + pats = [new_wild_pat | t <- dataConOrigArgTys con] new_wild_pat :: WarningPat -new_wild_pat = WildPatIn +new_wild_pat = WildPat placeHolderType \end{code} This equation makes the same thing as @tidy@ in @Match.lhs@, the @@ -581,83 +587,78 @@ simplify_pat :: TypecheckedPat -> TypecheckedPat simplify_pat pat@(WildPat gt) = pat simplify_pat (VarPat id) = WildPat (idType id) -simplify_pat (LazyPat p) = simplify_pat p -simplify_pat (AsPat id p) = simplify_pat p -simplify_pat (SigPat p ty fn) = simplify_pat p -- I'm not sure this is right +simplify_pat (ParPat p) = simplify_pat p +simplify_pat (LazyPat p) = simplify_pat p +simplify_pat (AsPat id p) = simplify_pat p +simplify_pat (SigPatOut p ty fn) = simplify_pat p -- I'm not sure this is right -simplify_pat (ConPat id ty tvs dicts ps) = ConPat id ty tvs dicts (map simplify_pat ps) +simplify_pat (ConPatOut id ps ty tvs dicts) = ConPatOut id (simplify_con id ps) ty tvs dicts -simplify_pat (ListPat ty ps) = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y]) - (ConPat nilDataCon list_ty [] [] []) +simplify_pat (ListPat ps ty) = foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty) + (mkNilPat list_ty) (map simplify_pat ps) where list_ty = mkListTy ty -- introduce fake parallel array constructors to be able to handle parallel -- arrays with the existing machinery for constructor pattern -- -simplify_pat (PArrPat ty ps) - = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] (map simplify_pat ps) +simplify_pat (PArrPat ps ty) + = ConPatOut (parrFakeCon arity) + (PrefixCon (map simplify_pat ps)) + (mkPArrTy ty) [] [] where arity = length ps simplify_pat (TuplePat ps boxity) - = ConPat (tupleCon boxity arity) - (mkTupleTy boxity arity (map outPatType ps)) [] [] - (map simplify_pat ps) + = ConPatOut (tupleCon boxity arity) + (PrefixCon (map simplify_pat ps)) + (mkTupleTy boxity arity (map hsPatType ps)) [] [] where arity = length ps -simplify_pat (RecPat dc ty ex_tvs dicts []) - = ConPat dc ty ex_tvs dicts all_wild_pats - where - all_wild_pats = map WildPat con_arg_tys - - -- Identical to machinations in Match.tidy1: - inst_tys = tcTyConAppArgs ty -- Newtype is observable - con_arg_tys = dataConArgTys dc (inst_tys ++ mkTyVarTys ex_tvs) - -simplify_pat (RecPat dc ty ex_tvs dicts idps) - = ConPat dc ty ex_tvs dicts pats - where - pats = map (simplify_pat.snd) all_pats - - -- pad out all the missing fields with WildPats. - field_pats = map (\ f -> (getName f, WildPat (panic "simplify_pat(RecPat-2)"))) - (dataConFieldLabels dc) - all_pats = - foldr - ( \ (id,p,_) acc -> insertNm (getName id) p acc) - field_pats - idps - - insertNm nm p [] = [(nm,p)] - insertNm nm p (x@(n,_):xs) - | nm == n = (nm,p):xs - | otherwise = x : insertNm nm p xs - -simplify_pat pat@(LitPat lit lit_ty) = tidyLitPat lit pat +simplify_pat pat@(LitPat lit) = tidyLitPat lit pat -- unpack string patterns fully, so we can see when they overlap with -- each other, or even explicit lists of Chars. -simplify_pat pat@(NPat (HsString s) _ _) = - foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat]) - (ConPat nilDataCon stringTy [] [] []) (unpackIntFS s) +simplify_pat pat@(NPatOut (HsString s) _ _) = + foldr (\c pat -> ConPatOut consDataCon (PrefixCon [mk_char_lit c,pat]) stringTy [] []) + (ConPatOut nilDataCon (PrefixCon []) stringTy [] []) (unpackIntFS s) where - mk_char_lit c = ConPat charDataCon charTy [] [] - [LitPat (HsCharPrim c) charPrimTy] + mk_char_lit c = ConPatOut charDataCon (PrefixCon [LitPat (HsCharPrim c)]) + charTy [] [] -simplify_pat pat@(NPat lit lit_ty hsexpr) = tidyNPat lit lit_ty pat +simplify_pat pat@(NPatOut lit lit_ty hsexpr) = tidyNPat lit lit_ty pat -simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) = - WildPat ty - where ty = panic "Check.simplify_pat: Gessing ty" +simplify_pat (NPlusKPatOut id hslit hsexpr1 hsexpr2) + = WildPat (idType id) -simplify_pat (DictPat dicts methods) = - case num_of_d_and_ms of +simplify_pat (DictPat dicts methods) + = case num_of_d_and_ms of 0 -> simplify_pat (TuplePat [] Boxed) 1 -> simplify_pat (head dict_and_method_pats) _ -> simplify_pat (TuplePat dict_and_method_pats Boxed) where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map VarPat (dicts ++ methods) + +----------------- +simplify_con con (PrefixCon ps) = PrefixCon (map simplify_pat ps) +simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_pat p1, simplify_pat p2] +simplify_con con (RecCon fs) + | null fs = PrefixCon [wild_pat | t <- dataConOrigArgTys con] + -- Special case for null patterns; maybe not a record at all + | otherwise = PrefixCon (map (simplify_pat.snd) all_pats) + where + -- pad out all the missing fields with WildPats. + field_pats = map (\ f -> (getName f, wild_pat)) + (dataConFieldLabels con) + all_pats = foldr (\ (id,p) acc -> insertNm (getName id) p acc) + field_pats fs + + insertNm nm p [] = [(nm,p)] + insertNm nm p (x@(n,_):xs) + | nm == n = (nm,p):xs + | otherwise = x : insertNm nm p xs + + wild_pat = WildPat (panic "Check.simplify_con") \end{code} diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 55152d9e84..7100acbb2b 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -4,18 +4,19 @@ \section[Desugar]{@deSugar@: the main function} \begin{code} -module Desugar ( deSugar, deSugarExpr, - deSugarCore ) where +module Desugar ( deSugar, deSugarExpr ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn ) -import HscTypes ( ModDetails(..), TypeEnv ) +import CmdLineOpts ( DynFlag(..), dopt, opt_SccProfilingOn ) +import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), ExternalPackageState(..), + PersistentCompilerState(..), + lookupType ) import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), HsExpr(..), HsBinds(..), MonoBinds(..) ) -import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr, - TypecheckedCoreBind ) -import TcModule ( TcResults(..) ) +import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr ) +import TcRnTypes ( TcGblEnv(..), ImportAvails(imp_mods) ) +import MkIface ( mkUsageInfo ) import Id ( Id ) import CoreSyn import PprCore ( pprIdRules, pprCoreExpr ) @@ -26,18 +27,18 @@ import DsBinds ( dsMonoBinds, AutoScc(..) ) import DsForeign ( dsForeigns ) import DsExpr () -- Forces DsExpr to be compiled; DsBinds only -- depends on DsExpr.hi-boot. -import Module ( Module ) +import Module ( Module, moduleEnvElts ) import Id ( Id ) import NameEnv ( lookupNameEnv ) import VarEnv import VarSet import Bag ( isEmptyBag ) import CoreLint ( showPass, endPass ) -import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings ) +import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, addShortWarnLocLine ) import Outputable import UniqSupply ( mkSplitUniqSupply ) -import HscTypes ( HomeSymbolTable, PersistentCompilerState(..), TyThing(..), lookupType, ) import FastString +import DATA_IOREF ( readIORef ) \end{code} %************************************************************************ @@ -46,70 +47,92 @@ import FastString %* * %************************************************************************ -The only trick here is to get the @DsMonad@ stuff off to a good -start. - \begin{code} -deSugar :: DynFlags - -> PersistentCompilerState -> HomeSymbolTable - -> Module -> PrintUnqualified - -> TcResults - -> IO (ModDetails, (SDoc, SDoc, [FastString], [CoreBndr])) - -deSugar dflags pcs hst mod_name unqual - (TcResults {tc_env = type_env, - tc_binds = all_binds, - tc_insts = insts, - tc_rules = rules, - tc_fords = fo_decls}) +deSugar :: HscEnv -> PersistentCompilerState + -> TcGblEnv -> IO ModGuts + +deSugar hsc_env pcs + (TcGblEnv { tcg_mod = mod, + tcg_type_env = type_env, + tcg_usages = usage_var, + tcg_imports = imports, + tcg_exports = exports, + tcg_rdr_env = rdr_env, + tcg_fix_env = fix_env, + tcg_deprecs = deprecs, + tcg_insts = insts, + tcg_binds = binds, + tcg_fords = fords, + tcg_rules = rules }) = do { showPass dflags "Desugar" ; us <- mkSplitUniqSupply 'd' + ; usages <- readIORef usage_var -- Do desugaring - ; let (ds_result, ds_warns) = initDs dflags us lookup mod_name - (dsProgram mod_name all_binds rules fo_decls) - - (ds_binds, ds_rules, foreign_stuff) = ds_result - - mod_details = ModDetails { md_types = type_env, - md_insts = insts, - md_rules = ds_rules, - md_binds = ds_binds } + ; let ((ds_binds, ds_rules, ds_fords), ds_warns) + = initDs dflags us lookup mod + (dsProgram binds rules fords) + + warn_doc = pprBagOfWarnings (mapBag mk_warn ds_warns)) -- Display any warnings ; doIfSet (not (isEmptyBag ds_warns)) - (printErrs unqual (pprBagOfWarnings ds_warns)) + (printErrs warn_doc) -- Lint result if necessary ; endPass dflags "Desugar" Opt_D_dump_ds ds_binds -- Dump output ; doIfSet (dopt Opt_D_dump_ds dflags) - (printDump (ppr_ds_rules ds_rules)) - - ; return (mod_details, foreign_stuff) + (printDump (ppr_ds_rules ds_rules)) + + ; let + mod_guts = ModGuts { + mg_module = mod, + mg_exports = exports, + mg_usages = mkUsageInfo hsc_env eps imports usages, + mg_dir_imps = [m | (m,_) <- moduleEnvElts (imp_mods imports)], + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_deprecs = deprecs, + mg_types = type_env, + mg_insts = insts, + mg_rules = ds_rules, + mg_binds = ds_binds, + mg_foreign = ds_fords } + + ; return mod_guts } where + dflags = hsc_dflags hsc_env + print_unqual = unQualInScope rdr_env + + -- Desugarer warnings are SDocs; here we + -- add the info about whether or not to print unqualified + mk_warn (loc,sdoc) = (loc, addShortWarnLocLine loc print_unqual sdoc) + -- The lookup function passed to initDs is used for well-known Ids, -- such as fold, build, cons etc, so the chances are -- it'll be found in the package symbol table. That's -- why we don't merge all these tables - pte = pcs_PTE pcs - lookup n = case lookupType hst pte n of { - Just (AnId v) -> v ; + eps = pcs_EPS pcs + pte = eps_PTE eps + hpt = hsc_HPT hsc_env + lookup n = case lookupType hpt pte n of { + Just v -> v ; other -> case lookupNameEnv type_env n of - Just (AnId v) -> v ; + Just v -> v ; other -> pprPanic "Desugar: lookup:" (ppr n) } -deSugarExpr :: DynFlags - -> PersistentCompilerState -> HomeSymbolTable +deSugarExpr :: HscEnv + -> PersistentCompilerState -> Module -> PrintUnqualified -> TypecheckedHsExpr -> IO CoreExpr -deSugarExpr dflags pcs hst mod_name unqual tc_expr +deSugarExpr hsc_env pcs mod_name unqual tc_expr = do { showPass dflags "Desugar" ; us <- mkSplitUniqSupply 'd' @@ -118,7 +141,7 @@ deSugarExpr dflags pcs hst mod_name unqual tc_expr -- Display any warnings ; doIfSet (not (isEmptyBag ds_warns)) - (printErrs unqual (pprBagOfWarnings ds_warns)) + (printErrs (pprBagOfWarnings ds_warns)) -- Dump output ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr) @@ -126,14 +149,16 @@ deSugarExpr dflags pcs hst mod_name unqual tc_expr ; return core_expr } where - pte = pcs_PTE pcs - lookup n = case lookupType hst pte n of - Just (AnId v) -> v - other -> pprPanic "Desugar: lookup:" (ppr n) - -dsProgram mod_name all_binds rules fo_decls + dflags = hsc_dflags hsc_env + hpt = hsc_HPT hsc_env + pte = eps_PTE (pcs_EPS pcs) + lookup n = case lookupType hpt pte n of + Just v -> v + other -> pprPanic "Desugar: lookup:" (ppr n) + +dsProgram all_binds rules fo_decls = dsMonoBinds auto_scc all_binds [] `thenDs` \ core_prs -> - dsForeigns mod_name fo_decls `thenDs` \ (fe_binders, foreign_binds, h_code, c_code, headers) -> + dsForeigns fo_decls `thenDs` \ (ds_fords, foreign_binds) -> let ds_binds = [Rec (foreign_binds ++ core_prs)] -- Notice that we put the whole lot in a big Rec, even the foreign binds @@ -144,8 +169,8 @@ dsProgram mod_name all_binds rules fo_decls local_binders = mkVarSet (bindersOfBinds ds_binds) in - mapDs (dsRule local_binders) rules `thenDs` \ rules' -> - returnDs (ds_binds, rules', (h_code, c_code, headers, fe_binders)) + mapDs (dsRule local_binders) rules `thenDs` \ ds_rules -> + returnDs (ds_binds, ds_rules, ds_fords) where auto_scc | opt_SccProfilingOn = TopLevel | otherwise = NoSccs @@ -156,23 +181,6 @@ ppr_ds_rules rules pprIdRules rules \end{code} -Simplest thing in the world, desugaring External Core: - -\begin{code} -deSugarCore :: (TypeEnv, [TypecheckedCoreBind], [TypecheckedRuleDecl]) - -> IO (ModDetails, (SDoc, SDoc, [FastString], [CoreBndr])) -deSugarCore (type_env, pairs, rules) - = return (mod_details, no_foreign_stuff) - where - mod_details = ModDetails { md_types = type_env - , md_insts = [] - , md_rules = ds_rules - , md_binds = ds_binds } - ds_binds = [Rec pairs] - ds_rules = [(fun,rule) | IfaceRuleOut fun rule <- rules] - - no_foreign_stuff = (empty,empty,[],[]) -\end{code} %************************************************************************ diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 4f2323d4ed..a62b9692e4 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -14,14 +14,14 @@ module DsBinds ( dsMonoBinds, AutoScc(..) ) where import {-# SOURCE #-} DsExpr( dsExpr ) +import DsMonad +import DsGRHSs ( dsGuarded ) +import DsUtils import HsSyn -- lots of things import CoreSyn -- lots of things import CoreUtils ( exprType, mkInlineMe, mkSCC ) import TcHsSyn ( TypecheckedMonoBinds ) -import DsMonad -import DsGRHSs ( dsGuarded ) -import DsUtils import Match ( matchWrapper ) import CmdLineOpts ( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs ) diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index a207c4d7ca..bc8a1f58f0 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -4,18 +4,32 @@ \section[DsExpr]{Matching expressions (Exprs)} \begin{code} -module DsExpr ( dsExpr, dsLet ) where +module DsExpr ( dsExpr, dsLet, dsLit ) where #include "HsVersions.h" +import Match ( matchWrapper, matchSimply ) +import MatchLit ( dsLit ) +import DsBinds ( dsMonoBinds, AutoScc(..) ) +import DsGRHSs ( dsGuarded ) +import DsCCall ( dsCCall ) +import DsListComp ( dsListComp, dsPArrComp ) +import DsUtils ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr) +import DsMonad + +#ifdef GHCI + -- Template Haskell stuff iff bootstrapped +import DsMeta ( dsBracket ) +#endif + import HsSyn ( failureFreePat, - HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..), + HsExpr(..), Pat(..), HsLit(..), ArithSeqInfo(..), Stmt(..), HsMatchContext(..), HsDoContext(..), - Match(..), HsBinds(..), MonoBinds(..), + Match(..), HsBinds(..), MonoBinds(..), HsConDetails(..), mkSimpleMatch ) -import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, outPatType ) +import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, hsPatType ) -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types (newtypes etc), and sometimes not @@ -23,38 +37,24 @@ import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, outPat -- Sigh. This is a pain. import TcType ( tcSplitAppTy, tcSplitFunTys, tcTyConAppArgs, - isIntegerTy, tcSplitTyConApp, isUnLiftedType, Type ) + tcSplitTyConApp, isUnLiftedType, Type ) import Type ( splitFunTys ) import CoreSyn import CoreUtils ( exprType, mkIfThenElse, bindNonRec ) -import DsMonad -import DsBinds ( dsMonoBinds, AutoScc(..) ) -import DsGRHSs ( dsGuarded ) -import DsCCall ( dsCCall, resultWrapper ) -import DsListComp ( dsListComp, dsPArrComp ) -import DsUtils ( mkErrorAppDs, mkStringLit, mkStringLitFS, - mkConsExpr, mkNilExpr, mkIntegerLit - ) -import Match ( matchWrapper, matchSimply ) - import FieldLabel ( FieldLabel, fieldLabelTyCon ) import CostCentre ( mkUserCC ) import Id ( Id, idType, recordSelectorFieldLabel ) import PrelInfo ( rEC_CON_ERROR_ID, iRREFUT_PAT_ERROR_ID ) import DataCon ( DataCon, dataConWrapId, dataConFieldLabels, dataConInstOrigArgTys ) import DataCon ( isExistentialDataCon ) -import Literal ( Literal(..) ) import TyCon ( tyConDataCons ) -import TysWiredIn ( tupleCon, charDataCon, intDataCon ) +import TysWiredIn ( tupleCon ) import BasicTypes ( RecFlag(..), Boxity(..), ipNameName ) -import Maybes ( maybeToBool ) -import PrelNames ( hasKey, ratioTyConKey, toPName ) +import PrelNames ( toPName ) import Util ( zipEqual, zipWithEqual ) import Outputable import FastString - -import Ratio ( numerator, denominator ) \end{code} @@ -146,6 +146,7 @@ dsLet (MonoBind binds sigs is_rec) body \begin{code} dsExpr :: TypecheckedHsExpr -> DsM CoreExpr +dsExpr (HsPar x) = dsExpr x dsExpr (HsVar var) = returnDs (Var var) dsExpr (HsIPVar ip) = returnDs (Var (ipNameName ip)) dsExpr (HsLit lit) = dsLit lit @@ -330,7 +331,7 @@ dsExpr (ExplicitList ty xs) -- here at compile time -- dsExpr (ExplicitPArr ty xs) - = dsLookupGlobalValue toPName `thenDs` \toP -> + = dsLookupGlobalId toPName `thenDs` \toP -> dsExpr (ExplicitList ty xs) `thenDs` \coreList -> returnDs (mkApps (Var toP) [Type ty, coreList]) @@ -412,7 +413,7 @@ dsExpr (RecordConOut data_con con_expr rbinds) -- hence TcType.tcSplitFunTys mk_arg (arg_ty, lbl) - = case [rhs | (sel_id,rhs,_) <- rbinds, + = case [rhs | (sel_id,rhs) <- rbinds, lbl == recordSelectorFieldLabel sel_id] of (rhs:rhss) -> ASSERT( null rhss ) dsExpr rhs @@ -467,7 +468,7 @@ dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty rbinds) out_inst_tys = tcTyConAppArgs record_out_ty -- Newtype opaque mk_val_arg field old_arg_id - = case [rhs | (sel_id, rhs, _) <- rbinds, + = case [rhs | (sel_id, rhs) <- rbinds, field == recordSelectorFieldLabel sel_id] of (rhs:rest) -> ASSERT(null rest) rhs [] -> HsVar old_arg_id @@ -481,7 +482,7 @@ dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty rbinds) rhs = foldl HsApp (TyApp (HsVar (dataConWrapId con)) out_inst_tys) val_args in - returnDs (mkSimpleMatch [ConPat con record_in_ty [] [] (map VarPat arg_ids)] + returnDs (mkSimpleMatch [ConPatOut con (PrefixCon (map VarPat arg_ids)) record_in_ty [] []] rhs record_out_ty src_loc) @@ -502,7 +503,7 @@ dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty rbinds) where updated_fields :: [FieldLabel] - updated_fields = [recordSelectorFieldLabel sel_id | (sel_id,_,_) <- rbinds] + updated_fields = [recordSelectorFieldLabel sel_id | (sel_id,_) <- rbinds] -- Get the type constructor from the first field label, -- so that we are sure it'll have all its DataCons @@ -538,6 +539,19 @@ dsExpr (DictApp expr dicts) -- becomes a curried application returnDs (foldl (\f d -> f `App` (Var d)) core_expr dicts) \end{code} +Here is where we desugar the Template Haskell brackets and escapes + +\begin{code} +-- Template Haskell stuff + +#ifdef GHCI /* Only if bootstrapping */ +dsExpr (HsBracketOut x ps) = dsBracket x ps +dsExpr (HsSplice n e) = pprPanic "dsExpr:splice" (ppr e) +#endif + +\end{code} + + \begin{code} #ifdef DEBUG @@ -601,7 +615,7 @@ dsDo do_or_lc stmts ids@[return_id, fail_id, bind_id, then_id] result_ty = putSrcLocDs locn $ dsExpr expr `thenDs` \ expr2 -> let - a_ty = outPatType pat + a_ty = hsPatType pat fail_expr = HsApp (TyApp (HsVar fail_id) [b_ty]) (HsLit (HsString (mkFastString msg))) msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn) @@ -624,52 +638,3 @@ dsDo do_or_lc stmts ids@[return_id, fail_id, bind_id, then_id] result_ty where do_expr expr locn = putSrcLocDs locn (dsExpr expr) \end{code} - - -%************************************************************************ -%* * -\subsection[DsExpr-literals]{Literals} -%* * -%************************************************************************ - -We give int/float literals type @Integer@ and @Rational@, respectively. -The typechecker will (presumably) have put \tr{from{Integer,Rational}s} -around them. - -ToDo: put in range checks for when converting ``@i@'' -(or should that be in the typechecker?) - -For numeric literals, we try to detect there use at a standard type -(@Int@, @Float@, etc.) are directly put in the right constructor. -[NB: down with the @App@ conversion.] - -See also below where we look for @DictApps@ for \tr{plusInt}, etc. - -\begin{code} -dsLit :: HsLit -> DsM CoreExpr -dsLit (HsChar c) = returnDs (mkConApp charDataCon [mkLit (MachChar c)]) -dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c)) -dsLit (HsString str) = mkStringLitFS str -dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s)) -dsLit (HsInteger i) = mkIntegerLit i -dsLit (HsInt i) = returnDs (mkConApp intDataCon [mkIntLit i]) -dsLit (HsIntPrim i) = returnDs (mkIntLit i) -dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f)) -dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d)) -dsLit (HsLitLit str ty) - = ASSERT( maybeToBool maybe_ty ) - returnDs (wrap_fn (mkLit (MachLitLit str rep_ty))) - where - (maybe_ty, wrap_fn) = resultWrapper ty - Just rep_ty = maybe_ty - -dsLit (HsRat r ty) - = mkIntegerLit (numerator r) `thenDs` \ num -> - mkIntegerLit (denominator r) `thenDs` \ denom -> - returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom]) - where - (ratio_data_con, integer_ty) - = case tcSplitTyConApp ty of - (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) - (head (tyConDataCons tycon), i_ty) -\end{code} diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index dd118ad6a8..c5c4dedc7c 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -21,7 +21,7 @@ import TcHsSyn ( TypecheckedForeignDecl ) import CoreUtils ( exprType, mkInlineMe ) import Id ( Id, idType, idName, mkSysLocal, setInlinePragma ) import Literal ( Literal(..) ) -import Module ( Module, moduleString ) +import Module ( moduleString ) import Name ( getOccString, NamedThing(..) ) import OccName ( encodeFS ) import Type ( repType, eqType ) @@ -30,6 +30,7 @@ import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp, tcSplitForAllTys, tcSplitFunTys, tcTyConAppArgs, ) +import HscTypes ( ForeignStubs(..) ) import ForeignCall ( ForeignCall(..), CCallSpec(..), Safety(..), playSafe, CExportSpec(..), @@ -41,7 +42,6 @@ import TysWiredIn ( unitTy, stablePtrTyCon ) import TysPrim ( addrPrimTy ) import PrelNames ( hasKey, ioTyConKey, newStablePtrName, bindIOName ) import BasicTypes ( Activation( NeverActive ) ) -import ErrUtils ( addShortWarnLocLine ) import Outputable import Maybe ( fromJust ) import FastString @@ -64,36 +64,28 @@ so we reuse the desugaring code in @DsCCall@ to deal with these. type Binding = (Id, CoreExpr) -- No rec/nonrec structure; -- the occurrence analyser will sort it all out -dsForeigns :: Module - -> [TypecheckedForeignDecl] - -> DsM ( [Id] -- Foreign-exported binders; - -- we have to generate code to register these - , [Binding] - , 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 - ) -dsForeigns mod_name fos - = foldlDs combine ([], [], empty, empty, []) fos +dsForeigns :: [TypecheckedForeignDecl] + -> DsM (ForeignStubs, [Binding]) +dsForeigns fos + = foldlDs combine (ForeignStubs empty empty [] [], []) fos where - combine (acc_feb, acc_f, acc_h, acc_c, acc_header) + combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) (ForeignImport id _ spec depr loc) - = dsFImport mod_name id spec `thenDs` \(bs, h, c, hd) -> + = dsFImport id spec `thenDs` \(bs, h, c, hd) -> warnDepr depr loc `thenDs` \_ -> - returnDs (acc_feb, bs ++ acc_f, h $$ acc_h, c $$ acc_c, hd ++ acc_header) + returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) (hd ++ acc_hdrs) acc_feb, + bs ++ acc_f) - combine (acc_feb, acc_f, acc_h, acc_c, acc_header) + combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) (ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) depr loc) - = dsFExport mod_name id (idType id) + = dsFExport id (idType id) ext_nm cconv False `thenDs` \(h, c) -> warnDepr depr loc `thenDs` \_ -> - returnDs (id:acc_feb, acc_f, h $$ acc_h, c $$ acc_c, acc_header) + returnDs (ForeignStubs (h $$ acc_h) (c $$ acc_c) acc_hdrs (id:acc_feb), + acc_f) warnDepr False _ = returnDs () - warnDepr True loc = dsWarn (addShortWarnLocLine loc msg) + warnDepr True loc = dsWarn (loc, msg) where msg = ptext SLIT("foreign declaration uses deprecated non-standard syntax") \end{code} @@ -124,36 +116,34 @@ inside returned tuples; but inlining this wrapper is a Really Good Idea because it exposes the boxing to the call site. \begin{code} -dsFImport :: Module - -> Id +dsFImport :: Id -> ForeignImport -> DsM ([Binding], SDoc, SDoc, [FastString]) -dsFImport modName id (CImport cconv safety header lib spec) - = dsCImport modName id spec cconv safety `thenDs` \(ids, h, c) -> +dsFImport id (CImport cconv safety header lib spec) + = dsCImport id spec cconv safety `thenDs` \(ids, h, c) -> returnDs (ids, h, c, if nullFastString header then [] else [header]) -- FIXME: the `lib' field is needed for .NET ILX generation when invoking -- routines that are external to the .NET runtime, but GHC doesn't -- support such calls yet; if `nullFastString lib', the value was not given -dsFImport modName id (DNImport spec) - = dsFCall modName id (DNCall spec) `thenDs` \(ids, h, c) -> +dsFImport id (DNImport spec) + = dsFCall id (DNCall spec) `thenDs` \(ids, h, c) -> returnDs (ids, h, c, []) -dsCImport :: Module - -> Id +dsCImport :: Id -> CImportSpec -> CCallConv -> Safety -> DsM ([Binding], SDoc, SDoc) -dsCImport modName id (CLabel cid) _ _ +dsCImport id (CLabel cid) _ _ = ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this returnDs ([(id, rhs)], empty, empty) where (resTy, foRhs) = resultWrapper (idType id) rhs = foRhs (mkLit (MachLabel cid)) -dsCImport modName id (CFunction target) cconv safety - = dsFCall modName id (CCall (CCallSpec target cconv safety)) -dsCImport modName id CWrapper cconv _ - = dsFExportDynamic modName id cconv +dsCImport id (CFunction target) cconv safety + = dsFCall id (CCall (CCallSpec target cconv safety)) +dsCImport id CWrapper cconv _ + = dsFExportDynamic id cconv \end{code} @@ -164,7 +154,7 @@ dsCImport modName id CWrapper cconv _ %************************************************************************ \begin{code} -dsFCall mod_Name fn_id fcall +dsFCall fn_id fcall = let ty = idType fn_id (tvs, fun_ty) = tcSplitForAllTys ty @@ -225,8 +215,7 @@ For each `@foreign export foo@' in a module M we generate: the user-written Haskell function `@M.foo@'. \begin{code} -dsFExport :: Module - -> Id -- Either the exported Id, +dsFExport :: Id -- Either the exported Id, -- or the foreign-export-dynamic constructor -> Type -- The type of the thing callable from C -> CLabelString -- The name to export to C land @@ -238,7 +227,7 @@ dsFExport :: Module , SDoc -- contents of Module_stub.c ) -dsFExport mod_name fn_id ty ext_name cconv isDyn +dsFExport fn_id ty ext_name cconv isDyn = let (tvs,sans_foralls) = tcSplitForAllTys ty @@ -265,8 +254,6 @@ dsFExport mod_name fn_id ty ext_name cconv isDyn ) `thenDs` \ (res_ty, -- t is_IO_res_ty) -> -- Bool - getModuleDs - `thenDs` \ mod -> let (h_stub, c_stub) = mkFExportCBits ext_name @@ -299,23 +286,23 @@ foreign export "f_helper" f_helper :: StablePtr (Addr -> Int -> IO Int) -> Addr \end{verbatim} \begin{code} -dsFExportDynamic :: Module - -> Id +dsFExportDynamic :: Id -> CCallConv -> DsM ([Binding], SDoc, SDoc) -dsFExportDynamic mod_name id cconv - = newSysLocalDs ty `thenDs` \ fe_id -> +dsFExportDynamic id cconv + = newSysLocalDs ty `thenDs` \ fe_id -> + getModuleDs `thenDs` \ mod_name -> let -- hack: need to get at the name of the C stub we're about to generate. fe_nm = mkFastString (moduleString mod_name ++ "_" ++ toCName fe_id) in - dsFExport mod_name id export_ty fe_nm cconv True `thenDs` \ (h_code, c_code) -> - newSysLocalDs arg_ty `thenDs` \ cback -> - dsLookupGlobalValue newStablePtrName `thenDs` \ newStablePtrId -> + dsFExport id export_ty fe_nm cconv True `thenDs` \ (h_code, c_code) -> + newSysLocalDs arg_ty `thenDs` \ cback -> + dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId -> let mk_stbl_ptr_app = mkApps (Var newStablePtrId) [ Type arg_ty, Var cback ] in - dsLookupGlobalValue bindIOName `thenDs` \ bindIOId -> + dsLookupGlobalId bindIOName `thenDs` \ bindIOId -> newSysLocalDs (mkTyConApp stablePtrTyCon [arg_ty]) `thenDs` \ stbl_value -> let stbl_app cont ret_ty diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 88c76f6de6..ee25c8b780 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -12,11 +12,11 @@ import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) import BasicTypes ( Boxity(..) ) import TyCon ( tyConName ) -import HsSyn ( OutPat(..), HsExpr(..), Stmt(..), +import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsMatchContext(..), HsDoContext(..), - collectHsOutBinders ) + collectHsBinders ) import TcHsSyn ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr, - outPatType ) + hsPatType ) import CoreSyn import DsMonad -- the monadery used in the desugarer @@ -30,7 +30,7 @@ import Type ( mkTyVarTy, mkFunTys, mkFunTy, Type, splitTyConApp_maybe ) import TysPrim ( alphaTyVar ) import TysWiredIn ( nilDataCon, consDataCon, unitDataConId, unitTy, - mkListTy, mkTupleTy, intDataCon ) + mkListTy, mkTupleTy ) import Match ( matchSimply ) import PrelNames ( trueDataConName, falseDataConName, foldrName, buildName, replicatePName, mapPName, filterPName, @@ -64,7 +64,7 @@ dsListComp quals elt_ty in newSysLocalsDs [c_ty,n_ty] `thenDs` \ [c, n] -> dfListComp c n quals `thenDs` \ result -> - dsLookupGlobalValue buildName `thenDs` \ build_id -> + dsLookupGlobalId buildName `thenDs` \ build_id -> returnDs (Var build_id `App` Type elt_ty `App` mkLams [n_tyvar, c, n] result) @@ -189,7 +189,7 @@ deBindComp pat core_list1 quals core_list2 u3_ty@u1_ty = exprType core_list1 -- two names, same thing -- u1_ty is a [alpha] type, and u2_ty = alpha - u2_ty = outPatType pat + u2_ty = hsPatType pat res_ty = exprType core_list2 h_ty = u1_ty `mkFunTy` res_ty @@ -304,7 +304,7 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals) = dsExpr list1 `thenDs` \ core_list1 -> -- find the required type - let x_ty = outPatType pat + let x_ty = hsPatType pat b_ty = idType n_id in @@ -319,7 +319,7 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals) pat core_rest (Var b) `thenDs` \ core_expr -> -- now build the outermost foldr, and return - dsLookupGlobalValue foldrName `thenDs` \ foldr_id -> + dsLookupGlobalId foldrName `thenDs` \ foldr_id -> returnDs ( Var foldr_id `App` Type x_ty `App` Type b_ty @@ -345,9 +345,9 @@ dsPArrComp :: [TypecheckedStmt] -> Type -- Don't use; called with `undefined' below -> DsM CoreExpr dsPArrComp qs _ = - dsLookupGlobalValue replicatePName `thenDs` \repP -> + dsLookupGlobalId replicatePName `thenDs` \repP -> let unitArray = mkApps (Var repP) [Type unitTy, - mkConApp intDataCon [mkIntLit 1], + mkIntExpr 1, mkTupleExpr []] in dePArrComp qs (TuplePat [] Boxed) unitArray @@ -362,7 +362,7 @@ dePArrComp :: [TypecheckedStmt] -- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea -- dePArrComp [ResultStmt e' _] pa cea = - dsLookupGlobalValue mapPName `thenDs` \mapP -> + dsLookupGlobalId mapPName `thenDs` \mapP -> let ty = parrElemType cea in deLambda ty pa e' `thenDs` \(clam, @@ -372,7 +372,7 @@ dePArrComp [ResultStmt e' _] pa cea = -- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea) -- dePArrComp (ExprStmt b _ _ : qs) pa cea = - dsLookupGlobalValue filterPName `thenDs` \filterP -> + dsLookupGlobalId filterPName `thenDs` \filterP -> let ty = parrElemType cea in deLambda ty pa b `thenDs` \(clam,_) -> @@ -384,10 +384,10 @@ dePArrComp (ExprStmt b _ _ : qs) pa cea = -- <<[:e' | qs:]>> (pa, p) (crossP ea ef) -- dePArrComp (BindStmt p e _ : qs) pa cea = - dsLookupGlobalValue falseDataConName `thenDs` \falseId -> - dsLookupGlobalValue trueDataConName `thenDs` \trueId -> - dsLookupGlobalValue filterPName `thenDs` \filterP -> - dsLookupGlobalValue crossPName `thenDs` \crossP -> + dsLookupGlobalId falseDataConName `thenDs` \falseId -> + dsLookupGlobalId trueDataConName `thenDs` \trueId -> + dsLookupGlobalId filterPName `thenDs` \filterP -> + dsLookupGlobalId crossPName `thenDs` \crossP -> dsExpr e `thenDs` \ce -> let ty'cea = parrElemType cea ty'ce = parrElemType ce @@ -409,8 +409,8 @@ dePArrComp (BindStmt p e _ : qs) pa cea = -- {x_1, ..., x_n} = DV (ds) -- Defined Variables -- dePArrComp (LetStmt ds : qs) pa cea = - dsLookupGlobalValue mapPName `thenDs` \mapP -> - let xs = collectHsOutBinders ds + dsLookupGlobalId mapPName `thenDs` \mapP -> + let xs = collectHsBinders ds ty'cea = parrElemType cea in newSysLocalDs ty'cea `thenDs` \v -> @@ -435,7 +435,7 @@ dePArrComp (LetStmt ds : qs) pa cea = -- dePArrComp (ParStmtOut [] : qss2) pa cea = dePArrComp qss2 pa cea dePArrComp (ParStmtOut ((xs, qs):qss) : qss2) pa cea = - dsLookupGlobalValue zipPName `thenDs` \zipP -> + dsLookupGlobalId zipPName `thenDs` \zipP -> let pa' = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed ty'cea = parrElemType cea resStmt = ResultStmt (ExplicitTuple (map HsVar xs) Boxed) noSrcLoc diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs new file mode 100644 index 0000000000..ba26f7a87e --- /dev/null +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -0,0 +1,789 @@ +----------------------------------------------------------------------------- +-- The purpose of this module is to transform an HsExpr into a CoreExpr which +-- when evaluated, returns a (Meta.Q Meta.Exp) computation analogous to the +-- input HsExpr. We do this in the DsM monad, which supplies access to +-- CoreExpr's of the "smart constructors" of the Meta.Exp datatype. +----------------------------------------------------------------------------- + + +module DsMeta( dsBracket ) where + +#include "HsVersions.h" + +import {-# SOURCE #-} DsExpr ( dsExpr ) + +import DsUtils ( mkListExpr, mkStringLit, mkCoreTup, + mkIntExpr, mkCharExpr ) +import DsMonad + +import qualified Language.Haskell.THSyntax as M + +import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..), + Match(..), GRHSs(..), GRHS(..), HsBracket(..), + HsDoContext(ListComp,DoExpr), ArithSeqInfo(..), + HsBinds(..), MonoBinds(..), HsConDetails(..), + HsDecl(..), TyClDecl(..), ForeignDecl(..), + PendingSplice, + placeHolderType, tyClDeclNames, + collectHsBinders, collectMonoBinders, + collectPatBinders, collectPatsBinders + ) + +import Name ( Name, nameOccName, nameModule ) +import OccName ( isDataOcc, occNameUserString ) +import Module ( moduleUserString ) +import PrelNames ( intLName,charLName, + plitName, pvarName, ptupName, pconName, + ptildeName, paspatName, pwildName, + varName, conName, litName, appName, lamName, + tupName, doEName, compName, + listExpName, condName, letEName, caseEName, + infixAppName, guardedName, normalName, + bindStName, letStName, noBindStName, + fromName, fromThenName, fromToName, fromThenToName, + funName, valName, matchName, clauseName, + liftName, gensymName, bindQName, + matTyConName, expTyConName, clsTyConName, + pattTyConName, exprTyConName, declTyConName + ) + +import Id ( Id ) +import NameEnv +import Type ( Type, mkGenTyConApp ) +import TysWiredIn ( stringTy ) +import CoreSyn +import CoreUtils ( exprType ) +import Panic ( panic ) + +import Outputable +import FastString ( mkFastString ) + +----------------------------------------------------------------------------- +dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr +-- Returns a CoreExpr of type M.Expr +-- The quoted thing is parameterised over Name, even though it has +-- been type checked. We don't want all those type decorations! + +dsBracket (ExpBr e) splices + = dsExtendMetaEnv new_bit (repE e) `thenDs` \ (MkC new_e) -> + returnDs new_e + where + new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices] + + +{- -------------- Examples -------------------- + + [| \x -> x |] +====> + gensym (unpackString "x"#) `bindQ` \ x1::String -> + lam (pvar x1) (var x1) + + + [| \x -> $(f [| x |]) |] +====> + gensym (unpackString "x"#) `bindQ` \ x1::String -> + lam (pvar x1) (f (var x1)) +-} + + +----------------------------------------------------------------------------- +-- repD + +{- +repDs :: [HsDecl Name] -> DsM (Core [M.Decl]) +repDs decls + = do { ds' <- mapM repD ds ; + coreList declTyConName ds' } + +repD :: HsDecl Name -> DsM (Core M.Decl) +repD (TyClD (TyData { tcdND = DataType, tcdCtxt = [], + tcdName = tc, tcdTyVars = tvs, + tcdCons = cons, tcdDerivs = mb_derivs })) + = do { tc1 <- localVar tc ; + cons1 <- mapM repCon cons ; + tvs1 <- repTvs tvs ; + cons2 <- coreList consTyConName cons1 ; + derivs1 <- repDerivs mb_derivs ; + derivs2 <- coreList stringTyConName derivs1 ; + repData tc1 tvs1 cons2 derivs2 } + +repD (TyClD (ClassD { tcdCtxt = cxt, tcdName = cls, + tcdTyVars = tvs, tcdFDs = [], + tcdSigs = sigs, tcdMeths = Just decls + })) + = do { cls1 <- localVar cls ; + tvs1 <- repTvs tvs ; + cxt1 <- repCtxt cxt ; + sigs1 <- repSigs sigs ; + repClass cxt1 cls1 tvs1 sigs1 } + +repD (InstD (InstDecl ty binds _ _ loc)) + -- Ignore user pragmas for now + = do { cls1 <- localVar cls ; + cxt1 <- repCtxt cxt ; + tys1 <- repTys tys ; + binds1 <- repMonoBind binds ; + binds2 <- coreList declTyConName binds1 ; + repInst ... binds2 } + where + (tvs, cxt, cls, tys) = splitHsInstDeclTy ty + +-- Un-handled cases +repD d = do { dsWarn (hang (ptext SLIT("Cannot desugar this Template Haskell declaration:")) + 4 (ppr d)) ; + return (ValD EmptyBinds) -- A sort of empty decl + } + +repTvs :: [HsTyVarBndr Name] -> DsM (Core [String]) +repTvs tvs = do { tvs1 <- mapM (localVar . hsTyVarName) tvs ; + coreList stringTyConName tvs1 } + +repCtxt :: HsContext Name -> DsM (Core M.Ctxt) +repCtxt ctxt + = do { + +repTy :: HsType Name -> DsM (Core M.Type) +repTy ty@(HsForAllTy _ cxt ty) + = pprPanic "repTy" (ppr ty) + +repTy (HsTyVar tv) + = do { tv1 <- localVar tv ; repTvar tv1 } + +repTy (HsAppTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; repTapp f1 a2 } +repTy (HsFunTy f a) = do { f1 <- repTy f ; a1 <- repTy a ; tcon <- repArrowTyCon ; repTapps tcon [f1,a1] } +repTy (HsListTy t) = do { t1 <- repTy t ; list <- repListTyCon ; repTapp tcon t1 } + +repTy (HsTupleTy tc tys) + = do +repTy (HsOpTy ty1 HsArrow ty2) = repTy (HsFunTy ty1 ty2) +repTy (HsOpTy ty1 (HsTyOp n) = repTy ((HsTyVar n `HsAppTy` ty1) `HsAppTy` ty2) +repTy (HsParTy t) = repTy t +repTy (HsPredTy (HsClassP c tys)) = repTy (foldl HsApp (HsTyVar c) tys) + + | HsTupleTy HsTupCon + [HsType name] -- Element types (length gives arity) + + | HsKindSig (HsType name) -- (ty :: kind) + Kind -- A type with a kind signature +-} + +----------------------------------------------------------------------------- +-- Using the phantom type constructors "repConstructor" we define repE +-- This ensures we keep the types of the CoreExpr objects we build are +-- consistent with their real types. + +repEs :: [HsExpr Name] -> DsM (Core [M.Expr]) +repEs es = do { es' <- mapM repE es ; + coreList exprTyConName es' } + +repE :: HsExpr Name -> DsM (Core M.Expr) +repE (HsVar x) + = do { mb_val <- dsLookupMetaEnv x + ; case mb_val of + Nothing -> do { str <- globalVar x + ; if constructor x then + repCon str + else + repVar str } + Just (Bound y) -> repVar (coreVar y) + Just (Splice e) -> do { e' <- dsExpr e + ; return (MkC e') } } + +repE (HsIPVar x) = panic "Can't represent implicit parameters" +repE (HsLit l) = do { a <- repLiteral l; repLit a } +repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a } + +repE (HsSplice n e) + = do { mb_val <- dsLookupMetaEnv n + ; case mb_val of + Just (Splice e) -> do { e' <- dsExpr e + ; return (MkC e') } + other -> pprPanic "HsSplice" (ppr n) } + + +repE (HsLam m) = repLambda m +repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b} +repE (NegApp x nm) = panic "No negate yet" +repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b } +repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b } + +repE (OpApp e1 (HsVar op) fix e2) = + do { arg1 <- repE e1; + arg2 <- repE e2; + mb_val <- dsLookupMetaEnv op; + the_op <- case mb_val of { + Nothing -> globalVar op ; + Just (Bound x) -> return (coreVar x) ; + other -> pprPanic "repE:OpApp" (ppr op) } ; + repInfixApp arg1 the_op arg2 } + +repE (HsCase e ms loc) + = do { arg <- repE e + ; ms2 <- mapM repMatchTup ms + ; repCaseE arg (nonEmptyCoreList ms2) } + +-- I havn't got the types here right yet +repE (HsDo DoExpr sts _ ty loc) = do { (ss,zs) <- repSts sts; + e <- repDoE (nonEmptyCoreList zs); + combine expTyConName ss e } +repE (HsDo ListComp sts _ ty loc) = do { (ss,zs) <- repSts sts; + e <- repComp (nonEmptyCoreList zs); + combine expTyConName ss e } + +repE (ArithSeqIn (From e)) = do { ds1 <- repE e; repFrom ds1 } +repE (ArithSeqIn (FromThen e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2; + repFromThen ds1 ds2 } +repE (ArithSeqIn (FromTo e1 e2)) = do { ds1 <- repE e1; ds2 <- repE e2; + repFromTo ds1 ds2 } +repE (ArithSeqIn (FromThenTo e1 e2 e3)) = do { ds1 <- repE e1; ds2 <- repE e2; + ds3 <- repE e3; repFromThenTo ds1 ds2 ds3 } + +repE (HsIf x y z loc) + = do { a <- repE x; b <- repE y; c <- repE z; repCond a b c } + +repE (HsLet bs e) = + do { (ss,ds) <- repDecs bs + ; e2 <- addBinds ss (repE e) + ; z <- repLetE ds e2 + ; combine expTyConName ss z } +repE (HsWith _ _ _) = panic "No with for implicit parameters yet" +repE (ExplicitList ty es) = + do { xs <- repEs es; repListExp xs } +repE (ExplicitTuple es boxed) = + do { xs <- repEs es; repTup xs } +repE (ExplicitPArr ty es) = panic "No parallel arrays yet" +repE (RecordConOut _ _ _) = panic "No record construction yet" +repE (RecordUpdOut _ _ _ _) = panic "No record update yet" +repE (ExprWithTySig e ty) = panic "No expressions with type signatures yet" + + +----------------------------------------------------------------------------- +-- Building representations of auxillary structures like Match, Clause, Stmt, + +repMatchTup :: Match Name -> DsM (Core M.Mtch) +repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) = + do { ss1 <- mkGenSyms (collectPatBinders p) + ; addBinds ss1 $ do { + ; p1 <- repP p + ; (ss2,ds) <- repDecs wheres + ; addBinds ss2 $ do { + ; gs <- repGuards guards + ; match <- repMatch p1 gs ds + ; combine matTyConName (ss1++ss2) match }}} + +repClauseTup :: Match Name -> DsM (Core M.Clse) +repClauseTup (Match ps ty (GRHSs guards wheres ty2)) = + do { ss1 <- mkGenSyms (collectPatsBinders ps) + ; addBinds ss1 $ do { + ps1 <- repPs ps + ; (ss2,ds) <- repDecs wheres + ; addBinds ss2 $ do { + gs <- repGuards guards + ; clause <- repClause ps1 gs ds + ; combine clsTyConName (ss1++ss2) clause }}} + +repGuards :: [GRHS Name] -> DsM (Core M.Rihs) +repGuards [GRHS[ResultStmt e loc] loc2] + = do {a <- repE e; repNormal a } +repGuards other + = do { zs <- mapM process other; + repGuarded (nonEmptyCoreList (map corePair zs)) } + where + process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _) + = do { x <- repE e1; y <- repE e2; return (x, y) } + process other = panic "Non Haskell 98 guarded body" + + +----------------------------------------------------------------------------- +-- Representing Stmt's is tricky, especially if bound variables +-- shaddow each other. Consider: [| do { x <- f 1; x <- f x; g x } |] +-- First gensym new names for every variable in any of the patterns. +-- both static (x'1 and x'2), and dynamic ((gensym "x") and (gensym "y")) +-- if variables didn't shaddow, the static gensym wouldn't be necessary +-- and we could reuse the original names (x and x). +-- +-- do { x'1 <- gensym "x" +-- ; x'2 <- gensym "x" +-- ; doE [ BindSt (pvar x'1) [| f 1 |] +-- , BindSt (pvar x'2) [| f x |] +-- , NoBindSt [| g x |] +-- ] +-- } + +-- The strategy is to translate a whole list of do-bindings by building a +-- bigger environment, and a bigger set of meta bindings +-- (like: x'1 <- gensym "x" ) and then combining these with the translations +-- of the expressions within the Do + +----------------------------------------------------------------------------- +-- The helper function repSts computes the translation of each sub expression +-- and a bunch of prefix bindings denoting the dynamic renaming. + +repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core M.Stmt]) +repSts [ResultStmt e loc] = + do { a <- repE e + ; e1 <- repNoBindSt a + ; return ([], [e1]) } +repSts (BindStmt p e loc : ss) = + do { e2 <- repE e + ; ss1 <- mkGenSyms (collectPatBinders p) + ; addBinds ss1 $ do { + ; p1 <- repP p; + ; (ss2,zs) <- repSts ss + ; z <- repBindSt p1 e2 + ; return (ss1++ss2, z : zs) }} +repSts (LetStmt bs : ss) = + do { (ss1,ds) <- repDecs bs + ; z <- repLetSt ds + ; (ss2,zs) <- addBinds ss1 (repSts ss) + ; return (ss1++ss2, z : zs) } +repSts (ExprStmt e ty loc : ss) = + do { e2 <- repE e + ; z <- repNoBindSt e2 + ; (ss2,zs) <- repSts ss + ; return (ss2, z : zs) } +repSts other = panic "Exotic Stmt in meta brackets" + + + +repDecs :: HsBinds Name -> DsM ([GenSymBind], Core [M.Decl]) +repDecs decs + = do { let { bndrs = collectHsBinders decs } ; + ss <- mkGenSyms bndrs ; + core <- addBinds ss (rep_decs decs) ; + core_list <- coreList declTyConName core ; + return (ss, core_list) } + +rep_decs :: HsBinds Name -> DsM [Core M.Decl] +rep_decs EmptyBinds = return [] +rep_decs (ThenBinds x y) + = do { core1 <- rep_decs x + ; core2 <- rep_decs y + ; return (core1 ++ core2) } +rep_decs (MonoBind bs sigs _) + = do { core1 <- repMonoBind bs + ; core2 <- rep_sigs sigs + ; return (core1 ++ core2) } + +rep_sigs sigs = return [] -- Incomplete! + +repMonoBind :: MonoBinds Name -> DsM [Core M.Decl] +repMonoBind EmptyMonoBinds = return [] +repMonoBind (AndMonoBinds x y) = do { x1 <- repMonoBind x; + y1 <- repMonoBind y; + return (x1 ++ y1) } + +-- Note GHC treats declarations of a variable (not a pattern) +-- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match +-- with an empty list of patterns +repMonoBind (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc) + = do { (ss,wherecore) <- repDecs wheres + ; guardcore <- addBinds ss (repGuards guards) + ; fn' <- lookupBinder fn + ; p <- repPvar fn' + ; ans <- repVal p guardcore wherecore + ; return [ans] } + +repMonoBind (FunMonoBind fn infx ms loc) + = do { ms1 <- mapM repClauseTup ms + ; fn' <- lookupBinder fn + ; ans <- repFun fn' (nonEmptyCoreList ms1) + ; return [ans] } + +repMonoBind (PatMonoBind pat (GRHSs guards wheres ty2) loc) + = do { patcore <- repP pat + ; (ss,wherecore) <- repDecs wheres + ; guardcore <- addBinds ss (repGuards guards) + ; ans <- repVal patcore guardcore wherecore + ; return [ans] } + +repMonoBind (VarMonoBind v e) + = do { v' <- lookupBinder v + ; e2 <- repE e + ; x <- repNormal e2 + ; patcore <- repPvar v' + ; empty_decls <- coreList declTyConName [] + ; ans <- repVal patcore x empty_decls + ; return [ans] } + +----------------------------------------------------------------------------- +-- Since everything in a MonoBind is mutually recursive we need rename all +-- all the variables simultaneously. For example: +-- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to +-- do { f'1 <- gensym "f" +-- ; g'2 <- gensym "g" +-- ; [ do { x'3 <- gensym "x"; fun f'1 [pvar x'3] [| x + g2 |]}, +-- do { x'4 <- gensym "x"; fun g'2 [pvar x'4] [| f 1 + 2 |]} +-- ]} +-- This requires collecting the bindings (f'1 <- gensym "f"), and the +-- environment ( f |-> f'1 ) from each binding, and then unioning them +-- together. As we do this we collect GenSymBinds's which represent the renamed +-- variables bound by the Bindings. In order not to lose track of these +-- representations we build a shadow datatype MB with the same structure as +-- MonoBinds, but which has slots for the representations + +----------------------------------------------------------------------------- +-- Gathering binders + +hsDeclsBinders :: [HsDecl Name] -> [Name] +hsDeclsBinders ds = concat (map hsDeclBinders ds) + +hsDeclBinders (ValD b) = collectHsBinders b +hsDeclBinders (TyClD d) = map fst (tyClDeclNames d) +hsDeclBinders (ForD d) = forDeclBinders d +hsDeclBinders other = [] + +forDeclBinders (ForeignImport n _ _ _ _) = [n] +forDeclBinders other = [] + + +----------------------------------------------------------------------------- +-- GHC seems to allow a more general form of lambda abstraction than specified +-- by Haskell 98. In particular it allows guarded lambda's like : +-- (\ x | even x -> 0 | odd x -> 1) at the moment we can't represent this in +-- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like +-- (\ p1 .. pn -> exp) by causing an error. + +repLambda :: Match Name -> DsM (Core M.Expr) +repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ] + EmptyBinds _)) + = do { let bndrs = collectPatsBinders ps ; + ; ss <- mkGenSyms bndrs + ; lam <- addBinds ss ( + do { xs <- repPs ps; body <- repE e; repLam xs body }) + ; combine expTyConName ss lam } + +repLambda z = panic "Can't represent a guarded lambda in Template Haskell" + + +----------------------------------------------------------------------------- +-- repP +-- repP deals with patterns. It assumes that we have already +-- walked over the pattern(s) once to collect the binders, and +-- have extended the environment. So every pattern-bound +-- variable should already appear in the environment. + +-- Process a list of patterns +repPs :: [Pat Name] -> DsM (Core [M.Patt]) +repPs ps = do { ps' <- mapM repP ps ; + coreList pattTyConName ps' } + +repP :: Pat Name -> DsM (Core M.Patt) +repP (WildPat _) = repPwild +repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } +repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' } +repP (LazyPat p) = do { p1 <- repP p; repPtilde p1 } +repP (AsPat x p) = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 } +repP (ParPat p) = repP p +repP (ListPat ps _) = repListPat ps +repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs } +repP (ConPatIn dc details) + = do { con_str <- globalVar dc + ; case details of + PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs } + RecCon pairs -> error "No records in template haskell yet" + InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs } + } +repP other = panic "Exotic pattern inside meta brackets" + +repListPat :: [Pat Name] -> DsM (Core M.Patt) +repListPat [] = do { nil_con <- coreStringLit "[]" + ; nil_args <- coreList pattTyConName [] + ; repPcon nil_con nil_args } +repListPat (p:ps) = do { p2 <- repP p + ; ps2 <- repListPat ps + ; cons_con <- coreStringLit ":" + ; repPcon cons_con (nonEmptyCoreList [p2,ps2]) } + + +---------------------------------------------------------- +-- Literals + +repLiteral :: HsLit -> DsM (Core M.Lit) +repLiteral (HsInt i) = rep2 intLName [mkIntExpr i] +repLiteral (HsChar c) = rep2 charLName [mkCharExpr c] +repLiteral x = panic "trying to represent exotic literal" + +repOverloadedLiteral :: HsOverLit -> DsM(Core M.Lit) +repOverloadedLiteral (HsIntegral i _) = rep2 intLName [mkIntExpr i] +repOverloadedLiteral (HsFractional f _) = panic "Cant do fractional literals yet" + + +---------------------------------------------------------- +-- The meta-environment + +type GenSymBind = (Name, Id) -- Gensym the string and bind it to the Id + -- I.e. (x, x_id) means + -- let x_id = gensym "x" in ... + +addBinds :: [GenSymBind] -> DsM a -> DsM a +addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m + +lookupBinder :: Name -> DsM (Core String) +lookupBinder n + = do { mb_val <- dsLookupMetaEnv n; + case mb_val of + Just (Bound id) -> return (MkC (Var id)) + other -> pprPanic "Failed binder lookup:" (ppr n) } + +mkGenSym :: Name -> DsM GenSymBind +mkGenSym nm = do { id <- newUniqueId nm stringTy; return (nm,id) } + +mkGenSyms :: [Name] -> DsM [GenSymBind] +mkGenSyms ns = mapM mkGenSym ns + +lookupType :: Name -- Name of type constructor (e.g. M.Expr) + -> DsM Type -- The type +lookupType tc_name = do { tc <- dsLookupTyCon tc_name ; + return (mkGenTyConApp tc []) } + +-- combine[ x1 <- e1, x2 <- e2 ] y +-- --> bindQ e1 (\ x1 -> bindQ e2 (\ x2 -> y)) + +combine :: Name -- Name of the type (consructor) for 'a' + -> [GenSymBind] + -> Core (M.Q a) -> DsM (Core (M.Q a)) +combine tc_name binds body@(MkC b) + = do { elt_ty <- lookupType tc_name + ; go elt_ty binds } + where + go elt_ty [] = return body + go elt_ty ((name,id) : binds) + = do { MkC body' <- go elt_ty binds + ; lit_str <- localVar name + ; gensym_app <- repGensym lit_str + ; repBindQ stringTy elt_ty + gensym_app (MkC (Lam id body')) } + +constructor :: Name -> Bool +constructor x = isDataOcc (nameOccName x) + +void = placeHolderType + +string :: String -> HsExpr Id +string s = HsLit (HsString (mkFastString s)) + + +-- %********************************************************************* +-- %* * +-- Constructing code +-- %* * +-- %********************************************************************* + +----------------------------------------------------------------------------- +-- PHANTOM TYPES for consistency. In order to make sure we do this correct +-- we invent a new datatype which uses phantom types. + +newtype Core a = MkC CoreExpr +unC (MkC x) = x + +rep2 :: Name -> [ CoreExpr ] -> DsM (Core a) +rep2 n xs = do { id <- dsLookupGlobalId n + ; return (MkC (foldl App (Var id) xs)) } + +-- Then we make "repConstructors" which use the phantom types for each of the +-- smart constructors of the Meta.Meta datatypes. + + +-- %********************************************************************* +-- %* * +-- The 'smart constructors' +-- %* * +-- %********************************************************************* + +--------------- Patterns ----------------- +repPlit :: Core M.Lit -> DsM (Core M.Patt) +repPlit (MkC l) = rep2 plitName [l] + +repPvar :: Core String -> DsM (Core M.Patt) +repPvar (MkC s) = rep2 pvarName [s] + +repPtup :: Core [M.Patt] -> DsM (Core M.Patt) +repPtup (MkC ps) = rep2 ptupName [ps] + +repPcon :: Core String -> Core [M.Patt] -> DsM (Core M.Patt) +repPcon (MkC s) (MkC ps) = rep2 pconName [s, ps] + +repPtilde :: Core M.Patt -> DsM (Core M.Patt) +repPtilde (MkC p) = rep2 ptildeName [p] + +repPaspat :: Core String -> Core M.Patt -> DsM (Core M.Patt) +repPaspat (MkC s) (MkC p) = rep2 paspatName [s, p] + +repPwild :: DsM (Core M.Patt) +repPwild = rep2 pwildName [] + +--------------- Expressions ----------------- +repVar :: Core String -> DsM (Core M.Expr) +repVar (MkC s) = rep2 varName [s] + +repCon :: Core String -> DsM (Core M.Expr) +repCon (MkC s) = rep2 conName [s] + +repLit :: Core M.Lit -> DsM (Core M.Expr) +repLit (MkC c) = rep2 litName [c] + +repApp :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) +repApp (MkC x) (MkC y) = rep2 appName [x,y] + +repLam :: Core [M.Patt] -> Core M.Expr -> DsM (Core M.Expr) +repLam (MkC ps) (MkC e) = rep2 lamName [ps, e] + +repTup :: Core [M.Expr] -> DsM (Core M.Expr) +repTup (MkC es) = rep2 tupName [es] + +repCond :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) +repCond (MkC x) (MkC y) (MkC z) = rep2 condName [x,y,z] + +repLetE :: Core [M.Decl] -> Core M.Expr -> DsM (Core M.Expr) +repLetE (MkC ds) (MkC e) = rep2 letEName [ds, e] + +repCaseE :: Core M.Expr -> Core [M.Mtch] -> DsM( Core M.Expr) +repCaseE (MkC e) (MkC ms) = rep2 caseEName [e, ms] + +repDoE :: Core [M.Stmt] -> DsM (Core M.Expr) +repDoE (MkC ss) = rep2 doEName [ss] + +repComp :: Core [M.Stmt] -> DsM (Core M.Expr) +repComp (MkC ss) = rep2 compName [ss] + +repListExp :: Core [M.Expr] -> DsM (Core M.Expr) +repListExp (MkC es) = rep2 listExpName [es] + +repInfixApp :: Core M.Expr -> Core String -> Core M.Expr -> DsM (Core M.Expr) +repInfixApp (MkC x) (MkC y) (MkC z) = rep2 infixAppName [x,y,z] + +repSectionL :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) +repSectionL (MkC x) (MkC y) = rep2 infixAppName [x,y] + +repSectionR :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) +repSectionR (MkC x) (MkC y) = rep2 infixAppName [x,y] + +------------ Right hand sides (guarded expressions) ---- +repGuarded :: Core [(M.Expr, M.Expr)] -> DsM (Core M.Rihs) +repGuarded (MkC pairs) = rep2 guardedName [pairs] + +repNormal :: Core M.Expr -> DsM (Core M.Rihs) +repNormal (MkC e) = rep2 normalName [e] + +------------- Statements ------------------- +repBindSt :: Core M.Patt -> Core M.Expr -> DsM (Core M.Stmt) +repBindSt (MkC p) (MkC e) = rep2 bindStName [p,e] + +repLetSt :: Core [M.Decl] -> DsM (Core M.Stmt) +repLetSt (MkC ds) = rep2 letStName [ds] + +repNoBindSt :: Core M.Expr -> DsM (Core M.Stmt) +repNoBindSt (MkC e) = rep2 noBindStName [e] + +-------------- DotDot (Arithmetic sequences) ----------- +repFrom :: Core M.Expr -> DsM (Core M.Expr) +repFrom (MkC x) = rep2 fromName [x] + +repFromThen :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) +repFromThen (MkC x) (MkC y) = rep2 fromThenName [x,y] + +repFromTo :: Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) +repFromTo (MkC x) (MkC y) = rep2 fromToName [x,y] + +repFromThenTo :: Core M.Expr -> Core M.Expr -> Core M.Expr -> DsM (Core M.Expr) +repFromThenTo (MkC x) (MkC y) (MkC z) = rep2 fromThenToName [x,y,z] + +------------ Match and Clause Tuples ----------- +repMatch :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Mtch) +repMatch (MkC p) (MkC bod) (MkC ds) = rep2 matchName [p, bod, ds] + +repClause :: Core [M.Patt] -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Clse) +repClause (MkC ps) (MkC bod) (MkC ds) = rep2 clauseName [ps, bod, ds] + +-------------- Dec ----------------------------- +repVal :: Core M.Patt -> Core M.Rihs -> Core [M.Decl] -> DsM (Core M.Decl) +repVal (MkC p) (MkC b) (MkC ds) = rep2 valName [p, b, ds] + +repFun :: Core String -> Core [M.Clse] -> DsM (Core M.Decl) +repFun (MkC nm) (MkC b) = rep2 funName [nm, b] + +repData :: Core String -> Core [String] -> Core [M.Cons] -> Core [String] -> DsM (Core M.Decl) +repData (MkC nm) (MkC tvs) (MkC cons) (MkC derivs) = rep2 dataDName [nm, tvs, cons, derivs] + +repInst :: Core M.Ctxt -> Core M.Type -> Core [M.Decl] +repInst (MkC cxt) (MkC ty) (Core ds) = rep2 instanceDName [cxt, ty, ds] + +repClass :: Core M.Ctxt -> Core String -> Core [String] -> Core [M.Decl] -> DsM (Core M.Decl) +repClass (MkC cxt) (MkC cls) (MkC tvs) (MkC ds) = rep2 classDName [cxt, cls, tvs, ds] + +repProto :: Core String -> Core M.Type -> DsM (Core M.Decl) +repProto (MkC s) (MkC ty) = rep2 protoName [s, ty] + +------------ Types ------------------- + +repTvar :: Core String -> DsM (Core M.Type) +repTvar (MkC s) = rep2 tvarName [s] + +repTapp :: Core M.Type -> Core M.Type -> DsM (Core M.Type) +repTapp (MkC t1) (MkC t2) = rep2 tappName [t1,t2] + +repTapps :: Core M.Type -> [Core M.Type] -> DsM (Core M.Type) +repTapps f [] = return f +repTapps f (t:ts) = do { f1 <- repTapp f t; repTapps f1 ts } + + +repNamedTyCon :: Core String -> DsM (Core M.Type) +repNamedTyCon (MkC s) = rep2 namedTyConName [s] + +repTupleTyCon :: Core Int -> DsM (Core M.Tag) +repTupleTyCon (MkC i) = rep2 tupleTyConName [i] + +repArrowTyCon :: DsM (Core M.Type) +repArrowTyCon = rep2 arrowTyConName [] + +repListTyCon :: DsM (Core M.Tag) +repListTyCon = rep2 listTyConName [] + + +--------------- Miscellaneous ------------------- + +repLift :: Core e -> DsM (Core M.Expr) +repLift (MkC x) = rep2 liftName [x] + +repGensym :: Core String -> DsM (Core (M.Q String)) +repGensym (MkC lit_str) = rep2 gensymName [lit_str] + +repBindQ :: Type -> Type -- a and b + -> Core (M.Q a) -> Core (a -> M.Q b) -> DsM (Core (M.Q b)) +repBindQ ty_a ty_b (MkC x) (MkC y) + = rep2 bindQName [Type ty_a, Type ty_b, x, y] + +------------ Lists and Tuples ------------------- +-- turn a list of patterns into a single pattern matching a list + +coreList :: Name -- Of the TyCon of the element type + -> [Core a] -> DsM (Core [a]) +coreList tc_name es + = do { elt_ty <- lookupType tc_name + ; let es' = map unC es + ; return (MkC (mkListExpr elt_ty es')) } + +nonEmptyCoreList :: [Core a] -> Core [a] + -- The list must be non-empty so we can get the element type + -- Otherwise use coreList +nonEmptyCoreList [] = panic "coreList: empty argument" +nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) + +corePair :: (Core a, Core b) -> Core (a,b) +corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y]) + +globalVar :: Name -> DsM (Core String) +globalVar n = coreStringLit (name_mod ++ ":" ++ name_occ) + where + name_mod = moduleUserString (nameModule n) + name_occ = occNameUserString (nameOccName n) + +localVar :: Name -> DsM (Core String) +localVar n = coreStringLit (occNameUserString (nameOccName n)) + +coreStringLit :: String -> DsM (Core String) +coreStringLit s = do { z <- mkStringLit s; return(MkC z) } + +coreVar :: Id -> Core String -- The Id has type String +coreVar id = MkC (Var id) diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index d15f621ff3..9a8b447b74 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -6,17 +6,19 @@ \begin{code} module DsMonad ( DsM, - initDs, returnDs, thenDs, andDs, mapDs, listDs, + initDs, returnDs, thenDs, mapDs, listDs, mapAndUnzipDs, zipWithDs, foldlDs, uniqSMtoDsM, newTyVarsDs, cloneTyVarsDs, - duplicateLocalDs, newSysLocalDs, newSysLocalsDs, + duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, newFailLocalDs, getSrcLocDs, putSrcLocDs, getModuleDs, getUniqueDs, getUniquesDs, getDOptsDs, - dsLookupGlobalValue, + dsLookupGlobalId, dsLookupTyCon, + + DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, dsWarn, DsWarnings, @@ -25,8 +27,10 @@ module DsMonad ( #include "HsVersions.h" -import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext ) +import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr ) +import HscTypes ( TyThing(..) ) import Bag ( emptyBag, snocBag, Bag ) +import TyCon ( TyCon ) import ErrUtils ( WarnMsg ) import Id ( mkSysLocal, setIdUnique, Id ) import Module ( Module ) @@ -34,10 +38,12 @@ import Var ( TyVar, setTyVarUnique ) import Outputable import SrcLoc ( noSrcLoc, SrcLoc ) import Type ( Type ) -import UniqSupply ( initUs_, splitUniqSupply, uniqFromSupply, uniqsFromSupply, +import UniqSupply ( initUs_, getUniqueUs, getUniquesUs, thenUs, returnUs, UniqSM, UniqSupply ) -import Unique ( Unique ) -import Name ( Name ) +import Unique ( Unique ) +import Name ( Name, nameOccName ) +import NameEnv +import OccName ( occNameFS ) import CmdLineOpts ( DynFlags ) infixr 9 `thenDs` @@ -47,19 +53,39 @@ Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around a @UniqueSupply@ and some annotations, which presumably include source-file location information: \begin{code} -type DsM result = - DynFlags - -> UniqSupply - -> (Name -> Id) -- Lookup well-known Ids - -> SrcLoc -- to put in pattern-matching error msgs - -> Module -- module: for SCC profiling - -> DsWarnings - -> (result, DsWarnings) +newtype DsM result + = DsM (DsEnv -> DsWarnings -> UniqSM (result, DsWarnings)) + +unDsM (DsM x) = x + +data DsEnv = DsEnv { + ds_dflags :: DynFlags, + ds_globals :: Name -> TyThing, -- Lookup well-known Ids + ds_meta :: DsMetaEnv, -- Template Haskell bindings + ds_loc :: SrcLoc, -- to put in pattern-matching error msgs + ds_mod :: Module -- module: for SCC profiling + } + +-- Inside [| |] brackets, the desugarer looks +-- up variables in the DsMetaEnv +type DsMetaEnv = NameEnv DsMetaVal -type DsWarnings = Bag WarnMsg -- The desugarer reports matches which are +data DsMetaVal + = Bound Id -- Bound by a pattern inside the [| |]. + -- Will be dynamically alpha renamed. + -- The Id has type String + + | Splice TypecheckedHsExpr -- These bindings are introduced by + -- the PendingSplices on a HsBracketOut + +instance Monad DsM where + return = returnDs + (>>=) = thenDs + +type DsWarnings = Bag DsWarning -- The desugarer reports matches which are -- completely shadowed or incomplete patterns +type DsWarning = (Loc, SDoc) -{-# INLINE andDs #-} {-# INLINE thenDs #-} {-# INLINE returnDs #-} @@ -67,30 +93,26 @@ type DsWarnings = Bag WarnMsg -- The desugarer reports matches which a initDs :: DynFlags -> UniqSupply - -> (Name -> Id) + -> (Name -> TyThing) -> Module -- module name: for profiling -> DsM a -> (a, DsWarnings) -initDs dflags init_us lookup mod action - = action dflags init_us lookup noSrcLoc mod emptyBag +initDs dflags init_us lookup mod (DsM action) + = initUs_ init_us (action ds_env emptyBag) + where + ds_env = DsEnv { ds_dflags = dflags, ds_globals = lookup, + ds_loc = noSrcLoc, ds_mod = mod, + ds_meta = emptyNameEnv } thenDs :: DsM a -> (a -> DsM b) -> DsM b -andDs :: (a -> a -> a) -> DsM a -> DsM a -> DsM a - -thenDs m1 m2 dflags us genv loc mod warns - = case splitUniqSupply us of { (s1, s2) -> - case (m1 dflags s1 genv loc mod warns) of { (result, warns1) -> - m2 result dflags s2 genv loc mod warns1}} -andDs combiner m1 m2 dflags us genv loc mod warns - = case splitUniqSupply us of { (s1, s2) -> - case (m1 dflags s1 genv loc mod warns) of { (result1, warns1) -> - case (m2 dflags s2 genv loc mod warns1) of { (result2, warns2) -> - (combiner result1 result2, warns2) }}} +thenDs (DsM m1) m2 = DsM( \ env warns -> + m1 env warns `thenUs` \ (result, warns1) -> + unDsM (m2 result) env warns1) returnDs :: a -> DsM a -returnDs result dflags us genv loc mod warns = (result, warns) +returnDs result = DsM (\ env warns -> returnUs (result, warns)) listDs :: [DsM a] -> DsM [a] listDs [] = returnDs [] @@ -136,76 +158,102 @@ functions are defined with it. The difference in name-strings makes it easier to read debugging output. \begin{code} -newSysLocalDs, newFailLocalDs :: Type -> DsM Id -newSysLocalDs ty dflags us genv loc mod warns - = case uniqFromSupply us of { assigned_uniq -> - (mkSysLocal FSLIT("ds") assigned_uniq ty, warns) } - -newSysLocalsDs tys = mapDs newSysLocalDs tys - -newFailLocalDs ty dflags us genv loc mod warns - = case uniqFromSupply us of { assigned_uniq -> - (mkSysLocal FSLIT("fail") assigned_uniq ty, warns) } - -- The UserLocal bit just helps make the code a little clearer +uniqSMtoDsM :: UniqSM a -> DsM a +uniqSMtoDsM u_action = DsM(\ env warns -> + u_action `thenUs` \ res -> + returnUs (res, warns)) + getUniqueDs :: DsM Unique -getUniqueDs dflags us genv loc mod warns - = (uniqFromSupply us, warns) +getUniqueDs = DsM (\ env warns -> + getUniqueUs `thenUs` \ uniq -> + returnUs (uniq, warns)) getUniquesDs :: DsM [Unique] -getUniquesDs dflags us genv loc mod warns - = (uniqsFromSupply us, warns) +getUniquesDs = DsM(\ env warns -> + getUniquesUs `thenUs` \ uniqs -> + returnUs (uniqs, warns)) -getDOptsDs :: DsM DynFlags -getDOptsDs dflags us genv loc mod warns - = (dflags, warns) +-- Make a new Id with the same print name, but different type, and new unique +newUniqueId :: Name -> Type -> DsM Id +newUniqueId id ty + = getUniqueDs `thenDs` \ uniq -> + returnDs (mkSysLocal (occNameFS (nameOccName id)) uniq ty) duplicateLocalDs :: Id -> DsM Id -duplicateLocalDs old_local dflags us genv loc mod warns - = case uniqFromSupply us of { assigned_uniq -> - (setIdUnique old_local assigned_uniq, warns) } +duplicateLocalDs old_local + = getUniqueDs `thenDs` \ uniq -> + returnDs (setIdUnique old_local uniq) -cloneTyVarsDs :: [TyVar] -> DsM [TyVar] -cloneTyVarsDs tyvars dflags us genv loc mod warns - = (zipWith setTyVarUnique tyvars (uniqsFromSupply us), warns) +newSysLocalDs, newFailLocalDs :: Type -> DsM Id +newSysLocalDs ty + = getUniqueDs `thenDs` \ uniq -> + returnDs (mkSysLocal FSLIT("ds") uniq ty) + +newSysLocalsDs tys = mapDs newSysLocalDs tys + +newFailLocalDs ty + = getUniqueDs `thenDs` \ uniq -> + returnDs (mkSysLocal FSLIT("fail") uniq ty) + -- The UserLocal bit just helps make the code a little clearer \end{code} \begin{code} +cloneTyVarsDs :: [TyVar] -> DsM [TyVar] +cloneTyVarsDs tyvars + = getUniquesDs `thenDs` \ uniqs -> + returnDs (zipWith setTyVarUnique tyvars uniqs) + newTyVarsDs :: [TyVar] -> DsM [TyVar] -newTyVarsDs tyvar_tmpls dflags us genv loc mod warns - = (zipWith setTyVarUnique tyvar_tmpls (uniqsFromSupply us), warns) +newTyVarsDs tyvar_tmpls + = getUniquesDs `thenDs` \ uniqs -> + returnDs (zipWith setTyVarUnique tyvar_tmpls uniqs) \end{code} We can also reach out and either set/grab location information from the @SrcLoc@ being carried around. + \begin{code} -uniqSMtoDsM :: UniqSM a -> DsM a +getDOptsDs :: DsM DynFlags +getDOptsDs = DsM(\ env warns -> returnUs (ds_dflags env, warns)) -uniqSMtoDsM u_action dflags us genv loc mod warns - = (initUs_ us u_action, warns) +getModuleDs :: DsM Module +getModuleDs = DsM(\ env warns -> returnUs (ds_mod env, warns)) getSrcLocDs :: DsM SrcLoc -getSrcLocDs dflags us genv loc mod warns - = (loc, warns) +getSrcLocDs = DsM(\ env warns -> returnUs (ds_loc env, warns)) putSrcLocDs :: SrcLoc -> DsM a -> DsM a -putSrcLocDs new_loc expr dflags us genv old_loc mod warns - = expr dflags us genv new_loc mod warns - -dsWarn :: WarnMsg -> DsM () -dsWarn warn dflags us genv loc mod warns = ((), warns `snocBag` warn) +putSrcLocDs new_loc (DsM expr) = DsM(\ env warns -> + expr (env { ds_loc = new_loc }) warns) +dsWarn :: DsWarning -> DsM () +dsWarn warn = DsM(\ env warns -> returnUs ((), warns `snocBag` warn)) \end{code} \begin{code} -getModuleDs :: DsM Module -getModuleDs dflags us genv loc mod warns = (mod, warns) +dsLookupGlobalId :: Name -> DsM Id +dsLookupGlobalId name = DsM(\ env warns -> + returnUs (get_id name (ds_globals env name), warns)) + +dsLookupTyCon :: Name -> DsM TyCon +dsLookupTyCon name = DsM(\ env warns -> + returnUs (get_tycon name (ds_globals env name), warns)) + +get_id name (AnId id) = id +get_id name other = pprPanic "dsLookupGlobalId" (ppr name) + +get_tycon name (ATyCon tc) = tc +get_tycon name other = pprPanic "dsLookupTyCon" (ppr name) \end{code} \begin{code} -dsLookupGlobalValue :: Name -> DsM Id -dsLookupGlobalValue name dflags us genv loc mod warns - = (genv name, warns) +dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal) +dsLookupMetaEnv name = DsM(\ env warns -> returnUs (lookupNameEnv (ds_meta env) name, warns)) + +dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a +dsExtendMetaEnv menv (DsM m) + = DsM (\ env warns -> m (env { ds_meta = ds_meta env `plusNameEnv` menv }) warns) \end{code} diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index ac9e85b35c..42bd271439 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -20,10 +20,11 @@ module DsUtils ( mkCoLetsMatchResult, mkGuardedMatchResult, mkCoPrimCaseMatchResult, mkCoAlgCaseMatchResult, - mkErrorAppDs, mkNilExpr, mkConsExpr, - mkStringLit, mkStringLitFS, mkIntegerLit, + mkErrorAppDs, mkNilExpr, mkConsExpr, mkListExpr, + mkIntExpr, mkCharExpr, + mkStringLit, mkStringLitFS, mkIntegerExpr, - mkSelectorBinds, mkTupleExpr, mkTupleSelector, + mkSelectorBinds, mkTupleExpr, mkTupleSelector, mkCoreTup, selectMatchVar ) where @@ -33,7 +34,7 @@ module DsUtils ( import {-# SOURCE #-} Match ( matchSimply ) import HsSyn -import TcHsSyn ( TypecheckedPat, outPatType, collectTypedPatBinders ) +import TcHsSyn ( TypecheckedPat, hsPatType ) import CoreSyn import DsMonad @@ -43,11 +44,11 @@ import PrelInfo ( iRREFUT_PAT_ERROR_ID ) import MkId ( mkReboxingAlt, mkNewTypeBody ) import Id ( idType, Id, mkWildId ) import Literal ( Literal(..), inIntRange, tARGET_MAX_INT ) -import TyCon ( isNewTyCon, tyConDataCons, isRecursiveTyCon ) +import TyCon ( isNewTyCon, tyConDataCons ) import DataCon ( DataCon, dataConSourceArity ) import Type ( mkFunTy, isUnLiftedType, Type, splitTyConApp ) import TcType ( tcTyConAppTyCon, isIntTy, isFloatTy, isDoubleTy ) -import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy ) +import TysPrim ( intPrimTy ) import TysWiredIn ( nilDataCon, consDataCon, tupleCon, unitDataConId, unitTy, @@ -77,23 +78,22 @@ import FastString \begin{code} tidyLitPat :: HsLit -> TypecheckedPat -> TypecheckedPat -tidyLitPat (HsChar c) pat = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy] +tidyLitPat (HsChar c) pat = mkCharLitPat c tidyLitPat lit pat = pat tidyNPat :: HsLit -> Type -> TypecheckedPat -> TypecheckedPat tidyNPat (HsString s) _ pat | lengthFS s <= 1 -- Short string literals only - = foldr (\c pat -> ConPat consDataCon stringTy [] [] [mk_char_lit c,pat]) - (ConPat nilDataCon stringTy [] [] []) (unpackIntFS s) + = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy) + (mkNilPat stringTy) (unpackIntFS s) -- The stringTy is the type of the whole pattern, not -- the type to instantiate (:) or [] with! where - mk_char_lit c = ConPat charDataCon charTy [] [] [LitPat (HsCharPrim c) charPrimTy] tidyNPat lit lit_ty default_pat - | isIntTy lit_ty = ConPat intDataCon lit_ty [] [] [LitPat (mk_int lit) intPrimTy] - | isFloatTy lit_ty = ConPat floatDataCon lit_ty [] [] [LitPat (mk_float lit) floatPrimTy] - | isDoubleTy lit_ty = ConPat doubleDataCon lit_ty [] [] [LitPat (mk_double lit) doublePrimTy] + | isIntTy lit_ty = mkPrefixConPat intDataCon [LitPat (mk_int lit)] lit_ty + | isFloatTy lit_ty = mkPrefixConPat floatDataCon [LitPat (mk_float lit)] lit_ty + | isDoubleTy lit_ty = mkPrefixConPat doubleDataCon [LitPat (mk_double lit)] lit_ty | otherwise = default_pat where @@ -144,7 +144,7 @@ selectMatchVar :: TypecheckedPat -> DsM Id selectMatchVar (VarPat var) = returnDs var selectMatchVar (AsPat var pat) = returnDs var selectMatchVar (LazyPat pat) = selectMatchVar pat -selectMatchVar other_pat = newSysLocalDs (outPatType other_pat) -- OK, better make up one... +selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat) -- OK, better make up one... \end{code} @@ -337,7 +337,7 @@ mkCoAlgCaseMatchResult var match_alts panic "DsUtils: You may not mix `[:...:]' with `PArr' patterns" -- mk_parrCase fail = - dsLookupGlobalValue lengthPName `thenDs` \lengthP -> + dsLookupGlobalId lengthPName `thenDs` \lengthP -> unboxAlt `thenDs` \alt -> returnDs (Case (len lengthP) (mkWildId intTy) [alt]) where @@ -349,7 +349,7 @@ mkCoAlgCaseMatchResult var match_alts -- unboxAlt = newSysLocalDs intPrimTy `thenDs` \l -> - dsLookupGlobalValue indexPName `thenDs` \indexP -> + dsLookupGlobalId indexPName `thenDs` \indexP -> mapDs (mkAlt indexP) match_alts `thenDs` \alts -> returnDs (DataAlt intDataCon, [l], (Case (Var l) wild (dft : alts))) where @@ -369,8 +369,7 @@ mkCoAlgCaseMatchResult var match_alts lit = MachInt $ toInteger (dataConSourceArity con) binds = [NonRec arg (indexExpr i) | (i, arg) <- zip [1..] args] -- - indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, toInt i] - toInt i = mkConApp intDataCon [Lit $ MachInt i] + indexExpr i = mkApps (Var indexP) [Type elemTy, Var var, mkIntExpr i] \end{code} @@ -403,8 +402,14 @@ mkErrorAppDs err_id ty msg %************************************************************************ \begin{code} -mkIntegerLit :: Integer -> DsM CoreExpr -mkIntegerLit i +mkCharExpr :: Int -> CoreExpr -- Returns C# c :: Int +mkIntExpr :: Integer -> CoreExpr -- Returns I# i :: Int +mkIntegerExpr :: Integer -> DsM CoreExpr -- Result :: Integer + +mkIntExpr i = mkConApp intDataCon [mkIntLit i] +mkCharExpr c = mkConApp charDataCon [mkLit (MachChar c)] + +mkIntegerExpr i | inIntRange i -- Small enough, so start from an Int = returnDs (mkSmallIntegerLit i) @@ -413,8 +418,8 @@ mkIntegerLit i -- integral literals. This improves constant folding. | otherwise -- Big, so start from a string - = dsLookupGlobalValue plusIntegerName `thenDs` \ plus_id -> - dsLookupGlobalValue timesIntegerName `thenDs` \ times_id -> + = dsLookupGlobalId plusIntegerName `thenDs` \ plus_id -> + dsLookupGlobalId timesIntegerName `thenDs` \ times_id -> let plus a b = Var plus_id `App` a `App` b times a b = Var times_id `App` a `App` b @@ -444,16 +449,16 @@ mkStringLitFS str | lengthFS str == 1 = let - the_char = mkConApp charDataCon [mkLit (MachChar (headIntFS str))] + the_char = mkCharExpr (headIntFS str) in returnDs (mkConsExpr charTy the_char (mkNilExpr charTy)) | all safeChar int_chars - = dsLookupGlobalValue unpackCStringName `thenDs` \ unpack_id -> + = dsLookupGlobalId unpackCStringName `thenDs` \ unpack_id -> returnDs (App (Var unpack_id) (Lit (MachStr str))) | otherwise - = dsLookupGlobalValue unpackCStringUtf8Name `thenDs` \ unpack_id -> + = dsLookupGlobalId unpackCStringUtf8Name `thenDs` \ unpack_id -> returnDs (App (Var unpack_id) (Lit (MachStr (mkFastString (intsToUtf8 int_chars))))) where @@ -518,7 +523,7 @@ mkSelectorBinds pat val_expr in returnDs ( (tuple_var, tuple_expr) : map mk_tup_bind binders ) where - binders = collectTypedPatBinders pat + binders = collectPatBinders pat local_tuple = mkTupleExpr binders tuple_ty = exprType local_tuple @@ -532,14 +537,15 @@ mkSelectorBinds pat val_expr where error_expr = mkCoerce (idType bndr_var) (Var err_var) - is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps - is_simple_pat (ConPat _ _ _ _ ps) = all is_triv_pat ps - is_simple_pat (VarPat _) = True - is_simple_pat (RecPat _ _ _ _ ps) = and [is_triv_pat p | (_,p,_) <- ps] - is_simple_pat other = False + is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps + is_simple_pat (ConPatOut _ ps _ _ _) = all is_triv_pat (hsConArgs ps) + is_simple_pat (VarPat _) = True + is_simple_pat (ParPat p) = is_simple_pat p + is_simple_pat other = False is_triv_pat (VarPat v) = True is_triv_pat (WildPat _) = True + is_triv_pat (ParPat p) = is_triv_pat p is_triv_pat other = False \end{code} @@ -550,10 +556,21 @@ has only one element, it is the identity function. \begin{code} mkTupleExpr :: [Id] -> CoreExpr +{- This code has been replaced by mkCoreTup below mkTupleExpr [] = Var unitDataConId mkTupleExpr [id] = Var id mkTupleExpr ids = mkConApp (tupleCon Boxed (length ids)) - (map (Type . idType) ids ++ [ Var i | i <- ids ]) + (map (Type . idType) ids ++ [ Var i | i <-ids]) +-} + +mkTupleExpr ids = mkCoreTup(map Var ids) + +mkCoreTup :: [CoreExpr] -> CoreExpr +mkCoreTup [] = Var unitDataConId +mkCoreTup [c] = c +mkCoreTup cs = mkConApp (tupleCon Boxed (length cs)) + (map (Type . exprType) cs ++ cs) + \end{code} @@ -598,6 +615,10 @@ mkNilExpr ty = mkConApp nilDataCon [Type ty] mkConsExpr :: Type -> CoreExpr -> CoreExpr -> CoreExpr mkConsExpr ty hd tl = mkConApp consDataCon [Type ty, hd, tl] + +mkListExpr :: Type -> [CoreExpr] -> CoreExpr +mkListExpr ty xs = foldr (mkConsExpr ty) (mkNilExpr ty) xs + \end{code} diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 776a9fffc7..02eeed7aa5 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -11,7 +11,7 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w import {-# SOURCE #-} DsExpr( dsExpr ) import CmdLineOpts ( DynFlag(..), dopt ) import HsSyn -import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, outPatType ) +import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, hsPatType ) import Check ( check, ExhaustivePat ) import CoreSyn import CoreUtils ( bindNonRec ) @@ -24,11 +24,11 @@ import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals ) import PrelInfo ( pAT_ERROR_ID ) import TcType ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType ) -import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, +import TysWiredIn ( consDataCon, mkTupleTy, mkListTy, tupleCon, parrFakeCon, mkPArrTy ) import BasicTypes ( Boxity(..) ) import UniqSet -import ErrUtils ( addWarnLocHdrLine, dontAddErrLoc ) +import SrcLoc ( noSrcLoc )x import Util ( lengthExceeds, isSingleton, notNull ) import Outputable \end{code} @@ -110,17 +110,16 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn | otherwise = empty pp_context NoMatchContext msg rest_of_msg_fun - = dontAddErrLoc (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id)) + = (noSrcLoc, ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id)) pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun - = addWarnLocHdrLine loc - (ptext SLIT("Pattern match(es)") <+> msg) - (sep [ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]) + = (loc, vcat [ptext SLIT("Pattern match(es)") <+> msg, + sep [ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)]]) where (ppr_match, pref) = case kind of - FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) - other -> (pprMatchContext kind <+> ppr_pats pats, \ pp -> pp) + FunRhs fun -> (pprMatchContext kind, \ pp -> ppr fun <+> pp) + other -> (pprMatchContext kind, \ pp -> pp) ppr_pats pats = sep (map ppr pats) @@ -320,7 +319,7 @@ The @VarPat@ information isn't needed any more after this. Float, Double, at least) are converted to unboxed form; e.g., \tr{(NPat (HsInt i) _ _)} is converted to: \begin{verbatim} -(ConPat I# _ _ [LitPat (HsIntPrim i) _]) +(ConPat I# _ _ [LitPat (HsIntPrim i)]) \end{verbatim} \end{description} @@ -343,6 +342,15 @@ tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result) = tidy1 v pat match_result `thenDs` \ (pat', match_result') -> returnDs (EqnInfo n ctx (pat' : pats) match_result') + +tidy1 :: Id -- The Id being scrutinised + -> TypecheckedPat -- The pattern against which it is to be matched + -> MatchResult -- Current thing do do after matching + -> DsM (TypecheckedPat, -- Equivalent pattern + MatchResult) -- Augmented thing to do afterwards + -- The augmentation usually takes the form + -- of new bindings to be added to the front + ------------------------------------------------------- -- (pat', mr') = tidy1 v pat mr -- tidies the *outer level only* of pat, giving pat' @@ -355,14 +363,8 @@ tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result) -- NPlusKPat -- - -tidy1 :: Id -- The Id being scrutinised - -> TypecheckedPat -- The pattern against which it is to be matched - -> MatchResult -- Current thing do do after matching - -> DsM (TypecheckedPat, -- Equivalent pattern - MatchResult) -- Augmented thing to do afterwards - -- The augmentation usually takes the form - -- of new bindings to be added to the front +tidy1 v (ParPat pat) match_result + = tidy1 v pat match_result -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } @@ -401,58 +403,34 @@ tidy1 v (LazyPat pat) match_result -- re-express as (ConPat ...) [directly] -tidy1 v (RecPat data_con pat_ty ex_tvs dicts rpats) match_result - | null rpats - = -- Special case for C {}, which can be used for - -- a constructor that isn't declared to have - -- fields at all - returnDs (ConPat data_con pat_ty ex_tvs dicts (map WildPat con_arg_tys'), match_result) - - | otherwise - = returnDs (ConPat data_con pat_ty ex_tvs dicts pats, match_result) +tidy1 v (ConPatOut con ps pat_ty ex_tvs dicts) match_result + = returnDs (ConPatOut con tidy_ps pat_ty ex_tvs dicts, match_result) where - pats = map mk_pat tagged_arg_tys + tidy_ps = PrefixCon (tidy_con con pat_ty ex_tvs ps) - -- Boring stuff to find the arg-tys of the constructor - inst_tys = tcTyConAppArgs pat_ty -- Newtypes must be opaque - con_arg_tys' = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs) - tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con) - - -- mk_pat picks a WildPat of the appropriate type for absent fields, - -- and the specified pattern for present fields - mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat,_) <- rpats, - recordSelectorFieldLabel sel_id == lbl - ] of - (pat:pats) -> ASSERT( null pats ) - pat - [] -> WildPat arg_ty - -tidy1 v (ListPat ty pats) match_result +tidy1 v (ListPat pats ty) match_result = returnDs (list_ConPat, match_result) where - list_ty = mkListTy ty - list_ConPat - = foldr (\ x -> \y -> ConPat consDataCon list_ty [] [] [x, y]) - (ConPat nilDataCon list_ty [] [] []) - pats + list_ty = mkListTy ty + list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty) + (mkNilPat list_ty) + pats -- introduce fake parallel array constructors to be able to handle parallel -- arrays with the existing machinery for constructor pattern -- -tidy1 v (PArrPat ty pats) match_result +tidy1 v (PArrPat pats ty) match_result = returnDs (parrConPat, match_result) where arity = length pats - parrConPat = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] pats + parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty) tidy1 v (TuplePat pats boxity) match_result = returnDs (tuple_ConPat, match_result) where arity = length pats - tuple_ConPat - = ConPat (tupleCon boxity arity) - (mkTupleTy boxity arity (map outPatType pats)) [] [] - pats + tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats + (mkTupleTy boxity arity (map hsPatType pats)) tidy1 v (DictPat dicts methods) match_result = case num_of_d_and_ms of @@ -464,17 +442,44 @@ tidy1 v (DictPat dicts methods) match_result dict_and_method_pats = map VarPat (dicts ++ methods) -- LitPats: we *might* be able to replace these w/ a simpler form -tidy1 v pat@(LitPat lit lit_ty) match_result +tidy1 v pat@(LitPat lit) match_result = returnDs (tidyLitPat lit pat, match_result) -- NPats: we *might* be able to replace these w/ a simpler form -tidy1 v pat@(NPat lit lit_ty _) match_result +tidy1 v pat@(NPatOut lit lit_ty _) match_result = returnDs (tidyNPat lit lit_ty pat, match_result) -- and everything else goes through unchanged... tidy1 v non_interesting_pat match_result = returnDs (non_interesting_pat, match_result) + + +tidy_con data_con pat_ty ex_tvs (PrefixCon ps) = ps +tidy_con data_con pat_ty ex_tvs (InfixCon p1 p2) = [p1,p2] +tidy_con data_con pat_ty ex_tvs (RecCon rpats) + | null rpats + = -- Special case for C {}, which can be used for + -- a constructor that isn't declared to have + -- fields at all + map WildPat con_arg_tys' + + | otherwise + = map mk_pat tagged_arg_tys + where + -- Boring stuff to find the arg-tys of the constructor + inst_tys = tcTyConAppArgs pat_ty -- Newtypes must be opaque + con_arg_tys' = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs) + tagged_arg_tys = con_arg_tys' `zip` (dataConFieldLabels data_con) + + -- mk_pat picks a WildPat of the appropriate type for absent fields, + -- and the specified pattern for present fields + mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat) <- rpats, + recordSelectorFieldLabel sel_id == lbl + ] of + (pat:pats) -> ASSERT( null pats ) + pat + [] -> WildPat arg_ty \end{code} \noindent @@ -620,7 +625,7 @@ Meanwhile, the strategy is: \begin{code} matchSigPat :: [Id] -> EquationInfo -> DsM MatchResult -matchSigPat (var:vars) (EqnInfo n ctx (SigPat pat ty co_fn : pats) result) +matchSigPat (var:vars) (EqnInfo n ctx (SigPatOut pat ty co_fn : pats) result) = selectMatchVar pat `thenDs` \ new_var -> dsExpr (HsApp co_fn (HsVar var)) `thenDs` \ rhs -> match (new_var:vars) [EqnInfo n ctx (pat:pats) result] `thenDs` \ result' -> diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs index 6fb0fff9d7..141f6a7e3d 100644 --- a/ghc/compiler/deSugar/MatchCon.lhs +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -10,7 +10,7 @@ module MatchCon ( matchConFamily ) where import {-# SOURCE #-} Match ( match ) -import HsSyn ( OutPat(..) ) +import HsSyn ( Pat(..), HsConDetails(..) ) import DsMonad import DsUtils @@ -83,7 +83,7 @@ matchConFamily (var:vars) eqns_info -- Sort into equivalence classes by the unique on the constructor -- All the EqnInfos should start with a ConPat eqn_groups = equivClassesByUniq get_uniq eqns_info - get_uniq (EqnInfo _ _ (ConPat data_con _ _ _ _ : _) _) = getUnique data_con + get_uniq (EqnInfo _ _ (ConPatOut data_con _ _ _ _ : _) _) = getUnique data_con in -- Now make a case alternative out of each group mapDs (match_con vars) eqn_groups `thenDs` \ alts -> @@ -96,7 +96,7 @@ more-or-less the @matchCon@/@matchClause@ functions on page~94 in Wadler's chapter in SLPJ. \begin{code} -match_con vars (eqn1@(EqnInfo _ _ (ConPat data_con _ ex_tvs ex_dicts arg_pats : _) _) +match_con vars (eqn1@(EqnInfo _ _ (ConPatOut data_con (PrefixCon arg_pats) _ ex_tvs ex_dicts : _) _) : other_eqns) = -- Make new vars for the con arguments; avoid new locals where possible mapDs selectMatchVar arg_pats `thenDs` \ arg_vars -> @@ -117,14 +117,14 @@ match_con vars (eqn1@(EqnInfo _ _ (ConPat data_con _ ex_tvs ex_dicts arg_pats : returnDs (data_con, ex_tvs ++ ex_dicts ++ arg_vars, match_result') where shift_con_pat :: EquationInfo -> EquationInfo - shift_con_pat (EqnInfo n ctx (ConPat _ _ _ _ arg_pats : pats) match_result) + shift_con_pat (EqnInfo n ctx (ConPatOut _ (PrefixCon arg_pats) _ _ _ : pats) match_result) = EqnInfo n ctx (arg_pats ++ pats) match_result other_pats = [p | EqnInfo _ _ (p:_) _ <- other_eqns] var_prs = concat [ (ex_tvs' `zip` ex_tvs) ++ (ex_dicts' `zip` ex_dicts) - | ConPat _ _ ex_tvs' ex_dicts' _ <- other_pats ] + | ConPatOut _ _ _ ex_tvs' ex_dicts' <- other_pats ] do_subst e = substExpr subst e where diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index 308ca8fe98..287d730f7d 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -4,27 +4,90 @@ \section[MatchLit]{Pattern-matching literal patterns} \begin{code} -module MatchLit ( matchLiterals ) where +module MatchLit ( dsLit, matchLiterals ) where #include "HsVersions.h" import {-# SOURCE #-} Match ( match ) import {-# SOURCE #-} DsExpr ( dsExpr ) -import HsSyn ( HsLit(..), OutPat(..), HsExpr(..) ) -import TcHsSyn ( TypecheckedPat ) -import CoreSyn ( Expr(..), Bind(..) ) -import Id ( Id ) - import DsMonad +import DsCCall ( resultWrapper ) import DsUtils +import HsSyn ( HsLit(..), Pat(..), HsExpr(..) ) +import TcHsSyn ( TypecheckedPat ) +import Id ( Id ) +import CoreSyn +import TyCon ( tyConDataCons ) +import TcType ( tcSplitTyConApp, isIntegerTy ) + +import PrelNames ( ratioTyConKey ) +import Unique ( hasKey ) import Literal ( mkMachInt, Literal(..) ) import Maybes ( catMaybes ) import Type ( isUnLiftedType ) import Panic ( panic, assertPanic ) +import Maybe ( isJust ) +import Ratio ( numerator, denominator ) \end{code} +%************************************************************************ +%* * + Desugaring literals + [used to be in DsExpr, but DsMeta needs it, + and it's nice to avoid a loop] +%* * +%************************************************************************ + +We give int/float literals type @Integer@ and @Rational@, respectively. +The typechecker will (presumably) have put \tr{from{Integer,Rational}s} +around them. + +ToDo: put in range checks for when converting ``@i@'' +(or should that be in the typechecker?) + +For numeric literals, we try to detect there use at a standard type +(@Int@, @Float@, etc.) are directly put in the right constructor. +[NB: down with the @App@ conversion.] + +See also below where we look for @DictApps@ for \tr{plusInt}, etc. + +\begin{code} +dsLit :: HsLit -> DsM CoreExpr +dsLit (HsChar c) = returnDs (mkCharExpr c) +dsLit (HsCharPrim c) = returnDs (mkLit (MachChar c)) +dsLit (HsString str) = mkStringLitFS str +dsLit (HsStringPrim s) = returnDs (mkLit (MachStr s)) +dsLit (HsInteger i) = mkIntegerExpr i +dsLit (HsInt i) = returnDs (mkIntExpr i) +dsLit (HsIntPrim i) = returnDs (mkIntLit i) +dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f)) +dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d)) +dsLit (HsLitLit str ty) + = ASSERT( isJust maybe_ty ) + returnDs (wrap_fn (mkLit (MachLitLit str rep_ty))) + where + (maybe_ty, wrap_fn) = resultWrapper ty + Just rep_ty = maybe_ty + +dsLit (HsRat r ty) + = mkIntegerExpr (numerator r) `thenDs` \ num -> + mkIntegerExpr (denominator r) `thenDs` \ denom -> + returnDs (mkConApp ratio_data_con [Type integer_ty, num, denom]) + where + (ratio_data_con, integer_ty) + = case tcSplitTyConApp ty of + (tycon, [i_ty]) -> ASSERT(isIntegerTy i_ty && tycon `hasKey` ratioTyConKey) + (head (tyConDataCons tycon), i_ty) +\end{code} + +%************************************************************************ +%* * + Pattern matching on literals +%* * +%************************************************************************ + \begin{code} matchLiterals :: [Id] -> [EquationInfo] @@ -39,7 +102,7 @@ is much like @matchConFamily@, which uses @match_cons_used@ to create the alts---here we use @match_prims_used@. \begin{code} -matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal lit_ty : ps1) _ : eqns) +matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal : ps1) _ : eqns) = -- GENERATE THE ALTS match_prims_used vars eqns_info `thenDs` \ prim_alts -> @@ -48,7 +111,7 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal lit_t where match_prims_used _ [{-no more eqns-}] = returnDs [] - match_prims_used vars eqns_info@(EqnInfo n ctx (pat@(LitPat literal lit_ty):ps1) _ : eqns) + match_prims_used vars eqns_info@(EqnInfo n ctx (pat@(LitPat literal):ps1) _ : eqns) = let (shifted_eqns_for_this_lit, eqns_not_for_this_lit) = partitionEqnsByLit pat eqns_info @@ -78,7 +141,7 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal lit_t \begin{code} matchLiterals all_vars@(var:vars) - eqns_info@(EqnInfo n ctx (pat@(NPat literal lit_ty eq_chk):ps1) _ : eqns) + eqns_info@(EqnInfo n ctx (pat@(NPatOut literal lit_ty eq_chk):ps1) _ : eqns) = let (shifted_eqns_for_this_lit, eqns_not_for_this_lit) = partitionEqnsByLit pat eqns_info @@ -108,7 +171,7 @@ We generate: \begin{code} -matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (pat@(NPlusKPat master_n k ty ge sub):ps1) _ : eqns) +matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (pat@(NPlusKPatOut master_n k ge sub):ps1) _ : eqns) = let (shifted_eqns_for_this_lit, eqns_not_for_this_lit) = partitionEqnsByLit pat eqns_info @@ -151,16 +214,16 @@ partitionEqnsByLit master_pat eqns where partition_eqn :: TypecheckedPat -> EquationInfo -> (Maybe EquationInfo, Maybe EquationInfo) - partition_eqn (LitPat k1 _) (EqnInfo n ctx (LitPat k2 _ : remaining_pats) match_result) + partition_eqn (LitPat k1) (EqnInfo n ctx (LitPat k2 : remaining_pats) match_result) | k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing) -- NB the pattern is stripped off the EquationInfo - partition_eqn (NPat k1 _ _) (EqnInfo n ctx (NPat k2 _ _ : remaining_pats) match_result) + partition_eqn (NPatOut k1 _ _) (EqnInfo n ctx (NPatOut k2 _ _ : remaining_pats) match_result) | k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing) -- NB the pattern is stripped off the EquationInfo - partition_eqn (NPlusKPat master_n k1 _ _ _) - (EqnInfo n ctx (NPlusKPat n' k2 _ _ _ : remaining_pats) match_result) + partition_eqn (NPlusKPatOut master_n k1 _ _) + (EqnInfo n ctx (NPlusKPatOut n' k2 _ _ : remaining_pats) match_result) | k1 == k2 = (Just (EqnInfo n ctx remaining_pats new_match_result), Nothing) -- NB the pattern is stripped off the EquationInfo where @@ -176,3 +239,4 @@ partitionEqnsByLit master_pat eqns -- Default case; not for this pattern partition_eqn master_pat eqn = (Nothing, Just eqn) \end{code} + diff --git a/ghc/compiler/ghci/ByteCodeAsm.lhs b/ghc/compiler/ghci/ByteCodeAsm.lhs new file mode 100644 index 0000000000..fdc083a25d --- /dev/null +++ b/ghc/compiler/ghci/ByteCodeAsm.lhs @@ -0,0 +1,531 @@ +% +% (c) The University of Glasgow 2000 +% +\section[ByteCodeLink]{Bytecode assembler and linker} + +\begin{code} + +{-# OPTIONS -optc-DNON_POSIX_SOURCE #-} + +module ByteCodeAsm ( + assembleBCOs, assembleBCO, + + CompiledByteCode(..), + UnlinkedBCO(..), UnlinkedBCOExpr, nameOfUnlinkedBCO, bcosFreeNames, + SizedSeq, sizeSS, ssElts, + iNTERP_STACK_CHECK_THRESH + ) where + +#include "HsVersions.h" + +import ByteCodeInstr ( BCInstr(..), ProtoBCO(..) ) +import ByteCodeItbls ( ItblEnv, mkITbls ) + +import Name ( Name, getName ) +import NameSet +import FiniteMap ( addToFM, lookupFM, emptyFM ) +import CoreSyn +import Literal ( Literal(..) ) +import TyCon ( TyCon ) +import PrimOp ( PrimOp ) +import PrimRep ( PrimRep(..), isFollowableRep ) +import Constants ( wORD_SIZE ) +import FastString ( FastString(..), unpackFS ) +import FiniteMap +import Outputable + +import Control.Monad ( foldM ) +import Control.Monad.ST ( runST ) + +import GHC.Word ( Word(..) ) +import Data.Array.MArray ( MArray, newArray_, readArray, writeArray ) +import Data.Array.ST ( castSTUArray ) +import Foreign.Ptr ( nullPtr ) +import Foreign ( Word16, free ) +import Data.Int ( Int64 ) + +#if __GLASGOW_HASKELL__ >= 503 +import GHC.IOBase ( IO(..) ) +import GHC.Ptr ( Ptr(..) ) +#else +import PrelIOBase ( IO(..) ) +import Ptr ( Ptr(..) ) +#endif +\end{code} + + + +%************************************************************************ +%* * + Unlinked BCOs +%* * +%************************************************************************ + +\begin{code} +-- CompiledByteCode represents the result of byte-code +-- compiling a bunch of functions and data types + +data CompiledByteCode + = ByteCode [UnlinkedBCO] -- Bunch of interpretable bindings + ItblEnv -- A mapping from DataCons to their itbls + +instance Outputable CompiledByteCode where + ppr (ByteCode bcos _) = ppr bcos + + +data UnlinkedBCO + = UnlinkedBCO Name + (SizedSeq Word16) -- insns + (SizedSeq (Either Word FastString)) -- literals + -- Either literal words or a pointer to a asciiz + -- string, denoting a label whose *address* should + -- be determined at link time + (SizedSeq (Either Name PrimOp)) -- ptrs + (SizedSeq Name) -- itbl refs + +nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _) = nm + +bcosFreeNames :: [UnlinkedBCO] -> NameSet +-- Finds external references. Remember to remove the names +-- defined by this group of BCOs themselves +bcosFreeNames bcos + = free_names `minusNameSet` defined_names + where + defined_names = mkNameSet (map nameOfUnlinkedBCO bcos) + free_names = foldr (unionNameSets . bco_refs) emptyNameSet bcos + + bco_refs (UnlinkedBCO _ _ _ ptrs itbls) + = mkNameSet [n | Left n <- ssElts ptrs] `unionNameSets` + mkNameSet (ssElts itbls) + +-- When translating expressions, we need to distinguish the root +-- BCO for the expression +type UnlinkedBCOExpr = (UnlinkedBCO, [UnlinkedBCO]) + +instance Outputable UnlinkedBCO where + ppr (UnlinkedBCO nm insns lits ptrs itbls) + = sep [text "BCO", ppr nm, text "with", + int (sizeSS insns), text "insns", + int (sizeSS lits), text "lits", + int (sizeSS ptrs), text "ptrs", + int (sizeSS itbls), text "itbls"] +\end{code} + + +%************************************************************************ +%* * +\subsection{The bytecode assembler} +%* * +%************************************************************************ + +The object format for bytecodes is: 16 bits for the opcode, and 16 for +each field -- so the code can be considered a sequence of 16-bit ints. +Each field denotes either a stack offset or number of items on the +stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an +index into the literal table (eg PUSH_I/D/L), or a bytecode address in +this BCO. + +\begin{code} +-- Top level assembler fn. +assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode +assembleBCOs proto_bcos tycons + = do itblenv <- mkITbls tycons + bcos <- mapM assembleBCO proto_bcos + return (ByteCode bcos itblenv) + +assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO + +assembleBCO (ProtoBCO nm instrs origin malloced) + = let + -- pass 1: collect up the offsets of the local labels. + -- Remember that the first insn starts at offset 1 since offset 0 + -- (eventually) will hold the total # of insns. + label_env = mkLabelEnv emptyFM 1 instrs + + mkLabelEnv env i_offset [] = env + mkLabelEnv env i_offset (i:is) + = let new_env + = case i of LABEL n -> addToFM env n i_offset ; _ -> env + in mkLabelEnv new_env (i_offset + instrSize16s i) is + + findLabel lab + = case lookupFM label_env lab of + Just bco_offset -> bco_offset + Nothing -> pprPanic "assembleBCO.findLabel" (int lab) + in + do -- pass 2: generate the instruction, ptr and nonptr bits + insns <- return emptySS :: IO (SizedSeq Word16) + lits <- return emptySS :: IO (SizedSeq (Either Word FastString)) + ptrs <- return emptySS :: IO (SizedSeq (Either Name PrimOp)) + itbls <- return emptySS :: IO (SizedSeq Name) + let init_asm_state = (insns,lits,ptrs,itbls) + (final_insns, final_lits, final_ptrs, final_itbls) + <- mkBits findLabel init_asm_state instrs + + let ul_bco = UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls + + -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive + -- objects, since they might get run too early. Disable this until + -- we figure out what to do. + -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced)) + + return ul_bco + where + zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#)) + free ptr + +-- instrs nonptrs ptrs itbls +type AsmState = (SizedSeq Word16, + SizedSeq (Either Word FastString), + SizedSeq (Either Name PrimOp), + SizedSeq Name) + +data SizedSeq a = SizedSeq !Int [a] +emptySS = SizedSeq 0 [] + +-- Why are these two monadic??? +addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs)) +addListToSS (SizedSeq n r_xs) xs + = return (SizedSeq (n + length xs) (reverse xs ++ r_xs)) + +ssElts :: SizedSeq a -> [a] +ssElts (SizedSeq n r_xs) = reverse r_xs + +sizeSS :: SizedSeq a -> Int +sizeSS (SizedSeq n r_xs) = n + +-- This is where all the action is (pass 2 of the assembler) +mkBits :: (Int -> Int) -- label finder + -> AsmState + -> [BCInstr] -- instructions (in) + -> IO AsmState + +mkBits findLabel st proto_insns + = foldM doInstr st proto_insns + where + doInstr :: AsmState -> BCInstr -> IO AsmState + doInstr st i + = case i of + SWIZZLE stkoff n -> instr3 st i_SWIZZLE stkoff n + ARGCHECK n -> instr2 st i_ARGCHECK n + STKCHECK n -> instr2 st i_STKCHECK n + PUSH_L o1 -> instr2 st i_PUSH_L o1 + PUSH_LL o1 o2 -> instr3 st i_PUSH_LL o1 o2 + PUSH_LLL o1 o2 o3 -> instr4 st i_PUSH_LLL o1 o2 o3 + PUSH_G nm -> do (p, st2) <- ptr st nm + instr2 st2 i_PUSH_G p + PUSH_AS nm pk -> do (p, st2) <- ptr st (Left nm) + (np, st3) <- ctoi_itbl st2 pk + instr3 st3 i_PUSH_AS p np + PUSH_UBX (Left lit) nws + -> do (np, st2) <- literal st lit + instr3 st2 i_PUSH_UBX np nws + PUSH_UBX (Right aa) nws + -> do (np, st2) <- addr st aa + instr3 st2 i_PUSH_UBX np nws + + PUSH_TAG tag -> instr2 st i_PUSH_TAG tag + SLIDE n by -> instr3 st i_SLIDE n by + ALLOC n -> instr2 st i_ALLOC n + MKAP off sz -> instr3 st i_MKAP off sz + UNPACK n -> instr2 st i_UNPACK n + UPK_TAG n m k -> instr4 st i_UPK_TAG n m k + PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon + instr3 st2 i_PACK itbl_no sz + LABEL lab -> return st + TESTLT_I i l -> do (np, st2) <- int st i + instr3 st2 i_TESTLT_I np (findLabel l) + TESTEQ_I i l -> do (np, st2) <- int st i + instr3 st2 i_TESTEQ_I np (findLabel l) + TESTLT_F f l -> do (np, st2) <- float st f + instr3 st2 i_TESTLT_F np (findLabel l) + TESTEQ_F f l -> do (np, st2) <- float st f + instr3 st2 i_TESTEQ_F np (findLabel l) + TESTLT_D d l -> do (np, st2) <- double st d + instr3 st2 i_TESTLT_D np (findLabel l) + TESTEQ_D d l -> do (np, st2) <- double st d + instr3 st2 i_TESTEQ_D np (findLabel l) + TESTLT_P i l -> instr3 st i_TESTLT_P i (findLabel l) + TESTEQ_P i l -> instr3 st i_TESTEQ_P i (findLabel l) + CASEFAIL -> instr1 st i_CASEFAIL + JMP l -> instr2 st i_JMP (findLabel l) + ENTER -> instr1 st i_ENTER + RETURN rep -> do (itbl_no,st2) <- itoc_itbl st rep + instr2 st2 i_RETURN itbl_no + CCALL m_addr -> do (np, st2) <- addr st m_addr + instr2 st2 i_CCALL np + + i2s :: Int -> Word16 + i2s = fromIntegral + + instr1 (st_i0,st_l0,st_p0,st_I0) i1 + = do st_i1 <- addToSS st_i0 (i2s i1) + return (st_i1,st_l0,st_p0,st_I0) + + instr2 (st_i0,st_l0,st_p0,st_I0) i1 i2 + = do st_i1 <- addToSS st_i0 (i2s i1) + st_i2 <- addToSS st_i1 (i2s i2) + return (st_i2,st_l0,st_p0,st_I0) + + instr3 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 + = do st_i1 <- addToSS st_i0 (i2s i1) + st_i2 <- addToSS st_i1 (i2s i2) + st_i3 <- addToSS st_i2 (i2s i3) + return (st_i3,st_l0,st_p0,st_I0) + + instr4 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 i4 + = do st_i1 <- addToSS st_i0 (i2s i1) + st_i2 <- addToSS st_i1 (i2s i2) + st_i3 <- addToSS st_i2 (i2s i3) + st_i4 <- addToSS st_i3 (i2s i4) + return (st_i4,st_l0,st_p0,st_I0) + + float (st_i0,st_l0,st_p0,st_I0) f + = do let ws = mkLitF f + st_l1 <- addListToSS st_l0 (map Left ws) + return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) + + double (st_i0,st_l0,st_p0,st_I0) d + = do let ws = mkLitD d + st_l1 <- addListToSS st_l0 (map Left ws) + return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) + + int (st_i0,st_l0,st_p0,st_I0) i + = do let ws = mkLitI i + st_l1 <- addListToSS st_l0 (map Left ws) + return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) + + int64 (st_i0,st_l0,st_p0,st_I0) i + = do let ws = mkLitI64 i + st_l1 <- addListToSS st_l0 (map Left ws) + return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) + + addr (st_i0,st_l0,st_p0,st_I0) a + = do let ws = mkLitPtr a + st_l1 <- addListToSS st_l0 (map Left ws) + return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) + + litlabel (st_i0,st_l0,st_p0,st_I0) fs + = do st_l1 <- addListToSS st_l0 [Right fs] + return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) + + ptr (st_i0,st_l0,st_p0,st_I0) p + = do st_p1 <- addToSS st_p0 p + return (sizeSS st_p0, (st_i0,st_l0,st_p1,st_I0)) + + itbl (st_i0,st_l0,st_p0,st_I0) dcon + = do st_I1 <- addToSS st_I0 (getName dcon) + return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1)) + + literal st (MachLabel fs) = litlabel st fs + literal st (MachWord w) = int st (fromIntegral w) + literal st (MachInt j) = int st (fromIntegral j) + literal st (MachFloat r) = float st (fromRational r) + literal st (MachDouble r) = double st (fromRational r) + literal st (MachChar c) = int st c + literal st (MachInt64 ii) = int64 st (fromIntegral ii) + literal st (MachWord64 ii) = int64 st (fromIntegral ii) + literal st other = pprPanic "ByteCodeLink.literal" (ppr other) + + ctoi_itbl st pk + = addr st ret_itbl_addr + where + ret_itbl_addr + = case pk of + WordRep -> stg_ctoi_ret_R1n_info + IntRep -> stg_ctoi_ret_R1n_info + AddrRep -> stg_ctoi_ret_R1n_info + CharRep -> stg_ctoi_ret_R1n_info + FloatRep -> stg_ctoi_ret_F1_info + DoubleRep -> stg_ctoi_ret_D1_info + VoidRep -> stg_ctoi_ret_V_info + other | isFollowableRep pk -> stg_ctoi_ret_R1p_info + -- Includes ArrayRep, ByteArrayRep, as well as + -- the obvious PtrRep + | otherwise + -> pprPanic "ByteCodeLink.ctoi_itbl" (ppr pk) + + itoc_itbl st pk + = addr st ret_itbl_addr + where + ret_itbl_addr + = case pk of + CharRep -> stg_gc_unbx_r1_info + IntRep -> stg_gc_unbx_r1_info + WordRep -> stg_gc_unbx_r1_info + AddrRep -> stg_gc_unbx_r1_info + FloatRep -> stg_gc_f1_info + DoubleRep -> stg_gc_d1_info + VoidRep -> nullPtr -- Interpreter.c spots this special case + other | isFollowableRep pk -> stg_gc_unpt_r1_info + | otherwise + -> pprPanic "ByteCodeLink.itoc_itbl" (ppr pk) + +foreign label "stg_ctoi_ret_R1p_info" stg_ctoi_ret_R1p_info :: Ptr () +foreign label "stg_ctoi_ret_R1n_info" stg_ctoi_ret_R1n_info :: Ptr () +foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Ptr () +foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Ptr () +foreign label "stg_ctoi_ret_V_info" stg_ctoi_ret_V_info :: Ptr () + +foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Ptr () +foreign label "stg_gc_unpt_r1_info" stg_gc_unpt_r1_info :: Ptr () +foreign label "stg_gc_f1_info" stg_gc_f1_info :: Ptr () +foreign label "stg_gc_d1_info" stg_gc_d1_info :: Ptr () + +-- The size in 16-bit entities of an instruction. +instrSize16s :: BCInstr -> Int +instrSize16s instr + = case instr of + STKCHECK _ -> 2 + ARGCHECK _ -> 2 + PUSH_L _ -> 2 + PUSH_LL _ _ -> 3 + PUSH_LLL _ _ _ -> 4 + PUSH_G _ -> 2 + PUSH_AS _ _ -> 3 + PUSH_UBX _ _ -> 3 + PUSH_TAG _ -> 2 + SLIDE _ _ -> 3 + ALLOC _ -> 2 + MKAP _ _ -> 3 + UNPACK _ -> 2 + UPK_TAG _ _ _ -> 4 + PACK _ _ -> 3 + LABEL _ -> 0 -- !! + TESTLT_I _ _ -> 3 + TESTEQ_I _ _ -> 3 + TESTLT_F _ _ -> 3 + TESTEQ_F _ _ -> 3 + TESTLT_D _ _ -> 3 + TESTEQ_D _ _ -> 3 + TESTLT_P _ _ -> 3 + TESTEQ_P _ _ -> 3 + JMP _ -> 2 + CASEFAIL -> 1 + ENTER -> 1 + RETURN _ -> 2 + + +-- Make lists of host-sized words for literals, so that when the +-- words are placed in memory at increasing addresses, the +-- bit pattern is correct for the host's word size and endianness. +mkLitI :: Int -> [Word] +mkLitF :: Float -> [Word] +mkLitD :: Double -> [Word] +mkLitPtr :: Ptr () -> [Word] +mkLitI64 :: Int64 -> [Word] + +mkLitF f + = runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 f + f_arr <- castSTUArray arr + w0 <- readArray f_arr 0 + return [w0 :: Word] + ) + +mkLitD d + | wORD_SIZE == 4 + = runST (do + arr <- newArray_ ((0::Int),1) + writeArray arr 0 d + d_arr <- castSTUArray arr + w0 <- readArray d_arr 0 + w1 <- readArray d_arr 1 + return [w0 :: Word, w1] + ) + | wORD_SIZE == 8 + = runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 d + d_arr <- castSTUArray arr + w0 <- readArray d_arr 0 + return [w0 :: Word] + ) + +mkLitI64 ii + | wORD_SIZE == 4 + = runST (do + arr <- newArray_ ((0::Int),1) + writeArray arr 0 ii + d_arr <- castSTUArray arr + w0 <- readArray d_arr 0 + w1 <- readArray d_arr 1 + return [w0 :: Word,w1] + ) + | wORD_SIZE == 8 + = runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 ii + d_arr <- castSTUArray arr + w0 <- readArray d_arr 0 + return [w0 :: Word] + ) + +mkLitI i + = runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 i + i_arr <- castSTUArray arr + w0 <- readArray i_arr 0 + return [w0 :: Word] + ) + +mkLitPtr a + = runST (do + arr <- newArray_ ((0::Int),0) + writeArray arr 0 a + a_arr <- castSTUArray arr + w0 <- readArray a_arr 0 + return [w0 :: Word] + ) +\end{code} + +%************************************************************************ +%* * +\subsection{Connect to actual values for bytecode opcodes} +%* * +%************************************************************************ + +\begin{code} + +#include "Bytecodes.h" + +i_ARGCHECK = (bci_ARGCHECK :: Int) +i_PUSH_L = (bci_PUSH_L :: Int) +i_PUSH_LL = (bci_PUSH_LL :: Int) +i_PUSH_LLL = (bci_PUSH_LLL :: Int) +i_PUSH_G = (bci_PUSH_G :: Int) +i_PUSH_AS = (bci_PUSH_AS :: Int) +i_PUSH_UBX = (bci_PUSH_UBX :: Int) +i_PUSH_TAG = (bci_PUSH_TAG :: Int) +i_SLIDE = (bci_SLIDE :: Int) +i_ALLOC = (bci_ALLOC :: Int) +i_MKAP = (bci_MKAP :: Int) +i_UNPACK = (bci_UNPACK :: Int) +i_UPK_TAG = (bci_UPK_TAG :: Int) +i_PACK = (bci_PACK :: Int) +i_TESTLT_I = (bci_TESTLT_I :: Int) +i_TESTEQ_I = (bci_TESTEQ_I :: Int) +i_TESTLT_F = (bci_TESTLT_F :: Int) +i_TESTEQ_F = (bci_TESTEQ_F :: Int) +i_TESTLT_D = (bci_TESTLT_D :: Int) +i_TESTEQ_D = (bci_TESTEQ_D :: Int) +i_TESTLT_P = (bci_TESTLT_P :: Int) +i_TESTEQ_P = (bci_TESTEQ_P :: Int) +i_CASEFAIL = (bci_CASEFAIL :: Int) +i_ENTER = (bci_ENTER :: Int) +i_RETURN = (bci_RETURN :: Int) +i_STKCHECK = (bci_STKCHECK :: Int) +i_JMP = (bci_JMP :: Int) +#ifdef bci_CCALL +i_CCALL = (bci_CCALL :: Int) +i_SWIZZLE = (bci_SWIZZLE :: Int) +#else +i_CCALL = error "Sorry pal, you need to bootstrap to use i_CCALL." +i_SWIZZLE = error "Sorry pal, you need to bootstrap to use i_SWIZZLE." +#endif + +iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int) +\end{code} + diff --git a/ghc/compiler/ghci/ByteCodeFFI.lhs b/ghc/compiler/ghci/ByteCodeFFI.lhs index 5e81002648..4fc09a7667 100644 --- a/ghc/compiler/ghci/ByteCodeFFI.lhs +++ b/ghc/compiler/ghci/ByteCodeFFI.lhs @@ -12,16 +12,16 @@ import Outputable import PrimRep ( PrimRep(..), getPrimRepSize, isFollowableRep ) import ForeignCall ( CCallConv(..) ) --- DON'T remove apparently unused imports here .. there is ifdeffery --- below -import Bits ( Bits(..), shiftR, shiftL ) +-- DON'T remove apparently unused imports here .. +-- there is ifdeffery below +import DATA_BITS ( Bits(..), shiftR, shiftL ) import Foreign ( newArray ) -import Data.Word ( Word8, Word32 ) -import Foreign ( Ptr, mallocBytes ) -import Debug.Trace ( trace ) +import DATA_WORD ( Word8, Word32 ) +import Foreign ( Ptr ) import System.IO.Unsafe ( unsafePerformIO ) import IO ( hPutStrLn, stderr ) +-- import Debug.Trace ( trace ) \end{code} %************************************************************************ diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 8238a6be21..72f4d62043 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -4,22 +4,28 @@ \section[ByteCodeGen]{Generate bytecode from Core} \begin{code} -module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, ItblEnv, ClosureEnv, HValue, - filterNameMap, - byteCodeGen, coreExprToBCOs +module ByteCodeGen ( UnlinkedBCO, UnlinkedBCOExpr, + byteCodeGen, coreExprToBCOs ) where #include "HsVersions.h" +import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse ) +import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 ) +import ByteCodeAsm ( CompiledByteCode(..), UnlinkedBCO, UnlinkedBCOExpr, + assembleBCO, assembleBCOs, iNTERP_STACK_CHECK_THRESH ) +import ByteCodeLink ( lookupStaticPtr ) + import Outputable -import Name ( Name, getName ) +import Name ( Name, getName, mkSystemName ) import Id ( Id, idType, isDataConId_maybe, isPrimOpId_maybe, isFCallId, - idPrimRep, mkSysLocal, idName, isFCallId_maybe, isPrimOpId ) + idPrimRep, mkLocalId, isFCallId_maybe, isPrimOpId ) import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) ) import OrdList ( OrdList, consOL, snocOL, appOL, unitOL, nilOL, toOL, concatOL, fromOL ) import FiniteMap ( FiniteMap, addListToFM, listToFM, elemFM, addToFM, lookupFM, fmToList ) +import HscTypes ( ModGuts(..), ModGuts, typeEnvTyCons, typeEnvClasses ) import CoreUtils ( exprType ) import CoreSyn import PprCore ( pprCoreExpr ) @@ -30,7 +36,7 @@ import CoreFVs ( freeVars ) import Type ( typePrimRep, isUnLiftedType, splitTyConApp_maybe, isTyVarTy ) import DataCon ( dataConTag, fIRST_TAG, dataConTyCon, dataConWrapId, isUnboxedTupleCon ) -import TyCon ( TyCon(..), tyConFamilySize, isDataTyCon, tyConDataCons, +import TyCon ( tyConFamilySize, isDataTyCon, tyConDataCons, isFunTyCon, isUnboxedTupleTyCon ) import Class ( Class, classTyCon ) import Type ( Type, repType, splitFunTys, dropForAlls ) @@ -52,17 +58,10 @@ import Panic ( GhcException(..) ) import PprType ( pprType ) import SMRep ( arrWordsHdrSize, arrPtrsHdrSize ) import Constants ( wORD_SIZE ) -import ByteCodeInstr ( BCInstr(..), ProtoBCO(..), nameOfProtoBCO, bciStackUse ) -import ByteCodeItbls ( ItblEnv, mkITbls ) -import ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO, - ClosureEnv, HValue, filterNameMap, linkFail, - iNTERP_STACK_CHECK_THRESH ) -import ByteCodeFFI ( taggedSizeW, untaggedSizeW, mkMarshalCode, moan64 ) -import Linker ( lookupSymbol ) import List ( intersperse, sortBy, zip4 ) import Foreign ( Ptr, castPtr, mallocBytes, pokeByteOff, Word8 ) -import CTypes ( CInt ) +import Foreign.C ( CInt ) import Control.Exception ( throwDyn ) import GHC.Exts ( Int(..), ByteArray# ) @@ -81,13 +80,13 @@ import Char ( ord ) \begin{code} byteCodeGen :: DynFlags - -> [CoreBind] - -> [TyCon] -> [Class] - -> IO ([UnlinkedBCO], ItblEnv) -byteCodeGen dflags binds local_tycons local_classes + -> ModGuts + -> IO CompiledByteCode +byteCodeGen dflags (ModGuts { mg_binds = binds, mg_types = type_env }) = do showPass dflags "ByteCodeGen" - let tycs = local_tycons ++ map classTyCon local_classes - itblenv <- mkITbls tycs + let local_tycons = typeEnvTyCons type_env + local_classes = typeEnvClasses type_env + tycs = local_tycons ++ map classTyCon local_classes let flatBinds = concatMap getBind binds getBind (NonRec bndr rhs) = [(bndr, freeVars rhs)] @@ -105,9 +104,7 @@ byteCodeGen dflags binds local_tycons local_classes dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-bcos" (vcat (intersperse (char ' ') (map ppr proto_bcos))) - bcos <- mapM assembleBCO proto_bcos - - return (bcos, itblenv) + assembleBCOs proto_bcos tycs -- Returns: (the root BCO for this expression, @@ -120,13 +117,10 @@ coreExprToBCOs dflags expr -- create a totally bogus name for the top-level BCO; this -- should be harmless, since it's never used for anything - let invented_id = mkSysLocal FSLIT("ExprTopLevel") - (mkPseudoUnique3 0) - (panic "invented_id's type") - let invented_name = idName invented_id - - annexpr = freeVars expr - fvs = filter (not.isTyVar) (varSetElems (fst annexpr)) + let invented_name = mkSystemName (mkPseudoUnique3 0) FSLIT("ExprTopLevel") + invented_id = mkLocalId invented_name (panic "invented_id's type") + annexpr = freeVars expr + fvs = filter (not.isTyVar) (varSetElems (fst annexpr)) (BcM_State all_proto_bcos final_ctr mallocd, ()) <- runBc (BcM_State [] 0 []) @@ -897,12 +891,8 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l DynamicTarget -> returnBc (False, panic "ByteCodeGen.generateCCall(dyn)") StaticTarget target - -> let sym_to_find = unpackFS target in - ioToBc (lookupSymbol sym_to_find) `thenBc` \res -> - case res of - Just aa -> returnBc (True, aa) - Nothing -> ioToBc (linkFail "ByteCodeGen.generateCCall" - sym_to_find) + -> ioToBc (lookupStaticPtr target) `thenBc` \res -> + returnBc (True, res) CasmTarget _ -> pprPanic "ByteCodeGen.generateCCall: casm" (ppr ccall_spec) in diff --git a/ghc/compiler/ghci/ByteCodeInstr.lhs b/ghc/compiler/ghci/ByteCodeInstr.lhs index 8ff89a8919..05b8a1a3f8 100644 --- a/ghc/compiler/ghci/ByteCodeInstr.lhs +++ b/ghc/compiler/ghci/ByteCodeInstr.lhs @@ -19,7 +19,7 @@ import PrimRep ( PrimRep ) import DataCon ( DataCon ) import VarSet ( VarSet ) import PrimOp ( PrimOp ) -import Ptr +import GHC.Ptr \end{code} %************************************************************************ diff --git a/ghc/compiler/ghci/ByteCodeItbls.lhs b/ghc/compiler/ghci/ByteCodeItbls.lhs index c7f829e77d..4473ccfcc6 100644 --- a/ghc/compiler/ghci/ByteCodeItbls.lhs +++ b/ghc/compiler/ghci/ByteCodeItbls.lhs @@ -12,7 +12,7 @@ module ByteCodeItbls ( ItblEnv, ItblPtr, mkITbls ) where #include "HsVersions.h" import Name ( Name, getName ) -import FiniteMap ( FiniteMap, listToFM, emptyFM, plusFM ) +import NameEnv import Type ( typePrimRep ) import DataCon ( DataCon, dataConRepArgTys ) import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons ) @@ -23,12 +23,14 @@ import Util ( lengthIs, listLengthCmp ) import Foreign ( Storable(..), Word8, Word16, Word32, Word64, malloc, castPtr, plusPtr ) -import Bits ( Bits(..), shiftR ) - -import Monad ( liftM ) +import DATA_BITS ( Bits(..), shiftR ) import GHC.Exts ( Int(I#), addr2Int# ) +#if __GLASGOW_HASKELL__ < 503 +import Ptr ( Ptr(..) ) +#else import GHC.Ptr ( Ptr(..) ) +#endif \end{code} %************************************************************************ @@ -38,22 +40,26 @@ import GHC.Ptr ( Ptr(..) ) %************************************************************************ \begin{code} - type ItblPtr = Ptr StgInfoTable -type ItblEnv = FiniteMap Name ItblPtr +type ItblEnv = NameEnv (Name, ItblPtr) + -- We need the Name in the range so we know which + -- elements to filter out when unloading a module + +mkItblEnv :: [(Name,ItblPtr)] -> ItblEnv +mkItblEnv pairs = mkNameEnv [(n, (n,p)) | (n,p) <- pairs] -- Make info tables for the data decls in this module mkITbls :: [TyCon] -> IO ItblEnv -mkITbls [] = return emptyFM +mkITbls [] = return emptyNameEnv mkITbls (tc:tcs) = do itbls <- mkITbl tc itbls2 <- mkITbls tcs - return (itbls `plusFM` itbls2) + return (itbls `plusNameEnv` itbls2) mkITbl :: TyCon -> IO ItblEnv mkITbl tc | not (isDataTyCon tc) - = return emptyFM + = return emptyNameEnv | dcs `lengthIs` n -- paranoia; this is an assertion. = make_constr_itbls dcs where @@ -68,10 +74,10 @@ make_constr_itbls :: [DataCon] -> IO ItblEnv make_constr_itbls cons | listLengthCmp cons 8 /= GT -- <= 8 elements in the list = do is <- mapM mk_vecret_itbl (zip cons [0..]) - return (listToFM is) + return (mkItblEnv is) | otherwise = do is <- mapM mk_dirret_itbl (zip cons [0..]) - return (listToFM is) + return (mkItblEnv is) where mk_vecret_itbl (dcon, conNo) = mk_itbl dcon conNo (vecret_entry conNo) diff --git a/ghc/compiler/ghci/ByteCodeLink.lhs b/ghc/compiler/ghci/ByteCodeLink.lhs index 0ca24f8d45..c3bb73342e 100644 --- a/ghc/compiler/ghci/ByteCodeLink.lhs +++ b/ghc/compiler/ghci/ByteCodeLink.lhs @@ -7,48 +7,34 @@ {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} -module ByteCodeLink ( UnlinkedBCO, UnlinkedBCOExpr, assembleBCO, - ClosureEnv, HValue, filterNameMap, - linkIModules, linkIExpr, linkFail, - iNTERP_STACK_CHECK_THRESH - ) where +module ByteCodeLink ( + HValue, + ClosureEnv, emptyClosureEnv, extendClosureEnv, + linkBCO, lookupStaticPtr + ) where #include "HsVersions.h" -import Outputable -import Name ( Name, getName, nameModule, toRdrName, isExternalName ) -import RdrName ( rdrNameOcc, rdrNameModule ) +import ByteCodeItbls ( ItblEnv, ItblPtr ) +import ByteCodeAsm ( UnlinkedBCO(..), sizeSS, ssElts ) +import ObjLink ( lookupSymbol ) + +import Name ( Name, nameModule, nameOccName, isExternalName ) +import NameEnv import OccName ( occNameString ) -import FiniteMap ( FiniteMap, addListToFM, filterFM, - addToFM, lookupFM, emptyFM ) -import CoreSyn -import Literal ( Literal(..) ) import PrimOp ( PrimOp, primOpOcc ) -import PrimRep ( PrimRep(..), isFollowableRep ) -import Constants ( wORD_SIZE ) -import Module ( ModuleName, moduleName, moduleNameFS ) -import Linker ( lookupSymbol ) +import Module ( moduleString ) import FastString ( FastString(..), unpackFS ) -import ByteCodeInstr ( BCInstr(..), ProtoBCO(..) ) -import ByteCodeItbls ( ItblEnv, ItblPtr ) -import FiniteMap +import Outputable import Panic ( GhcException(..) ) -import Util ( notNull ) - -import Control.Monad ( when, foldM ) -import Control.Monad.ST ( runST ) -import Data.Array.IArray ( array ) +-- Standard libraries import GHC.Word ( Word(..) ) -import Data.Array.MArray ( MArray, newArray_, readArray, writeArray ) -import Data.Array.ST ( castSTUArray ) + +import Data.Array.IArray ( array ) import Data.Array.Base ( UArray(..) ) -import Foreign.Ptr ( nullPtr ) -import Foreign ( Word16, free ) -import System.Mem.Weak ( addFinalizer ) -import Data.Int ( Int64 ) +import Foreign ( Word16 ) -import System.IO ( fixIO ) import Control.Exception ( throwDyn ) import GHC.Exts ( BCO#, newBCO#, unsafeCoerce#, @@ -59,459 +45,25 @@ import GHC.IOBase ( IO(..) ) import GHC.Ptr ( Ptr(..) ) \end{code} + %************************************************************************ %* * -\subsection{Top-level stuff} +\subsection{Linking interpretables into something we can run} %* * %************************************************************************ \begin{code} --- Linking stuff -linkIModules :: ItblEnv -- incoming global itbl env; returned updated - -> ClosureEnv -- incoming global closure env; returned updated - -> [([UnlinkedBCO], ItblEnv)] - -> IO ([HValue], ItblEnv, ClosureEnv) -linkIModules gie gce mods - = do let (bcoss, ies) = unzip mods - bcos = concat bcoss - final_gie = foldr plusFM gie ies - (final_gce, linked_bcos) <- linkSomeBCOs True final_gie gce bcos - return (linked_bcos, final_gie, final_gce) - - -linkIExpr :: ItblEnv -> ClosureEnv -> UnlinkedBCOExpr - -> IO HValue -- IO BCO# really -linkIExpr ie ce (root_ul_bco, aux_ul_bcos) - = do (aux_ce, _) <- linkSomeBCOs False ie ce aux_ul_bcos - (_, [root_bco]) <- linkSomeBCOs False ie aux_ce [root_ul_bco] - return root_bco - --- Link a bunch of BCOs and return them + updated closure env. -linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env - -- True <=> add only toplevel BCOs to closure env - -> ItblEnv - -> ClosureEnv - -> [UnlinkedBCO] - -> IO (ClosureEnv, [HValue]) -linkSomeBCOs toplevs_only ie ce_in ul_bcos - = do let nms = map nameOfUnlinkedBCO ul_bcos - hvals <- fixIO - ( \ hvs -> let ce_out = addListToFM ce_in (zipLazily nms hvs) - in mapM (linkBCO ie ce_out) ul_bcos ) - - let ce_all_additions = zip nms hvals - ce_top_additions = filter (isExternalName.fst) ce_all_additions - ce_additions = if toplevs_only then ce_top_additions - else ce_all_additions - ce_out = -- make sure we're not inserting duplicate names into the - -- closure environment, which leads to trouble. - ASSERT (all (not . (`elemFM` ce_in)) (map fst ce_additions)) - addListToFM ce_in ce_additions - return (ce_out, hvals) - where - -- A lazier zip, in which no demand is propagated to the second - -- list unless some demand is propagated to the snd of one of the - -- result list elems. - zipLazily [] ys = [] - zipLazily (x:xs) ys = (x, head ys) : zipLazily xs (tail ys) - - -data UnlinkedBCO - = UnlinkedBCO Name - (SizedSeq Word16) -- insns - (SizedSeq (Either Word FastString)) -- literals - -- Either literal words or a pointer to a asciiz - -- string, denoting a label whose *address* should - -- be determined at link time - (SizedSeq (Either Name PrimOp)) -- ptrs - (SizedSeq Name) -- itbl refs - -nameOfUnlinkedBCO (UnlinkedBCO nm _ _ _ _) = nm - --- When translating expressions, we need to distinguish the root --- BCO for the expression -type UnlinkedBCOExpr = (UnlinkedBCO, [UnlinkedBCO]) - -instance Outputable UnlinkedBCO where - ppr (UnlinkedBCO nm insns lits ptrs itbls) - = sep [text "BCO", ppr nm, text "with", - int (sizeSS insns), text "insns", - int (sizeSS lits), text "lits", - int (sizeSS ptrs), text "ptrs", - int (sizeSS itbls), text "itbls"] - - --- these need a proper home -type ClosureEnv = FiniteMap Name HValue +type ClosureEnv = NameEnv (Name, HValue) data HValue = HValue -- dummy type, actually a pointer to some Real Code. --- remove all entries for a given set of modules from the environment; --- note that this removes all local names too (ie. temporary bindings from --- the command line). -filterNameMap :: [ModuleName] -> FiniteMap Name a -> FiniteMap Name a -filterNameMap mods env - = filterFM (\n _ -> isExternalName n - && moduleName (nameModule n) `elem` mods) env -\end{code} - -%************************************************************************ -%* * -\subsection{The bytecode assembler} -%* * -%************************************************************************ - -The object format for bytecodes is: 16 bits for the opcode, and 16 for -each field -- so the code can be considered a sequence of 16-bit ints. -Each field denotes either a stack offset or number of items on the -stack (eg SLIDE), and index into the pointer table (eg PUSH_G), an -index into the literal table (eg PUSH_I/D/L), or a bytecode address in -this BCO. +emptyClosureEnv = emptyNameEnv -\begin{code} --- Top level assembler fn. -assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO - -assembleBCO (ProtoBCO nm instrs origin malloced) - = let - -- pass 1: collect up the offsets of the local labels. - -- Remember that the first insn starts at offset 1 since offset 0 - -- (eventually) will hold the total # of insns. - label_env = mkLabelEnv emptyFM 1 instrs - - mkLabelEnv env i_offset [] = env - mkLabelEnv env i_offset (i:is) - = let new_env - = case i of LABEL n -> addToFM env n i_offset ; _ -> env - in mkLabelEnv new_env (i_offset + instrSize16s i) is - - findLabel lab - = case lookupFM label_env lab of - Just bco_offset -> bco_offset - Nothing -> pprPanic "assembleBCO.findLabel" (int lab) - in - do -- pass 2: generate the instruction, ptr and nonptr bits - insns <- return emptySS :: IO (SizedSeq Word16) - lits <- return emptySS :: IO (SizedSeq (Either Word FastString)) - ptrs <- return emptySS :: IO (SizedSeq (Either Name PrimOp)) - itbls <- return emptySS :: IO (SizedSeq Name) - let init_asm_state = (insns,lits,ptrs,itbls) - (final_insns, final_lits, final_ptrs, final_itbls) - <- mkBits findLabel init_asm_state instrs - - let ul_bco = UnlinkedBCO nm final_insns final_lits final_ptrs final_itbls - - -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive - -- objects, since they might get run too early. Disable this until - -- we figure out what to do. - -- when (notNull malloced) (addFinalizer ul_bco (mapM_ zonk malloced)) - - return ul_bco - where - zonk ptr = do -- putStrLn ("freeing malloc'd block at " ++ show (A# a#)) - free ptr - --- instrs nonptrs ptrs itbls -type AsmState = (SizedSeq Word16, - SizedSeq (Either Word FastString), - SizedSeq (Either Name PrimOp), - SizedSeq Name) - -data SizedSeq a = SizedSeq !Int [a] -emptySS = SizedSeq 0 [] -addToSS (SizedSeq n r_xs) x = return (SizedSeq (n+1) (x:r_xs)) -addListToSS (SizedSeq n r_xs) xs - = return (SizedSeq (n + length xs) (reverse xs ++ r_xs)) -sizeSS (SizedSeq n r_xs) = n -listFromSS (SizedSeq n r_xs) = return (reverse r_xs) - - --- This is where all the action is (pass 2 of the assembler) -mkBits :: (Int -> Int) -- label finder - -> AsmState - -> [BCInstr] -- instructions (in) - -> IO AsmState - -mkBits findLabel st proto_insns - = foldM doInstr st proto_insns - where - doInstr :: AsmState -> BCInstr -> IO AsmState - doInstr st i - = case i of - SWIZZLE stkoff n -> instr3 st i_SWIZZLE stkoff n - ARGCHECK n -> instr2 st i_ARGCHECK n - STKCHECK n -> instr2 st i_STKCHECK n - PUSH_L o1 -> instr2 st i_PUSH_L o1 - PUSH_LL o1 o2 -> instr3 st i_PUSH_LL o1 o2 - PUSH_LLL o1 o2 o3 -> instr4 st i_PUSH_LLL o1 o2 o3 - PUSH_G nm -> do (p, st2) <- ptr st nm - instr2 st2 i_PUSH_G p - PUSH_AS nm pk -> do (p, st2) <- ptr st (Left nm) - (np, st3) <- ctoi_itbl st2 pk - instr3 st3 i_PUSH_AS p np - PUSH_UBX (Left lit) nws - -> do (np, st2) <- literal st lit - instr3 st2 i_PUSH_UBX np nws - PUSH_UBX (Right aa) nws - -> do (np, st2) <- addr st aa - instr3 st2 i_PUSH_UBX np nws - - PUSH_TAG tag -> instr2 st i_PUSH_TAG tag - SLIDE n by -> instr3 st i_SLIDE n by - ALLOC n -> instr2 st i_ALLOC n - MKAP off sz -> instr3 st i_MKAP off sz - UNPACK n -> instr2 st i_UNPACK n - UPK_TAG n m k -> instr4 st i_UPK_TAG n m k - PACK dcon sz -> do (itbl_no,st2) <- itbl st dcon - instr3 st2 i_PACK itbl_no sz - LABEL lab -> return st - TESTLT_I i l -> do (np, st2) <- int st i - instr3 st2 i_TESTLT_I np (findLabel l) - TESTEQ_I i l -> do (np, st2) <- int st i - instr3 st2 i_TESTEQ_I np (findLabel l) - TESTLT_F f l -> do (np, st2) <- float st f - instr3 st2 i_TESTLT_F np (findLabel l) - TESTEQ_F f l -> do (np, st2) <- float st f - instr3 st2 i_TESTEQ_F np (findLabel l) - TESTLT_D d l -> do (np, st2) <- double st d - instr3 st2 i_TESTLT_D np (findLabel l) - TESTEQ_D d l -> do (np, st2) <- double st d - instr3 st2 i_TESTEQ_D np (findLabel l) - TESTLT_P i l -> instr3 st i_TESTLT_P i (findLabel l) - TESTEQ_P i l -> instr3 st i_TESTEQ_P i (findLabel l) - CASEFAIL -> instr1 st i_CASEFAIL - JMP l -> instr2 st i_JMP (findLabel l) - ENTER -> instr1 st i_ENTER - RETURN rep -> do (itbl_no,st2) <- itoc_itbl st rep - instr2 st2 i_RETURN itbl_no - CCALL m_addr -> do (np, st2) <- addr st m_addr - instr2 st2 i_CCALL np - - i2s :: Int -> Word16 - i2s = fromIntegral - - instr1 (st_i0,st_l0,st_p0,st_I0) i1 - = do st_i1 <- addToSS st_i0 (i2s i1) - return (st_i1,st_l0,st_p0,st_I0) - - instr2 (st_i0,st_l0,st_p0,st_I0) i1 i2 - = do st_i1 <- addToSS st_i0 (i2s i1) - st_i2 <- addToSS st_i1 (i2s i2) - return (st_i2,st_l0,st_p0,st_I0) - - instr3 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 - = do st_i1 <- addToSS st_i0 (i2s i1) - st_i2 <- addToSS st_i1 (i2s i2) - st_i3 <- addToSS st_i2 (i2s i3) - return (st_i3,st_l0,st_p0,st_I0) - - instr4 (st_i0,st_l0,st_p0,st_I0) i1 i2 i3 i4 - = do st_i1 <- addToSS st_i0 (i2s i1) - st_i2 <- addToSS st_i1 (i2s i2) - st_i3 <- addToSS st_i2 (i2s i3) - st_i4 <- addToSS st_i3 (i2s i4) - return (st_i4,st_l0,st_p0,st_I0) - - float (st_i0,st_l0,st_p0,st_I0) f - = do let ws = mkLitF f - st_l1 <- addListToSS st_l0 (map Left ws) - return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) - - double (st_i0,st_l0,st_p0,st_I0) d - = do let ws = mkLitD d - st_l1 <- addListToSS st_l0 (map Left ws) - return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) - - int (st_i0,st_l0,st_p0,st_I0) i - = do let ws = mkLitI i - st_l1 <- addListToSS st_l0 (map Left ws) - return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) - - int64 (st_i0,st_l0,st_p0,st_I0) i - = do let ws = mkLitI64 i - st_l1 <- addListToSS st_l0 (map Left ws) - return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) - - addr (st_i0,st_l0,st_p0,st_I0) a - = do let ws = mkLitPtr a - st_l1 <- addListToSS st_l0 (map Left ws) - return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) - - litlabel (st_i0,st_l0,st_p0,st_I0) fs - = do st_l1 <- addListToSS st_l0 [Right fs] - return (sizeSS st_l0, (st_i0,st_l1,st_p0,st_I0)) - - ptr (st_i0,st_l0,st_p0,st_I0) p - = do st_p1 <- addToSS st_p0 p - return (sizeSS st_p0, (st_i0,st_l0,st_p1,st_I0)) - - itbl (st_i0,st_l0,st_p0,st_I0) dcon - = do st_I1 <- addToSS st_I0 (getName dcon) - return (sizeSS st_I0, (st_i0,st_l0,st_p0,st_I1)) - - literal st (MachLabel fs) = litlabel st fs - literal st (MachWord w) = int st (fromIntegral w) - literal st (MachInt j) = int st (fromIntegral j) - literal st (MachFloat r) = float st (fromRational r) - literal st (MachDouble r) = double st (fromRational r) - literal st (MachChar c) = int st c - literal st (MachInt64 ii) = int64 st (fromIntegral ii) - literal st (MachWord64 ii) = int64 st (fromIntegral ii) - literal st other = pprPanic "ByteCodeLink.literal" (ppr other) - - ctoi_itbl st pk - = addr st ret_itbl_addr - where - ret_itbl_addr - = case pk of - WordRep -> stg_ctoi_ret_R1n_info - IntRep -> stg_ctoi_ret_R1n_info - AddrRep -> stg_ctoi_ret_R1n_info - CharRep -> stg_ctoi_ret_R1n_info - FloatRep -> stg_ctoi_ret_F1_info - DoubleRep -> stg_ctoi_ret_D1_info - VoidRep -> stg_ctoi_ret_V_info - other | isFollowableRep pk -> stg_ctoi_ret_R1p_info - -- Includes ArrayRep, ByteArrayRep, as well as - -- the obvious PtrRep - | otherwise - -> pprPanic "ByteCodeLink.ctoi_itbl" (ppr pk) - - itoc_itbl st pk - = addr st ret_itbl_addr - where - ret_itbl_addr - = case pk of - CharRep -> stg_gc_unbx_r1_info - IntRep -> stg_gc_unbx_r1_info - WordRep -> stg_gc_unbx_r1_info - AddrRep -> stg_gc_unbx_r1_info - FloatRep -> stg_gc_f1_info - DoubleRep -> stg_gc_d1_info - VoidRep -> nullPtr -- Interpreter.c spots this special case - other | isFollowableRep pk -> stg_gc_unpt_r1_info - | otherwise - -> pprPanic "ByteCodeLink.itoc_itbl" (ppr pk) - -foreign label "stg_ctoi_ret_R1p_info" stg_ctoi_ret_R1p_info :: Ptr () -foreign label "stg_ctoi_ret_R1n_info" stg_ctoi_ret_R1n_info :: Ptr () -foreign label "stg_ctoi_ret_F1_info" stg_ctoi_ret_F1_info :: Ptr () -foreign label "stg_ctoi_ret_D1_info" stg_ctoi_ret_D1_info :: Ptr () -foreign label "stg_ctoi_ret_V_info" stg_ctoi_ret_V_info :: Ptr () - -foreign label "stg_gc_unbx_r1_info" stg_gc_unbx_r1_info :: Ptr () -foreign label "stg_gc_unpt_r1_info" stg_gc_unpt_r1_info :: Ptr () -foreign label "stg_gc_f1_info" stg_gc_f1_info :: Ptr () -foreign label "stg_gc_d1_info" stg_gc_d1_info :: Ptr () - --- The size in 16-bit entities of an instruction. -instrSize16s :: BCInstr -> Int -instrSize16s instr - = case instr of - STKCHECK _ -> 2 - ARGCHECK _ -> 2 - PUSH_L _ -> 2 - PUSH_LL _ _ -> 3 - PUSH_LLL _ _ _ -> 4 - PUSH_G _ -> 2 - PUSH_AS _ _ -> 3 - PUSH_UBX _ _ -> 3 - PUSH_TAG _ -> 2 - SLIDE _ _ -> 3 - ALLOC _ -> 2 - MKAP _ _ -> 3 - UNPACK _ -> 2 - UPK_TAG _ _ _ -> 4 - PACK _ _ -> 3 - LABEL _ -> 0 -- !! - TESTLT_I _ _ -> 3 - TESTEQ_I _ _ -> 3 - TESTLT_F _ _ -> 3 - TESTEQ_F _ _ -> 3 - TESTLT_D _ _ -> 3 - TESTEQ_D _ _ -> 3 - TESTLT_P _ _ -> 3 - TESTEQ_P _ _ -> 3 - JMP _ -> 2 - CASEFAIL -> 1 - ENTER -> 1 - RETURN _ -> 2 - - --- Make lists of host-sized words for literals, so that when the --- words are placed in memory at increasing addresses, the --- bit pattern is correct for the host's word size and endianness. -mkLitI :: Int -> [Word] -mkLitF :: Float -> [Word] -mkLitD :: Double -> [Word] -mkLitPtr :: Ptr () -> [Word] -mkLitI64 :: Int64 -> [Word] - -mkLitF f - = runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 f - f_arr <- castSTUArray arr - w0 <- readArray f_arr 0 - return [w0 :: Word] - ) - -mkLitD d - | wORD_SIZE == 4 - = runST (do - arr <- newArray_ ((0::Int),1) - writeArray arr 0 d - d_arr <- castSTUArray arr - w0 <- readArray d_arr 0 - w1 <- readArray d_arr 1 - return [w0 :: Word, w1] - ) - | wORD_SIZE == 8 - = runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 d - d_arr <- castSTUArray arr - w0 <- readArray d_arr 0 - return [w0 :: Word] - ) - -mkLitI64 ii - | wORD_SIZE == 4 - = runST (do - arr <- newArray_ ((0::Int),1) - writeArray arr 0 ii - d_arr <- castSTUArray arr - w0 <- readArray d_arr 0 - w1 <- readArray d_arr 1 - return [w0 :: Word,w1] - ) - | wORD_SIZE == 8 - = runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 ii - d_arr <- castSTUArray arr - w0 <- readArray d_arr 0 - return [w0 :: Word] - ) - -mkLitI i - = runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 i - i_arr <- castSTUArray arr - w0 <- readArray i_arr 0 - return [w0 :: Word] - ) - -mkLitPtr a - = runST (do - arr <- newArray_ ((0::Int),0) - writeArray arr 0 a - a_arr <- castSTUArray arr - w0 <- readArray a_arr 0 - return [w0 :: Word] - ) +extendClosureEnv :: ClosureEnv -> [(Name,HValue)] -> ClosureEnv +extendClosureEnv cl_env pairs + = extendNameEnvList cl_env [ (n, (n,v)) | (n,v) <- pairs] \end{code} + %************************************************************************ %* * \subsection{Linking interpretables into something we can run} @@ -519,7 +71,6 @@ mkLitPtr a %************************************************************************ \begin{code} - {- data BCO# = BCO# ByteArray# -- instrs :: Array Word16# ByteArray# -- literals :: Array Word32# @@ -527,11 +78,13 @@ data BCO# = BCO# ByteArray# -- instrs :: Array Word16# ByteArray# -- itbls :: Array Addr# -} +linkBCO :: ItblEnv -> ClosureEnv -> UnlinkedBCO -> IO HValue linkBCO ie ce (UnlinkedBCO nm insnsSS literalsSS ptrsSS itblsSS) - = do insns <- listFromSS insnsSS - literals <- listFromSS literalsSS - ptrs <- listFromSS ptrsSS - itbls <- listFromSS itblsSS +-- Raises an IO exception on failure + = do let insns = ssElts insnsSS + literals = ssElts literalsSS + ptrs = ssElts ptrsSS + itbls = ssElts itblsSS linked_ptrs <- mapM (lookupCE ce) ptrs linked_itbls <- mapM (lookupIE ie) itbls @@ -580,18 +133,22 @@ newBCO a b c d lookupLiteral :: Either Word FastString -> IO Word -lookupLiteral (Left w) = return w -lookupLiteral (Right addr_of_label_string) +lookupLiteral (Left lit) = return lit +lookupLiteral (Right sym) = do Ptr addr <- lookupStaticPtr sym + return (W# (unsafeCoerce# addr)) + -- Can't be bothered to find the official way to convert Addr# to Word#; + -- the FFI/Foreign designers make it too damn difficult + -- Hence we apply the Blunt Instrument, which works correctly + -- on all reasonable architectures anyway + +lookupStaticPtr :: FastString -> IO (Ptr ()) +lookupStaticPtr addr_of_label_string = do let label_to_find = unpackFS addr_of_label_string m <- lookupSymbol label_to_find case m of - -- Can't be bothered to find the official way to convert Addr# to Word#; - -- the FFI/Foreign designers make it too damn difficult - -- Hence we apply the Blunt Instrument, which works correctly - -- on all reasonable architectures anyway - Just (Ptr addr) -> return (W# (unsafeCoerce# addr)) - Nothing -> linkFail "ByteCodeLink: can't find label" - label_to_find + Just ptr -> return ptr + Nothing -> linkFail "ByteCodeLink: can't find label" + label_to_find lookupCE :: ClosureEnv -> Either Name PrimOp -> IO HValue lookupCE ce (Right primop) @@ -601,9 +158,10 @@ lookupCE ce (Right primop) Just (Ptr addr) -> case addrToHValue# addr of (# hval #) -> return hval Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find + lookupCE ce (Left nm) - = case lookupFM ce nm of - Just aa -> return aa + = case lookupNameEnv ce nm of + Just (_,aa) -> return aa Nothing -> ASSERT2(isExternalName nm, ppr nm) do let sym_to_find = nameToCLabel nm "closure" @@ -615,8 +173,8 @@ lookupCE ce (Left nm) lookupIE :: ItblEnv -> Name -> IO (Ptr a) lookupIE ie con_nm - = case lookupFM ie con_nm of - Just (Ptr a) -> return (Ptr a) + = case lookupNameEnv ie con_nm of + Just (_, Ptr a) -> return (Ptr a) Nothing -> do -- try looking up in the object files. let sym_to_find1 = nameToCLabel con_nm "con_info" @@ -650,63 +208,13 @@ linkFail who what -- HACKS!!! ToDo: cleaner nameToCLabel :: Name -> String{-suffix-} -> String nameToCLabel n suffix - = unpackFS(moduleNameFS (rdrNameModule rn)) - ++ '_':occNameString(rdrNameOcc rn) ++ '_':suffix - where rn = toRdrName n + = moduleString (nameModule n) + ++ '_':occNameString (nameOccName n) ++ '_':suffix primopToCLabel :: PrimOp -> String{-suffix-} -> String primopToCLabel primop suffix = let str = "GHCziPrimopWrappers_" ++ occNameString (primOpOcc primop) ++ '_':suffix in --trace ("primopToCLabel: " ++ str) str - \end{code} -%************************************************************************ -%* * -\subsection{Connect to actual values for bytecode opcodes} -%* * -%************************************************************************ - -\begin{code} - -#include "Bytecodes.h" - -i_ARGCHECK = (bci_ARGCHECK :: Int) -i_PUSH_L = (bci_PUSH_L :: Int) -i_PUSH_LL = (bci_PUSH_LL :: Int) -i_PUSH_LLL = (bci_PUSH_LLL :: Int) -i_PUSH_G = (bci_PUSH_G :: Int) -i_PUSH_AS = (bci_PUSH_AS :: Int) -i_PUSH_UBX = (bci_PUSH_UBX :: Int) -i_PUSH_TAG = (bci_PUSH_TAG :: Int) -i_SLIDE = (bci_SLIDE :: Int) -i_ALLOC = (bci_ALLOC :: Int) -i_MKAP = (bci_MKAP :: Int) -i_UNPACK = (bci_UNPACK :: Int) -i_UPK_TAG = (bci_UPK_TAG :: Int) -i_PACK = (bci_PACK :: Int) -i_TESTLT_I = (bci_TESTLT_I :: Int) -i_TESTEQ_I = (bci_TESTEQ_I :: Int) -i_TESTLT_F = (bci_TESTLT_F :: Int) -i_TESTEQ_F = (bci_TESTEQ_F :: Int) -i_TESTLT_D = (bci_TESTLT_D :: Int) -i_TESTEQ_D = (bci_TESTEQ_D :: Int) -i_TESTLT_P = (bci_TESTLT_P :: Int) -i_TESTEQ_P = (bci_TESTEQ_P :: Int) -i_CASEFAIL = (bci_CASEFAIL :: Int) -i_ENTER = (bci_ENTER :: Int) -i_RETURN = (bci_RETURN :: Int) -i_STKCHECK = (bci_STKCHECK :: Int) -i_JMP = (bci_JMP :: Int) -#ifdef bci_CCALL -i_CCALL = (bci_CCALL :: Int) -i_SWIZZLE = (bci_SWIZZLE :: Int) -#else -i_CCALL = error "Sorry pal, you need to bootstrap to use i_CCALL." -i_SWIZZLE = error "Sorry pal, you need to bootstrap to use i_SWIZZLE." -#endif - -iNTERP_STACK_CHECK_THRESH = (INTERP_STACK_CHECK_THRESH :: Int) - -\end{code} diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 14208e137f..8660650e0d 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" -#include "SchedAPI.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.133 2002/09/06 14:35:44 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.134 2002/09/13 15:02:32 simonpj Exp $ -- -- GHC Interactive User Interface -- @@ -9,26 +9,21 @@ ----------------------------------------------------------------------------- module InteractiveUI ( interactiveUI, -- :: CmState -> [FilePath] -> [LibrarySpec] -> IO () - LibrarySpec(..), ghciWelcomeMsg ) where #include "../includes/config.h" #include "HsVersions.h" -import Packages - import CompManager -import CmTypes ( Linkable, isObjectLinkable, ModSummary(..) ) -import CmLink ( findModuleLinkable_maybe ) - -import HscTypes ( TyThing(..), showModMsg, InteractiveContext(..) ) +import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable, + isObjectLinkable ) import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) ) import MkIface ( ifaceTyThing ) import DriverFlags import DriverState -import DriverUtil ( handle, remove_spaces ) -import Linker +import DriverUtil ( remove_spaces, handle ) +import Linker ( initLinker, showLinkerState, linkLibraries ) import Finder ( flushPackageCache ) import Util import Id ( isRecordSelector, recordSelectorFieldLabel, @@ -37,11 +32,11 @@ import Class ( className ) import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) ) import FieldLabel ( fieldLabelTyCon ) import SrcLoc ( isGoodSrcLoc ) -import Module ( moduleName ) +import Module ( showModMsg, lookupModuleEnv ) import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName, NamedThing(..) ) import OccName ( isSymOcc ) -import BasicTypes ( defaultFixity ) +import BasicTypes ( defaultFixity, SuccessFlag(..) ) import Outputable import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags, restoreDynFlags, dopt_unset ) @@ -53,6 +48,7 @@ import System.Posix #endif #if HAVE_READLINE_HEADERS && HAVE_READLINE_LIBS +import Control.Concurrent ( yield ) -- Used in readline loop import System.Console.Readline as Readline #endif @@ -78,7 +74,6 @@ import Foreign ( nullPtr ) import Foreign.C.String ( CString, peekCString, withCString ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) - ----------------------------------------------------------------------------- ghciWelcomeMsg = "\ @@ -152,42 +147,26 @@ helpText = "\ \ (eg. -v2, -fglasgow-exts, etc.)\n\ \" -interactiveUI :: CmState -> [FilePath] -> [LibrarySpec] -> IO () -interactiveUI cmstate paths cmdline_libs = do +interactiveUI :: CmState -> [FilePath] -> [FilePath] -> IO () +interactiveUI cmstate paths cmdline_objs = do hFlush stdout hSetBuffering stdout NoBuffering dflags <- getDynFlags - -- link in the available packages - pkgs <- getPackageInfo + -- Link in the available packages initLinker - linkPackages dflags cmdline_libs pkgs - - (cmstate, maybe_hval) - <- cmCompileExpr cmstate dflags "IO.hSetBuffering IO.stdout IO.NoBuffering Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering" - case maybe_hval of - Just hval -> do - let action = unsafeCoerce# hval :: IO () - action -- do it now - writeIORef turn_off_buffering action -- and save it for later - _ -> panic "interactiveUI:buffering" - - (cmstate, maybe_hval) - <- cmCompileExpr cmstate dflags "IO.hFlush IO.stderr" - case maybe_hval of - Just hval -> writeIORef flush_stderr (unsafeCoerce# hval :: IO ()) - _ -> panic "interactiveUI:stderr" - - (cmstate, maybe_hval) - <- cmCompileExpr cmstate dflags "IO.hFlush IO.stdout" - case maybe_hval of - Just hval -> writeIORef flush_stdout (unsafeCoerce# hval :: IO ()) - _ -> panic "interactiveUI:stdout" + -- Now that demand-loading works, we don't really need to pre-load the packages + -- pkgs <- getPackages + -- linkPackages dflags pkgs + linkLibraries dflags cmdline_objs + + -- Initialise buffering for the *interpreted* I/O system + cmstate <- initInterpBuffering cmstate dflags -- We don't want the cmd line to buffer any input that might be -- intended for the program, so unbuffer stdin. - hSetBuffering stdin NoBuffering + hSetBuffering stdin NoBuffering -- initial context is just the Prelude cmstate <- cmSetContext cmstate dflags [] ["Prelude"] @@ -209,7 +188,6 @@ interactiveUI cmstate paths cmdline_libs = do return () - runGHCi :: [FilePath] -> DynFlags -> GHCi () runGHCi paths dflags = do read_dot_files <- io (readIORef v_Read_DotGHCi) @@ -358,7 +336,7 @@ readlineLoop = do runCommand :: String -> GHCi Bool runCommand c = ghciHandle ( \exception -> do - flushEverything + flushInterpBuffers showException exception return False ) $ @@ -402,9 +380,9 @@ finishEvalExpr names cmstate <- getCmState when b (mapM_ (showTypeOfName cmstate) names) + flushInterpBuffers b <- isOptionSet RevertCAFs io (when b revertCAFs) - flushEverything return True showTypeOfName :: CmState -> Name -> GHCi () @@ -414,12 +392,6 @@ showTypeOfName cmstate n Nothing -> return () Just str -> io (putStrLn (showSDoc (ppr n) ++ " :: " ++ str)) -flushEverything :: GHCi () -flushEverything - = io $ do Monad.join (readIORef flush_stdout) - Monad.join (readIORef flush_stderr) - return () - specialCommand :: String -> GHCi Bool specialCommand ('!':str) = shellEscape (dropWhile isSpace str) specialCommand str = do @@ -436,6 +408,46 @@ specialCommand str = do noArgs c = throwDyn (CmdLineError ("command `" ++ c ++ "' takes no arguments")) + +----------------------------------------------------------------------------- +-- To flush buffers for the *interpreted* computation we need +-- to refer to *its* stdout/stderr handles + +GLOBAL_VAR(flush_interp, error "no flush_interp", IO ()) +GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ()) + +no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++ + " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering" +flush_cmd = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr" + +initInterpBuffering :: CmState -> DynFlags -> IO CmState +initInterpBuffering cmstate dflags + = do (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags no_buf_cmd + + case maybe_hval of + Just hval -> writeIORef turn_off_buffering (unsafeCoerce# hval :: IO ()) + other -> panic "interactiveUI:setBuffering" + + (cmstate, maybe_hval) <- cmCompileExpr cmstate dflags flush_cmd + case maybe_hval of + Just hval -> writeIORef flush_interp (unsafeCoerce# hval :: IO ()) + _ -> panic "interactiveUI:flush" + + turnOffBuffering -- Turn it off right now + + return cmstate + + +flushInterpBuffers :: GHCi () +flushInterpBuffers + = io $ do Monad.join (readIORef flush_interp) + return () + +turnOffBuffering :: IO () +turnOffBuffering + = do Monad.join (readIORef turn_off_buffering) + return () + ----------------------------------------------------------------------------- -- Commands @@ -623,9 +635,9 @@ modulesLoadedMsg ok mods dflags = | otherwise = hsep ( punctuate comma (map text mods)) <> text "." case ok of - False -> + Failed -> io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))) - True -> + Succeeded -> io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas))) @@ -701,7 +713,7 @@ browseModule m exports_only = do rn_decl{ tcdCons = DataCons (filter conIsVisible cons) } other -> other where - conIsVisible (ConDecl n _ _ _ _ _) = n `elem` thing_names + conIsVisible (ConDecl n _ _ _ _) = n `elem` thing_names io (putStrLn (showSDocForUser unqual ( vcat (map (ppr . thingDecl) things'))) @@ -877,18 +889,14 @@ optToStr ShowTiming = "s" optToStr ShowType = "t" optToStr RevertCAFs = "r" -newPackages new_pkgs = do - state <- getGHCiState - dflags <- io getDynFlags +newPackages new_pkgs = do -- The new packages are already in v_Packages + state <- getGHCiState + dflags <- io getDynFlags cmstate1 <- io (cmUnload (cmstate state) dflags) setGHCiState state{ cmstate = cmstate1, targets = [] } - io $ do - pkgs <- getPackageInfo - flushPackageCache pkgs - - new_pkg_info <- getPackageDetails new_pkgs - mapM_ (linkPackage dflags) (reverse new_pkg_info) + io $ do pkgs <- getPackageInfo + flushPackageCache pkgs setContextAfterLoad [] @@ -899,21 +907,25 @@ showCmd str = case words str of ["modules" ] -> showModules ["bindings"] -> showBindings + ["linker"] -> io showLinkerState _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]") showModules = do cms <- getCmState - let mg = cmGetModuleGraph cms - ls = cmGetLinkables cms - maybe_linkables = map (findModuleLinkable_maybe ls) - (map (moduleName.ms_mod) mg) - zipWithM showModule mg maybe_linkables - return () + let (mg, hpt) = cmGetModInfo cms + mapM_ (showModule hpt) mg + -showModule :: ModSummary -> Maybe Linkable -> GHCi () -showModule m (Just l) = do - io (putStrLn (showModMsg (isObjectLinkable l) (ms_mod m) (ms_location m))) -showModule _ Nothing = panic "missing linkable" +showModule :: HomePackageTable -> ModSummary -> GHCi () +showModule hpt mod_summary + = case lookupModuleEnv hpt mod of + Nothing -> panic "missing linkable" + Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn)) + where + obj_linkable = isObjectLinkable (hm_linkable mod_info) + where + mod = ms_mod mod_summary + locn = ms_location mod_summary showBindings = do cms <- getCmState @@ -924,6 +936,7 @@ showBindings = do io (mapM_ showBinding (cmGetBindings cms)) return () + ----------------------------------------------------------------------------- -- GHCi monad @@ -942,10 +955,6 @@ data GHCiOption | RevertCAFs -- revert CAFs after every evaluation deriving Eq -GLOBAL_VAR(flush_stdout, error "no flush_stdout", IO ()) -GLOBAL_VAR(flush_stderr, error "no flush_stdout", IO ()) -GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ()) - newtype GHCi a = GHCi { unGHCi :: IORef GHCiState -> IO a } startGHCi :: GHCi a -> GHCiState -> IO a @@ -999,219 +1008,6 @@ ghciHandle h (GHCi m) = GHCi $ \s -> ghciUnblock :: GHCi a -> GHCi a ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) ------------------------------------------------------------------------------ --- package loader - --- Left: full path name of a .o file, including trailing .o --- Right: "unadorned" name of a .DLL/.so --- e.g. On unix "qt" denotes "libqt.so" --- On WinDoze "burble" denotes "burble.DLL" --- addDLL is platform-specific and adds the lib/.so/.DLL --- suffixes platform-dependently; we don't do that here. --- --- For dynamic objects only, try to find the object file in all the --- directories specified in v_Library_Paths before giving up. - -data LibrarySpec = Object FilePath | DLL String -#ifdef darwin_TARGET_OS - | Framework String -#endif - --- Packages that don't need loading, because the compiler shares them with --- the interpreted program. -dont_load_these = [ "rts" ] - --- Packages that are already linked into GHCi. For mingw32, we only --- skip gmp and rts, since std and after need to load the msvcrt.dll --- library which std depends on. -loaded_in_ghci -# ifndef mingw32_TARGET_OS - = [ "std", "concurrent", "posix", "text", "util" ] -# else - = [ ] -# endif - -showLS (Object nm) = "(static) " ++ nm -showLS (DLL nm) = "(dynamic) " ++ nm -#ifdef darwin_TARGET_OS -showLS (Framework nm) = "(framework) " ++ nm -#endif - -linkPackages :: DynFlags -> [LibrarySpec] -> [PackageConfig] -> IO () -linkPackages dflags cmdline_lib_specs pkgs - = do mapM_ (linkPackage dflags) (reverse pkgs) - lib_paths <- readIORef v_Library_paths - mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs - if (null cmdline_lib_specs) - then return () - else do maybePutStr dflags "final link ... " - - ok <- resolveObjs - if ok then maybePutStrLn dflags "done." - else throwDyn (InstallationError - "linking extra libraries/objects failed") - where - preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO () - preloadLib dflags lib_paths lib_spec - = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") - case lib_spec of - Object static_ish - -> do b <- preload_static lib_paths static_ish - maybePutStrLn dflags (if b then "done." - else "not found") - DLL dll_unadorned - -> -- We add "" to the set of paths to try, so that - -- if none of the real paths match, we force addDLL - -- to look in the default dynamic-link search paths. - do maybe_errstr <- loadDynamic (lib_paths++[""]) - dll_unadorned - case maybe_errstr of - Nothing -> return () - Just mm -> preloadFailed mm lib_paths lib_spec - maybePutStrLn dflags "done" - - preloadFailed :: String -> [String] -> LibrarySpec -> IO () - preloadFailed sys_errmsg paths spec - = do maybePutStr dflags - ("failed.\nDynamic linker error message was:\n " - ++ sys_errmsg ++ "\nWhilst trying to load: " - ++ showLS spec ++ "\nDirectories to search are:\n" - ++ unlines (map (" "++) paths) ) - give_up - - -- not interested in the paths in the static case. - preload_static paths name - = do b <- doesFileExist name - if not b then return False - else loadObj name >> return True - - give_up - = (throwDyn . CmdLineError) - "user specified .o/.so/.DLL could not be loaded." - -linkPackage :: DynFlags -> PackageConfig -> IO () -linkPackage dflags pkg - | name pkg `elem` dont_load_these = return () - | otherwise - = do - let dirs = library_dirs pkg - let libs = hs_libraries pkg ++ extra_libraries pkg - classifieds <- mapM (locateOneObj dirs) libs -#ifdef darwin_TARGET_OS - let fwDirs = framework_dirs pkg - let frameworks= extra_frameworks pkg -#endif - - -- Complication: all the .so's must be loaded before any of the .o's. - let dlls = [ dll | DLL dll <- classifieds ] - objs = [ obj | Object obj <- classifieds ] - - maybePutStr dflags ("Loading package " ++ name pkg ++ " ... ") - - -- If this package is already part of the GHCi binary, we'll already - -- have the right DLLs for this package loaded, so don't try to - -- load them again. - when (name pkg `notElem` loaded_in_ghci) $ do -#ifdef darwin_TARGET_OS - loadFrameworks fwDirs frameworks -#endif - loadDynamics dirs dlls - - -- After loading all the DLLs, we can load the static objects. - mapM_ loadObj objs - - maybePutStr dflags "linking ... " - ok <- resolveObjs - if ok then maybePutStrLn dflags "done." - else panic ("can't load package `" ++ name pkg ++ "'") - -loadDynamics dirs [] = return () -loadDynamics dirs (dll:dlls) = do - r <- loadDynamic dirs dll - case r of - Nothing -> loadDynamics dirs dlls - Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: " - ++ dll ++ " (" ++ err ++ ")" )) -#ifdef darwin_TARGET_OS -loadFrameworks dirs [] = return () -loadFrameworks dirs (fw:fws) = do - r <- loadFramework dirs fw - case r of - Nothing -> loadFrameworks dirs fws - Just err -> throwDyn (CmdLineError ("can't load framework: " - ++ fw ++ " (" ++ err ++ ")" )) -#endif - --- Try to find an object file for a given library in the given paths. --- If it isn't present, we assume it's a dynamic library. -locateOneObj :: [FilePath] -> String -> IO LibrarySpec -locateOneObj [] lib - = return (DLL lib) -- we assume -locateOneObj (d:ds) lib - = do let path = d ++ '/':lib ++ ".o" - b <- doesFileExist path - if b then return (Object path) else locateOneObj ds lib - --- ---------------------------------------------------------------------------- --- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) - -#if defined(mingw32_TARGET_OS) || defined(cygwin32_TARGET_OS) -loadDynamic paths rootname = addDLL rootname - -- ignore paths on windows (why? --SDM) - -#else - --- return Nothing == success, else Just error message from dlopen -loadDynamic (path:paths) rootname = do - let dll = path ++ '/':mkSOName rootname - b <- doesFileExist dll - if not b - then loadDynamic paths rootname - else addDLL dll -loadDynamic [] rootname = do - -- tried all our known library paths, let dlopen() search its - -- own builtin paths now. - addDLL (mkSOName rootname) - -#ifdef darwin_TARGET_OS -mkSOName root = "lib" ++ root ++ ".dylib" -#else -mkSOName root = "lib" ++ root ++ ".so" -#endif - -#endif - --- Darwin / MacOS X only: load a framework --- a framework is a dynamic library packaged inside a directory of the same --- name. They are searched for in different paths than normal libraries. -#ifdef darwin_TARGET_OS -loadFramework extraPaths rootname - = loadFramework' (extraPaths ++ defaultFrameworkPaths) where - defaultFrameworkPaths = ["/Library/Frameworks", "/System/Library/Frameworks"] - - loadFramework' (path:paths) = do - let dll = path ++ '/' : rootname ++ ".framework/" ++ rootname - b <- doesFileExist dll - if not b - then loadFramework' paths - else addDLL dll - loadFramework' [] = do - -- tried all our known library paths, but dlopen() - -- has no built-in paths for frameworks: give up - return $ Just $ "not found" -#endif - -addDLL :: String -> IO (Maybe String) -addDLL str = do - maybe_errmsg <- withCString str $ \dll -> c_addDLL dll - if maybe_errmsg == nullPtr - then return Nothing - else do str <- peekCString maybe_errmsg - return (Just str) - -foreign import ccall "addDLL" unsafe - c_addDLL :: CString -> IO CString - ----------------------------------------------------------------------------- -- timing & statistics @@ -1228,7 +1024,7 @@ timeIt action io $ printTimes (allocs2 - allocs1) (time2 - time1) return a -foreign import "getAllocations" getAllocations :: IO Int +foreign import ccall "getAllocations" getAllocations :: IO Int printTimes :: Int -> Integer -> IO () printTimes allocs psecs @@ -1246,21 +1042,15 @@ looksLikeModuleName (c:cs) = isUpper c && all isAlphaNumEx cs isAlphaNumEx c = isAlphaNum c || c == '_' || c == '.' -maybePutStr dflags s | verbosity dflags > 0 = putStr s - | otherwise = return () - -maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s - | otherwise = return () - ----------------------------------------------------------------------------- -- reverting CAFs revertCAFs :: IO () revertCAFs = do rts_revertCAFs - Monad.join (readIORef turn_off_buffering) - -- have to do this again, because we just reverted - -- stdout, stderr & stdin to their defaults. + turnOffBuffering + -- Have to turn off buffering again, because we just + -- reverted stdout, stderr & stdin to their defaults. foreign import ccall "revertCAFs" rts_revertCAFs :: IO () - -- make it "safe", just in case + -- Make it "safe", just in case diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 2e517b080e..d5ba66d494 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -1,73 +1,770 @@ % -% (c) The University of Glasgow, 2000 +% (c) The University of Glasgow 2000 % -\section[Linker]{The In-Memory Object File Linker} + +-- -------------------------------------- +-- The dynamic linker for GHCi +-- -------------------------------------- + +This module deals with the top-level issues of dynamic linking, +calling the object-code linker and the byte-code linker where +necessary. + \begin{code} -{-# OPTIONS -#include "Linker.h" #-} -module Linker ( - initLinker, -- :: IO () - loadObj, -- :: String -> IO () - unloadObj, -- :: String -> IO () - lookupSymbol, -- :: String -> IO (Maybe (Ptr a)) - resolveObjs -- :: IO Bool - ) where +{-# OPTIONS -optc-DNON_POSIX_SOURCE #-} -import Monad ( when ) +module Linker ( HValue, initLinker, showLinkerState, + linkPackages, linkLibraries, + linkModules, unload, extendLinkEnv, linkExpr, + LibrarySpec(..) + ) where -import Foreign.C -import Foreign ( Ptr, nullPtr ) -import Panic ( panic ) -import DriverUtil ( prefixUnderscore ) +#include "../includes/config.h" +#include "HsVersions.h" --- --------------------------------------------------------------------------- --- RTS Linker Interface --- --------------------------------------------------------------------------- +import ObjLink ( loadDLL, loadObj, unloadObj, resolveObjs, initLinker ) +import ByteCodeLink ( HValue, ClosureEnv, extendClosureEnv, linkBCO ) +import ByteCodeItbls ( ItblEnv ) +import ByteCodeAsm ( CompiledByteCode(..), bcosFreeNames, + UnlinkedBCO, UnlinkedBCOExpr, nameOfUnlinkedBCO ) -lookupSymbol :: String -> IO (Maybe (Ptr a)) -lookupSymbol str_in = do - let str = prefixUnderscore str_in - withCString str $ \c_str -> do - addr <- c_lookupSymbol c_str - if addr == nullPtr - then return Nothing - else return (Just addr) - -loadObj :: String -> IO () -loadObj str = - withCString str $ \c_str -> do - r <- c_loadObj c_str - when (r == 0) (panic "loadObj: failed") - -unloadObj :: String -> IO () -unloadObj str = - withCString str $ \c_str -> do - r <- c_unloadObj c_str - when (r == 0) (panic "unloadObj: failed") - -resolveObjs :: IO Bool -resolveObjs = do - r <- c_resolveObjs - return (r /= 0) -- returns True <=> success +import Packages ( PackageConfig(..), PackageName, PackageConfigMap, lookupPkg, + packageDependents, packageNameString ) +import DriverState ( v_Library_paths, v_Cmdline_libraries, getPackageConfigMap ) +import HscTypes ( Linkable(..), isObjectLinkable, nameOfObject, byteCodeOfObject, + Unlinked(..), isInterpretable, isObject, + HscEnv(..), PersistentCompilerState(..), ExternalPackageState(..), + HomePackageTable, PackageIfaceTable, ModIface(..), HomeModInfo(..) ) +import Name ( Name, nameModule, isExternalName ) +import NameEnv +import NameSet ( nameSetToList ) +import Module ( Module, ModuleName, moduleName, lookupModuleEnvByName ) +import FastString ( FastString(..), unpackFS ) +import CmdLineOpts ( DynFlags(verbosity) ) +import BasicTypes ( SuccessFlag(..), succeeded, failed ) +import Outputable +import Panic ( GhcException(..) ) +import Util ( zipLazy, global ) +import ErrUtils ( Message ) + +-- Standard libraries +import Control.Monad ( when, filterM, foldM ) + +import Data.IORef ( IORef, readIORef, writeIORef ) +import Data.List ( partition ) + +import System.IO ( putStr, putStrLn, hPutStrLn, stderr, fixIO ) +import System.Directory ( doesFileExist ) + +import Control.Exception ( block, throwDyn ) + +#if __GLASGOW_HASKELL__ >= 503 +import GHC.IOBase ( IO(..) ) +#else +import PrelIOBase ( IO(..) ) +#endif +\end{code} + + +%************************************************************************ +%* * + The Linker's state +%* * +%************************************************************************ + +The persistent linker state *must* match the actual state of the +C dynamic linker at all times, so we keep it in a private global variable. + + +The PersistentLinkerState maps Names to actual closures (for +interpreted code only), for use during linking. + +\begin{code} +GLOBAL_VAR(v_PersistentLinkerState, emptyPLS, PersistentLinkerState) + +data PersistentLinkerState + = PersistentLinkerState { + + -- Current global mapping from Names to their true values + closure_env :: ClosureEnv, + + -- The current global mapping from RdrNames of DataCons to + -- info table addresses. + -- When a new Unlinked is linked into the running image, or an existing + -- module in the image is replaced, the itbl_env must be updated + -- appropriately. + itbl_env :: ItblEnv, + + -- The currently loaded interpreted modules (home package) + bcos_loaded :: [Linkable], + + -- And the currently-loaded compiled modules (home package) + objs_loaded :: [Linkable], + + -- The currently-loaded packages; always object code + -- Held, as usual, in dependency order; though I am not sure if + -- that is really important + pkgs_loaded :: [PackageName] + } + +emptyPLS :: PersistentLinkerState +emptyPLS = PersistentLinkerState { closure_env = emptyNameEnv, + itbl_env = emptyNameEnv, + pkgs_loaded = init_pkgs_loaded, + bcos_loaded = [], + objs_loaded = [] } + +-- Packages that don't need loading, because the compiler +-- shares them with the interpreted program. +init_pkgs_loaded = [ FSLIT("rts") ] +\end{code} + +\begin{code} +extendLinkEnv :: [(Name,HValue)] -> IO () +-- Automatically discards shadowed bindings +extendLinkEnv new_bindings + = do pls <- readIORef v_PersistentLinkerState + let new_closure_env = extendClosureEnv (closure_env pls) new_bindings + new_pls = pls { closure_env = new_closure_env } + writeIORef v_PersistentLinkerState new_pls + +-- filterNameMap removes from the environment all entries except +-- those for a given set of modules; +-- Note that this removes all *local* (i.e. non-isExternal) names too +-- (these are the temporary bindings from the command line). +-- Used to filter both the ClosureEnv and ItblEnv + +filterNameMap :: [ModuleName] -> NameEnv (Name, a) -> NameEnv (Name, a) +filterNameMap mods env + = filterNameEnv keep_elt env + where + keep_elt (n,_) = isExternalName n + && (moduleName (nameModule n) `elem` mods) +\end{code} + + +\begin{code} +showLinkerState :: IO () +-- Display the persistent linker state +showLinkerState + = do pls <- readIORef v_PersistentLinkerState + printDump (vcat [text "----- Linker state -----", + text "Pkgs:" <+> ppr (pkgs_loaded pls), + text "Objs:" <+> ppr (objs_loaded pls), + text "BCOs:" <+> ppr (bcos_loaded pls)]) +\end{code} + + + +%************************************************************************ +%* * + Link a byte-code expression +%* * +%************************************************************************ + +\begin{code} +linkExpr :: HscEnv -> PersistentCompilerState + -> UnlinkedBCOExpr -> IO HValue -- IO BCO# really + +-- Link a single expression, *including* first linking packages and +-- modules that this expression depends on. +-- +-- Raises an IO exception if it can't find a compiled version of the +-- dependents to link. + +linkExpr hsc_env pcs (root_ul_bco, aux_ul_bcos) + = -- Find what packages and linkables are required + case getLinkDeps hpt pit needed_mods of { + Left msg -> dieWith (msg $$ ptext SLIT("When linking an expression")) ; + Right (lnks, pkgs) -> do { + + linkPackages dflags pkgs + ; ok <- linkModules dflags lnks + ; if failed ok then + dieWith empty + else do { + + -- Link the expression itself + pls <- readIORef v_PersistentLinkerState + ; let ie = itbl_env pls + ce = closure_env pls + + -- Link the necessary packages and linkables + ; (_, (root_hval:_)) <- linkSomeBCOs False ie ce all_bcos + ; return root_hval + }}} + where + pit = eps_PIT (pcs_EPS pcs) + hpt = hsc_HPT hsc_env + dflags = hsc_dflags hsc_env + all_bcos = root_ul_bco : aux_ul_bcos + free_names = nameSetToList (bcosFreeNames all_bcos) + + needed_mods :: [Module] + needed_mods = [ nameModule n | n <- free_names, isExternalName n ] + +dieWith msg = throwDyn (UsageError (showSDoc msg)) + +getLinkDeps :: HomePackageTable -> PackageIfaceTable + -> [Module] -- If you need these + -> Either Message + ([Linkable], [PackageName]) -- ... then link these first + +-- Find all the packages and linkables that a set of modules depends on + +getLinkDeps hpt pit mods + = go [] -- Linkables so far + [] -- Packages so far + [] -- Modules dealt with + (map moduleName mods) -- The usage info that we use for + -- dependencies has ModuleNames not Modules + where + go lnks pkgs _ [] = Right (lnks,pkgs) + go lnks pkgs mods_done (mod:mods) + | mod `elem` mods_done + = -- Already dealt with + go lnks pkgs mods_done mods + + | Just mod_info <- lookupModuleEnvByName hpt mod + = -- OK, so it's a home module + let + mod_deps = [m | (m,_,_,_) <- mi_usages (hm_iface mod_info)] + -- Get the modules that this one depends on + in + go (hm_linkable mod_info : lnks) pkgs (mod : mods_done) (mod_deps ++ mods) + + | Just pkg_iface <- lookupModuleEnvByName pit mod + = -- It's a package module, so add it to the package list + let + pkg_name = mi_package pkg_iface + pkgs' | pkg_name `elem` pkgs = pkgs + | otherwise = pkg_name : pkgs + in + go lnks pkgs' (mod : mods_done) mods + + | otherwise + = -- Not in either table + Left (ptext SLIT("Can't find compiled code for dependent module") <+> ppr mod) +\end{code} + + +%************************************************************************ +%* * + Link some linkables + The linkables may consist of a mixture of + byte-code modules and object modules +%* * +%************************************************************************ + +\begin{code} +linkModules :: DynFlags -> [Linkable] -> IO SuccessFlag +linkModules dflags linkables + = block $ do -- don't want to be interrupted by ^C in here + + let (objs, bcos) = partition isObjectLinkable + (concatMap partitionLinkable linkables) + + -- Load objects first; they can't depend on BCOs + ok_flag <- dynLinkObjs dflags objs + + if failed ok_flag then + return Failed + else do + dynLinkBCOs bcos + return Succeeded + + +-- HACK to support f-x-dynamic in the interpreter; no other purpose +partitionLinkable :: Linkable -> [Linkable] +partitionLinkable li + = let li_uls = linkableUnlinked li + li_uls_obj = filter isObject li_uls + li_uls_bco = filter isInterpretable li_uls + in + case (li_uls_obj, li_uls_bco) of + (objs@(_:_), bcos@(_:_)) + -> [li{linkableUnlinked=li_uls_obj}, li{linkableUnlinked=li_uls_bco}] + other + -> [li] + +findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable +findModuleLinkable_maybe lis mod + = case [LM time nm us | LM time nm us <- lis, nm == mod] of + [] -> Nothing + [li] -> Just li + many -> pprPanic "findModuleLinkable" (ppr mod) + +filterModuleLinkables :: (ModuleName -> Bool) -> [Linkable] -> [Linkable] +filterModuleLinkables p ls = filter (p . linkableModName) ls + +linkableInSet :: Linkable -> [Linkable] -> Bool +linkableInSet l objs_loaded = + case findModuleLinkable_maybe objs_loaded (linkableModName l) of + Nothing -> False + Just m -> linkableTime l == linkableTime m +\end{code} + + +%************************************************************************ +%* * +\subsection{The object-code linker} +%* * +%************************************************************************ + +\begin{code} +dynLinkObjs :: DynFlags -> [Linkable] -> IO SuccessFlag + -- Side-effects the PersistentLinkerState + +dynLinkObjs dflags objs + = do pls <- readIORef v_PersistentLinkerState + + -- Load the object files and link them + let (objs_loaded', new_objs) = rmDupLinkables (objs_loaded pls) objs + pls1 = pls { objs_loaded = objs_loaded' } + unlinkeds = concatMap linkableUnlinked new_objs + + mapM loadObj (map nameOfObject unlinkeds) + + -- Link the all together + ok <- resolveObjs + + -- If resolving failed, unload all our + -- object modules and carry on + if succeeded ok then do + writeIORef v_PersistentLinkerState pls1 + return Succeeded + else do + pls2 <- unload_wkr dflags [] pls1 + writeIORef v_PersistentLinkerState pls2 + return Failed + + +rmDupLinkables :: [Linkable] -- Already loaded + -> [Linkable] -- New linkables + -> ([Linkable], -- New loaded set (including new ones) + [Linkable]) -- New linkables (excluding dups) +rmDupLinkables already ls + = go already [] ls + where + go already extras [] = (already, extras) + go already extras (l:ls) + | linkableInSet l already = go already extras ls + | otherwise = go (l:already) (l:extras) ls +\end{code} + + +\begin{code} +linkLibraries :: DynFlags + -> [String] -- foo.o files specified on command line + -> IO () +-- Used just at initialisation time to link in libraries +-- specified on the command line. +linkLibraries dflags objs + = do { lib_paths <- readIORef v_Library_paths + ; minus_ls <- readIORef v_Cmdline_libraries + ; let cmdline_lib_specs = map Object objs ++ map DLL minus_ls + + ; if (null cmdline_lib_specs) then return () + else do { + + -- Now link them + ; mapM_ (preloadLib dflags lib_paths) cmdline_lib_specs + + ; maybePutStr dflags "final link ... " + ; ok <- resolveObjs + ; if succeeded ok then maybePutStrLn dflags "done." + else throwDyn (InstallationError "linking extra libraries/objects failed") + }} + where + preloadLib :: DynFlags -> [String] -> LibrarySpec -> IO () + preloadLib dflags lib_paths lib_spec + = do maybePutStr dflags ("Loading object " ++ showLS lib_spec ++ " ... ") + case lib_spec of + Object static_ish + -> do b <- preload_static lib_paths static_ish + maybePutStrLn dflags (if b then "done." + else "not found") + DLL dll_unadorned + -> do maybe_errstr <- loadDynamic lib_paths dll_unadorned + case maybe_errstr of + Nothing -> return () + Just mm -> preloadFailed mm lib_paths lib_spec + maybePutStrLn dflags "done" + + preloadFailed :: String -> [String] -> LibrarySpec -> IO () + preloadFailed sys_errmsg paths spec + = do maybePutStr dflags + ("failed.\nDynamic linker error message was:\n " + ++ sys_errmsg ++ "\nWhilst trying to load: " + ++ showLS spec ++ "\nDirectories to search are:\n" + ++ unlines (map (" "++) paths) ) + give_up + + -- not interested in the paths in the static case. + preload_static paths name + = do b <- doesFileExist name + if not b then return False + else loadObj name >> return True + + give_up + = (throwDyn . CmdLineError) + "user specified .o/.so/.DLL could not be loaded." +\end{code} + + +%************************************************************************ +%* * +\subsection{The byte-code linker} +%* * +%************************************************************************ + +\begin{code} +dynLinkBCOs :: [Linkable] -> IO () + -- Side-effects the persistent linker state +dynLinkBCOs bcos + = do pls <- readIORef v_PersistentLinkerState + + let (bcos_loaded', new_bcos) = rmDupLinkables (bcos_loaded pls) bcos + pls1 = pls { bcos_loaded = bcos_loaded' } + unlinkeds :: [Unlinked] + unlinkeds = concatMap linkableUnlinked new_bcos + + cbcs :: [CompiledByteCode] + cbcs = map byteCodeOfObject unlinkeds + + + ul_bcos = [b | ByteCode bs _ <- cbcs, b <- bs] + ies = [ie | ByteCode _ ie <- cbcs] + gce = closure_env pls + final_ie = foldr plusNameEnv (itbl_env pls) ies + + (final_gce, linked_bcos) <- linkSomeBCOs True final_ie gce ul_bcos + -- What happens to these linked_bcos? + + let pls2 = pls1 { closure_env = final_gce, + itbl_env = final_ie } + + writeIORef v_PersistentLinkerState pls2 + return () + +-- Link a bunch of BCOs and return them + updated closure env. +linkSomeBCOs :: Bool -- False <=> add _all_ BCOs to returned closure env + -- True <=> add only toplevel BCOs to closure env + -> ItblEnv + -> ClosureEnv + -> [UnlinkedBCO] + -> IO (ClosureEnv, [HValue]) + -- The returned HValues are associated 1-1 with + -- the incoming unlinked BCOs. Each gives the + -- value of the corresponding unlinked BCO + + +linkSomeBCOs toplevs_only ie ce_in ul_bcos + = do let nms = map nameOfUnlinkedBCO ul_bcos + hvals <- fixIO + ( \ hvs -> let ce_out = extendClosureEnv ce_in (zipLazy nms hvs) + in mapM (linkBCO ie ce_out) ul_bcos ) + + let ce_all_additions = zip nms hvals + ce_top_additions = filter (isExternalName.fst) ce_all_additions + ce_additions = if toplevs_only then ce_top_additions + else ce_all_additions + ce_out = -- make sure we're not inserting duplicate names into the + -- closure environment, which leads to trouble. + ASSERT (all (not . (`elemNameEnv` ce_in)) (map fst ce_additions)) + extendClosureEnv ce_in ce_additions + return (ce_out, hvals) + +\end{code} + + +%************************************************************************ +%* * + Unload some object modules +%* * +%************************************************************************ + +\begin{code} -- --------------------------------------------------------------------------- --- Foreign declaractions to RTS entry points which does the real work; --- --------------------------------------------------------------------------- +-- Unloading old objects ready for a new compilation sweep. +-- +-- The compilation manager provides us with a list of linkables that it +-- considers "stable", i.e. won't be recompiled this time around. For +-- each of the modules current linked in memory, +-- +-- * if the linkable is stable (and it's the same one - the +-- user may have recompiled the module on the side), we keep it, +-- +-- * otherwise, we unload it. +-- +-- * we also implicitly unload all temporary bindings at this point. + +unload :: DynFlags -> [Linkable] -> IO () +-- The 'linkables' are the ones to *keep* + +unload dflags linkables + = block $ do -- block, so we're safe from Ctrl-C in here -foreign import "initLinker" unsafe - initLinker :: IO () + pls <- readIORef v_PersistentLinkerState + new_pls <- unload_wkr dflags linkables pls + writeIORef v_PersistentLinkerState new_pls -foreign import "lookupSymbol" unsafe - c_lookupSymbol :: CString -> IO (Ptr a) + let verb = verbosity dflags + when (verb >= 3) $ do + hPutStrLn stderr (showSDoc + (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))) + hPutStrLn stderr (showSDoc + (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))) -foreign import "loadObj" unsafe - c_loadObj :: CString -> IO Int + return () -foreign import "unloadObj" unsafe - c_unloadObj :: CString -> IO Int +unload_wkr :: DynFlags + -> [Linkable] -- stable linkables + -> PersistentLinkerState + -> IO PersistentLinkerState +-- Does the core unload business +-- (the wrapper blocks exceptions and deals with the PLS get and put) -foreign import "resolveObjs" unsafe - c_resolveObjs :: IO Int +unload_wkr dflags linkables pls + = do let (objs_to_keep, bcos_to_keep) = partition isObjectLinkable linkables + + objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls) + bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls) + + let objs_retained = map linkableModName objs_loaded' + bcos_retained = map linkableModName bcos_loaded' + itbl_env' = filterNameMap bcos_retained (itbl_env pls) + closure_env' = filterNameMap bcos_retained (closure_env pls) + new_pls = pls { itbl_env = itbl_env', + closure_env = closure_env', + bcos_loaded = bcos_loaded', + objs_loaded = objs_loaded' } + + return new_pls + where + maybeUnload :: [Linkable] -> Linkable -> IO Bool + maybeUnload keep_linkables lnk + | linkableInSet lnk linkables = return True + | otherwise + = do mapM_ unloadObj [f | DotO f <- linkableUnlinked lnk] + -- The components of a BCO linkable may contain + -- dot-o files. Which is very confusing. + -- + -- But the BCO parts can be unlinked just by + -- letting go of them (plus of course depopulating + -- the symbol table which is done in the main body) + return False +\end{code} + + +%************************************************************************ +%* * + Loading packages +%* * +%************************************************************************ + + +\begin{code} +data LibrarySpec + = Object FilePath -- Full path name of a .o file, including trailing .o + -- For dynamic objects only, try to find the object + -- file in all the directories specified in + -- v_Library_paths before giving up. + + | DLL String -- "Unadorned" name of a .DLL/.so + -- e.g. On unix "qt" denotes "libqt.so" + -- On WinDoze "burble" denotes "burble.DLL" + -- loadDLL is platform-specific and adds the lib/.so/.DLL + -- suffixes platform-dependently +#ifdef darwin_TARGET_OS + | Framework String +#endif + +-- If this package is already part of the GHCi binary, we'll already +-- have the right DLLs for this package loaded, so don't try to +-- load them again. +-- +-- But on Win32 we must load them 'again'; doing so is a harmless no-op +-- as far as the loader is concerned, but it does initialise the list +-- of DLL handles that rts/Linker.c maintains, and that in turn is +-- used by lookupSymbol. So we must call addDLL for each library +-- just to get the DLL handle into the list. +partOfGHCi +# ifndef mingw32_TARGET_OS + = [ "base", "concurrent", "posix", "text", "util" ] +# else + = [ ] +# endif + +showLS (Object nm) = "(static) " ++ nm +showLS (DLL nm) = "(dynamic) " ++ nm +#ifdef darwin_TARGET_OS +showLS (Framework nm) = "(framework) " ++ nm +#endif + +linkPackages :: DynFlags -> [PackageName] -> IO () +-- Link exactly the specified packages, and their dependents +-- (unless of course they are already linked) +-- The dependents are linked automatically, and it doesn't matter +-- what order you specify the input packages. + +linkPackages dflags new_pkgs + = do { pls <- readIORef v_PersistentLinkerState + ; pkg_map <- getPackageConfigMap + + ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs + + ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' }) + } + where + link :: PackageConfigMap -> [PackageName] -> [PackageName] -> IO [PackageName] + link pkg_map pkgs new_pkgs + = foldM (link_one pkg_map) pkgs new_pkgs + + link_one pkg_map pkgs new_pkg + | new_pkg `elem` pkgs -- Already linked + = return pkgs + + | Just pkg_cfg <- lookupPkg pkg_map new_pkg + = do { -- Link dependents first + pkgs' <- link pkg_map pkgs (packageDependents pkg_cfg) + -- Now link the package itself + ; linkPackage dflags pkg_cfg + ; return (new_pkg : pkgs') } + + | otherwise + = throwDyn (CmdLineError ("unknown package name: " ++ packageNameString new_pkg)) + + +linkPackage :: DynFlags -> PackageConfig -> IO () +linkPackage dflags pkg + = do + let dirs = Packages.library_dirs pkg + let libs = Packages.hs_libraries pkg ++ extra_libraries pkg + classifieds <- mapM (locateOneObj dirs) libs +#ifdef darwin_TARGET_OS + let fwDirs = Packages.framework_dirs pkg + let frameworks= Packages.extra_frameworks pkg +#endif + + -- Complication: all the .so's must be loaded before any of the .o's. + let dlls = [ dll | DLL dll <- classifieds ] + objs = [ obj | Object obj <- classifieds ] + + maybePutStr dflags ("Loading package " ++ Packages.name pkg ++ " ... ") + + -- See comments with partOfGHCi + when (Packages.name pkg `notElem` partOfGHCi) $ do +#ifdef darwin_TARGET_OS + loadFrameworks fwDirs frameworks +#endif + loadDynamics dirs dlls + + -- After loading all the DLLs, we can load the static objects. + mapM_ loadObj objs + + maybePutStr dflags "linking ... " + ok <- resolveObjs + if succeeded ok then maybePutStrLn dflags "done." + else panic ("can't load package `" ++ name pkg ++ "'") + +loadDynamics dirs [] = return () +loadDynamics dirs (dll:dlls) = do + r <- loadDynamic dirs dll + case r of + Nothing -> loadDynamics dirs dlls + Just err -> throwDyn (CmdLineError ("can't load .so/.DLL for: " + ++ dll ++ " (" ++ err ++ ")" )) +#ifdef darwin_TARGET_OS +loadFrameworks dirs [] = return () +loadFrameworks dirs (fw:fws) = do + r <- loadFramework dirs fw + case r of + Nothing -> loadFrameworks dirs fws + Just err -> throwDyn (CmdLineError ("can't load framework: " + ++ fw ++ " (" ++ err ++ ")" )) +#endif + +-- Try to find an object file for a given library in the given paths. +-- If it isn't present, we assume it's a dynamic library. +locateOneObj :: [FilePath] -> String -> IO LibrarySpec +locateOneObj dirs lib + = do { mb_obj_path <- findFile mk_obj_path dirs + ; case mb_obj_path of + Just obj_path -> return (Object obj_path) + Nothing -> return (DLL lib) } -- we assume + where + mk_obj_path dir = dir ++ '/':lib ++ ".o" + + +-- ---------------------------------------------------------------------------- +-- Loading a dyanmic library (dlopen()-ish on Unix, LoadLibrary-ish on Win32) + +-- return Nothing == success, else Just error message from dlopen +loadDynamic paths rootname + = do { mb_dll <- findFile mk_dll_path paths + ; case mb_dll of + Just dll -> loadDLL dll + Nothing -> loadDLL (mkSOName rootname) } + -- Tried all our known library paths, so let + -- dlopen() search its own builtin paths now. + where + mk_dll_path dir = dir ++ '/':mkSOName rootname + +#if defined(darwin_TARGET_OS) +mkSOName root = "lib" ++ root ++ ".dylib" +#elif defined(mingw32_TARGET_OS) +-- Win32 DLLs have no .dll extension here, because addDLL tries +-- both foo.dll and foo.drv +mkSOName root = root +#else +mkSOName root = "lib" ++ root ++ ".so" +#endif + +-- Darwin / MacOS X only: load a framework +-- a framework is a dynamic library packaged inside a directory of the same +-- name. They are searched for in different paths than normal libraries. +#ifdef darwin_TARGET_OS +loadFramework extraPaths rootname + = do { mb_fwk <- findFile mk_fwk (extraPaths ++ defaultFrameworkPaths) + ; case mb_fwk of + Just fwk_path -> loadDLL fwk_path + Nothing -> return (Just "not found") + -- Tried all our known library paths, but dlopen() + -- has no built-in paths for frameworks: give up + where + mk_fwk dir = dir ++ '/' : rootname ++ ".framework/" ++ rootname +#endif +\end{code} + +%************************************************************************ +%* * + Helper functions +%* * +%************************************************************************ + +\begin{code} +findFile :: (FilePath -> FilePath) -- Maps a directory path to a file path + -> [FilePath] -- Directories to look in + -> IO (Maybe FilePath) -- The first file path to match +findFile mk_file_path [] + = return Nothing +findFile mk_file_path (dir:dirs) + = do { let file_path = mk_file_path dir + ; b <- doesFileExist file_path + ; if b then + return (Just file_path) + else + findFile mk_file_path dirs } +\end{code} + +\begin{code} +maybePutStr dflags s | verbosity dflags > 0 = putStr s + | otherwise = return () +maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s + | otherwise = return () \end{code} diff --git a/ghc/compiler/ghci/ObjLink.lhs b/ghc/compiler/ghci/ObjLink.lhs new file mode 100644 index 0000000000..7998f502ac --- /dev/null +++ b/ghc/compiler/ghci/ObjLink.lhs @@ -0,0 +1,92 @@ +% +% (c) The University of Glasgow, 2000 +% + +-- --------------------------------------------------------------------------- +-- The dynamic linker for object code (.o .so .dll files) +-- --------------------------------------------------------------------------- + +Primarily, this module consists of an interface to the C-land dynamic linker. + +\begin{code} +{-# OPTIONS -#include "Linker.h" #-} + +module ObjLink ( + initLinker, -- :: IO () + loadDLL, -- :: String -> IO (Maybe String) + loadObj, -- :: String -> IO () + unloadObj, -- :: String -> IO () + lookupSymbol, -- :: String -> IO (Maybe (Ptr a)) + resolveObjs -- :: IO SuccessFlag + ) where + +import Monad ( when ) + +import Foreign.C +import Foreign ( Ptr, nullPtr ) +import Panic ( panic ) +import DriverUtil ( prefixUnderscore ) +import BasicTypes ( SuccessFlag, successIf ) +import Outputable + +-- --------------------------------------------------------------------------- +-- RTS Linker Interface +-- --------------------------------------------------------------------------- + +lookupSymbol :: String -> IO (Maybe (Ptr a)) +lookupSymbol str_in = do + let str = prefixUnderscore str_in + withCString str $ \c_str -> do + addr <- c_lookupSymbol c_str + if addr == nullPtr + then return Nothing + else return (Just addr) + +loadDLL :: String -> IO (Maybe String) +-- Nothing => success +-- Just err_msg => failure +loadDLL str = do + maybe_errmsg <- withCString str $ \dll -> c_addDLL dll + if maybe_errmsg == nullPtr + then return Nothing + else do str <- peekCString maybe_errmsg + return (Just str) + +loadObj :: String -> IO () +loadObj str = do + withCString str $ \c_str -> do + r <- c_loadObj c_str + when (r == 0) (panic "loadObj: failed") + +unloadObj :: String -> IO () +unloadObj str = + withCString str $ \c_str -> do + r <- c_unloadObj c_str + when (r == 0) (panic "unloadObj: failed") + +resolveObjs :: IO SuccessFlag +resolveObjs = do + r <- c_resolveObjs + return (successIf (r /= 0)) + +-- --------------------------------------------------------------------------- +-- Foreign declaractions to RTS entry points which does the real work; +-- --------------------------------------------------------------------------- + +#if __GLASGOW_HASKELL__ >= 504 +foreign import ccall unsafe "addDLL" c_addDLL :: CString -> IO CString +foreign import ccall unsafe "initLinker" initLinker :: IO () +foreign import ccall unsafe "lookupSymbol" c_lookupSymbol :: CString -> IO (Ptr a) +foreign import ccall unsafe "loadObj" c_loadObj :: CString -> IO Int +foreign import ccall unsafe "unloadObj" c_unloadObj :: CString -> IO Int +foreign import ccall unsafe "resolveObjs" c_resolveObjs :: IO Int +#else +foreign import "addDLL" unsafe c_addDLL :: CString -> IO CString +foreign import "initLinker" unsafe initLinker :: IO () +foreign import "lookupSymbol" unsafe c_lookupSymbol :: CString -> IO (Ptr a) +foreign import "loadObj" unsafe c_loadObj :: CString -> IO Int +foreign import "unloadObj" unsafe c_unloadObj :: CString -> IO Int +foreign import "resolveObjs" unsafe c_resolveObjs :: IO Int +#endif + +\end{code} diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs new file mode 100644 index 0000000000..e3a60641b2 --- /dev/null +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -0,0 +1,297 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% + +This module converts Template Haskell syntax into HsSyn + + +\begin{code} +module Convert( convertToHsExpr, convertToHsDecls ) where + +#include "HsVersions.h" + +import Language.Haskell.THSyntax as Meta + +import HsSyn as Hs + ( HsExpr(..), HsLit(..), ArithSeqInfo(..), + HsDoContext(..), + Match(..), GRHSs(..), GRHS(..), HsPred(..), + HsDecl(..), TyClDecl(..), InstDecl(..), + Stmt(..), HsBinds(..), MonoBinds(..), Sig(..), + Pat(..), HsConDetails(..), HsOverLit, BangType(..), + placeHolderType, HsType(..), HsTupCon(..), + HsTyVarBndr(..), HsContext, + mkSimpleMatch + ) + +import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig ) +import Module ( mkModuleName ) +import RdrHsSyn ( mkHsIntegral, mkClassDecl, mkTyData, mkConDecl ) +import OccName +import SrcLoc ( SrcLoc, generatedSrcLoc ) +import TyCon ( DataConDetails(..) ) +import Type ( Type ) +import BasicTypes( Boxity(..), RecFlag(Recursive), + NewOrData(..), StrictnessMark(..) ) +import FastString( mkFastString ) +import Char ( ord, isAlphaNum ) +import List ( partition ) +import Outputable + + +------------------------------------------------------------------- +convertToHsDecls :: [Meta.Dec] -> [HsDecl RdrName] +convertToHsDecls ds + = ValD (cvtdecs binds_and_sigs) : map cvt_top top_decls + where + (binds_and_sigs, top_decls) = partition sigOrBindP ds + +cvt_top (Data tc tvs constrs derivs) + = TyClD (mkTyData DataType + (noContext, tconName tc, cvt_tvs tvs) + (DataCons (map mk_con constrs)) + (mk_derivs derivs) loc0) + where + mk_con (Constr c tys) + = mkConDecl (cName c) noExistentials noContext + (PrefixCon (map mk_arg tys)) loc0 + + mk_arg ty = BangType NotMarkedStrict (cvtType ty) + + mk_derivs [] = Nothing + mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs] + +cvt_top (Class ctxt cl tvs decs) + = TyClD (mkClassDecl (cvt_context ctxt, tconName cl, cvt_tvs tvs) + noFunDeps + sigs (Just binds) loc0) + where + (binds,sigs) = cvtBindsAndSigs decs + +cvt_top (Instance tys ty decs) + = InstD (InstDecl inst_ty binds sigs Nothing loc0) + where + (binds, sigs) = cvtBindsAndSigs decs + inst_ty = HsForAllTy Nothing + (cvt_context tys) + (HsPredTy (cvt_pred ty)) + +noContext = [] +noExistentials = [] +noFunDeps = [] + +------------------------------------------------------------------- +convertToHsExpr :: Meta.Exp -> HsExpr RdrName +convertToHsExpr = cvt + +cvt (Var s) = HsVar(vName s) +cvt (Con s) = HsVar(cName s) +cvt (Lit l) + | overloadedLit l = HsOverLit (cvtOverLit l) + | otherwise = HsLit (cvtLit l) + +cvt (App x y) = HsApp (cvt x) (cvt y) +cvt (Lam ps e) = HsLam (mkSimpleMatch (map cvtp ps) (cvt e) void loc0) +cvt (Tup es) = ExplicitTuple(map cvt es) Boxed +cvt (Cond x y z) = HsIf (cvt x) (cvt y) (cvt z) loc0 +cvt (Let ds e) = HsLet (cvtdecs ds) (cvt e) +cvt (Case e ms) = HsCase (cvt e) (map cvtm ms) loc0 +cvt (Do ss) = HsDo DoExpr (cvtstmts ss) [] void loc0 +cvt (Comp ss) = HsDo ListComp (cvtstmts ss) [] void loc0 +cvt (ArithSeq dd) = ArithSeqIn (cvtdd dd) +cvt (ListExp xs) = ExplicitList void (map cvt xs) +cvt (Infix (Just x) s (Just y)) = OpApp (cvt x) (HsVar(vName s)) undefined (cvt y) +cvt (Infix Nothing s (Just y)) = SectionR (HsVar(vName s)) (cvt y) +cvt (Infix (Just x) s Nothing ) = SectionL (cvt x) (HsVar(vName s)) +cvt (Infix Nothing s Nothing ) = HsVar(vName s) -- Can I indicate this is an infix thing? + + +cvtdecs :: [Meta.Dec] -> HsBinds RdrName +cvtdecs [] = EmptyBinds +cvtdecs ds = MonoBind binds sigs Recursive + where + (binds, sigs) = cvtBindsAndSigs ds + +cvtBindsAndSigs ds + = (cvtds non_sigs, map cvtSig sigs) + where + (sigs, non_sigs) = partition sigP ds + +cvtSig (Proto nm typ) = Sig (vName nm) (cvtType typ) loc0 + +cvtds :: [Meta.Dec] -> MonoBinds RdrName +cvtds [] = EmptyMonoBinds +cvtds (d:ds) = AndMonoBinds (cvtd d) (cvtds ds) + +cvtd :: Meta.Dec -> MonoBinds RdrName +-- Used only for declarations in a 'let/where' clause, +-- not for top level decls +cvtd (Val (Pvar s) body ds) = FunMonoBind (vName s) False + (panic "what now?") loc0 +cvtd (Fun nm cls) = FunMonoBind (vName nm) False (map cvtclause cls) loc0 +cvtd (Val p body ds) = PatMonoBind (cvtp p) (GRHSs (cvtguard body) + (cvtdecs ds) + void) loc0 +cvtd x = panic "Illegal kind of declaration in where clause" + + +cvtclause :: Meta.Clause (Meta.Pat) (Meta.Exp) (Meta.Dec) -> Hs.Match RdrName +cvtclause (ps,body,wheres) = Match (map cvtp ps) Nothing + (GRHSs (cvtguard body) (cvtdecs wheres) void) + + + +cvtdd :: Meta.DDt -> ArithSeqInfo RdrName +cvtdd (Meta.From x) = (Hs.From (cvt x)) +cvtdd (Meta.FromThen x y) = (Hs.FromThen (cvt x) (cvt y)) +cvtdd (Meta.FromTo x y) = (Hs.FromTo (cvt x) (cvt y)) +cvtdd (Meta.FromThenTo x y z) = (Hs.FromThenTo (cvt x) (cvt y) (cvt z)) + + +cvtstmts :: [Meta.Stm] -> [Hs.Stmt RdrName] +cvtstmts [] = [] -- this is probably an error as every [stmt] should end with ResultStmt +cvtstmts [NoBindSt e] = [ResultStmt (cvt e) loc0] -- when its the last element use ResultStmt +cvtstmts (NoBindSt e : ss) = ExprStmt (cvt e) void loc0 : cvtstmts ss +cvtstmts (BindSt p e : ss) = BindStmt (cvtp p) (cvt e) loc0 : cvtstmts ss +cvtstmts (LetSt ds : ss) = LetStmt (cvtdecs ds) : cvtstmts ss +cvtstmts (ParSt dss : ss) = ParStmt(map cvtstmts dss) : cvtstmts ss + + +cvtm :: Meta.Mat -> Hs.Match RdrName +cvtm (p,body,wheres) = Match [cvtp p] Nothing + (GRHSs (cvtguard body) (cvtdecs wheres) void) + +cvtguard :: Meta.Rhs -> [GRHS RdrName] +cvtguard (Guarded pairs) = map cvtpair pairs +cvtguard (Normal e) = [GRHS [ ResultStmt (cvt e) loc0 ] loc0] + +cvtpair :: (Meta.Exp,Meta.Exp) -> GRHS RdrName +cvtpair (x,y) = GRHS [BindStmt truePat (cvt x) loc0, + ResultStmt (cvt y) loc0] loc0 + +cvtOverLit :: Lit -> HsOverLit +cvtOverLit (Int i) = mkHsIntegral (fromInt i) +-- An Int is like an an (overloaded) '3' in a Haskell source program + +cvtLit :: Lit -> HsLit +cvtLit (Char c) = HsChar (ord c) +cvtLit (CrossStage s) = error "What do we do about crossStage constants?" + +cvtp :: Meta.Pat -> Hs.Pat RdrName +cvtp (Plit l) + | overloadedLit l = NPatIn (cvtOverLit l) Nothing -- Not right for negative + -- patterns; need to think + -- about that! + | otherwise = LitPat (cvtLit l) +cvtp (Pvar s) = VarPat(vName s) +cvtp (Ptup ps) = TuplePat (map cvtp ps) Boxed +cvtp (Pcon s ps) = ConPatIn (cName s) (PrefixCon (map cvtp ps)) +cvtp (Ptilde p) = LazyPat (cvtp p) +cvtp (Paspat s p) = AsPat (vName s) (cvtp p) +cvtp Pwild = WildPat void + +----------------------------------------------------------- +-- Types and type variables + +cvt_tvs :: [String] -> [HsTyVarBndr RdrName] +cvt_tvs tvs = map (UserTyVar . tName) tvs + +cvt_context :: Context -> HsContext RdrName +cvt_context tys = map cvt_pred tys + +cvt_pred :: Typ -> HsPred RdrName +cvt_pred ty = case split_ty_app ty of + (Tvar tc, tys) -> HsClassP (tconName tc) (map cvtType tys) + other -> panic "Malformed predicate" + +cvtType :: Meta.Typ -> HsType RdrName +cvtType (Tvar nm) = HsTyVar(tName nm) +cvtType (Tapp x y) = trans (root x [y]) + where root (Tapp a b) zs = root a (b:zs) + root t zs = (t,zs) + trans (Tcon (Tuple n),args) = HsTupleTy (HsTupCon Boxed n) (map cvtType args) + trans (Tcon Arrow,[x,y]) = HsFunTy (cvtType x) (cvtType y) + trans (Tcon List,[x]) = HsListTy (cvtType x) + trans (Tcon (Name nm),args) = HsTyVar(tconName nm) + trans (t,args) = panic "bad type application" + +split_ty_app :: Typ -> (Typ, [Typ]) +split_ty_app ty = go ty [] + where + go (Tapp f a) as = go f (a:as) + go f as = (f,as) + +----------------------------------------------------------- +sigP :: Dec -> Bool +sigP (Proto _ _) = True +sigP other = False + +sigOrBindP :: Dec -> Bool +sigOrBindP (Proto _ _) = True +sigOrBindP (Val _ _ _) = True +sigOrBindP (Fun _ _) = True +sigOrBindP other = False + + +----------------------------------------------------------- +-- some useful things + +truePat = ConPatIn (cName "True") (PrefixCon []) +falsePat = ConPatIn (cName "False") (PrefixCon []) + +overloadedLit :: Lit -> Bool +-- True for literals that Haskell treats as overloaded +overloadedLit (Int l) = True +overloadedLit l = False + +void :: Type.Type +void = placeHolderType + +loc0 :: SrcLoc +loc0 = generatedSrcLoc + +fromInt :: Int -> Integer +fromInt x = toInteger x + +-- variable names +vName :: String -> RdrName +vName = mkName varName + +-- Constructor function names +cName :: String -> RdrName +cName = mkName dataName + +-- Type variable names +tName :: String -> RdrName +tName = mkName tvName + +-- Type Constructor names +tconName = mkName tcName + +mkName :: NameSpace -> String -> RdrName +-- Parse the string to see if it has a "." or ":" in it +-- so we know whether to generate a qualified or original name +-- It's a bit tricky because we need to parse +-- Foo.Baz.x as Qual Foo.Baz x +-- So we parse it from back to front + +mkName ns str + = split [] (reverse str) + where + split occ [] = mkRdrUnqual (mk_occ occ) + split occ (c:d:rev) -- 'd' is the last char before the separator + | is_sep c -- E.g. Fo.x d='o' + && isAlphaNum d -- Fo.+: d='+' perhaps + = mk_qual (reverse (d:rev)) c occ + split occ (c:rev) = split (c:occ) rev + + mk_qual mod '.' occ = mkRdrQual (mk_mod mod) (mk_occ occ) + mk_qual mod ':' occ = mkOrig (mk_mod mod) (mk_occ occ) + + mk_occ occ = mkOccFS ns (mkFastString occ) + mk_mod mod = mkModuleName mod + + is_sep '.' = True + is_sep ':' = True + is_sep other = False +\end{code} diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index a57fbbe293..c02c435256 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -15,7 +15,8 @@ import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, GRHSs, pprPatBind ) -- friends: -import HsImpExp ( ppr_var ) +import HsImpExp ( pprHsVar ) +import HsPat ( Pat ) import HsTypes ( HsType ) import CoreSyn ( CoreExpr ) import PprCore ( {- instance Outputable (Expr a) -} ) @@ -24,7 +25,7 @@ import PprCore ( {- instance Outputable (Expr a) -} ) import Name ( Name ) import PrelNames ( isUnboundName ) import NameSet ( NameSet, elemNameSet, nameSetToList ) -import BasicTypes ( RecFlag(..), Fixity, Activation(..) ) +import BasicTypes ( RecFlag(..), FixitySig(..), Activation(..) ) import Outputable import SrcLoc ( SrcLoc ) import Var ( TyVar ) @@ -46,32 +47,31 @@ grammar. Collections of bindings, created by dependency analysis and translation: \begin{code} -data HsBinds id pat -- binders and bindees +data HsBinds id -- binders and bindees = EmptyBinds - | ThenBinds (HsBinds id pat) - (HsBinds id pat) + | ThenBinds (HsBinds id) + (HsBinds id) - | MonoBind (MonoBinds id pat) - [Sig id] -- Empty on typechecker output + | MonoBind (MonoBinds id) + [Sig id] -- Empty on typechecker output, Type Signatures RecFlag \end{code} \begin{code} -nullBinds :: HsBinds id pat -> Bool +nullBinds :: HsBinds id -> Bool nullBinds EmptyBinds = True nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2 nullBinds (MonoBind b _ _) = nullMonoBinds b -mkMonoBind :: MonoBinds id pat -> [Sig id] -> RecFlag -> HsBinds id pat +mkMonoBind :: MonoBinds id -> [Sig id] -> RecFlag -> HsBinds id mkMonoBind EmptyMonoBinds _ _ = EmptyBinds mkMonoBind mbinds sigs is_rec = MonoBind mbinds sigs is_rec \end{code} \begin{code} -instance (Outputable pat, Outputable id) => - Outputable (HsBinds id pat) where +instance (OutputableBndr id) => Outputable (HsBinds id) where ppr binds = ppr_binds binds ppr_binds EmptyBinds = empty @@ -99,11 +99,11 @@ ppr_binds (MonoBind bind sigs is_rec) Global bindings (where clauses) \begin{code} -data MonoBinds id pat +data MonoBinds id = EmptyMonoBinds - | AndMonoBinds (MonoBinds id pat) - (MonoBinds id pat) + | AndMonoBinds (MonoBinds id) + (MonoBinds id) | FunMonoBind id -- Used for both functions f x = e -- and variables f = \x -> e @@ -114,16 +114,16 @@ data MonoBinds id pat -- FunMonoBinds, so if you change this, you'll need to -- change e.g. rnMethodBinds Bool -- True => infix declaration - [Match id pat] + [Match id] SrcLoc - | PatMonoBind pat -- The pattern is never a simple variable; + | PatMonoBind (Pat id) -- The pattern is never a simple variable; -- That case is done by FunMonoBind - (GRHSs id pat) + (GRHSs id) SrcLoc | VarMonoBind id -- TRANSLATION - (HsExpr id pat) + (HsExpr id) | CoreMonoBind id -- TRANSLATION CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types! @@ -133,7 +133,7 @@ data MonoBinds id pat [id] -- Dicts [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples NameSet -- Set of *polymorphic* variables that have an INLINE pragma - (MonoBinds id pat) -- The "business end" + (MonoBinds id) -- The "business end" -- Creates bindings for *new* (polymorphic, overloaded) locals -- in terms of *old* (monomorphic, non-overloaded) ones. @@ -171,16 +171,16 @@ So the desugarer tries to do a better job: -- We keep the invariant that a MonoBinds is only empty -- if it is exactly EmptyMonoBinds -nullMonoBinds :: MonoBinds id pat -> Bool +nullMonoBinds :: MonoBinds id -> Bool nullMonoBinds EmptyMonoBinds = True nullMonoBinds other_monobind = False -andMonoBinds :: MonoBinds id pat -> MonoBinds id pat -> MonoBinds id pat +andMonoBinds :: MonoBinds id -> MonoBinds id -> MonoBinds id andMonoBinds EmptyMonoBinds mb = mb andMonoBinds mb EmptyMonoBinds = mb andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2 -andMonoBindList :: [MonoBinds id pat] -> MonoBinds id pat +andMonoBindList :: [MonoBinds id] -> MonoBinds id andMonoBindList binds = loop1 binds where @@ -196,12 +196,11 @@ andMonoBindList binds \begin{code} -instance (Outputable id, Outputable pat) => - Outputable (MonoBinds id pat) where +instance OutputableBndr id => Outputable (MonoBinds id) where ppr mbind = ppr_monobind mbind -ppr_monobind :: (Outputable id, Outputable pat) => MonoBinds id pat -> SDoc +ppr_monobind :: OutputableBndr id => MonoBinds id -> SDoc ppr_monobind EmptyMonoBinds = empty ppr_monobind (AndMonoBinds binds1 binds2) = ppr_monobind binds1 $$ ppr_monobind binds2 @@ -211,10 +210,10 @@ ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches -- ToDo: print infix if appropriate ppr_monobind (VarMonoBind name expr) - = sep [ppr name <+> equals, nest 4 (pprExpr expr)] + = sep [pprBndr LetBind name <+> equals, nest 4 (pprExpr expr)] ppr_monobind (CoreMonoBind name expr) - = sep [ppr name <+> equals, nest 4 (ppr expr)] + = sep [pprBndr LetBind name <+> equals, nest 4 (ppr expr)] ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds) = sep [ptext SLIT("AbsBinds"), @@ -223,7 +222,10 @@ ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds) brackets (sep (punctuate comma (map ppr exports))), brackets (interpp'SP (nameSetToList inlines))] $$ - nest 4 (ppr val_binds) + nest 4 ( vcat [pprBndr LetBind x | (_,x,_) <- exports] + -- Print type signatures + $$ + ppr val_binds ) \end{code} %************************************************************************ @@ -263,12 +265,6 @@ data Sig name SrcLoc | FixSig (FixitySig name) -- Fixity declaration - - -data FixitySig name = FixitySig name Fixity SrcLoc - -instance Eq name => Eq (FixitySig name) where - (FixitySig n1 f1 _) == (FixitySig n2 f2 _) = n1==n2 && f1==f2 \end{code} \begin{code} @@ -335,7 +331,7 @@ ppr_sig (Sig var ty _) = sep [ppr var <+> dcolon, nest 4 (ppr ty)] ppr_sig (ClassOpSig var dm ty _) - = sep [ ppr_var var <+> dcolon, + = sep [ pprHsVar var <+> dcolon, nest 4 (ppr ty), nest 4 (pp_dm_comment) ] where @@ -363,10 +359,6 @@ ppr_sig (SpecInstSig ty _) = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"] ppr_sig (FixSig fix_sig) = ppr fix_sig - - -instance Outputable name => Outputable (FixitySig name) where - ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name] \end{code} Checking for distinct signatures; oh, so boring diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 0f5a020370..1174278c2c 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -16,7 +16,7 @@ module HsCore ( UfBinding(..), UfConAlt(..), HsIdInfo(..), pprHsIdInfo, - eq_ufExpr, eq_ufBinders, pprUfExpr, pprHsIdInfo, + eq_ufExpr, eq_ufBinders, pprUfExpr, toUfExpr, toUfBndr, ufBinderName ) where @@ -34,9 +34,8 @@ import HsTypes ( HsType, pprParendHsType, pprHsTyVarBndr, toHsType, import Id ( idArity, idType, isDataConId_maybe, isFCallId_maybe ) import Var ( varType, isId ) import IdInfo ( InlinePragInfo ) -import Name ( Name, NamedThing(..), toRdrName ) +import Name ( Name, NamedThing(..), eqNameByOcc ) import RdrName ( RdrName, rdrNameOcc ) -import OccName ( isTvOcc ) import CoreSyn import CostCentre ( pprCostCentreCore ) import NewDemand ( StrictSig, pprIfaceStrictSig ) @@ -63,7 +62,7 @@ import FastString data UfExpr name = UfVar name | UfType (HsType name) - | UfTuple (HsTupCon name) [UfExpr name] -- Type arguments omitted + | UfTuple HsTupCon [UfExpr name] -- Type arguments omitted | UfLam (UfBinder name) (UfExpr name) | UfApp (UfExpr name) (UfExpr name) | UfCase (UfExpr name) name [UfAlt name] @@ -82,7 +81,7 @@ type UfAlt name = (UfConAlt name, [name], UfExpr name) data UfConAlt name = UfDefault | UfDataAlt name - | UfTupleAlt (HsTupCon name) + | UfTupleAlt HsTupCon | UfLitAlt Literal | UfLitLitAlt FastString (HsType name) @@ -145,7 +144,7 @@ toUfCon (LitAlt l) = case maybeLitLit l of toUfCon DEFAULT = UfDefault --------------------- -mk_hs_tup_con tc dc = HsTupCon (getName dc) (tupleTyConBoxity tc) (dataConSourceArity dc) +mk_hs_tup_con tc dc = HsTupCon (tupleTyConBoxity tc) (dataConSourceArity dc) --------------------- toUfBndr x | isId x = UfValBinder (getName x) (toHsType (varType x)) @@ -186,7 +185,7 @@ toUfVar v = case isFCallId_maybe v of %************************************************************************ \begin{code} -instance (NamedThing name, Outputable name) => Outputable (UfExpr name) where +instance OutputableBndr name => Outputable (UfExpr name) where ppr e = pprUfExpr noParens e @@ -200,7 +199,7 @@ instance NamedThing RdrName where noParens :: SDoc -> SDoc noParens pp = pp -pprUfExpr :: (NamedThing name, Outputable name) => (SDoc -> SDoc) -> UfExpr name -> SDoc +pprUfExpr :: OutputableBndr name => (SDoc -> SDoc) -> UfExpr name -> SDoc -- The function adds parens in context that need -- an atomic value (e.g. function args) @@ -210,7 +209,7 @@ pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHs pprUfExpr add_par (UfFCall cc ty) = braces (ppr cc <+> ppr ty) pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty -pprUfExpr add_par e@(UfLam _ _) = add_par (char '\\' <+> hsep (map ppr bndrs) +pprUfExpr add_par e@(UfLam _ _) = add_par (char '\\' <+> hsep (map (pprBndr LambdaBind) bndrs) <+> ptext SLIT("->") <+> pprUfExpr noParens body) where (bndrs,body) = collectUfBndrs e pprUfExpr add_par app@(UfApp _ _) = add_par (pprUfApp app) @@ -221,17 +220,13 @@ pprUfExpr add_par (UfCase scrut bndr alts) braces (hsep (map pp_alt alts))]) where pp_alt (UfTupleAlt tup_con, bs, rhs) = hsTupParens tup_con (interpp'SP bs) <+> ppr_rhs rhs - pp_alt (c, bs, rhs) = ppr c <+> hsep (map pp_bndr bs) <+> ppr_rhs rhs + pp_alt (c, bs, rhs) = ppr c <+> hsep (map (pprBndr CaseBind) bs) <+> ppr_rhs rhs ppr_rhs rhs = ptext SLIT("->") <+> pprUfExpr noParens rhs <> semi - -- This use of getOccName is the sole reason for the NamedThing in pprUfExpr's type - pp_bndr v | isTvOcc (getOccName v) = char '@' <+> ppr v - | otherwise = ppr v - pprUfExpr add_par (UfLet (UfNonRec b rhs) body) = add_par (hsep [ptext SLIT("let"), - braces (ppr b <+> equals <+> pprUfExpr noParens rhs), + braces (pprBndr LetBind b <+> equals <+> pprUfExpr noParens rhs), ptext SLIT("in"), pprUfExpr noParens body]) pprUfExpr add_par (UfLet (UfRec pairs) body) @@ -267,6 +262,10 @@ instance Outputable name => Outputable (UfConAlt name) where instance Outputable name => Outputable (UfBinder name) where ppr (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty] ppr (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind + +instance OutputableBndr name => OutputableBndr (UfBinder name) where + pprBndr _ (UfValBinder name ty) = hsep [ppr name, dcolon, pprParendHsType ty] + pprBndr _ (UfTyBinder name kind) = char '@' <+> pprHsTyVarBndr name kind \end{code} @@ -315,9 +314,10 @@ eq_ufVar :: (NamedThing name, Ord name) => EqHsEnv name -> name -> name -> Bool -- Compare *Rdr* names. A real hack to avoid gratuitous -- differences when comparing interface files eq_ufVar env n1 n2 = case lookupFM env n1 of - Just n1 -> toRdrName n1 == toRdrName n2 - Nothing -> toRdrName n1 == toRdrName n2 - + Just n1 -> check n1 + Nothing -> check n2 + where + check n1 = eqNameByOcc (getName n1) (getName n2) ----------------- eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExpr name -> Bool @@ -374,7 +374,7 @@ eq_ufConAlt env _ _ = False %************************************************************************ \begin{code} -pprHsIdInfo :: (NamedThing n, Outputable n) => [HsIdInfo n] -> SDoc +pprHsIdInfo :: OutputableBndr n => [HsIdInfo n] -> SDoc pprHsIdInfo [] = empty pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext SLIT("##-}") diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 036a427318..7553cca68b 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -12,31 +12,34 @@ module HsDecls ( DefaultDecl(..), ForeignDecl(..), ForeignImport(..), ForeignExport(..), CImportSpec(..), FoType(..), - ConDecl(..), ConDetails(..), + ConDecl(..), CoreDecl(..), BangType(..), getBangType, getBangStrictness, unbangedType, DeprecDecl(..), DeprecTxt, hsDeclName, instDeclName, - tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars, - isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, isCoreDecl, + tyClDeclName, tyClDeclNames, tyClDeclTyVars, + isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, isTypeOrClassDecl, countTyClDecls, - mkClassDeclSysNames, isSourceInstDecl, ifaceRuleDeclName, - getClassDeclSysNames, conDetailsTys, - collectRuleBndrSigTys + isSourceInstDecl, ifaceRuleDeclName, + conDetailsTys, + collectRuleBndrSigTys, isSrcRule ) where #include "HsVersions.h" -- friends: -import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig(..) ) -import HsExpr ( HsExpr ) -import HsImpExp ( ppr_var ) +import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) + -- Because Expr imports Decls via HsBracket + +import HsBinds ( HsBinds, MonoBinds, Sig(..) ) +import HsPat ( HsConDetails(..), hsConArgs ) +import HsImpExp ( pprHsVar ) import HsTypes import PprCore ( pprCoreRule ) import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo, eq_ufBinders, eq_ufExpr, pprUfExpr ) import CoreSyn ( CoreRule(..), RuleName ) -import BasicTypes ( NewOrData(..), StrictnessMark(..), Activation(..) ) +import BasicTypes ( NewOrData(..), StrictnessMark(..), Activation(..), FixitySig(..) ) import ForeignCall ( CCallTarget(..), DNCallSpec, CCallConv, Safety, CExportSpec(..)) @@ -62,15 +65,17 @@ import Maybe ( isNothing, fromJust ) %************************************************************************ \begin{code} -data HsDecl name pat - = TyClD (TyClDecl name pat) - | InstD (InstDecl name pat) - | DefD (DefaultDecl name) - | ValD (HsBinds name pat) - | ForD (ForeignDecl name) - | FixD (FixitySig name) - | DeprecD (DeprecDecl name) - | RuleD (RuleDecl name pat) +data HsDecl id + = TyClD (TyClDecl id) + | InstD (InstDecl id) + | DefD (DefaultDecl id) + | ValD (HsBinds id) + | ForD (ForeignDecl id) + | FixD (FixitySig id) + | DeprecD (DeprecDecl id) + | RuleD (RuleDecl id) + | CoreD (CoreDecl id) + | SpliceD (HsExpr id) -- Top level splice -- NB: all top-level fixity decls are contained EITHER -- EITHER FixDs @@ -88,27 +93,27 @@ data HsDecl name pat \begin{code} #ifdef DEBUG -hsDeclName :: (NamedThing name, Outputable name, Outputable pat) - => HsDecl name pat -> name +hsDeclName :: (NamedThing name, OutputableBndr name) + => HsDecl name -> name #endif -hsDeclName (TyClD decl) = tyClDeclName decl -hsDeclName (InstD decl) = instDeclName decl -hsDeclName (ForD decl) = foreignDeclName decl -hsDeclName (FixD (FixitySig name _ _)) = name +hsDeclName (TyClD decl) = tyClDeclName decl +hsDeclName (InstD decl) = instDeclName decl +hsDeclName (ForD decl) = foreignDeclName decl +hsDeclName (FixD (FixitySig name _ _)) = name +hsDeclName (CoreD (CoreDecl name _ _ _)) = name -- Others don't make sense #ifdef DEBUG hsDeclName x = pprPanic "HsDecls.hsDeclName" (ppr x) #endif -instDeclName :: InstDecl name pat -> name +instDeclName :: InstDecl name -> name instDeclName (InstDecl _ _ _ (Just name) _) = name \end{code} \begin{code} -instance (NamedThing name, Outputable name, Outputable pat) - => Outputable (HsDecl name pat) where +instance OutputableBndr name => Outputable (HsDecl name) where ppr (TyClD dcl) = ppr dcl ppr (ValD binds) = ppr binds @@ -118,6 +123,8 @@ instance (NamedThing name, Outputable name, Outputable pat) ppr (FixD fd) = ppr fd ppr (RuleD rd) = ppr rd ppr (DeprecD dd) = ppr dd + ppr (CoreD dd) = ppr dd + ppr (SpliceD e) = ptext SLIT("splice") <> parens (pprExpr e) \end{code} @@ -153,15 +160,16 @@ interface files, of course. Any such occurrence must haul in the relevant type or class decl. Plan of attack: - - Make up their occurrence names immediately - This is done in RdrHsSyn.mkClassDecl, mkTyDecl, mkConDecl - - Ensure they "point to" the parent data/class decl when loading that decl from an interface file - (See RnHiFiles.getTyClDeclSysNames) + (See RnHiFiles.getSysBinders) + + - When typechecking the decl, we build the implicit TyCons and Ids. + When doing so we look them up in the name cache (RnEnv.lookupSysName), + to ensure correct module and provenance is set - - When renaming the decl look them up in the name cache, - ensure correct module and provenance is set +These are the two places that we have to conjure up the magic derived +names. (The actual magic is in OccName.mkWorkerOcc, etc.) Default methods ~~~~~~~~~~~~~~~ @@ -263,7 +271,7 @@ Interface file code: -- for a module. That's why (despite the misnomer) IfaceSig and ForeignType -- are both in TyClDecl -data TyClDecl name pat +data TyClDecl name = IfaceSig { tcdName :: name, -- It may seem odd to classify an interface-file signature tcdType :: HsType name, -- as a 'TyClDecl', but it's very convenient. tcdIdInfo :: [HsIdInfo name], @@ -276,14 +284,19 @@ data TyClDecl name pat tcdLoc :: SrcLoc } | TyData { tcdND :: NewOrData, - tcdCtxt :: HsContext name, -- context - tcdName :: name, -- type constructor - tcdTyVars :: [HsTyVarBndr name], -- type variables - tcdCons :: DataConDetails (ConDecl name), -- data constructors (empty if abstract) - tcdDerivs :: Maybe (HsContext name), -- derivings; Nothing => not specified + tcdCtxt :: HsContext name, -- Context + tcdName :: name, -- Type constructor + tcdTyVars :: [HsTyVarBndr name], -- Type variables + tcdCons :: DataConDetails (ConDecl name), -- Data constructors + tcdDerivs :: Maybe (HsContext name), -- Derivings; Nothing => not specified -- Just [] => derive exactly what is asked - tcdSysNames :: DataSysNames name, -- Generic converter functions - tcdLoc :: SrcLoc + tcdGeneric :: Maybe Bool, -- Nothing <=> source decl + -- Just x <=> interface-file decl; + -- x=True <=> generic converter functions available + -- We need this for imported data decls, since the + -- imported modules may have been compiled with + -- different flags to the current compilation unit + tcdLoc :: SrcLoc } | TySynonym { tcdName :: name, -- type constructor @@ -297,25 +310,17 @@ data TyClDecl name pat tcdTyVars :: [HsTyVarBndr name], -- The class type variables tcdFDs :: [FunDep name], -- Functional dependencies tcdSigs :: [Sig name], -- Methods' signatures - tcdMeths :: Maybe (MonoBinds name pat), -- Default methods - -- Nothing for imported class decls - -- Just bs for source class decls - tcdSysNames :: ClassSysNames name, + tcdMeths :: Maybe (MonoBinds name), -- Default methods + -- Nothing for imported class decls + -- Just bs for source class decls tcdLoc :: SrcLoc } - -- a Core value binding (coming from 'external Core' input.) - | CoreDecl { tcdName :: name, - tcdType :: HsType name, - tcdRhs :: UfExpr name, - tcdLoc :: SrcLoc - } - \end{code} Simple classifiers \begin{code} -isIfaceSigDecl, isCoreDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool +isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name -> Bool isIfaceSigDecl (IfaceSig {}) = True isIfaceSigDecl other = False @@ -334,21 +339,17 @@ isTypeOrClassDecl (TyData {}) = True isTypeOrClassDecl (TySynonym {}) = True isTypeOrClassDecl (ForeignType {}) = True isTypeOrClassDecl other = False - -isCoreDecl (CoreDecl {}) = True -isCoreDecl other = False - \end{code} Dealing with names \begin{code} -------------------------------- -tyClDeclName :: TyClDecl name pat -> name +tyClDeclName :: TyClDecl name -> name tyClDeclName tycl_decl = tcdName tycl_decl -------------------------------- -tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)] +tyClDeclNames :: Eq name => TyClDecl name -> [(name, SrcLoc)] -- Returns all the *binding* names of the decl, along with their SrcLocs -- The first one is guaranteed to be the name of the decl -- For record fields, the first one counts as the SrcLoc @@ -356,7 +357,6 @@ tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)] tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc}) = [(name,loc)] tyClDeclNames (IfaceSig {tcdName = name, tcdLoc = loc}) = [(name,loc)] -tyClDeclNames (CoreDecl {tcdName = name, tcdLoc = loc}) = [(name,loc)] tyClDeclNames (ForeignType {tcdName = name, tcdLoc = loc}) = [(name,loc)] tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc}) @@ -371,56 +371,16 @@ tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs tyClDeclTyVars (ForeignType {}) = [] tyClDeclTyVars (IfaceSig {}) = [] -tyClDeclTyVars (CoreDecl {}) = [] - - --------------------------------- --- The "system names" are extra implicit names *bound* by the decl. --- They are kept in a list rather than a tuple --- to make the renamer easier. - -type ClassSysNames name = [name] --- For class decls they are: --- [tycon, datacon wrapper, datacon worker, --- superclass selector 1, ..., superclass selector n] - -type DataSysNames name = [name] --- For data decls they are --- [from, to] --- where from :: T -> Tring --- to :: Tring -> T - -tyClDeclSysNames :: TyClDecl name pat -> [(name, SrcLoc)] --- Similar to tyClDeclNames, but returns the "implicit" --- or "system" names of the declaration - -tyClDeclSysNames (ClassDecl {tcdSysNames = names, tcdLoc = loc}) - = [(n,loc) | n <- names] -tyClDeclSysNames (TyData {tcdCons = DataCons cons, tcdSysNames = names, tcdLoc = loc}) - = [(n,loc) | n <- names] ++ - [(wkr_name,loc) | ConDecl _ wkr_name _ _ _ loc <- cons] -tyClDeclSysNames decl = [] - - -mkClassDeclSysNames :: (name, name, name, [name]) -> [name] -getClassDeclSysNames :: [name] -> (name, name, name, [name]) -mkClassDeclSysNames (a,b,c,ds) = a:b:c:ds -getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds) \end{code} \begin{code} -instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where +instance (NamedThing name, Ord name) => Eq (TyClDecl name) where -- Used only when building interface files (==) d1@(IfaceSig {}) d2@(IfaceSig {}) = tcdName d1 == tcdName d2 && tcdType d1 == tcdType d2 && tcdIdInfo d1 == tcdIdInfo d2 - (==) d1@(CoreDecl {}) d2@(CoreDecl {}) - = tcdName d1 == tcdName d2 && - tcdType d1 == tcdType d2 && - tcdRhs d1 == tcdRhs d2 - (==) d1@(ForeignType {}) d2@(ForeignType {}) = tcdName d1 == tcdName d2 && tcdFoType d1 == tcdFoType d2 @@ -468,17 +428,15 @@ eq_cls_sig env (ClassOpSig n1 dm1 ty1 _) (ClassOpSig n2 dm2 ty2 _) GenDefMeth `eq_dm` GenDefMeth = True DefMeth _ `eq_dm` DefMeth _ = True dm1 `eq_dm` dm2 = False - - \end{code} \begin{code} -countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int, Int) +countTyClDecls :: [TyClDecl name] -> (Int, Int, Int, Int, Int) -- class, data, newtype, synonym decls countTyClDecls decls = (count isClassDecl decls, count isSynDecl decls, - count (\ x -> isIfaceSigDecl x || isCoreDecl x) decls, + count isIfaceSigDecl decls, count isDataTy decls, count isNewTy decls) where @@ -490,12 +448,12 @@ countTyClDecls decls \end{code} \begin{code} -instance (NamedThing name, Outputable name, Outputable pat) - => Outputable (TyClDecl name pat) where +instance OutputableBndr name + => Outputable (TyClDecl name) where ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info}) = getPprStyle $ \ sty -> - hsep [ ppr_var var, dcolon, ppr ty, pprHsIdInfo info ] + hsep [ pprHsVar var, dcolon, ppr ty, pprHsIdInfo info ] ppr (ForeignType {tcdName = tycon}) = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon] @@ -530,12 +488,8 @@ instance (NamedThing name, Outputable name, Outputable pat) pp_methods = if isNothing methods then empty else ppr (fromJust methods) - - ppr (CoreDecl {tcdName = var, tcdType = ty, tcdRhs = rhs}) - = getPprStyle $ \ sty -> - hsep [ ppr_var var, dcolon, ppr ty, ppr rhs ] -pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc +pp_decl_head :: OutputableBndr name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars] pp_condecls Unknown = ptext SLIT("{- abstract -}") @@ -563,26 +517,12 @@ data ConDecl name = ConDecl name -- Constructor name; this is used for the -- DataCon itself, and for the user-callable wrapper Id - name -- Name of the constructor's 'worker Id' - -- Filled in as the ConDecl is built - [HsTyVarBndr name] -- Existentially quantified type variables (HsContext name) -- ...and context -- If both are empty then there are no existentials - (ConDetails name) + (HsConDetails name (BangType name)) SrcLoc - -data ConDetails name - = VanillaCon -- prefix-style con decl - [BangType name] - - | InfixCon -- infix-style con decl - (BangType name) - (BangType name) - - | RecCon -- record-style con decl - [([name], BangType name)] -- list of "fields" \end{code} \begin{code} @@ -593,34 +533,26 @@ conDeclsNames :: Eq name => DataConDetails (ConDecl name) -> [(name,SrcLoc)] conDeclsNames cons = snd (foldl do_one ([], []) (visibleDataCons cons)) where - do_one (flds_seen, acc) (ConDecl name _ _ _ details loc) - = do_details ((name,loc):acc) details + do_one (flds_seen, acc) (ConDecl name _ _ (RecCon flds) loc) + = (new_flds ++ flds_seen, (name,loc) : [(f,loc) | f <- new_flds] ++ acc) where - do_details acc (RecCon flds) = foldl do_fld (flds_seen, acc) flds - do_details acc other = (flds_seen, acc) - - do_fld acc (flds, _) = foldl do_fld1 acc flds + new_flds = [ f | (f,_) <- flds, not (f `elem` flds_seen) ] - do_fld1 (flds_seen, acc) fld - | fld `elem` flds_seen = (flds_seen,acc) - | otherwise = (fld:flds_seen, (fld,loc):acc) + do_one (flds_seen, acc) (ConDecl name _ _ _ loc) + = (flds_seen, (name,loc):acc) \end{code} \begin{code} -conDetailsTys :: ConDetails name -> [HsType name] -conDetailsTys (VanillaCon btys) = map getBangType btys -conDetailsTys (InfixCon bty1 bty2) = [getBangType bty1, getBangType bty2] -conDetailsTys (RecCon fields) = [getBangType bty | (_, bty) <- fields] +conDetailsTys details = map getBangType (hsConArgs details) - -eq_ConDecl env (ConDecl n1 _ tvs1 cxt1 cds1 _) - (ConDecl n2 _ tvs2 cxt2 cds2 _) +eq_ConDecl env (ConDecl n1 tvs1 cxt1 cds1 _) + (ConDecl n2 tvs2 cxt2 cds2 _) = n1 == n2 && (eq_hsTyVars env tvs1 tvs2 $ \ env -> eq_hsContext env cxt1 cxt2 && eq_ConDetails env cds1 cds2) -eq_ConDetails env (VanillaCon bts1) (VanillaCon bts2) +eq_ConDetails env (PrefixCon bts1) (PrefixCon bts2) = eqListBy (eq_btype env) bts1 bts2 eq_ConDetails env (InfixCon bta1 btb1) (InfixCon bta2 btb2) = eq_btype env bta1 bta2 && eq_btype env btb1 btb2 @@ -643,28 +575,26 @@ eq_btype env (BangType s1 t1) (BangType s2 t2) = s1==s2 && eq_hsType env t1 t2 \end{code} \begin{code} -instance (Outputable name) => Outputable (ConDecl name) where - ppr (ConDecl con _ tvs cxt con_details loc) +instance (OutputableBndr name) => Outputable (ConDecl name) where + ppr (ConDecl con tvs cxt con_details loc) = sep [pprHsForAll tvs cxt, ppr_con_details con con_details] ppr_con_details con (InfixCon ty1 ty2) = hsep [ppr_bang ty1, ppr con, ppr_bang ty2] --- ConDecls generated by MkIface.ifaceTyThing always have a VanillaCon, even +-- ConDecls generated by MkIface.ifaceTyThing always have a PrefixCon, even -- if the constructor is an infix one. This is because in an interface file -- we don't distinguish between the two. Hence when printing these for the -- user, we need to parenthesise infix constructor names. -ppr_con_details con (VanillaCon tys) - = hsep (ppr_var con : map (ppr_bang) tys) +ppr_con_details con (PrefixCon tys) + = hsep (pprHsVar con : map ppr_bang tys) ppr_con_details con (RecCon fields) = ppr con <+> braces (sep (punctuate comma (map ppr_field fields))) where - ppr_field (ns, ty) = hsep (map (ppr) ns) <+> - dcolon <+> - ppr_bang ty + ppr_field (n, ty) = ppr n <+> dcolon <+> ppr_bang ty -instance Outputable name => Outputable (BangType name) where +instance OutputableBndr name => Outputable (BangType name) where ppr = ppr_bang ppr_bang (BangType s ty) = ppr s <> pprParendHsType ty @@ -678,12 +608,12 @@ ppr_bang (BangType s ty) = ppr s <> pprParendHsType ty %************************************************************************ \begin{code} -data InstDecl name pat +data InstDecl name = InstDecl (HsType name) -- Context => Class Instance-type -- Using a polytype means that the renamer conveniently -- figures out the quantified type variables for us. - (MonoBinds name pat) + (MonoBinds name) [Sig name] -- User-supplied pragmatic info @@ -692,13 +622,12 @@ data InstDecl name pat SrcLoc -isSourceInstDecl :: InstDecl name pat -> Bool +isSourceInstDecl :: InstDecl name -> Bool isSourceInstDecl (InstDecl _ _ _ maybe_dfun _) = isNothing maybe_dfun \end{code} \begin{code} -instance (Outputable name, Outputable pat) - => Outputable (InstDecl name pat) where +instance (OutputableBndr name) => Outputable (InstDecl name) where ppr (InstDecl inst_ty binds uprags maybe_dfun_name src_loc) = vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")], @@ -711,7 +640,7 @@ instance (Outputable name, Outputable pat) \end{code} \begin{code} -instance Ord name => Eq (InstDecl name pat) where +instance Ord name => Eq (InstDecl name) where -- Used for interface comparison only, so don't compare bindings (==) (InstDecl inst_ty1 _ _ dfun1 _) (InstDecl inst_ty2 _ _ dfun2 _) = inst_ty1 == inst_ty2 && dfun1 == dfun2 @@ -733,7 +662,7 @@ data DefaultDecl name = DefaultDecl [HsType name] SrcLoc -instance (Outputable name) +instance (OutputableBndr name) => Outputable (DefaultDecl name) where ppr (DefaultDecl tys src_loc) @@ -813,7 +742,7 @@ data FoType = DNType -- In due course we'll add subtype stuff -- pretty printing of foreign declarations -- -instance Outputable name => Outputable (ForeignDecl name) where +instance OutputableBndr name => Outputable (ForeignDecl name) where ppr (ForeignImport n ty fimport _ _) = ptext SLIT("foreign import") <+> ppr fimport <+> ppr n <+> dcolon <+> ppr ty @@ -861,13 +790,13 @@ instance Outputable FoType where %************************************************************************ \begin{code} -data RuleDecl name pat +data RuleDecl name = HsRule -- Source rule RuleName -- Rule name Activation [RuleBndr name] -- Forall'd vars; after typechecking this includes tyvars - (HsExpr name pat) -- LHS - (HsExpr name pat) -- RHS + (HsExpr name) -- LHS + (HsExpr name) -- RHS SrcLoc | IfaceRule -- One that's come in from an interface file; pre-typecheck @@ -883,7 +812,10 @@ data RuleDecl name pat name -- Head of LHS CoreRule -ifaceRuleDeclName :: RuleDecl name pat -> name +isSrcRule (HsRule _ _ _ _ _ _) = True +isSrcRule other = False + +ifaceRuleDeclName :: RuleDecl name -> name ifaceRuleDeclName (IfaceRule _ _ _ n _ _ _) = n ifaceRuleDeclName (IfaceRuleOut n r) = n ifaceRuleDeclName (HsRule fs _ _ _ _ _) = pprPanic "ifaceRuleDeclName" (ppr fs) @@ -895,18 +827,17 @@ data RuleBndr name collectRuleBndrSigTys :: [RuleBndr name] -> [HsType name] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] -instance (NamedThing name, Ord name) => Eq (RuleDecl name pat) where +instance (NamedThing name, Ord name) => Eq (RuleDecl name) where -- Works for IfaceRules only; used when comparing interface file versions (IfaceRule n1 a1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 a2 bs2 f2 es2 rhs2 _) = n1==n2 && f1 == f2 && a1==a2 && eq_ufBinders emptyEqHsEnv bs1 bs2 (\env -> eqListBy (eq_ufExpr env) (rhs1:es1) (rhs2:es2)) -instance (NamedThing name, Outputable name, Outputable pat) - => Outputable (RuleDecl name pat) where +instance OutputableBndr name => Outputable (RuleDecl name) where ppr (HsRule name act ns lhs rhs loc) = sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act, - pp_forall, ppr lhs, equals <+> ppr rhs, + pp_forall, pprExpr lhs, equals <+> pprExpr rhs, text "#-}" ] where pp_forall | null ns = empty @@ -921,7 +852,7 @@ instance (NamedThing name, Outputable name, Outputable pat) ppr (IfaceRuleOut fn rule) = pprCoreRule (ppr fn) rule -instance Outputable name => Outputable (RuleBndr name) where +instance OutputableBndr name => Outputable (RuleBndr name) where ppr (RuleBndr name) = ppr name ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty \end{code} @@ -940,7 +871,27 @@ data DeprecDecl name = Deprecation name DeprecTxt SrcLoc type DeprecTxt = FastString -- reason/explanation for deprecation -instance Outputable name => Outputable (DeprecDecl name) where +instance OutputableBndr name => Outputable (DeprecDecl name) where ppr (Deprecation thing txt _) = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"] \end{code} + + +%************************************************************************ +%* * + External-core declarations +%* * +%************************************************************************ + +\begin{code} +data CoreDecl name -- a Core value binding (from 'external Core' input) + = CoreDecl name + (HsType name) + (UfExpr name) + SrcLoc + +instance OutputableBndr name => Outputable (CoreDecl name) where + ppr (CoreDecl var ty rhs loc) + = getPprStyle $ \ sty -> + hsep [ pprHsVar var, dcolon, ppr ty, ppr rhs ] +\end{code} diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot b/ghc/compiler/hsSyn/HsExpr.hi-boot index 2341419e06..ecc9528d9a 100644 --- a/ghc/compiler/hsSyn/HsExpr.hi-boot +++ b/ghc/compiler/hsSyn/HsExpr.hi-boot @@ -3,9 +3,9 @@ _exports_ HsExpr HsExpr pprExpr Match GRHSs pprFunBind pprPatBind ; _declarations_ 1 data HsExpr i p; -1 pprExpr _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ;; +1 pprExpr _:_ _forall_ [i] {Outputable.OutputableBndr i} => HsExpr.HsExpr i -> Outputable.SDoc ;; 1 data Match a b ; 1 data GRHSs a b ; -1 pprPatBind _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => p -> HsExpr.GRHSs i p -> Outputable.SDoc ;; -1 pprFunBind _:_ _forall_ [i p] {Outputable.Outputable i, Outputable.Outputable p} => i -> [HsExpr.Match i p] -> Outputable.SDoc ;; +1 pprPatBind _:_ _forall_ [i] {Outputable.OutputableBndr i} => HsPat.Pat i -> HsExpr.GRHSs i -> Outputable.SDoc ;; +1 pprFunBind _:_ _forall_ [i p] {Outputable.OutputableBndr i} => i -> [HsExpr.Match i] -> Outputable.SDoc ;; diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot-5 b/ghc/compiler/hsSyn/HsExpr.hi-boot-5 index bf952e3fdf..cc7018d177 100644 --- a/ghc/compiler/hsSyn/HsExpr.hi-boot-5 +++ b/ghc/compiler/hsSyn/HsExpr.hi-boot-5 @@ -1,12 +1,12 @@ __interface HsExpr 1 0 where __export HsExpr HsExpr pprExpr Match GRHSs pprPatBind pprFunBind ; -1 data HsExpr i p ; -1 pprExpr :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => HsExpr.HsExpr i p -> Outputable.SDoc ; +1 data HsExpr i ; +1 pprExpr :: __forall [i] {Outputable.OutputableBndr i} => HsExpr.HsExpr i -> Outputable.SDoc ; -1 data Match a b ; -1 data GRHSs a b ; +1 data Match a ; +1 data GRHSs a ; -1 pprPatBind :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => p -> HsExpr.GRHSs i p -> Outputable.SDoc ; -1 pprFunBind :: __forall [i p] {Outputable.Outputable i, Outputable.Outputable p} => i -> [HsExpr.Match i p] -> Outputable.SDoc ; +1 pprPatBind :: __forall [i] {Outputable.OutputableBndr i} => HsPat.Pat i -> HsExpr.GRHSs i -> Outputable.SDoc ; +1 pprFunBind :: __forall [i] {Outputable.OutputableBndr i} => i -> [HsExpr.Match i] -> Outputable.SDoc ; diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot-6 b/ghc/compiler/hsSyn/HsExpr.hi-boot-6 index fd32ceb5ed..73bbfdefb8 100644 --- a/ghc/compiler/hsSyn/HsExpr.hi-boot-6 +++ b/ghc/compiler/hsSyn/HsExpr.hi-boot-6 @@ -1,14 +1,14 @@ module HsExpr where -data HsExpr i p -data Match a b -data GRHSs a b +data HsExpr i +data Match a +data GRHSs a -pprExpr :: (Outputable.Outputable i, Outputable.Outputable p) => - HsExpr.HsExpr i p -> Outputable.SDoc +pprExpr :: (Outputable.OutputableBndr i) => + HsExpr.HsExpr i -> Outputable.SDoc -pprPatBind :: (Outputable.Outputable i, Outputable.Outputable p) => - p -> HsExpr.GRHSs i p -> Outputable.SDoc +pprPatBind :: (Outputable.OutputableBndr i) => + HsPat.Pat i -> HsExpr.GRHSs i -> Outputable.SDoc -pprFunBind :: (Outputable.Outputable i, Outputable.Outputable p) => - i -> [HsExpr.Match i p] -> Outputable.SDoc +pprFunBind :: (Outputable.OutputableBndr i) => + i -> [HsExpr.Match i] -> Outputable.SDoc diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 62a8a285c5..838fbe0fe7 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -9,20 +9,22 @@ module HsExpr where #include "HsVersions.h" -- friends: +import HsDecls ( HsDecl ) import HsBinds ( HsBinds(..), nullBinds ) +import HsPat ( Pat ) import HsLit ( HsLit, HsOverLit ) -import BasicTypes ( Fixity(..) ) import HsTypes ( HsType, PostTcType, SyntaxName ) -import HsImpExp ( isOperator ) +import HsImpExp ( isOperator, pprHsVar ) -- others: import ForeignCall ( Safety ) import PprType ( pprParendType ) -import Type ( Type ) -import Var ( TyVar ) +import Type ( Type ) +import Var ( TyVar, Id ) +import Name ( Name ) import DataCon ( DataCon ) import CStrings ( CLabelString, pprCLabelString ) -import BasicTypes ( IPName, Boxity, tupleParens ) +import BasicTypes ( IPName, Boxity, tupleParens, Fixity(..) ) import SrcLoc ( SrcLoc ) import Outputable import FastString @@ -35,15 +37,15 @@ import FastString %************************************************************************ \begin{code} -data HsExpr id pat +data HsExpr id = HsVar id -- variable | HsIPVar (IPName id) -- implicit parameter | HsOverLit HsOverLit -- Overloaded literals; eliminated by type checker | HsLit HsLit -- Simple (non-overloaded) literals - | HsLam (Match id pat) -- lambda - | HsApp (HsExpr id pat) -- application - (HsExpr id pat) + | HsLam (Match id) -- lambda + | HsApp (HsExpr id) -- application + (HsExpr id) -- Operator applications: -- NB Bracketed ops such as (+) come out as Vars. @@ -51,43 +53,43 @@ data HsExpr id pat -- NB We need an expr for the operator in an OpApp/Section since -- the typechecker may need to apply the operator to a few types. - | OpApp (HsExpr id pat) -- left operand - (HsExpr id pat) -- operator + | OpApp (HsExpr id) -- left operand + (HsExpr id) -- operator Fixity -- Renamer adds fixity; bottom until then - (HsExpr id pat) -- right operand + (HsExpr id) -- right operand -- We preserve prefix negation and parenthesis for the precedence parser. -- They are eventually removed by the type checker. - | NegApp (HsExpr id pat) -- negated expr + | NegApp (HsExpr id) -- negated expr SyntaxName -- Name of 'negate' (see RnEnv.lookupSyntaxName) - | HsPar (HsExpr id pat) -- parenthesised expr + | HsPar (HsExpr id) -- parenthesised expr - | SectionL (HsExpr id pat) -- operand - (HsExpr id pat) -- operator - | SectionR (HsExpr id pat) -- operator - (HsExpr id pat) -- operand + | SectionL (HsExpr id) -- operand + (HsExpr id) -- operator + | SectionR (HsExpr id) -- operator + (HsExpr id) -- operand - | HsCase (HsExpr id pat) - [Match id pat] + | HsCase (HsExpr id) + [Match id] SrcLoc - | HsIf (HsExpr id pat) -- predicate - (HsExpr id pat) -- then part - (HsExpr id pat) -- else part + | HsIf (HsExpr id) -- predicate + (HsExpr id) -- then part + (HsExpr id) -- else part SrcLoc - | HsLet (HsBinds id pat) -- let(rec) - (HsExpr id pat) + | HsLet (HsBinds id) -- let(rec) + (HsExpr id) - | HsWith (HsExpr id pat) -- implicit parameter binding - [(IPName id, HsExpr id pat)] + | HsWith (HsExpr id) -- implicit parameter binding + [(IPName id, HsExpr id)] Bool -- True <=> this was a 'with' binding -- (tmp, until 'with' is removed) | HsDo HsDoContext - [Stmt id pat] -- "do":one or more stmts + [Stmt id] -- "do":one or more stmts [id] -- Ids for [return,fail,>>=,>>] -- Brutal but simple -- Before type checking, used for rebindable syntax @@ -96,14 +98,14 @@ data HsExpr id pat | ExplicitList -- syntactic list PostTcType -- Gives type of components of list - [HsExpr id pat] + [HsExpr id] | ExplicitPArr -- syntactic parallel array: [:e1, ..., en:] PostTcType -- type of elements of the parallel array - [HsExpr id pat] + [HsExpr id] | ExplicitTuple -- tuple - [HsExpr id pat] + [HsExpr id] -- NB: Unit is ExplicitTuple [] -- for tuples, we can get the types -- direct from the components @@ -112,39 +114,39 @@ data HsExpr id pat -- Record construction | RecordCon id -- The constructor - (HsRecordBinds id pat) + (HsRecordBinds id) | RecordConOut DataCon - (HsExpr id pat) -- Data con Id applied to type args - (HsRecordBinds id pat) + (HsExpr id) -- Data con Id applied to type args + (HsRecordBinds id) -- Record update - | RecordUpd (HsExpr id pat) - (HsRecordBinds id pat) + | RecordUpd (HsExpr id) + (HsRecordBinds id) - | RecordUpdOut (HsExpr id pat) -- TRANSLATION + | RecordUpdOut (HsExpr id) -- TRANSLATION Type -- Type of *input* record Type -- Type of *result* record (may differ from -- type of input record) - (HsRecordBinds id pat) + (HsRecordBinds id) | ExprWithTySig -- signature binding - (HsExpr id pat) + (HsExpr id) (HsType id) | ArithSeqIn -- arithmetic sequence - (ArithSeqInfo id pat) + (ArithSeqInfo id) | ArithSeqOut - (HsExpr id pat) -- (typechecked, of course) - (ArithSeqInfo id pat) + (HsExpr id) -- (typechecked, of course) + (ArithSeqInfo id) | PArrSeqIn -- arith. sequence for parallel array - (ArithSeqInfo id pat) -- [:e1..e2:] or [:e1, e2..e3:] + (ArithSeqInfo id) -- [:e1..e2:] or [:e1, e2..e3:] | PArrSeqOut - (HsExpr id pat) -- (typechecked, of course) - (ArithSeqInfo id pat) + (HsExpr id) -- (typechecked, of course) + (ArithSeqInfo id) | HsCCall CLabelString -- call into the C world; string is - [HsExpr id pat] -- the C function; exprs are the + [HsExpr id] -- the C function; exprs are the -- arguments to pass. Safety -- True <=> might cause Haskell -- garbage-collection (must generate @@ -157,10 +159,21 @@ data HsExpr id pat -- until the typechecker gets ahold of it | HsSCC FastString -- "set cost centre" (_scc_) annotation - (HsExpr id pat) -- expr whose cost is to be measured - + (HsExpr id) -- expr whose cost is to be measured + + -- MetaHaskell Extensions + | HsBracket (HsBracket id) + + | HsBracketOut (HsBracket Name) -- Output of the type checker is the *original* + [PendingSplice] -- renamed expression, plus *typechecked* splices + -- to be pasted back in by the desugarer + + | HsSplice id (HsExpr id ) -- $z or $(f 4) + -- The id is just a unique name to + -- identify this splice point \end{code} + These constructors only appear temporarily in the parser. The renamer translates them into the Right Thing. @@ -168,9 +181,9 @@ The renamer translates them into the Right Thing. | EWildPat -- wildcard | EAsPat id -- as pattern - (HsExpr id pat) + (HsExpr id) - | ELazyPat (HsExpr id pat) -- ~ pattern + | ELazyPat (HsExpr id) -- ~ pattern | HsType (HsType id) -- Explicit type argument; e.g f {| Int |} x y \end{code} @@ -180,25 +193,24 @@ Everything from here on appears only in typechecker output. \begin{code} | TyLam -- TRANSLATION [TyVar] - (HsExpr id pat) + (HsExpr id) | TyApp -- TRANSLATION - (HsExpr id pat) -- generated by Spec + (HsExpr id) -- generated by Spec [Type] -- DictLam and DictApp are "inverses" | DictLam [id] - (HsExpr id pat) + (HsExpr id) | DictApp - (HsExpr id pat) + (HsExpr id) [id] -type HsRecordBinds id pat - = [(id, HsExpr id pat, Bool)] - -- True <=> source code used "punning", - -- i.e. {op1, op2} rather than {op1=e1, op2=e2} +type PendingSplice = (Name, HsExpr Id) -- Typechecked splices, waiting to be + -- pasted back in by the desugarer \end{code} + A @Dictionary@, unless of length 0 or 1, becomes a tuple. A @ClassDictLam dictvars methods expr@ is, therefore: \begin{verbatim} @@ -206,23 +218,17 @@ A @Dictionary@, unless of length 0 or 1, becomes a tuple. A \end{verbatim} \begin{code} -instance (Outputable id, Outputable pat) => - Outputable (HsExpr id pat) where +instance OutputableBndr id => Outputable (HsExpr id) where ppr expr = pprExpr expr \end{code} \begin{code} -pprExpr :: (Outputable id, Outputable pat) - => HsExpr id pat -> SDoc +pprExpr :: OutputableBndr id => HsExpr id -> SDoc -pprExpr e = pprDeeper (ppr_expr e) +pprExpr e = pprDeeper (ppr_expr e) pprBinds b = pprDeeper (ppr b) -ppr_expr (HsVar v) - -- Put it in parens if it's an operator - | isOperator v = parens (ppr v) - | otherwise = ppr v - +ppr_expr (HsVar v) = pprHsVar v ppr_expr (HsIPVar v) = ppr v ppr_expr (HsLit lit) = ppr lit ppr_expr (HsOverLit lit) = ppr lit @@ -251,8 +257,9 @@ ppr_expr (OpApp e1 op fixity e2) pp_infixly v = sep [pp_e1, hsep [pp_v_op, pp_e2]] where - pp_v_op | isOperator v = ppr v - | otherwise = char '`' <> ppr v <> char '`' + ppr_v = ppr v + pp_v_op | isOperator ppr_v = ppr_v + | otherwise = char '`' <> ppr_v <> char '`' -- Put it in backquotes if it's not an operator already ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e @@ -311,7 +318,7 @@ ppr_expr (ExplicitList _ exprs) = brackets (fsep (punctuate comma (map ppr_expr exprs))) ppr_expr (ExplicitPArr _ exprs) - = pabrackets (fsep (punctuate comma (map ppr_expr exprs))) + = pa_brackets (fsep (punctuate comma (map ppr_expr exprs))) ppr_expr (ExplicitTuple exprs boxity) = tupleParens boxity (sep (punctuate comma (map ppr_expr exprs))) @@ -336,9 +343,9 @@ ppr_expr (ArithSeqOut expr info) = brackets (ppr info) ppr_expr (PArrSeqIn info) - = pabrackets (ppr info) + = pa_brackets (ppr info) ppr_expr (PArrSeqOut expr info) - = pabrackets (ppr info) + = pa_brackets (ppr info) ppr_expr EWildPat = char '_' ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e @@ -354,7 +361,9 @@ ppr_expr (HsSCC lbl expr) = sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ] ppr_expr (TyLam tyvars expr) - = hang (hsep [ptext SLIT("/\\"), interppSP tyvars, ptext SLIT("->")]) + = hang (hsep [ptext SLIT("/\\"), + hsep (map (pprBndr LambdaBind) tyvars), + ptext SLIT("->")]) 4 (ppr_expr expr) ppr_expr (TyApp expr [ty]) @@ -365,7 +374,9 @@ ppr_expr (TyApp expr tys) 4 (brackets (interpp'SP tys)) ppr_expr (DictLam dictvars expr) - = hang (hsep [ptext SLIT("\\{-dict-}"), interppSP dictvars, ptext SLIT("->")]) + = hang (hsep [ptext SLIT("\\{-dict-}"), + hsep (map (pprBndr LambdaBind) dictvars), + ptext SLIT("->")]) 4 (ppr_expr expr) ppr_expr (DictApp expr [dname]) @@ -377,16 +388,19 @@ ppr_expr (DictApp expr dnames) ppr_expr (HsType id) = ppr id +ppr_expr (HsSplice n e) = char '$' <> brackets (ppr n) <> pprParendExpr e +ppr_expr (HsBracket b) = pprHsBracket b +ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("where") <+> ppr ps + -- add parallel array brackets around a document -- -pabrackets :: SDoc -> SDoc -pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") +pa_brackets :: SDoc -> SDoc +pa_brackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \end{code} Parenthesize unless very simple: \begin{code} -pprParendExpr :: (Outputable id, Outputable pat) - => HsExpr id pat -> SDoc +pprParendExpr :: OutputableBndr id => HsExpr id -> SDoc pprParendExpr expr = let @@ -413,28 +427,25 @@ pprParendExpr expr %************************************************************************ \begin{code} -pp_rbinds :: (Outputable id, Outputable pat) - => SDoc - -> HsRecordBinds id pat -> SDoc +type HsRecordBinds id = [(id, HsExpr id)] + +recBindFields :: HsRecordBinds id -> [id] +recBindFields rbinds = [field | (field,_) <- rbinds] + +pp_rbinds :: OutputableBndr id => SDoc -> HsRecordBinds id -> SDoc pp_rbinds thing rbinds = hang thing 4 (braces (sep (punctuate comma (map (pp_rbind) rbinds)))) where - pp_rbind (v, e, pun_flag) - = getPprStyle $ \ sty -> - if pun_flag && userStyle sty then - ppr v - else - hsep [ppr v, char '=', ppr e] + pp_rbind (v, e) = hsep [pprBndr LetBind v, char '=', ppr e] \end{code} \begin{code} -pp_ipbinds :: (Outputable id, Outputable pat) - => [(IPName id, HsExpr id pat)] -> SDoc +pp_ipbinds :: OutputableBndr id => [(IPName id, HsExpr id)] -> SDoc pp_ipbinds pairs = hsep (punctuate semi (map pp_item pairs)) where - pp_item (id,rhs) = ppr id <+> equals <+> ppr_expr rhs + pp_item (id,rhs) = pprBndr LetBind id <+> equals <+> ppr_expr rhs \end{code} @@ -459,31 +470,29 @@ a function defined by pattern matching must have the same number of patterns in each equation. \begin{code} -data Match id pat +data Match id = Match - [pat] -- The patterns + [Pat id] -- The patterns (Maybe (HsType id)) -- A type signature for the result of the match -- Nothing after typechecking - (GRHSs id pat) + (GRHSs id) -- GRHSs are used both for pattern bindings and for Matches -data GRHSs id pat - = GRHSs [GRHS id pat] -- Guarded RHSs - (HsBinds id pat) -- The where clause +data GRHSs id + = GRHSs [GRHS id] -- Guarded RHSs + (HsBinds id) -- The where clause PostTcType -- Type of RHS (after type checking) -data GRHS id pat - = GRHS [Stmt id pat] -- The RHS is the final ResultStmt - -- I considered using a RetunStmt, but - -- it printed 'wrong' in error messages +data GRHS id + = GRHS [Stmt id] -- The RHS is the final ResultStmt SrcLoc -mkSimpleMatch :: [pat] -> HsExpr id pat -> Type -> SrcLoc -> Match id pat +mkSimpleMatch :: [Pat id] -> HsExpr id -> Type -> SrcLoc -> Match id mkSimpleMatch pats rhs rhs_ty locn = Match pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds rhs_ty) -unguardedRHS :: HsExpr id pat -> SrcLoc -> [GRHS id pat] +unguardedRHS :: HsExpr id -> SrcLoc -> [GRHS id] unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc] \end{code} @@ -492,44 +501,41 @@ source-location gotten from the GRHS inside. THis is something of a nuisance, but no more. \begin{code} -getMatchLoc :: Match id pat -> SrcLoc +getMatchLoc :: Match id -> SrcLoc getMatchLoc (Match _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc \end{code} We know the list must have at least one @Match@ in it. \begin{code} -pprMatches :: (Outputable id, Outputable pat) - => HsMatchContext id -> [Match id pat] -> SDoc +pprMatches :: (OutputableBndr id) => HsMatchContext id -> [Match id] -> SDoc pprMatches ctxt matches = vcat (map (pprMatch ctxt) matches) -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (Outputable id, Outputable pat) - => id -> [Match id pat] -> SDoc +pprFunBind :: (OutputableBndr id) => id -> [Match id] -> SDoc pprFunBind fun matches = pprMatches (FunRhs fun) matches -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprPatBind :: (Outputable id, Outputable pat) - => pat -> GRHSs id pat -> SDoc +pprPatBind :: (OutputableBndr id) + => Pat id -> GRHSs id -> SDoc pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)] -pprMatch :: (Outputable id, Outputable pat) - => HsMatchContext id -> Match id pat -> SDoc +pprMatch :: OutputableBndr id => HsMatchContext id -> Match id -> SDoc pprMatch ctxt (Match pats maybe_ty grhss) = pp_name ctxt <+> sep [sep (map ppr pats), ppr_maybe_ty, nest 2 (pprGRHSs ctxt grhss)] where - pp_name (FunRhs fun) = ppr fun + pp_name (FunRhs fun) = ppr fun -- Not pprBndr; the AbsBinds will + -- have printed the signature pp_name other = empty ppr_maybe_ty = case maybe_ty of Just ty -> dcolon <+> ppr ty Nothing -> empty -pprGRHSs :: (Outputable id, Outputable pat) - => HsMatchContext id -> GRHSs id pat -> SDoc +pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc pprGRHSs ctxt (GRHSs grhss binds ty) = vcat (map (pprGRHS ctxt) grhss) $$ @@ -537,8 +543,7 @@ pprGRHSs ctxt (GRHSs grhss binds ty) else text "where" $$ nest 4 (pprDeeper (ppr binds))) -pprGRHS :: (Outputable id, Outputable pat) - => HsMatchContext id -> GRHS id pat -> SDoc +pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc pprGRHS ctxt (GRHS [ResultStmt expr _] locn) = pp_rhs ctxt expr @@ -561,14 +566,14 @@ pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) %************************************************************************ \begin{code} -data Stmt id pat - = BindStmt pat (HsExpr id pat) SrcLoc - | LetStmt (HsBinds id pat) - | ResultStmt (HsExpr id pat) SrcLoc -- See notes that follow - | ExprStmt (HsExpr id pat) PostTcType SrcLoc -- See notes that follow +data Stmt id + = BindStmt (Pat id) (HsExpr id) SrcLoc + | LetStmt (HsBinds id) + | ResultStmt (HsExpr id) SrcLoc -- See notes that follow + | ExprStmt (HsExpr id) PostTcType SrcLoc -- See notes that follow -- The type is the *element type* of the expression - | ParStmt [[Stmt id pat]] -- List comp only: parallel set of quals - | ParStmtOut [([id], [Stmt id pat])] -- PLC after renaming; the ids are the binders + | ParStmt [[Stmt id]] -- List comp only: parallel set of quals + | ParStmtOut [([id], [Stmt id])] -- PLC after renaming; the ids are the binders -- bound by the stmts \end{code} @@ -610,14 +615,13 @@ depends on the context. Consider the following contexts: Array comprehensions are handled like list comprehensions -=chak \begin{code} -consLetStmt :: HsBinds id pat -> [Stmt id pat] -> [Stmt id pat] +consLetStmt :: HsBinds id -> [Stmt id] -> [Stmt id] consLetStmt EmptyBinds stmts = stmts consLetStmt binds stmts = LetStmt binds : stmts \end{code} \begin{code} -instance (Outputable id, Outputable pat) => - Outputable (Stmt id pat) where +instance OutputableBndr id => Outputable (Stmt id) where ppr stmt = pprStmt stmt pprStmt (BindStmt pat expr _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr] @@ -629,14 +633,12 @@ pprStmt (ParStmt stmtss) pprStmt (ParStmtOut stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) -pprDo :: (Outputable id, Outputable pat) - => HsDoContext -> [Stmt id pat] -> SDoc +pprDo :: OutputableBndr id => HsDoContext -> [Stmt id] -> SDoc pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts)) pprDo ListComp stmts = pprComp brackets stmts -pprDo PArrComp stmts = pprComp pabrackets stmts +pprDo PArrComp stmts = pprComp pa_brackets stmts -pprComp :: (Outputable id, Outputable pat) - => (SDoc -> SDoc) -> [Stmt id pat] -> SDoc +pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [Stmt id] -> SDoc pprComp brack stmts = brack $ hang (pprExpr expr <+> char '|') 4 (interpp'SP quals) @@ -645,6 +647,32 @@ pprComp brack stmts = brack $ quals = init stmts -- be an ResultStmt \end{code} +%************************************************************************ +%* * + Template Haskell quotation brackets +%* * +%************************************************************************ + +\begin{code} +data HsBracket id = ExpBr (HsExpr id) + | PatBr (Pat id) + | DecBr [HsDecl id] + | TypBr (HsType id) + +instance OutputableBndr id => Outputable (HsBracket id) where + ppr = pprHsBracket + + +pprHsBracket (ExpBr e) = thBrackets empty (ppr e) +pprHsBracket (PatBr p) = thBrackets (char 'p') (ppr p) +pprHsBracket (DecBr d) = thBrackets (char 'd') (vcat (map ppr d)) +pprHsBracket (TypBr t) = thBrackets (char 't') (ppr t) + + +thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+> + pp_body <+> ptext SLIT("|]") +\end{code} + %************************************************************************ %* * \subsection{Enumerations and list comprehensions} @@ -652,20 +680,19 @@ pprComp brack stmts = brack $ %************************************************************************ \begin{code} -data ArithSeqInfo id pat - = From (HsExpr id pat) - | FromThen (HsExpr id pat) - (HsExpr id pat) - | FromTo (HsExpr id pat) - (HsExpr id pat) - | FromThenTo (HsExpr id pat) - (HsExpr id pat) - (HsExpr id pat) +data ArithSeqInfo id + = From (HsExpr id) + | FromThen (HsExpr id) + (HsExpr id) + | FromTo (HsExpr id) + (HsExpr id) + | FromThenTo (HsExpr id) + (HsExpr id) + (HsExpr id) \end{code} \begin{code} -instance (Outputable id, Outputable pat) => - Outputable (ArithSeqInfo id pat) where +instance OutputableBndr id => Outputable (ArithSeqInfo id) where ppr (From e1) = hcat [ppr e1, pp_dotdot] ppr (FromThen e1 e2) = hcat [ppr e1, comma, space, ppr e2, pp_dotdot] ppr (FromTo e1 e3) = hcat [ppr e1, pp_dotdot, ppr e3] diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs index b33fb2bcd7..52ce08bb9e 100644 --- a/ghc/compiler/hsSyn/HsImpExp.lhs +++ b/ghc/compiler/hsSyn/HsImpExp.lhs @@ -8,11 +8,11 @@ module HsImpExp where #include "HsVersions.h" -import Name ( isLexSym ) -import Module ( ModuleName, WhereFrom ) +import Module ( ModuleName ) import Outputable import FastString import SrcLoc ( SrcLoc ) +import Char ( isAlpha ) \end{code} %************************************************************************ @@ -25,7 +25,7 @@ One per \tr{import} declaration in a module. \begin{code} data ImportDecl name = ImportDecl ModuleName -- module name - WhereFrom + Bool -- True <=> {-# SOURCE #-} import Bool -- True => qualified (Maybe ModuleName) -- as Module (Maybe (Bool, [IE name])) -- (True => hiding, names) @@ -35,7 +35,7 @@ data ImportDecl name \begin{code} instance (Outputable name) => Outputable (ImportDecl name) where ppr (ImportDecl mod from qual as spec _) - = hang (hsep [ptext SLIT("import"), ppr from, + = hang (hsep [ptext SLIT("import"), ppr_imp from, pp_qual qual, ppr mod, pp_as as]) 4 (pp_spec spec) where @@ -45,6 +45,9 @@ instance (Outputable name) => Outputable (ImportDecl name) where pp_as Nothing = empty pp_as (Just a) = ptext SLIT("as ") <+> ppr a + ppr_imp True = ptext SLIT("{-# SOURCE #-}") + ppr_imp False = empty + pp_spec Nothing = empty pp_spec (Just (False, spec)) = parens (interpp'SP spec) @@ -86,23 +89,33 @@ ieNames (IEModuleContents _ ) = [] \begin{code} instance (Outputable name) => Outputable (IE name) where - ppr (IEVar var) = ppr_var var + ppr (IEVar var) = pprHsVar var ppr (IEThingAbs thing) = ppr thing ppr (IEThingAll thing) = hcat [ppr thing, text "(..)"] ppr (IEThingWith thing withs) - = ppr thing <> parens (fsep (punctuate comma (map ppr_var withs))) + = ppr thing <> parens (fsep (punctuate comma (map pprHsVar withs))) ppr (IEModuleContents mod) = ptext SLIT("module") <+> ppr mod - -ppr_var v | isOperator v = parens (ppr v) - | otherwise = ppr v \end{code} \begin{code} -isOperator :: Outputable a => a -> Bool -isOperator v = isLexSym (mkFastString (showSDocUnqual (ppr v))) - -- We use (showSDoc (ppr v)), rather than isSymOcc (getOccName v) simply so - -- that we don't need NamedThing in the context of all these functions. - -- Gruesome, but simple. +pprHsVar :: Outputable name => name -> SDoc +pprHsVar v | isOperator ppr_v = parens ppr_v + | otherwise = ppr_v + where + ppr_v = ppr v + +isOperator :: SDoc -> Bool +isOperator ppr_v + = case showSDocUnqual ppr_v of + ('(':s) -> False -- (), (,) etc + ('[':s) -> False -- [] + ('$':c:s) -> not (isAlpha c) -- Don't treat $d as an operator + (':':c:s) -> not (isAlpha c) -- Don't treat :T as an operator + (c:s) -> not (isAlpha c) -- Starts with non-alpha + other -> False + -- We use (showSDoc (ppr v)), rather than isSymOcc (getOccName v) simply so + -- that we don't need NamedThing in the context of all these functions. + -- Gruesome, but simple. \end{code} diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 7a070083ab..71aba6b71f 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -5,190 +5,194 @@ \begin{code} module HsPat ( - InPat(..), - OutPat(..), + Pat(..), InPat, OutPat, + + HsConDetails(..), hsConArgs, + + mkPrefixConPat, mkCharLitPat, mkNilPat, - irrefutablePat, irrefutablePats, failureFreePat, isWildPat, patsAreAllCons, isConPat, isSigPat, patsAreAllLits, isLitPat, - collectPatBinders, collectOutPatBinders, collectPatsBinders, + collectPatBinders, collectPatsBinders, collectSigTysFromPat, collectSigTysFromPats ) where #include "HsVersions.h" --- friends: -import HsLit ( HsLit, HsOverLit ) -import HsExpr ( HsExpr ) -import HsTypes ( HsType, SyntaxName ) -import BasicTypes ( Fixity, Boxity, tupleParens ) +import {-# SOURCE #-} HsExpr ( HsExpr ) +-- friends: +import HsLit ( HsLit(HsCharPrim), HsOverLit ) +import HsTypes ( HsType, SyntaxName, PostTcType ) +import BasicTypes ( Boxity, tupleParens ) -- others: -import Name ( Name ) -import Var ( Id, TyVar ) +import TysWiredIn ( nilDataCon, charDataCon, charTy ) +import Var ( TyVar ) import DataCon ( DataCon, dataConTyCon ) -import Name ( isDataSymOcc, getOccName, NamedThing ) import Maybes ( maybeToBool ) import Outputable import TyCon ( maybeTyConSingleCon ) import Type ( Type ) \end{code} -Patterns come in distinct before- and after-typechecking flavo(u)rs. + \begin{code} -data InPat name - = WildPatIn -- wild card - | VarPatIn name -- variable - | LitPatIn HsLit -- literal - | LazyPatIn (InPat name) -- lazy pattern - | AsPatIn name -- as pattern - (InPat name) - | SigPatIn (InPat name) - (HsType name) - | ConPatIn name -- constructed type - [InPat name] - | ConOpPatIn (InPat name) - name - Fixity -- c.f. OpApp in HsExpr - (InPat name) +type InPat id = Pat id -- No 'Out' constructors +type OutPat id = Pat id -- No 'In' constructors + +data Pat id + = ------------ Simple patterns --------------- + WildPat PostTcType -- Wild card + | VarPat id -- Variable + | LazyPat (Pat id) -- Lazy pattern + | AsPat id (Pat id) -- As pattern + | ParPat (Pat id) -- Parenthesised pattern + + ------------ Lists, tuples, arrays --------------- + | ListPat [Pat id] -- Syntactic list + PostTcType -- The type of the elements + + | TuplePat [Pat id] -- Tuple + Boxity -- UnitPat is TuplePat [] + + | PArrPat [Pat id] -- Syntactic parallel array + PostTcType -- The type of the elements + + ------------ Constructor patterns --------------- + | ConPatIn id + (HsConDetails id (Pat id)) + + | ConPatOut DataCon + (HsConDetails id (Pat id)) + Type -- The type of the pattern + [TyVar] -- Existentially bound type variables + [id] -- Ditto dictionaries + + ------------ Literal and n+k patterns --------------- + | LitPat HsLit -- Used for *non-overloaded* literal patterns: + -- Int#, Char#, Int, Char, String, etc. | NPatIn HsOverLit -- Always positive (Maybe SyntaxName) -- Just (Name of 'negate') for negative -- patterns, Nothing otherwise - | NPlusKPatIn name -- n+k pattern + | NPatOut HsLit -- Used for literal patterns where there's an equality function to call + -- The literal is retained so that the desugarer can readily identify + -- equations with identical literal-patterns + -- Always HsInteger, HsRat or HsString. + -- Always HsInteger, HsRat or HsString. + -- *Unlike* NPatIn, for negative literals, the + -- literal is acutally negative! + Type -- Type of pattern, t + (HsExpr id) -- Of type t -> Bool; detects match + + | NPlusKPatIn id -- n+k pattern HsOverLit -- It'll always be an HsIntegral SyntaxName -- Name of '-' (see RnEnv.lookupSyntaxName) - -- We preserve prefix negation and parenthesis for the precedence parser. - - | ParPatIn (InPat name) -- parenthesised pattern - - | ListPatIn [InPat name] -- syntactic list - -- must have >= 1 elements - | PArrPatIn [InPat name] -- syntactic parallel array - -- must have >= 1 elements - | TuplePatIn [InPat name] Boxity -- tuple (boxed?) + | NPlusKPatOut id + Integer + (HsExpr id) -- Of type t -> Bool; detects match + (HsExpr id) -- Of type t -> t; subtracts k - | RecPatIn name -- record - [(name, InPat name, Bool)] -- True <=> source used punning --- Generics - | TypePatIn (HsType name) -- Type pattern for generic definitions + ------------ Generics --------------- + | TypePat (HsType id) -- Type pattern for generic definitions -- e.g f{| a+b |} = ... - -- These show up only in class - -- declarations, + -- These show up only in class declarations, -- and should be a top-level pattern --- /Generics - -data OutPat id - = WildPat Type -- wild card - | VarPat id -- variable (type is in the Id) - | LazyPat (OutPat id) -- lazy pattern - | AsPat id -- as pattern - (OutPat id) - - | SigPat (OutPat id) -- Pattern p - Type -- Type, t, of the whole pattern - (HsExpr id (OutPat id)) - -- Coercion function, - -- of type t -> typeof(p) - - | ListPat -- Syntactic list - Type -- The type of the elements - [OutPat id] - | PArrPat -- Syntactic parallel array - Type -- The type of the elements - [OutPat id] - - | TuplePat [OutPat id] -- Tuple - Boxity - -- UnitPat is TuplePat [] - - | ConPat DataCon - Type -- the type of the pattern - [TyVar] -- Existentially bound type variables - [id] -- Ditto dictionaries - [OutPat id] - - -- ConOpPats are only used on the input side - - | RecPat DataCon -- Record constructor - Type -- The type of the pattern - [TyVar] -- Existentially bound type variables - [id] -- Ditto dictionaries - [(Id, OutPat id, Bool)] -- True <=> source used punning - - | LitPat -- Used for *non-overloaded* literal patterns: - -- Int#, Char#, Int, Char, String, etc. - HsLit - Type -- Type of pattern - - | NPat -- Used for literal patterns where there's an equality function to call - HsLit -- The literal is retained so that - -- the desugarer can readily identify - -- equations with identical literal-patterns - -- Always HsInteger, HsRat or HsString. - -- *Unlike* NPatIn, for negative literals, the - -- literal is acutally negative! - Type -- Type of pattern, t - (HsExpr id (OutPat id)) -- Of type t -> Bool; detects match - - | NPlusKPat id - Integer - Type -- Type of pattern, t - (HsExpr id (OutPat id)) -- Of type t -> Bool; detects match - (HsExpr id (OutPat id)) -- Of type t -> t; subtracts k + ------------ Pattern type signatures --------------- + | SigPatIn (Pat id) -- Pattern with a type signature + (HsType id) + | SigPatOut (Pat id) -- Pattern p + Type -- Type, t, of the whole pattern + (HsExpr id) -- Coercion function, + -- of type t -> typeof(p) + + ------------ Dictionary patterns (translation only) --------------- | DictPat -- Used when destructing Dictionaries with an explicit case [id] -- superclass dicts [id] -- methods \end{code} -Now name in Inpat is not need to be in NAmedThing to be Outputable. -Needed by ../deSugar/Check.lhs +HsConDetails is use both for patterns and for data type declarations + +\begin{code} +data HsConDetails id arg + = PrefixCon [arg] -- C p1 p2 p3 + | RecCon [(id, arg)] -- C { x = p1, y = p2 } + | InfixCon arg arg -- p1 `C` p2 + +hsConArgs :: HsConDetails id arg -> [arg] +hsConArgs (PrefixCon ps) = ps +hsConArgs (RecCon fs) = map snd fs +hsConArgs (InfixCon p1 p2) = [p1,p2] +\end{code} + -JJQC-2-12-97 +%************************************************************************ +%* * +%* Printing patterns +%* * +%************************************************************************ \begin{code} -instance (Outputable name) => Outputable (InPat name) where - ppr = pprInPat - -pprInPat :: (Outputable name) => InPat name -> SDoc - -pprInPat (WildPatIn) = char '_' -pprInPat (VarPatIn var) = ppr var -pprInPat (LitPatIn s) = ppr s -pprInPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty -pprInPat (LazyPatIn pat) = char '~' <> ppr pat -pprInPat (AsPatIn name pat) = parens (hcat [ppr name, char '@', ppr pat]) -pprInPat (ParPatIn pat) = parens (pprInPat pat) -pprInPat (ListPatIn pats) = brackets (interpp'SP pats) -pprInPat (PArrPatIn pats) = pabrackets (interpp'SP pats) -pprInPat (TuplePatIn pats bx) = tupleParens bx (interpp'SP pats) -pprInPat (NPlusKPatIn n k _) = parens (hcat [ppr n, char '+', ppr k]) -pprInPat (NPatIn l _) = ppr l - -pprInPat (ConPatIn c pats) - | null pats = ppr c - | otherwise = hsep [ppr c, interppSP pats] -- inner ParPats supply the necessary parens. - -pprInPat (ConOpPatIn pat1 op fixity pat2) - = hsep [ppr pat1, ppr op, ppr pat2] -- ParPats put in parens +instance (OutputableBndr name) => Outputable (Pat name) where + ppr = pprPat + +pprPat :: (OutputableBndr name) => Pat name -> SDoc + +pprPat (VarPat var) -- Print with type info if -dppr-debug is on + = getPprStyle $ \ sty -> + if debugStyle sty then + parens (pprBndr LambdaBind var) -- Could pass the site to pprPat + -- but is it worth it? + else + ppr var +pprPat (WildPat _) = char '_' +pprPat (LazyPat pat) = char '~' <> ppr pat +pprPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat]) +pprPat (ParPat pat) = parens (pprPat pat) + +pprPat (ListPat pats _) = brackets (interpp'SP pats) +pprPat (PArrPat pats _) = pabrackets (interpp'SP pats) +pprPat (TuplePat pats bx) = tupleParens bx (interpp'SP pats) + +pprPat (ConPatIn c details) = pprConPat c details +pprPat (ConPatOut c details _ _ _) = pprConPat c details + +pprPat (LitPat s) = ppr s +pprPat (NPatIn l _) = ppr l +pprPat (NPatOut l _ _) = ppr l +pprPat (NPlusKPatIn n k _) = hcat [ppr n, char '+', ppr k] +pprPat (NPlusKPatOut n k _ _) = hcat [ppr n, char '+', integer k] + +pprPat (TypePat ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}") + +pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty +pprPat (SigPatOut pat ty _) = ppr pat <+> dcolon <+> ppr ty + +pprPat (DictPat dicts methods) + = parens (sep [ptext SLIT("{-dict-}"), + brackets (interpp'SP dicts), + brackets (interpp'SP methods)]) + + + +pprConPat con (PrefixCon pats) = ppr con <+> interppSP pats -- inner ParPats supply the necessary parens. +pprConPat con (InfixCon pat1 pat2) = hsep [ppr pat1, ppr con, ppr pat2] -- ParPats put in parens -- ToDo: use pprSym to print op (but this involves fiddling various -- contexts & I'm lazy...); *PatIns are *rarely* printed anyway... (WDP) - -pprInPat (RecPatIn con rpats) - = hsep [ppr con, braces (hsep (punctuate comma (map (pp_rpat) rpats)))] +pprConPat con (RecCon rpats) + = ppr con <+> braces (hsep (punctuate comma (map (pp_rpat) rpats))) where - pp_rpat (v, _, True) = ppr v - pp_rpat (v, p, _) = hsep [ppr v, char '=', ppr p] + pp_rpat (v, p) = hsep [ppr v, char '=', ppr p] -pprInPat (TypePatIn ty) = ptext SLIT("{|") <> ppr ty <> ptext SLIT("|}") -- add parallel array brackets around a document -- @@ -196,61 +200,32 @@ pabrackets :: SDoc -> SDoc pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \end{code} -\begin{code} -instance (NamedThing id, Outputable id) => Outputable (OutPat id) where - ppr = pprOutPat -\end{code} - -\begin{code} -pprOutPat (WildPat ty) = char '_' -pprOutPat (VarPat var) = ppr var -pprOutPat (LazyPat pat) = hcat [char '~', ppr pat] -pprOutPat (AsPat name pat) - = parens (hcat [ppr name, char '@', ppr pat]) - -pprOutPat (SigPat pat ty _) = ppr pat <+> dcolon <+> ppr ty - -pprOutPat (ConPat name ty [] [] []) - = ppr name --- Kludge to get infix constructors to come out right --- when ppr'ing desugar warnings. -pprOutPat (ConPat name ty tyvars dicts pats) - = getPprStyle $ \ sty -> - parens $ - case pats of - [p1,p2] - | userStyle sty && isDataSymOcc (getOccName name) -> - hsep [ppr p1, ppr name, ppr p2] - _ -> hsep [ppr name, interppSP tyvars, interppSP dicts, interppSP pats] - -pprOutPat (ListPat ty pats) = brackets (interpp'SP pats) -pprOutPat (PArrPat ty pats) = pabrackets (interpp'SP pats) -pprOutPat (TuplePat pats boxity) = tupleParens boxity (interpp'SP pats) - -pprOutPat (RecPat con ty tvs dicts rpats) - = hsep [ppr con, interppSP tvs, interppSP dicts, braces (hsep (punctuate comma (map (pp_rpat) rpats)))] - where - pp_rpat (v, _, True) = ppr v - pp_rpat (v, p, _) = hsep [ppr v, char '=', ppr p] +%************************************************************************ +%* * +%* Building patterns +%* * +%************************************************************************ -pprOutPat (LitPat l ty) = ppr l -- ToDo: print more -pprOutPat (NPat l ty e) = ppr l -- ToDo: print more -pprOutPat (NPlusKPat n k ty e1 e2) -- ToDo: print more - = parens (hcat [ppr n, char '+', integer k]) +\begin{code} +mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id +-- Make a vanilla Prefix constructor pattern +mkPrefixConPat dc pats ty = ConPatOut dc (PrefixCon pats) ty [] [] -pprOutPat (DictPat dicts methods) - = parens (sep [ptext SLIT("{-dict-}"), - brackets (interpp'SP dicts), - brackets (interpp'SP methods)]) +mkNilPat :: Type -> OutPat id +mkNilPat ty = mkPrefixConPat nilDataCon [] ty +mkCharLitPat :: Int -> OutPat id +mkCharLitPat c = mkPrefixConPat charDataCon [LitPat (HsCharPrim c)] charTy \end{code} + %************************************************************************ %* * -%* predicates for checking things about pattern-lists in EquationInfo * +%* Predicates for checking things about pattern-lists in EquationInfo * %* * %************************************************************************ + \subsection[Pat-list-predicates]{Look for interesting things in patterns} Unlike in the Wadler chapter, where patterns are either ``variables'' @@ -275,30 +250,30 @@ patterns are treated specially, of course. The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. \begin{code} -irrefutablePats :: [OutPat id] -> Bool -irrefutablePats pat_list = all irrefutablePat pat_list - -irrefutablePat (AsPat _ pat) = irrefutablePat pat -irrefutablePat (WildPat _) = True -irrefutablePat (VarPat _) = True -irrefutablePat (LazyPat _) = True -irrefutablePat (DictPat ds ms) = (length ds + length ms) <= 1 -irrefutablePat other = False - failureFreePat :: OutPat id -> Bool failureFreePat (WildPat _) = True failureFreePat (VarPat _) = True failureFreePat (LazyPat _) = True +failureFreePat (ParPat _) = True failureFreePat (AsPat _ pat) = failureFreePat pat -failureFreePat (ConPat con tys _ _ pats) = only_con con && all failureFreePat pats -failureFreePat (RecPat con _ _ _ fields) = only_con con && and [ failureFreePat pat | (_,pat,_) <- fields ] + failureFreePat (ListPat _ _) = False failureFreePat (PArrPat _ _) = False failureFreePat (TuplePat pats _) = all failureFreePat pats + +failureFreePat (ConPatOut con ps _ _ _) = only_con con && failure_free_con ps + +failureFreePat (SigPatOut p _ _) = failureFreePat p + failureFreePat (DictPat _ _) = True + failureFreePat other_pat = False -- Literals, NPat +failure_free_con (PrefixCon pats) = all failureFreePat pats +failure_free_con (InfixCon p1 p2) = failureFreePat p1 && failureFreePat p2 +failure_free_con (RecCon fs) = all (failureFreePat . snd) fs + only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con)) \end{code} @@ -306,82 +281,78 @@ only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con)) isWildPat (WildPat _) = True isWildPat other = False -patsAreAllCons :: [OutPat id] -> Bool +patsAreAllCons :: [Pat id] -> Bool patsAreAllCons pat_list = all isConPat pat_list isConPat (AsPat _ pat) = isConPat pat -isConPat (ConPat _ _ _ _ _) = True +isConPat (ConPatIn _ _) = True +isConPat (ConPatOut _ _ _ _ _) = True isConPat (ListPat _ _) = True isConPat (PArrPat _ _) = True isConPat (TuplePat _ _) = True -isConPat (RecPat _ _ _ _ _) = True isConPat (DictPat ds ms) = (length ds + length ms) > 1 isConPat other = False -isSigPat (SigPat _ _ _) = True -isSigPat other = False +isSigPat (SigPatIn _ _) = True +isSigPat (SigPatOut _ _ _) = True +isSigPat other = False -patsAreAllLits :: [OutPat id] -> Bool +patsAreAllLits :: [Pat id] -> Bool patsAreAllLits pat_list = all isLitPat pat_list -isLitPat (AsPat _ pat) = isLitPat pat -isLitPat (LitPat _ _) = True -isLitPat (NPat _ _ _) = True -isLitPat (NPlusKPat _ _ _ _ _) = True -isLitPat other = False +isLitPat (AsPat _ pat) = isLitPat pat +isLitPat (LitPat _) = True +isLitPat (NPatIn _ _) = True +isLitPat (NPatOut _ _ _) = True +isLitPat (NPlusKPatIn _ _ _) = True +isLitPat (NPlusKPatOut _ _ _ _) = True +isLitPat other = False \end{code} +%************************************************************************ +%* * +%* Gathering stuff out of patterns +%* * +%************************************************************************ + This function @collectPatBinders@ works with the ``collectBinders'' functions for @HsBinds@, etc. The order in which the binders are collected is important; see @HsBinds.lhs@. +It collects the bounds *value* variables in renamed patterns; type variables +are *not* collected. + \begin{code} -collectPatBinders :: InPat a -> [a] +collectPatBinders :: Pat a -> [a] collectPatBinders pat = collect pat [] -collectOutPatBinders :: OutPat a -> [a] -collectOutPatBinders pat = collectOut pat [] - -collectPatsBinders :: [InPat a] -> [a] +collectPatsBinders :: [Pat a] -> [a] collectPatsBinders pats = foldr collect [] pats -collect WildPatIn bndrs = bndrs -collect (VarPatIn var) bndrs = var : bndrs -collect (LitPatIn _) bndrs = bndrs -collect (SigPatIn pat _) bndrs = collect pat bndrs -collect (LazyPatIn pat) bndrs = collect pat bndrs -collect (AsPatIn a pat) bndrs = a : collect pat bndrs -collect (NPlusKPatIn n _ _) bndrs = n : bndrs +collect (WildPat _) bndrs = bndrs +collect (VarPat var) bndrs = var : bndrs +collect (LazyPat pat) bndrs = collect pat bndrs +collect (AsPat a pat) bndrs = a : collect pat bndrs +collect (ParPat pat) bndrs = collect pat bndrs + +collect (ListPat pats _) bndrs = foldr collect bndrs pats +collect (PArrPat pats _) bndrs = foldr collect bndrs pats +collect (TuplePat pats _) bndrs = foldr collect bndrs pats + +collect (ConPatIn c ps) bndrs = foldr collect bndrs (hsConArgs ps) +collect (ConPatOut c ps _ _ ds) bndrs = ds ++ foldr collect bndrs (hsConArgs ps) + +collect (LitPat _) bndrs = bndrs collect (NPatIn _ _) bndrs = bndrs -collect (ConPatIn c pats) bndrs = foldr collect bndrs pats -collect (ConOpPatIn p1 c f p2) bndrs = collect p1 (collect p2 bndrs) -collect (ParPatIn pat) bndrs = collect pat bndrs -collect (ListPatIn pats) bndrs = foldr collect bndrs pats -collect (PArrPatIn pats) bndrs = foldr collect bndrs pats -collect (TuplePatIn pats _) bndrs = foldr collect bndrs pats -collect (RecPatIn c fields) bndrs = foldr (\ (f,pat,_) bndrs -> collect pat bndrs) bndrs fields --- Generics -collect (TypePatIn ty) bndrs = bndrs --- assume the type variables do not need to be bound - --- collect the bounds *value* variables in renamed patterns; type variables --- are *not* collected --- -collectOut (WildPat _) bndrs = bndrs -collectOut (VarPat var) bndrs = var : bndrs -collectOut (LazyPat pat) bndrs = collectOut pat bndrs -collectOut (AsPat a pat) bndrs = a : collectOut pat bndrs -collectOut (ListPat _ pats) bndrs = foldr collectOut bndrs pats -collectOut (PArrPat _ pats) bndrs = foldr collectOut bndrs pats -collectOut (TuplePat pats _) bndrs = foldr collectOut bndrs pats -collectOut (ConPat _ _ _ ds pats) bndrs = ds ++ foldr collectOut bndrs pats -collectOut (RecPat _ _ _ ds fields) bndrs = ds ++ foldr comb bndrs fields - where - comb (_, pat, _) bndrs = collectOut pat bndrs -collectOut (LitPat _ _) bndrs = bndrs -collectOut (NPat _ _ _) bndrs = bndrs -collectOut (NPlusKPat n _ _ _ _) bndrs = n : bndrs -collectOut (DictPat ids1 ids2) bndrs = ids1 ++ ids2 ++ bndrs +collect (NPatOut _ _ _) bndrs = bndrs + +collect (NPlusKPatIn n _ _) bndrs = n : bndrs +collect (NPlusKPatOut n _ _ _) bndrs = n : bndrs + +collect (SigPatIn pat _) bndrs = collect pat bndrs +collect (SigPatOut pat _ _) bndrs = collect pat bndrs +collect (TypePat ty) bndrs = bndrs +collect (DictPat ids1 ids2) bndrs = ids1 ++ ids2 ++ bndrs \end{code} \begin{code} @@ -391,22 +362,16 @@ collectSigTysFromPats pats = foldr collect_pat [] pats collectSigTysFromPat :: InPat name -> [HsType name] collectSigTysFromPat pat = collect_pat pat [] -collect_pat (SigPatIn pat ty) acc = collect_pat pat (ty:acc) -collect_pat WildPatIn acc = acc -collect_pat (VarPatIn var) acc = acc -collect_pat (LitPatIn _) acc = acc -collect_pat (LazyPatIn pat) acc = collect_pat pat acc -collect_pat (AsPatIn a pat) acc = collect_pat pat acc -collect_pat (NPatIn _ _) acc = acc -collect_pat (NPlusKPatIn n _ _) acc = acc -collect_pat (ConPatIn c pats) acc = foldr collect_pat acc pats -collect_pat (ConOpPatIn p1 c f p2) acc = collect_pat p1 (collect_pat p2 acc) -collect_pat (ParPatIn pat) acc = collect_pat pat acc -collect_pat (ListPatIn pats) acc = foldr collect_pat acc pats -collect_pat (PArrPatIn pats) acc = foldr collect_pat acc pats -collect_pat (TuplePatIn pats _) acc = foldr collect_pat acc pats -collect_pat (RecPatIn c fields) acc = foldr (\ (f,pat,_) acc -> collect_pat pat acc) acc fields --- Generics -collect_pat (TypePatIn ty) acc = ty:acc +collect_pat (SigPatIn pat ty) acc = collect_pat pat (ty:acc) +collect_pat (TypePat ty) acc = ty:acc + +collect_pat (LazyPat pat) acc = collect_pat pat acc +collect_pat (AsPat a pat) acc = collect_pat pat acc +collect_pat (ParPat pat) acc = collect_pat pat acc +collect_pat (ListPat pats _) acc = foldr collect_pat acc pats +collect_pat (PArrPat pats _) acc = foldr collect_pat acc pats +collect_pat (TuplePat pats _) acc = foldr collect_pat acc pats +collect_pat (ConPatIn c ps) acc = foldr collect_pat acc (hsConArgs ps) +collect_pat other acc = acc -- Literals, vars, wildcard \end{code} diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 6a393cf2fa..2db1176556 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -23,10 +23,10 @@ module HsSyn ( module HsTypes, Fixity, NewOrData, - collectHsBinders, collectHsOutBinders, collectLocatedHsBinders, + collectHsBinders, collectLocatedHsBinders, collectMonoBinders, collectLocatedMonoBinders, collectSigTysFromMonoBinds, - hsModuleName, hsModuleImports + hsModule, hsImports ) where #include "HsVersions.h" @@ -45,14 +45,14 @@ import BasicTypes ( Fixity, Version, NewOrData ) import Name ( NamedThing ) import Outputable import SrcLoc ( SrcLoc ) -import Module ( ModuleName ) +import Module ( Module ) \end{code} All we actually declare here is the top-level structure for a module. \begin{code} -data HsModule name pat +data HsModule name = HsModule - ModuleName -- module name + Module (Maybe Version) -- source interface version number (Maybe [IE name]) -- export list; Nothing => export everything -- Just [] => export *nothing* (???) @@ -61,14 +61,14 @@ data HsModule name pat -- imported interfaces early on, adding that -- info to TyDecls/etc; so this list is -- often empty, downstream. - [HsDecl name pat] -- Type, class, value, and interface signature decls + [HsDecl name] -- Type, class, value, and interface signature decls (Maybe DeprecTxt) -- reason/explanation for deprecation of this module SrcLoc \end{code} \begin{code} -instance (NamedThing name, Outputable name, Outputable pat) - => Outputable (HsModule name pat) where +instance (NamedThing name, OutputableBndr name) + => Outputable (HsModule name) where ppr (HsModule name iface_version exports imports decls deprec src_loc) @@ -93,8 +93,8 @@ instance (NamedThing name, Outputable name, Outputable pat) pp_nonnull [] = empty pp_nonnull xs = vcat (map ppr xs) -hsModuleName (HsModule mod_name _ _ _ _ _ _) = mod_name -hsModuleImports (HsModule mod_name vers exports imports decls deprec src_loc) = imports +hsModule (HsModule mod _ _ _ _ _ _) = mod +hsImports (HsModule mod vers exports imports decls deprec src_loc) = imports \end{code} @@ -118,30 +118,21 @@ where it should return @[x, y, f, a, b]@ (remember, order important). \begin{code} -collectLocatedHsBinders :: HsBinds name (InPat name) -> [(name,SrcLoc)] +collectLocatedHsBinders :: HsBinds name -> [(name,SrcLoc)] collectLocatedHsBinders EmptyBinds = [] collectLocatedHsBinders (MonoBind b _ _) = collectLocatedMonoBinders b collectLocatedHsBinders (ThenBinds b1 b2) = collectLocatedHsBinders b1 ++ collectLocatedHsBinders b2 -collectHsBinders :: HsBinds name (InPat name) -> [name] +collectHsBinders :: HsBinds name -> [name] collectHsBinders EmptyBinds = [] collectHsBinders (MonoBind b _ _) = collectMonoBinders b collectHsBinders (ThenBinds b1 b2) = collectHsBinders b1 ++ collectHsBinders b2 --- corresponds to `collectHsBinders', but operates on renamed patterns --- -collectHsOutBinders :: HsBinds name (OutPat name) -> [name] -collectHsOutBinders EmptyBinds = [] -collectHsOutBinders (MonoBind b _ _) - = collectMonoOutBinders b -collectHsOutBinders (ThenBinds b1 b2) - = collectHsOutBinders b1 ++ collectHsOutBinders b2 - -collectLocatedMonoBinders :: MonoBinds name (InPat name) -> [(name,SrcLoc)] +collectLocatedMonoBinders :: MonoBinds name -> [(name,SrcLoc)] collectLocatedMonoBinders binds = go binds [] where @@ -150,7 +141,7 @@ collectLocatedMonoBinders binds go (FunMonoBind f _ _ loc) acc = (f,loc) : acc go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc) -collectMonoBinders :: MonoBinds name (InPat name) -> [name] +collectMonoBinders :: MonoBinds name -> [name] collectMonoBinders binds = go binds [] where @@ -158,17 +149,6 @@ collectMonoBinders binds go (PatMonoBind pat _ loc) acc = collectPatBinders pat ++ acc go (FunMonoBind f _ _ loc) acc = f : acc go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc) - --- corresponds to `collectMonoBinders', but operates on renamed patterns --- -collectMonoOutBinders :: MonoBinds name (OutPat name) -> [name] -collectMonoOutBinders binds - = go binds [] - where - go EmptyMonoBinds acc = acc - go (PatMonoBind pat _ loc) acc = collectOutPatBinders pat ++ acc - go (FunMonoBind f _ _ loc) acc = f : acc - go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc) \end{code} %************************************************************************ @@ -180,7 +160,7 @@ collectMonoOutBinders binds Get all the pattern type signatures out of a bunch of bindings \begin{code} -collectSigTysFromMonoBinds :: MonoBinds name (InPat name) -> [HsType name] +collectSigTysFromMonoBinds :: MonoBinds name -> [HsType name] collectSigTysFromMonoBinds bind = go bind [] where diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index d7a2b0b9a6..a0e899940a 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -12,7 +12,7 @@ module HsTypes ( , mkHsForAllTy, mkHsDictTy, mkHsIParamTy , hsTyVarName, hsTyVarNames, replaceTyVarName - , getHsInstHead + , splitHsInstDeclTy -- Type place holder , PostTcType, placeHolderType, @@ -46,10 +46,10 @@ import Var ( TyVar, tyVarKind ) import Subst ( substTyWith ) import PprType ( {- instance Outputable Kind -}, pprParendKind, pprKind ) import BasicTypes ( Boxity(..), Arity, IPName, tupleParens ) -import PrelNames ( mkTupConRdrName, listTyConKey, parrTyConKey, +import PrelNames ( listTyConKey, parrTyConKey, usOnceTyConKey, usManyTyConKey, hasKey, unboundKey, usOnceTyConName, usManyTyConName ) -import SrcLoc ( builtinSrcLoc ) +import SrcLoc ( noSrcLoc ) import Util ( eqListBy, lengthIs ) import FiniteMap import Outputable @@ -81,7 +81,7 @@ type SyntaxName = Name -- These names are filled in by the renamer placeHolderName :: SyntaxName placeHolderName = mkInternalName unboundKey (mkVarOcc FSLIT("syntaxPlaceHolder")) - builtinSrcLoc + noSrcLoc \end{code} @@ -116,7 +116,7 @@ data HsType name | HsPArrTy (HsType name) -- Elem. type of parallel array: [:t:] - | HsTupleTy (HsTupCon name) + | HsTupleTy HsTupCon [HsType name] -- Element types (length gives arity) | HsOpTy (HsType name) (HsTyOp name) (HsType name) @@ -153,18 +153,16 @@ hsUsOnce_Name = HsTyVar usOnceTyConName hsUsMany_Name = HsTyVar usManyTyConName ----------------------- -data HsTupCon name = HsTupCon name Boxity Arity +data HsTupCon = HsTupCon Boxity Arity -instance Eq name => Eq (HsTupCon name) where - (HsTupCon _ b1 a1) == (HsTupCon _ b2 a2) = b1==b2 && a1==a2 +instance Eq HsTupCon where + (HsTupCon b1 a1) == (HsTupCon b2 a2) = b1==b2 && a1==a2 -mkHsTupCon :: NameSpace -> Boxity -> [a] -> HsTupCon RdrName -mkHsTupCon space boxity args = HsTupCon (mkTupConRdrName space boxity arity) boxity arity - where - arity = length args +mkHsTupCon :: NameSpace -> Boxity -> [a] -> HsTupCon +mkHsTupCon space boxity args = HsTupCon boxity (length args) -hsTupParens :: HsTupCon name -> SDoc -> SDoc -hsTupParens (HsTupCon _ b _) p = tupleParens b p +hsTupParens :: HsTupCon -> SDoc -> SDoc +hsTupParens (HsTupCon b _) p = tupleParens b p ----------------------- -- Combine adjacent for-alls. @@ -211,23 +209,41 @@ replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k \begin{code} -getHsInstHead :: HsType name -> ([HsTyVarBndr name], (name, [HsType name])) - -- Split up an instance decl type, returning the 'head' part - --- In interface fiels, the type of the decl is held like this: --- forall a. Foo a -> Baz (T a) --- so we have to strip off function argument types, --- as well as the bit before the '=>' (which is always --- empty in interface files) --- --- The parser ensures the type will have the right shape. +splitHsInstDeclTy + :: Outputable name + => HsType name + -> ([HsTyVarBndr name], HsContext name, name, [HsType name]) + -- Split up an instance decl type, returning the pieces + +-- In interface files, the instance declaration head is created +-- by HsTypes.toHsType, which does not guarantee to produce a +-- HsForAllTy. For example, if we had the weird decl +-- instance Foo T => Foo [T] +-- then we'd get the instance type +-- Foo T -> Foo [T] +-- So when colleting the instance context, to be on the safe side +-- we gather predicate arguments +-- +-- For source code, the parser ensures the type will have the right shape. -- (e.g. see ParseUtil.checkInstType) -getHsInstHead (HsForAllTy (Just tvs) _ tau) = (tvs, get_head1 tau) -getHsInstHead tau = ([], get_head1 tau) +splitHsInstDeclTy inst_ty + = case inst_ty of + HsForAllTy (Just tvs) cxt1 tau + -> (tvs, cxt1++cxt2, cls, tys) + where + (cxt2, cls, tys) = split_tau tau + + other -> ([], cxt2, cls, tys) + where + (cxt2, cls, tys) = split_tau inst_ty -get_head1 (HsFunTy _ ty) = get_head1 ty -get_head1 (HsPredTy (HsClassP cls tys)) = (cls,tys) + where + split_tau (HsFunTy (HsPredTy p) ty) = (p:ps, cls, tys) + where + (ps, cls, tys) = split_tau ty + split_tau (HsPredTy (HsClassP cls tys)) = ([], cls,tys) + split_tau other = pprPanic "splitHsInstDeclTy" (ppr inst_ty) \end{code} @@ -409,7 +425,7 @@ toHsType (SourceTy pred) = HsPredTy (toHsPred pred) toHsType ty@(TyConApp tc tys) -- Must be saturated because toHsType's arg is of kind * | not saturated = generic_case - | isTupleTyCon tc = HsTupleTy (HsTupCon (getName tc) (tupleTyConBoxity tc) (tyConArity tc)) tys' + | isTupleTyCon tc = HsTupleTy (HsTupCon (tupleTyConBoxity tc) (tyConArity tc)) tys' | tc `hasKey` listTyConKey = HsListTy (head tys') | tc `hasKey` parrTyConKey = HsPArrTy (head tys') | tc `hasKey` usOnceTyConKey = hsUsOnce_Name -- must print !, . unqualified 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 @@ -364,13 +390,6 @@ instance Binary ParsedIface where pi_rules = rules, 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. *-} @@ -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- 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- 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 @@ -697,6 +788,68 @@ type GateFn = (Name -> Bool) -> Bool -- Returns True <=> gate is open \end{code} +%************************************************************************ +%* * +\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} @@ -704,6 +857,7 @@ type GateFn = (Name -> Bool) -> Bool -- Returns True <=> gate is open %************************************************************************ 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 ; +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 diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index 5489238a96..8cdcae2b29 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -23,7 +23,7 @@ import Stix ( StixReg(..), StixStmt(..), StixExpr(..), StixVReg(..), pprStixStmts, pprStixStmt, stixStmt_CountTempUses, stixStmt_Subst, liftStrings, - initNat, mapNat, + initNat, mkNatM_State, uniqOfNatM_State, deltaOfNatM_State ) import UniqSupply ( returnUs, thenUs, initUs, diff --git a/ghc/compiler/ndpFlatten/FlattenInfo.hs b/ghc/compiler/ndpFlatten/FlattenInfo.hs index 4a08c69ba3..b6e91e517b 100644 --- a/ghc/compiler/ndpFlatten/FlattenInfo.hs +++ b/ghc/compiler/ndpFlatten/FlattenInfo.hs @@ -37,7 +37,7 @@ import PrelNames (fstName, andName, orName, lengthPName, replicatePName, namesNeededForFlattening :: FreeVars namesNeededForFlattening | not opt_Flatten = emptyFVs -- none without -fflatten - | otherwise = mkFVs - [fstName, andName, orName, lengthPName, replicatePName, mapPName, - bpermutePName, bpermuteDftPName, indexOfPName] + | otherwise + = mkFVs [fstName, andName, orName, lengthPName, replicatePName, mapPName, + bpermutePName, bpermuteDftPName, indexOfPName] -- stuff from PrelGHC doesn't have to go here diff --git a/ghc/compiler/ndpFlatten/FlattenMonad.hs b/ghc/compiler/ndpFlatten/FlattenMonad.hs index 874f02048b..beb5f16e89 100644 --- a/ghc/compiler/ndpFlatten/FlattenMonad.hs +++ b/ghc/compiler/ndpFlatten/FlattenMonad.hs @@ -72,13 +72,13 @@ import OccName (UserFS) import Var (Var(..)) import Id (Id, mkSysLocal) import Name (Name) -import VarSet (VarSet, emptyVarSet, unitVarSet, extendVarSet, - varSetElems, unionVarSet) -import VarEnv (VarEnv, emptyVarEnv, unitVarEnv, zipVarEnv, plusVarEnv, +import VarSet (VarSet, emptyVarSet, extendVarSet, varSetElems ) +import VarEnv (VarEnv, emptyVarEnv, zipVarEnv, plusVarEnv, elemVarEnv, lookupVarEnv, lookupVarEnv_NF, delVarEnvList) import TyCon (tyConName) import Type (Type, tyConAppTyCon) -import HscTypes (HomeSymbolTable, PersistentCompilerState(..), +import HscTypes (HomePackageTable, PersistentCompilerState(pcs_EPS), + ExternalPackageState(eps_PTE), HscEnv(hsc_HPT), TyThing(..), lookupType) import PrelNames (charPrimTyConName, intPrimTyConName, floatPrimTyConName, doublePrimTyConName, fstName, andName, orName, @@ -87,8 +87,7 @@ import PrelNames (charPrimTyConName, intPrimTyConName, floatPrimTyConName, import PrimOp (eqCharName, eqIntName, eqFloatName, eqDoubleName, neqIntName) -- neqCharName, neqFloatName,neqDoubleName, -import CoreSyn (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps, - bindersOfBinds) +import CoreSyn (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps) import CoreUtils (exprType) -- friends @@ -133,10 +132,10 @@ data FlattenState = FlattenState { -- initial value of the flattening state -- initialFlattenState :: PersistentCompilerState - -> HomeSymbolTable + -> HomePackageTable -> UniqSupply -> FlattenState -initialFlattenState pcs hst us = +initialFlattenState pcs hpt us = FlattenState { us = us, env = lookup, @@ -146,7 +145,7 @@ initialFlattenState pcs hst us = } where lookup n = - case lookupType hst (pcs_PTE pcs) n of + case lookupType hpt (eps_PTE (pcs_EPS pcs)) n of Just (AnId v) -> v _ -> pprPanic "FlattenMonad: unknown name:" (ppr n) @@ -165,12 +164,13 @@ instance Monad Flatten where -- execute the given flattening computation (EXPORTED) -- -runFlatten :: PersistentCompilerState - -> HomeSymbolTable +runFlatten :: HscEnv + -> PersistentCompilerState -> UniqSupply -> Flatten a -> a -runFlatten pcs hst us m = fst $ unFlatten m (initialFlattenState pcs hst us) +runFlatten hsc_env pcs us m + = fst $ unFlatten m (initialFlattenState pcs (hsc_HPT hsc_env) us) -- variable generation diff --git a/ghc/compiler/ndpFlatten/Flattening.hs b/ghc/compiler/ndpFlatten/Flattening.hs index b8bf32dfe1..51a5d9a944 100644 --- a/ghc/compiler/ndpFlatten/Flattening.hs +++ b/ghc/compiler/ndpFlatten/Flattening.hs @@ -66,28 +66,30 @@ import FlattenMonad (Flatten, runFlatten, mkBind, extendContext, packContext, import CmdLineOpts (opt_Flatten) import Panic (panic) import ErrUtils (dumpIfSet_dyn) -import UniqSupply (UniqSupply, mkSplitUniqSupply) -import CmdLineOpts (DynFlag(..), DynFlags) +import UniqSupply (mkSplitUniqSupply) +import CmdLineOpts (DynFlag(..)) import Literal (Literal, literalType) -import Var (Var(..),TyVar) +import Var (Var(..)) import DataCon (DataCon, dataConTag) import TypeRep (Type(..)) import Type (isTypeKind) -import HscTypes (HomeSymbolTable, PersistentCompilerState, ModDetails(..)) +import HscTypes (PersistentCompilerState, ModGuts(..), + ModGuts, HscEnv(..) ) import CoreFVs (exprFreeVars) import CoreSyn (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..), - CoreBndr, CoreExpr, CoreBind, CoreAlt, mkLams, mkLets, + CoreBndr, CoreExpr, CoreBind, mkLams, mkLets, mkApps, mkIntLitInt) import PprCore (pprCoreExpr) import CoreLint (showPass, endPass) import CoreUtils (exprType, applyTypeToArg, mkPiType) -import VarEnv (IdEnv, mkVarEnv, zipVarEnv, extendVarEnv) +import VarEnv (zipVarEnv) import TysWiredIn (mkTupleTy) import BasicTypes (Boxity(..)) -import Outputable (showSDoc, Outputable(..)) +import Outputable import FastString + -- FIXME: fro debugging - remove this import TRACE (trace) @@ -100,15 +102,16 @@ import Monad (liftM, foldM) -- entry point to the flattening transformation for the compiler driver when -- compiling a complete module (EXPORTED) -- -flatten :: DynFlags +flatten :: HscEnv -> PersistentCompilerState - -> HomeSymbolTable - -> ModDetails -- the module to be flattened - -> IO ModDetails -flatten dflags pcs hst modDetails@(ModDetails {md_binds = binds}) - | not opt_Flatten = return modDetails -- skip without -fflatten + -> ModGuts + -> IO ModGuts +flatten hsc_env pcs mod_impl@(ModGuts {mg_binds = binds}) + | not opt_Flatten = return mod_impl -- skip without -fflatten | otherwise = do + let dflags = hsc_dflags hsc_env + us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening -- -- announce vectorisation @@ -117,26 +120,27 @@ flatten dflags pcs hst modDetails@(ModDetails {md_binds = binds}) -- -- vectorise all toplevel bindings -- - let binds' = runFlatten pcs hst us $ vectoriseTopLevelBinds binds + let binds' = runFlatten hsc_env pcs us $ vectoriseTopLevelBinds binds -- -- and dump the result if requested -- endPass dflags "Flattening [first phase: vectorisation]" Opt_D_dump_vect binds' - return $ modDetails {md_binds = binds'} + return $ mod_impl {mg_binds = binds'} -- entry point to the flattening transformation for the compiler driver when -- compiling a single expression in interactive mode (EXPORTED) -- -flattenExpr :: DynFlags +flattenExpr :: HscEnv -> PersistentCompilerState - -> HomeSymbolTable -> CoreExpr -- the expression to be flattened -> IO CoreExpr -flattenExpr dflags pcs hst expr +flattenExpr hsc_env pcs expr | not opt_Flatten = return expr -- skip without -fflatten | otherwise = do + let dflags = hsc_dflags hsc_env + us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening -- -- announce vectorisation @@ -145,7 +149,7 @@ flattenExpr dflags pcs hst expr -- -- vectorise the expression -- - let expr' = fst . runFlatten pcs hst us $ vectorise expr + let expr' = fst . runFlatten hsc_env pcs us $ vectorise expr -- -- and dump the result if requested -- diff --git a/ghc/compiler/parser/Lex.lhs b/ghc/compiler/parser/Lex.lhs index da7b16d6b5..f8e5423d67 100644 --- a/ghc/compiler/parser/Lex.lhs +++ b/ghc/compiler/parser/Lex.lhs @@ -135,6 +135,7 @@ data Token | ITclose_prag | ITdotdot -- reserved symbols + | ITcolon | ITdcolon | ITequal | ITlam @@ -195,6 +196,15 @@ data Token | ITprimdouble Rational | ITlitlit FastString + -- MetaHaskell extension tokens + | ITopenExpQuote -- [| or [e| + | ITopenPatQuote -- [p| + | ITopenDecQuote -- [d| + | ITopenTypQuote -- [t| + | ITcloseQuote -- |] + | ITidEscape FastString -- $x + | ITparenEscape -- $( + | ITunknown String -- Used when the lexer can't make sense of it | ITeof -- end of file token deriving Show -- debugging @@ -302,6 +312,8 @@ ghcExtensionKeywordsFM = listToUFM $ haskellKeySymsFM = listToUFM $ map (\ (x,y) -> (mkFastString x,y)) [ ("..", ITdotdot) + ,(":", ITcolon) -- (:) is a reserved op, + -- meaning only list cons ,("::", ITdcolon) ,("=", ITequal) ,("\\", ITlam) @@ -316,6 +328,7 @@ haskellKeySymsFM = listToUFM $ ,("*", ITstar) ,(".", ITdot) -- sadly, for 'forall a . t' ] + \end{code} ----------------------------------------------------------------------------- @@ -374,7 +387,7 @@ lexer cont buf s@(PState{ -- processing if necessary). '{'# | lookAhead# buf 1# `eqChar#` '-'# -> if lookAhead# buf 2# `eqChar#` '#'# then - case expandWhile# is_space (setCurrentPos# buf 3#) of { buf1-> + case expandWhile# is_space (addToCurrentPos buf 3#) of { buf1-> case expandWhile# is_ident (stepOverLexeme buf1) of { buf2-> let lexeme = mkFastString -- ToDo: too slow (map toUpper (lexemeToString buf2)) in @@ -514,57 +527,76 @@ lexToken cont exts buf = -- special symbols ---------------------------------------------------- '('# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '#'# - -> cont IToubxparen (setCurrentPos# buf 2#) + -> cont IToubxparen (addToCurrentPos buf 2#) | otherwise - -> cont IToparen (incLexeme buf) + -> cont IToparen (incCurrentPos buf) - ')'# -> cont ITcparen (incLexeme buf) + ')'# -> cont ITcparen (incCurrentPos buf) '['# | parrEnabled exts && lookAhead# buf 1# `eqChar#` ':'# -> - cont ITopabrack (setCurrentPos# buf 2#) - | otherwise -> - cont ITobrack (incLexeme buf) - ']'# -> cont ITcbrack (incLexeme buf) - ','# -> cont ITcomma (incLexeme buf) - ';'# -> cont ITsemi (incLexeme buf) + cont ITopabrack (addToCurrentPos buf 2#) + ------- MetaHaskell Extensions, looking for [| [e| [t| [p| and [d| + | glaExtsEnabled exts && + ((lookAhead# buf 1# ) `eqChar#` '|'# ) -> + cont ITopenExpQuote (addToCurrentPos buf 2# ) + | glaExtsEnabled exts && + (let c = (lookAhead# buf 1# ) + in eqChar# c 'e'# || eqChar# c 't'# || eqChar# c 'd'# || eqChar# c 'p'#) && + ((lookAhead# buf 2#) `eqChar#` '|'#) -> + let quote 'e'# = ITopenExpQuote + quote 'p'# = ITopenPatQuote + quote 'd'# = ITopenDecQuote + quote 't'# = ITopenTypQuote + in cont (quote (lookAhead# buf 1#)) (addToCurrentPos buf 3# ) + | otherwise -> + cont ITobrack (incCurrentPos buf) + + ']'# -> cont ITcbrack (incCurrentPos buf) + ','# -> cont ITcomma (incCurrentPos buf) + ';'# -> cont ITsemi (incCurrentPos buf) '}'# -> \ s@PState{context = ctx} -> case ctx of - (_:ctx') -> cont ITccurly (incLexeme buf) s{context=ctx'} + (_:ctx') -> cont ITccurly (incCurrentPos buf) s{context=ctx'} _ -> lexError "too many '}'s" buf s '|'# -> case lookAhead# buf 1# of '}'# | glaExtsEnabled exts -> cont ITccurlybar - (setCurrentPos# buf 2#) - _ -> lex_sym cont (incLexeme buf) + (addToCurrentPos buf 2#) + -- MetaHaskell extension + ']'# | glaExtsEnabled exts -> cont ITcloseQuote (addToCurrentPos buf 2#) + other -> lex_sym cont (incCurrentPos buf) ':'# -> case lookAhead# buf 1# of ']'# | parrEnabled exts -> cont ITcpabrack - (setCurrentPos# buf 2#) - _ -> lex_sym cont (incLexeme buf) + (addToCurrentPos buf 2#) + _ -> lex_sym cont (incCurrentPos buf) '#'# -> case lookAhead# buf 1# of ')'# | glaExtsEnabled exts - -> cont ITcubxparen (setCurrentPos# buf 2#) + -> cont ITcubxparen (addToCurrentPos buf 2#) '-'# -> case lookAhead# buf 2# of - '}'# -> cont ITclose_prag (setCurrentPos# buf 3#) - _ -> lex_sym cont (incLexeme buf) - _ -> lex_sym cont (incLexeme buf) + '}'# -> cont ITclose_prag (addToCurrentPos buf 3#) + _ -> lex_sym cont (incCurrentPos buf) + _ -> lex_sym cont (incCurrentPos buf) '`'# | glaExtsEnabled exts && lookAhead# buf 1# `eqChar#` '`'# - -> lex_cstring cont (setCurrentPos# buf 2#) + -> lex_cstring cont (addToCurrentPos buf 2#) | otherwise - -> cont ITbackquote (incLexeme buf) + -> cont ITbackquote (incCurrentPos buf) '{'# -> -- for Emacs: -} case lookAhead# buf 1# of '|'# | glaExtsEnabled exts - -> cont ITocurlybar (setCurrentPos# buf 2#) + -> cont ITocurlybar (addToCurrentPos buf 2#) '-'# -> case lookAhead# buf 2# of - '#'# -> lex_prag cont (setCurrentPos# buf 3#) - _ -> cont ITocurly (incLexeme buf) - _ -> (layoutOff `thenP_` cont ITocurly) (incLexeme buf) + '#'# -> lex_prag cont (addToCurrentPos buf 3#) + _ -> cont ITocurly (incCurrentPos buf) + _ -> (layoutOff `thenP_` cont ITocurly) (incCurrentPos buf) + + + -- strings/characters ------------------------------------------------- - '\"'#{-"-} -> lex_string cont exts [] (incLexeme buf) - '\''# -> lex_char (char_end cont) exts (incLexeme buf) + '\"'#{-"-} -> lex_string cont exts [] (incCurrentPos buf) + '\''# -> lex_char (char_end cont) exts (incCurrentPos buf) -- Hexadecimal and octal constants '0'# | (ch `eqChar#` 'x'# || ch `eqChar#` 'X'#) && is_hexdigit ch2 @@ -573,7 +605,7 @@ lexToken cont exts buf = -> readNum (after_lexnum cont exts) buf' is_octdigit 8 oct_or_dec where ch = lookAhead# buf 1# ch2 = lookAhead# buf 2# - buf' = setCurrentPos# buf 2# + buf' = addToCurrentPos buf 2# '\NUL'# -> if bufferExhausted (stepOn buf) then @@ -582,14 +614,21 @@ lexToken cont exts buf = trace "lexIface: misplaced NUL?" $ cont (ITunknown "\NUL") (stepOn buf) - '?'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> - lex_ip ITdupipvarid cont (incLexeme buf) + '?'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> -- ?x implicit parameter + specialPrefixId ITdupipvarid cont exts (incCurrentPos buf) '%'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> - lex_ip ITsplitipvarid cont (incLexeme buf) + specialPrefixId ITsplitipvarid cont exts (incCurrentPos buf) + + ---------------- MetaHaskell Extensions for quotation escape + '$'# | glaExtsEnabled exts && is_lower (lookAhead# buf 1#) -> -- $x variable escape + specialPrefixId ITidEscape cont exts (addToCurrentPos buf 1#) + '$'# | glaExtsEnabled exts && -- $( f x ) expression escape + ((lookAhead# buf 1#) `eqChar#` '('#) -> cont ITparenEscape (addToCurrentPos buf 2#) + c | is_digit c -> lex_num cont exts 0 buf | is_symbol c -> lex_sym cont buf | is_upper c -> lex_con cont exts buf - | is_ident c -> lex_id cont exts buf + | is_lower c -> lex_id cont exts buf | otherwise -> lexError "illegal character" buf -- Int# is unlifted, and therefore faster than Bool for flags. @@ -616,11 +655,11 @@ lex_prag cont buf lex_string cont exts s buf = case currentChar# buf of '"'#{-"-} -> - let buf' = incLexeme buf + let buf' = incCurrentPos buf s' = mkFastString (map chr (reverse s)) in case currentChar# buf' of '#'# | glaExtsEnabled exts -> if all (<= 0xFF) s - then cont (ITprimstring s') (incLexeme buf') + then cont (ITprimstring s') (incCurrentPos buf') else lexError "primitive string literal must contain only characters <= \'\\xFF\'" buf' _ -> cont (ITstring s') buf' @@ -628,15 +667,15 @@ lex_string cont exts s buf '\\'# | next_ch `eqChar#` '&'# -> lex_string cont exts s buf' | is_space next_ch - -> lex_stringgap cont exts s (incLexeme buf) + -> lex_stringgap cont exts s (incCurrentPos buf) where next_ch = lookAhead# buf 1# - buf' = setCurrentPos# buf 2# + buf' = addToCurrentPos buf 2# _ -> lex_char (lex_next_string cont s) exts buf lex_stringgap cont exts s buf - = let buf' = incLexeme buf in + = let buf' = incCurrentPos buf in case currentChar# buf of '\n'# -> \st@PState{loc = loc} -> lex_stringgap cont exts s buf' st{loc = incSrcLine loc} @@ -649,21 +688,21 @@ lex_next_string cont s exts c buf = lex_string cont exts (c:s) buf lex_char :: (Int# -> Int -> P a) -> Int# -> P a lex_char cont exts buf = case currentChar# buf of - '\\'# -> lex_escape (cont exts) (incLexeme buf) - c | is_any c -> cont exts (I# (ord# c)) (incLexeme buf) + '\\'# -> lex_escape (cont exts) (incCurrentPos buf) + c | is_any c -> cont exts (I# (ord# c)) (incCurrentPos buf) other -> charError buf char_end cont exts c buf = case currentChar# buf of - '\''# -> let buf' = incLexeme buf in + '\''# -> let buf' = incCurrentPos buf in case currentChar# buf' of '#'# | glaExtsEnabled exts - -> cont (ITprimchar c) (incLexeme buf') + -> cont (ITprimchar c) (incCurrentPos buf') _ -> cont (ITchar c) buf' _ -> charError buf lex_escape cont buf - = let buf' = incLexeme buf in + = let buf' = incCurrentPos buf in case currentChar# buf of 'a'# -> cont (ord '\a') buf' 'b'# -> cont (ord '\b') buf' @@ -677,7 +716,7 @@ lex_escape cont buf '\''# -> cont (ord '\'') buf' '^'# -> let c = currentChar# buf' in if c `geChar#` '@'# && c `leChar#` '_'# - then cont (I# (ord# c -# ord# '@'#)) (incLexeme buf') + then cont (I# (ord# c -# ord# '@'#)) (incCurrentPos buf') else charError buf' 'x'# -> readNum (after_charnum cont) buf' is_hexdigit 16 hex @@ -699,7 +738,7 @@ readNum cont buf is_digit base conv = read buf 0 where read buf i = case currentChar# buf of { c -> if is_digit c - then read (incLexeme buf) (i*base + (toInteger (I# (conv c)))) + then read (incCurrentPos buf) (i*base + (toInteger (I# (conv c)))) else cont i buf } @@ -770,7 +809,7 @@ lex_num cont exts acc buf = -- this case is not optimised at all, as the -- presence of floating point numbers in interface -- files is not that common. (ToDo) - case expandWhile# is_digit (incLexeme buf') of + case expandWhile# is_digit (incCurrentPos buf') of buf2 -> -- points to first non digit char let l = case currentChar# buf2 of @@ -779,21 +818,21 @@ lex_num cont exts acc buf = _ -> buf2 do_exponent - = let buf3 = incLexeme buf2 in + = let buf3 = incCurrentPos buf2 in case currentChar# buf3 of '-'# | is_digit (lookAhead# buf3 1#) - -> expandWhile# is_digit (incLexeme buf3) + -> expandWhile# is_digit (incCurrentPos buf3) '+'# | is_digit (lookAhead# buf3 1#) - -> expandWhile# is_digit (incLexeme buf3) + -> expandWhile# is_digit (incCurrentPos buf3) x | is_digit x -> expandWhile# is_digit buf3 _ -> buf2 v = readRational__ (lexemeToString l) in case currentChar# l of -- glasgow exts only - '#'# | glaExtsEnabled exts -> let l' = incLexeme l in + '#'# | glaExtsEnabled exts -> let l' = incCurrentPos l in case currentChar# l' of - '#'# -> cont (ITprimdouble v) (incLexeme l') + '#'# -> cont (ITprimdouble v) (incCurrentPos l') _ -> cont (ITprimfloat v) l' _ -> cont (ITrational v) l @@ -801,7 +840,7 @@ lex_num cont exts acc buf = after_lexnum cont exts i buf = case currentChar# buf of - '#'# | glaExtsEnabled exts -> cont (ITprimint i) (incLexeme buf) + '#'# | glaExtsEnabled exts -> cont (ITprimint i) (incCurrentPos buf) _ -> cont (ITinteger i) buf readRational :: ReadS Rational -- NB: doesn't handle leading "-" @@ -858,17 +897,26 @@ readRational__ top_s lex_cstring cont buf = case expandUntilMatch (stepOverLexeme buf) "\'\'" of Just buf' -> cont (ITlitlit (lexemeToFastString - (setCurrentPos# buf' (negateInt# 2#)))) + (addToCurrentPos buf' (negateInt# 2#)))) (mergeLexemes buf buf') Nothing -> lexError "unterminated ``" buf ----------------------------------------------------------------------------- -- identifiers, symbols etc. -lex_ip ip_constr cont buf = +-- used for identifiers with special prefixes like +-- ?x (implicit parameters), $x (MetaHaskell escapes) and #x +-- we've already seen the prefix char, so look for an id, and wrap +-- the new "ip_constr" around the lexeme returned + +specialPrefixId ip_constr cont exts buf = lex_id newcont exts buf + where newcont (ITvarid lexeme) buf2 = cont (ip_constr (tailFS lexeme)) buf2 + newcont token buf2 = cont token buf2 +{- case expandWhile# is_ident buf of buf' -> cont (ip_constr (tailFS lexeme)) buf' where lexeme = lexemeToFastString buf' +-} lex_id cont exts buf = let buf1 = expandWhile# is_ident buf in @@ -901,8 +949,8 @@ lex_sym cont buf = buf' -> case lookupUFM haskellKeySymsFM lexeme of { Just kwd_token -> --trace ("keysym: "++unpackFS lexeme) $ cont kwd_token buf' ; - Nothing -> --trace ("sym: "++unpackFS lexeme) $ - cont (mk_var_token lexeme) buf' + Nothing -> --trace ("sym: "++unpackFS lexeme) $ + cont (mk_var_token lexeme) buf' } where lexeme = lexemeToFastString buf' @@ -920,7 +968,7 @@ lex_con cont exts buf = let all_buf = mergeLexemes buf con_buf con_lexeme = lexemeToFastString con_buf - mod_lexeme = lexemeToFastString (decLexeme buf) + mod_lexeme = lexemeToFastString (decCurrentPos buf) all_lexeme = lexemeToFastString all_buf just_a_conid @@ -930,7 +978,7 @@ lex_con cont exts buf = case currentChar# all_buf of '.'# -> maybe_qualified cont exts all_lexeme - (incLexeme all_buf) just_a_conid + (incCurrentPos all_buf) just_a_conid _ -> just_a_conid }} @@ -940,22 +988,22 @@ maybe_qualified cont exts mod buf just_a_conid = case currentChar# buf of '['# -> -- Special case for [] case lookAhead# buf 1# of - ']'# -> cont (ITqconid (mod,FSLIT("[]"))) (setCurrentPos# buf 2#) + ']'# -> cont (ITqconid (mod,FSLIT("[]"))) (addToCurrentPos buf 2#) _ -> just_a_conid '('# -> -- Special case for (,,,) -- This *is* necessary to deal with e.g. "instance C PrelBase.(,,)" case lookAhead# buf 1# of '#'# | glaExtsEnabled exts -> case lookAhead# buf 2# of - ','# -> lex_ubx_tuple cont mod (setCurrentPos# buf 3#) + ','# -> lex_ubx_tuple cont mod (addToCurrentPos buf 3#) just_a_conid _ -> just_a_conid - ')'# -> cont (ITqconid (mod,FSLIT("()"))) (setCurrentPos# buf 2#) - ','# -> lex_tuple cont mod (setCurrentPos# buf 2#) just_a_conid + ')'# -> cont (ITqconid (mod,FSLIT("()"))) (addToCurrentPos buf 2#) + ','# -> lex_tuple cont mod (addToCurrentPos buf 2#) just_a_conid _ -> just_a_conid '-'# -> case lookAhead# buf 1# of - '>'# -> cont (ITqconid (mod,FSLIT("(->)"))) (setCurrentPos# buf 2#) + '>'# -> cont (ITqconid (mod,FSLIT("(->)"))) (addToCurrentPos buf 2#) _ -> lex_id3 cont exts mod buf just_a_conid _ -> lex_id3 cont exts mod buf just_a_conid diff --git a/ghc/compiler/parser/ParseUtil.lhs b/ghc/compiler/parser/ParseUtil.lhs index 3bec98e035..4e6c9119c1 100644 --- a/ghc/compiler/parser/ParseUtil.lhs +++ b/ghc/compiler/parser/ParseUtil.lhs @@ -6,7 +6,7 @@ \begin{code} module ParseUtil ( parseError -- String -> Pa - , mkVanillaCon, mkRecCon, + , mkPrefixCon, mkRecCon , mkRecConstrOrUpdate -- HsExp -> [HsFieldUpdate] -> P HsExp , groupBindings @@ -44,14 +44,13 @@ import List ( isSuffixOf ) import Lex import HscTypes ( RdrAvailInfo, GenAvailInfo(..) ) import HsSyn -- Lots of it +import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), DNCallSpec(..)) import SrcLoc import RdrHsSyn import RdrName -import PrelNames ( unitTyCon_RDR ) -import OccName ( dataName, varName, tcClsName, isDataOcc, - occNameSpace, setOccNameSpace, occNameUserString ) +import OccName ( dataName, varName, isDataOcc, isTcOcc, occNameUserString ) import CStrings ( CLabelString ) import FastString import Outputable @@ -66,37 +65,33 @@ parseError s = ----------------------------------------------------------------------------- --- mkVanillaCon +-- mkPrefixCon -- When parsing data declarations, we sometimes inadvertently parse -- a constructor application as a type (eg. in data T a b = C a b `D` E a b) -- This function splits up the type application, adds any pending -- arguments, and converts the type constructor back into a data constructor. -mkVanillaCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails) +mkPrefixCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails) -mkVanillaCon ty tys +mkPrefixCon ty tys = split ty tys where split (HsAppTy t u) ts = split t (unbangedType u : ts) split (HsTyVar tc) ts = tyConToDataCon tc `thenP` \ data_con -> - returnP (data_con, VanillaCon ts) + returnP (data_con, PrefixCon ts) split _ _ = parseError "Illegal data/newtype declaration" -mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails) -mkRecCon con fields - = tyConToDataCon con `thenP` \ data_con -> - returnP (data_con, RecCon fields) +mkRecCon :: [([RdrName],RdrNameBangType)] -> RdrNameConDetails +mkRecCon fields + = RecCon [ (l,t) | (ls,t) <- fields, l <- ls ] tyConToDataCon :: RdrName -> P RdrName tyConToDataCon tc - | occNameSpace tc_occ == tcClsName - = returnP (setRdrNameOcc tc (setOccNameSpace tc_occ dataName)) + | isTcOcc (rdrNameOcc tc) + = returnP (setRdrNameSpace tc dataName) | otherwise = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc))) - where - tc_occ = rdrNameOcc tc - ---------------------------------------------------------------------------- -- Various Syntactic Checks @@ -147,7 +142,7 @@ checkContext (HsParTy ty) -- to be sure HsParTy doesn't get into the way = checkContext ty checkContext (HsTyVar t) -- Empty context shows up as a unit type () - | t == unitTyCon_RDR = returnP [] + | t == getRdrName unitTyCon = returnP [] checkContext t = checkPred t `thenP` \p -> @@ -201,17 +196,17 @@ checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat] checkPatterns loc es = mapP (checkPattern loc) es checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat -checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c args) +checkPat (HsVar c) args | isRdrDataCon c = returnP (ConPatIn c (PrefixCon args)) checkPat (HsApp f x) args = checkPat x [] `thenP` \x -> checkPat f (x:args) checkPat e [] = case e of - EWildPat -> returnP WildPatIn - HsVar x -> returnP (VarPatIn x) - HsLit l -> returnP (LitPatIn l) + EWildPat -> returnP (WildPat placeHolderType) + HsVar x -> returnP (VarPat x) + HsLit l -> returnP (LitPat l) HsOverLit l -> returnP (NPatIn l Nothing) - ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPatIn) - EAsPat n e -> checkPat e [] `thenP` (returnP . AsPatIn n) + ELazyPat e -> checkPat e [] `thenP` (returnP . LazyPat) + EAsPat n e -> checkPat e [] `thenP` (returnP . AsPat n) ExprWithTySig e t -> checkPat e [] `thenP` \e -> -- Pattern signatures are parsed as sigtypes, -- but they aren't explicit forall points. Hence @@ -239,31 +234,29 @@ checkPat e [] = case e of checkPat r [] `thenP` \r -> case op of HsVar c | isDataOcc (rdrNameOcc c) - -> returnP (ConOpPatIn l c fix r) + -> returnP (ConPatIn c (InfixCon l r)) _ -> patFail - HsPar e -> checkPat e [] `thenP` (returnP . ParPatIn) + HsPar e -> checkPat e [] `thenP` (returnP . ParPat) ExplicitList _ es -> mapP (\e -> checkPat e []) es `thenP` \ps -> - returnP (ListPatIn ps) + returnP (ListPat ps placeHolderType) ExplicitPArr _ es -> mapP (\e -> checkPat e []) es `thenP` \ps -> - returnP (PArrPatIn ps) + returnP (PArrPat ps placeHolderType) ExplicitTuple es b -> mapP (\e -> checkPat e []) es `thenP` \ps -> - returnP (TuplePatIn ps b) + returnP (TuplePat ps b) RecordCon c fs -> mapP checkPatField fs `thenP` \fs -> - returnP (RecPatIn c fs) + returnP (ConPatIn c (RecCon fs)) -- Generics - HsType ty -> returnP (TypePatIn ty) + HsType ty -> returnP (TypePat ty) _ -> patFail checkPat _ _ = patFail -checkPatField :: (RdrName, RdrNameHsExpr, Bool) - -> P (RdrName, RdrNamePat, Bool) -checkPatField (n,e,b) = - checkPat e [] `thenP` \p -> - returnP (n,p,b) +checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat) +checkPatField (n,e) = checkPat e [] `thenP` \p -> + returnP (n,p) patFail = parseError "Parse error in pattern" diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y index f128af2fa7..3a0b3acb01 100644 --- a/ghc/compiler/parser/Parser.y +++ b/ghc/compiler/parser/Parser.y @@ -1,6 +1,6 @@ {- -*-haskell-*- ----------------------------------------------------------------------------- -$Id: Parser.y,v 1.101 2002/09/06 14:35:44 simonmar Exp $ +$Id: Parser.y,v 1.102 2002/09/13 15:02:37 simonpj Exp $ Haskell grammar. @@ -17,13 +17,13 @@ import HsSyn import HsTypes ( mkHsTupCon ) import RdrHsSyn -import RnMonad ( ParsedIface(..) ) +import HscTypes ( ParsedIface(..), IsBootInterface ) import Lex import ParseUtil import RdrName -import PrelNames ( mAIN_Name, unitTyCon_RDR, funTyCon_RDR, - listTyCon_RDR, parrTyCon_RDR, tupleTyCon_RDR, - unitCon_RDR, nilCon_RDR, tupleCon_RDR ) +import PrelNames ( mAIN_Name, funTyConName, listTyConName, + parrTyConName, consDataConName, nilDataConName ) +import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon ) import ForeignCall ( Safety(..), CExportSpec(..), CCallConv(..), CCallTarget(..), defaultCCallConv, ) @@ -34,7 +34,8 @@ import Module import CmdLineOpts ( opt_SccProfilingOn, opt_InPackage ) import Type ( Kind, mkArrowKind, liftedTypeKind ) import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), - NewOrData(..), StrictnessMark(..), Activation(..) ) + NewOrData(..), StrictnessMark(..), Activation(..), + FixitySig(..) ) import Panic import GLAEXTS @@ -177,6 +178,7 @@ Conflicts: 21 shift/reduce, -=chak[4Feb2] -} '..' { ITdotdot } -- reserved symbols + ':' { ITcolon } '::' { ITdcolon } '=' { ITequal } '\\' { ITlam } @@ -231,6 +233,15 @@ Conflicts: 21 shift/reduce, -=chak[4Feb2] PRIMFLOAT { ITprimfloat $$ } PRIMDOUBLE { ITprimdouble $$ } CLITLIT { ITlitlit $$ } + +-- Template Haskell +'[|' { ITopenExpQuote } +'[p|' { ITopenPatQuote } +'[t|' { ITopenTypQuote } +'[d|' { ITopenDecQuote } +'|]' { ITcloseQuote } +ID_SPLICE { ITidEscape $$ } -- $x +'$(' { ITparenEscape } -- $( exp ) %monad { P } { thenP } { returnP } %lexer { lexer } { ITeof } @@ -253,9 +264,10 @@ Conflicts: 21 shift/reduce, -=chak[4Feb2] module :: { RdrNameHsModule } : srcloc 'module' modid maybemoddeprec maybeexports 'where' body - { HsModule $3 Nothing $5 (fst $7) (snd $7) $4 $1 } + { HsModule (mkHomeModule $3) Nothing $5 (fst $7) (snd $7) $4 $1 } | srcloc body - { HsModule mAIN_Name Nothing Nothing (fst $2) (snd $2) Nothing $1 } + { HsModule (mkHomeModule mAIN_Name) Nothing Nothing + (fst $2) (snd $2) Nothing $1 } maybemoddeprec :: { Maybe DeprecTxt } : '{-# DEPRECATED' STRING '#-}' { Just $2 } @@ -336,20 +348,21 @@ exportlist :: { [RdrNameIE] } | export { [$1] } | {- empty -} { [] } - -- GHC extension: we allow things like [] and (,,,) to be exported + -- No longer allow things like [] and (,,,) to be exported + -- They are built in syntax, always available export :: { RdrNameIE } : qvar { IEVar $1 } - | gtycon { IEThingAbs $1 } - | gtycon '(' '..' ')' { IEThingAll $1 } - | gtycon '(' ')' { IEThingWith $1 [] } - | gtycon '(' qcnames ')' { IEThingWith $1 (reverse $3) } + | oqtycon { IEThingAbs $1 } + | oqtycon '(' '..' ')' { IEThingAll $1 } + | oqtycon '(' ')' { IEThingWith $1 [] } + | oqtycon '(' qcnames ')' { IEThingWith $1 (reverse $3) } | 'module' modid { IEModuleContents $2 } qcnames :: { [RdrName] } : qcnames ',' qcname { $3 : $1 } | qcname { [$1] } -qcname :: { RdrName } +qcname :: { RdrName } -- Variable or data constructor : qvar { $1 } | gcon { $1 } @@ -369,9 +382,9 @@ importdecl :: { RdrNameImportDecl } : 'import' srcloc maybe_src optqualified modid maybeas maybeimpspec { ImportDecl $5 $3 $4 $6 $7 $2 } -maybe_src :: { WhereFrom } - : '{-# SOURCE' '#-}' { ImportByUserSource } - | {- empty -} { ImportByUser } +maybe_src :: { IsBootInterface } + : '{-# SOURCE' '#-}' { True } + | {- empty -} { False } optqualified :: { Bool } : 'qualified' { True } @@ -449,6 +462,7 @@ topdecl :: { RdrBinding } | 'foreign' fdecl { RdrHsDecl $2 } | '{-# DEPRECATED' deprecations '#-}' { $2 } | '{-# RULES' rules '#-}' { $2 } + | '$(' exp ')' { RdrHsDecl (SpliceD $2) } | decl { $1 } syn_hdr :: { (RdrName, [RdrNameHsTyVar]) } -- We don't retain the syntax of an infix @@ -795,6 +809,7 @@ type :: { RdrNameHsType } gentype :: { RdrNameHsType } : btype { $1 } | btype qtyconop gentype { HsOpTy $1 (HsTyOp $2) $3 } + | btype '`' tyvar '`' gentype { HsOpTy $1 (HsTyOp $3) $5 } | btype '->' gentype { HsOpTy $1 HsArrow $3 } btype :: { RdrNameHsType } @@ -867,9 +882,9 @@ akind :: { Kind } -- Datatype declarations newconstr :: { RdrNameConDecl } - : srcloc conid atype { mkConDecl $2 [] [] (VanillaCon [unbangedType $3]) $1 } + : srcloc conid atype { ConDecl $2 [] [] (PrefixCon [unbangedType $3]) $1 } | srcloc conid '{' var '::' ctype '}' - { mkConDecl $2 [] [] (RecCon [([$4], unbangedType $6)]) $1 } + { ConDecl $2 [] [] (RecCon [($4, unbangedType $6)]) $1 } constrs :: { [RdrNameConDecl] } : {- empty; a GHC extension -} { [] } @@ -881,19 +896,19 @@ constrs1 :: { [RdrNameConDecl] } constr :: { RdrNameConDecl } : srcloc forall context '=>' constr_stuff - { mkConDecl (fst $5) $2 $3 (snd $5) $1 } + { ConDecl (fst $5) $2 $3 (snd $5) $1 } | srcloc forall constr_stuff - { mkConDecl (fst $3) $2 [] (snd $3) $1 } + { ConDecl (fst $3) $2 [] (snd $3) $1 } forall :: { [RdrNameHsTyVar] } : 'forall' tv_bndrs '.' { $2 } | {- empty -} { [] } constr_stuff :: { (RdrName, RdrNameConDetails) } - : btype {% mkVanillaCon $1 [] } - | btype '!' atype satypes {% mkVanillaCon $1 (BangType MarkedUserStrict $3 : $4) } - | gtycon '{' '}' {% mkRecCon $1 [] } - | gtycon '{' fielddecls '}' {% mkRecCon $1 $3 } + : btype {% mkPrefixCon $1 [] } + | btype '!' atype satypes {% mkPrefixCon $1 (BangType MarkedUserStrict $3 : $4) } + | conid '{' '}' { ($1, RecCon []) } + | conid '{' fielddecls '}' { ($1, mkRecCon $3) } | sbtype conop sbtype { ($2, InfixCon $1 $3) } satypes :: { [RdrNameBangType] } @@ -952,7 +967,6 @@ valdef :: { RdrBinding } [ RdrSig (Sig n $6 $4) | n <- $1:$3 ] } - rhs :: { RdrNameGRHSs } : '=' srcloc exp wherebinds { (GRHSs (unguardedRHS $3 $2) $4 placeHolderType)} | gdrhs wherebinds { GRHSs (reverse $1) $2 placeHolderType } @@ -1026,19 +1040,17 @@ aexp :: { RdrNameHsExpr } | aexp1 { $1 } aexp1 :: { RdrNameHsExpr } - : aexp1 '{' fbinds '}' {% (mkRecConstrOrUpdate $1 - (reverse $3)) } - | aexp2 { $1 } - | var_or_con '{|' gentype '|}' { HsApp $1 (HsType $3) } - + : aexp1 '{' fbinds '}' {% (mkRecConstrOrUpdate $1 (reverse $3)) } + | aexp2 { $1 } -var_or_con :: { RdrNameHsExpr } - : qvar { HsVar $1 } - | gcon { HsVar $1 } +-- Here was the syntax for type applications that I was planning +-- but there are difficulties (e.g. what order for type args) +-- so it's not enabled yet. + | qcname '{|' gentype '|}' { (HsApp (HsVar $1) (HsType $3)) } aexp2 :: { RdrNameHsExpr } : ipvar { HsIPVar $1 } - | var_or_con { $1 } + | qcname { HsVar $1 } | literal { HsLit $1 } | INTEGER { HsOverLit (mkHsIntegral $1) } | RATIONAL { HsOverLit (mkHsFractional $1) } @@ -1050,6 +1062,16 @@ aexp2 :: { RdrNameHsExpr } | '(' infixexp qop ')' { (SectionL $2 (HsVar $3)) } | '(' qopm infixexp ')' { (SectionR $2 $3) } | '_' { EWildPat } + + -- MetaHaskell Extension + | ID_SPLICE { mkHsSplice (HsVar (mkUnqual varName $1))} -- $x + | '$(' exp ')' { mkHsSplice $2 } -- $( exp ) + | '[|' exp '|]' { HsBracket (ExpBr $2) } + | '[t|' ctype '|]' { HsBracket (TypBr $2) } + | '[p|' srcloc infixexp '|]' {% checkPattern $2 $3 `thenP` \p -> + returnP (HsBracket (PatBr p)) } + | '[d|' cvtopdecls '|]' { HsBracket (DecBr $2) } + texps :: { [RdrNameHsExpr] } : texps ',' exp { $3 : $1 } @@ -1197,8 +1219,8 @@ fbinds :: { RdrNameHsRecordBinds } | fbind { [$1] } | {- empty -} { [] } -fbind :: { (RdrName, RdrNameHsExpr, Bool) } - : qvar '=' exp { ($1,$3,False) } +fbind :: { (RdrName, RdrNameHsExpr) } + : qvar '=' exp { ($1,$3) } ----------------------------------------------------------------------------- -- Implicit Parameter Bindings @@ -1232,22 +1254,16 @@ deprec_var :: { RdrName } deprec_var : var { $1 } | tycon { $1 } -gtycon :: { RdrName } - : qtycon { $1 } - | '(' qtyconop ')' { $2 } - | '(' ')' { unitTyCon_RDR } - | '(' '->' ')' { funTyCon_RDR } - | '[' ']' { listTyCon_RDR } - | '[:' ':]' { parrTyCon_RDR } - | '(' commas ')' { tupleTyCon_RDR $2 } - gcon :: { RdrName } -- Data constructor namespace - : '(' ')' { unitCon_RDR } - | '[' ']' { nilCon_RDR } - | '(' commas ')' { tupleCon_RDR $2 } + : sysdcon { $1 } | qcon { $1 } -- the case of '[:' ':]' is part of the production `parr' +sysdcon :: { RdrName } -- Data constructor namespace + : '(' ')' { getRdrName unitDataCon } + | '(' commas ')' { getRdrName (tupleCon Boxed $2) } + | '[' ']' { nameRdrName nilDataConName } + var :: { RdrName } : varid { $1 } | '(' varsym ')' { $2 } @@ -1291,13 +1307,17 @@ qconop :: { RdrName } ----------------------------------------------------------------------------- -- Type constructors -tycon :: { RdrName } -- Unqualified - : CONID { mkUnqual tcClsName $1 } +gtycon :: { RdrName } -- A "general" qualified tycon + : oqtycon { $1 } + | '(' ')' { getRdrName unitTyCon } + | '(' commas ')' { getRdrName (tupleTyCon Boxed $2) } + | '(' '->' ')' { nameRdrName funTyConName } + | '[' ']' { nameRdrName listTyConName } + | '[:' ':]' { nameRdrName parrTyConName } -tyconop :: { RdrName } -- Unqualified - : CONSYM { mkUnqual tcClsName $1 } - | '`' tyvar '`' { $2 } - | '`' tycon '`' { $2 } +oqtycon :: { RdrName } -- An "ordinary" qualified tycon + : qtycon { $1 } + | '(' qtyconop ')' { $2 } qtycon :: { RdrName } -- Qualified or unqualified : QCONID { mkQual tcClsName $1 } @@ -1308,6 +1328,14 @@ qtyconop :: { RdrName } -- Qualified or unqualified | '`' QCONID '`' { mkQual tcClsName $2 } | tyconop { $1 } +tycon :: { RdrName } -- Unqualified + : CONID { mkUnqual tcClsName $1 } + +tyconop :: { RdrName } -- Unqualified + : CONSYM { mkUnqual tcClsName $1 } + | '`' tycon '`' { $2 } + + ----------------------------------------------------------------------------- -- Any operator @@ -1407,6 +1435,8 @@ qconsym :: { RdrName } -- Qualified or unqualified consym :: { RdrName } : CONSYM { mkUnqual dataName $1 } + | ':' { nameRdrName consDataConName } + -- ':' means only list cons ----------------------------------------------------------------------------- diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y index 2f6080e8ce..9d45fad1de 100644 --- a/ghc/compiler/parser/ParserCore.y +++ b/ghc/compiler/parser/ParserCore.y @@ -66,7 +66,8 @@ import FastString module :: { RdrNameHsModule } : '%module' modid tdefs vdefgs - { HsModule $2 Nothing Nothing [] ($3 ++ concat $4) Nothing noSrcLoc} + { HsModule (mkHomeModule $2) Nothing Nothing + [] ($3 ++ concat $4) Nothing noSrcLoc} tdefs :: { [RdrNameHsDecl] } : {- empty -} {[]} @@ -80,7 +81,7 @@ tdef :: { RdrNameHsDecl } trep :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) } : {- empty -} { (\ x ts -> Unknown) } - | '=' ty { (\ x ts -> DataCons [ConDecl x x ts [] (VanillaCon [unbangedType $2]) noSrcLoc]) } + | '=' ty { (\ x ts -> DataCons [ConDecl x ts [] (PrefixCon [unbangedType $2]) noSrcLoc]) } tbind :: { HsTyVarBndr RdrName } : name { IfaceTyVar $1 liftedTypeKind } @@ -95,20 +96,20 @@ vdefgs :: { [[RdrNameHsDecl]] } | vdefg ';' vdefgs { ($1:$3) } vdefg :: { [RdrNameHsDecl] } - : '%rec' '{' vdefs1 '}' { $3 } - | vdef { [$1] } + : '%rec' '{' vdefs1 '}' { map CoreD $3 } + | vdef { [CoreD $1] } let_bind :: { UfBinding RdrName } : '%rec' '{' vdefs1 '}' { UfRec (map convBind $3) } | vdef { let (b,r) = convBind $1 in UfNonRec b r } -vdefs1 :: { [RdrNameHsDecl] } +vdefs1 :: { [RdrNameCoreDecl] } : vdef { [$1] } | vdef ';' vdefs1 { $1:$3 } -vdef :: { RdrNameHsDecl } - : qname '::' ty '=' exp { TyClD (CoreDecl $1 $3 $5 noSrcLoc) } +vdef :: { RdrNameCoreDecl } + : qname '::' ty '=' exp { CoreDecl $1 $3 $5 noSrcLoc } vbind :: { (RdrName, RdrNameHsType) } @@ -146,7 +147,7 @@ cons1 :: { [ConDecl RdrName] } con :: { ConDecl RdrName } : q_d_name attbinds atys - { mkConDecl $1 $2 [] (VanillaCon (map unbangedType $3)) noSrcLoc} + { ConDecl $1 $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc} atys :: { [ RdrNameHsType] } : {- empty -} { [] } @@ -240,8 +241,8 @@ q_d_name :: { RdrName } { -convBind :: RdrNameHsDecl -> (UfBinder RdrName, UfExpr RdrName) -convBind (TyClD (CoreDecl n ty rhs _)) = (UfValBinder n ty, rhs) +convBind :: RdrNameCoreDecl -> (UfBinder RdrName, UfExpr RdrName) +convBind (CoreDecl n ty rhs _) = (UfValBinder n ty, rhs) happyError :: P a happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 2f16a89feb..b00d84d308 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -16,6 +16,7 @@ module RdrHsSyn ( RdrNameContext, RdrNameDefaultDecl, RdrNameForeignDecl, + RdrNameCoreDecl, RdrNameGRHS, RdrNameGRHSs, RdrNameHsBinds, @@ -46,9 +47,9 @@ module RdrHsSyn ( extractHsTyRdrNames, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars, extractGenericPatTyVars, - mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl, + mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional, - mkHsDo, + mkHsDo, mkHsSplice, cvBinds, cvMonoBindsAndSigs, @@ -60,13 +61,10 @@ module RdrHsSyn ( #include "HsVersions.h" import HsSyn -- Lots of it -import OccName ( mkClassTyConOcc, mkClassDataConOcc, mkWorkerOcc, - mkSuperDictSelOcc, mkDefaultMethodOcc, mkGenOcc1, - mkGenOcc2 - ) +import OccName ( mkDefaultMethodOcc, mkVarOcc ) import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, rdrNameOcc, isRdrTyVar ) import List ( nub ) -import BasicTypes ( RecFlag(..) ) +import BasicTypes ( RecFlag(..), FixitySig ) import Class ( DefMeth (..) ) \end{code} @@ -78,38 +76,39 @@ import Class ( DefMeth (..) ) %************************************************************************ \begin{code} -type RdrNameArithSeqInfo = ArithSeqInfo RdrName RdrNamePat +type RdrNameArithSeqInfo = ArithSeqInfo RdrName type RdrNameBangType = BangType RdrName type RdrNameClassOpSig = Sig RdrName type RdrNameConDecl = ConDecl RdrName -type RdrNameConDetails = ConDetails RdrName +type RdrNameConDetails = HsConDetails RdrName RdrNameBangType type RdrNameContext = HsContext RdrName -type RdrNameHsDecl = HsDecl RdrName RdrNamePat +type RdrNameHsDecl = HsDecl RdrName type RdrNameDefaultDecl = DefaultDecl RdrName type RdrNameForeignDecl = ForeignDecl RdrName -type RdrNameGRHS = GRHS RdrName RdrNamePat -type RdrNameGRHSs = GRHSs RdrName RdrNamePat -type RdrNameHsBinds = HsBinds RdrName RdrNamePat -type RdrNameHsExpr = HsExpr RdrName RdrNamePat -type RdrNameHsModule = HsModule RdrName RdrNamePat +type RdrNameCoreDecl = CoreDecl RdrName +type RdrNameGRHS = GRHS RdrName +type RdrNameGRHSs = GRHSs RdrName +type RdrNameHsBinds = HsBinds RdrName +type RdrNameHsExpr = HsExpr RdrName +type RdrNameHsModule = HsModule RdrName type RdrNameIE = IE RdrName type RdrNameImportDecl = ImportDecl RdrName -type RdrNameInstDecl = InstDecl RdrName RdrNamePat -type RdrNameMatch = Match RdrName RdrNamePat -type RdrNameMonoBinds = MonoBinds RdrName RdrNamePat +type RdrNameInstDecl = InstDecl RdrName +type RdrNameMatch = Match RdrName +type RdrNameMonoBinds = MonoBinds RdrName type RdrNamePat = InPat RdrName type RdrNameHsType = HsType RdrName type RdrNameHsTyVar = HsTyVarBndr RdrName type RdrNameSig = Sig RdrName -type RdrNameStmt = Stmt RdrName RdrNamePat -type RdrNameTyClDecl = TyClDecl RdrName RdrNamePat +type RdrNameStmt = Stmt RdrName +type RdrNameTyClDecl = TyClDecl RdrName type RdrNameRuleBndr = RuleBndr RdrName -type RdrNameRuleDecl = RuleDecl RdrName RdrNamePat +type RdrNameRuleDecl = RuleDecl RdrName type RdrNameDeprecation = DeprecDecl RdrName type RdrNameFixitySig = FixitySig RdrName -type RdrNameHsRecordBinds = HsRecordBinds RdrName RdrNamePat +type RdrNameHsRecordBinds = HsRecordBinds RdrName \end{code} @@ -171,8 +170,8 @@ extractGenericPatTyVars binds get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms get other acc = acc - get_m (Match (TypePatIn ty : _) _ _) acc = extract_ty ty acc - get_m other acc = acc + get_m (Match (TypePat ty : _) _ _) acc = extract_ty ty acc + get_m other acc = acc \end{code} @@ -196,41 +195,17 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds, - tcdSysNames = new_names, tcdLoc = loc } - where - cls_occ = rdrNameOcc cname - data_occ = mkClassDataConOcc cls_occ - dname = mkRdrUnqual data_occ - dwname = mkRdrUnqual (mkWorkerOcc data_occ) - tname = mkRdrUnqual (mkClassTyConOcc cls_occ) - sc_sel_names = [ mkRdrUnqual (mkSuperDictSelOcc n cls_occ) - | n <- [1..length cxt]] - -- We number off the superclass selectors, 1, 2, 3 etc so that we - -- can construct names for the selectors. Thus - -- class (C a, C b) => D a b where ... - -- gives superclass selectors - -- D_sc1, D_sc2 - -- (We used to call them D_C, but now we can have two different - -- superclasses both called C!) - new_names = mkClassDeclSysNames (tname, dname, dwname, sc_sel_names) + tcdLoc = loc } mkTyData new_or_data (context, tname, tyvars) data_cons maybe src - = let t_occ = rdrNameOcc tname - name1 = mkRdrUnqual (mkGenOcc1 t_occ) - name2 = mkRdrUnqual (mkGenOcc2 t_occ) - in TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname, - tcdTyVars = tyvars, tcdCons = data_cons, - tcdDerivs = maybe, tcdLoc = src, tcdSysNames = [name1, name2] } + = TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname, + tcdTyVars = tyvars, tcdCons = data_cons, + tcdDerivs = maybe, tcdLoc = src, tcdGeneric = Nothing } mkClassOpSigDM op ty loc = ClassOpSig op (DefMeth dm_rn) ty loc where dm_rn = mkRdrUnqual (mkDefaultMethodOcc (rdrNameOcc op)) - -mkConDecl cname ex_vars cxt details loc - = ConDecl cname wkr_name ex_vars cxt details loc - where - wkr_name = mkRdrUnqual (mkWorkerOcc (rdrNameOcc cname)) \end{code} \begin{code} @@ -262,6 +237,13 @@ mkNPlusKPat n k = NPlusKPatIn n k placeHolderName mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc \end{code} +\begin{code} +mkHsSplice e = HsSplice unqualSplice e + +unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice")) + -- A name (uniquified later) to + -- identify the splice +\end{code} %************************************************************************ %* * diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index e97d2882b6..450dea50dd 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -13,12 +13,6 @@ module PrelInfo ( ghcPrimExports, cCallableClassDecl, cReturnableClassDecl, assertDecl, - -- Primop RdrNames - eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR, - eqH_Addr_RDR, ltH_Addr_RDR, eqH_Float_RDR, ltH_Float_RDR, - eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR, ltH_Int_RDR, - geH_RDR, leH_RDR, minusH_RDR, tagToEnumH_RDR, - -- Random other things maybeCharLikeCon, maybeIntLikeCon, @@ -32,13 +26,13 @@ module PrelInfo ( import PrelNames -- Prelude module names -import PrimOp ( PrimOp(..), allThePrimOps, primOpRdrName, primOpOcc ) +import PrimOp ( allThePrimOps, primOpOcc ) import DataCon ( DataCon ) import Id ( idName ) import MkId ( mkPrimOpId, wiredInIds ) import MkId -- All of it, for re-export -import Name ( nameOccName, nameRdrName ) -import RdrName ( mkRdrUnqual ) +import Name ( nameOccName ) +import RdrName ( mkRdrUnqual, getRdrName ) import HsSyn ( HsTyVarBndr(..), TyClDecl(..), HsType(..) ) import OccName ( mkVarOcc ) import TysPrim ( primTyCons ) @@ -100,7 +94,6 @@ wired-in Ids, and the CCallable & CReturnable classes. ghcPrimExports :: [RdrAvailInfo] = AvailTC cCallableOcc [ cCallableOcc ] : AvailTC cReturnableOcc [ cReturnableOcc ] : - Avail (nameOccName assertName) : -- doesn't have an Id map (Avail . nameOccName . idName) ghcPrimIds ++ map (Avail . primOpOcc) allThePrimOps ++ [ AvailTC occ [occ] | @@ -112,7 +105,7 @@ ghcPrimExports :: [RdrAvailInfo] assertDecl = IfaceSig { - tcdName = nameRdrName assertName, + tcdName = getRdrName assertName, tcdType = HsForAllTy (Just [liftedAlpha]) [] (HsTyVar alpha), tcdIdInfo = [], tcdLoc = noSrcLoc @@ -120,7 +113,7 @@ assertDecl cCallableClassDecl = mkClassDecl - ([], nameRdrName cCallableClassName, [openAlpha]) + ([], getRdrName cCallableClassName, [openAlpha]) [] -- no fds [] -- no sigs Nothing -- no mbinds @@ -128,7 +121,7 @@ cCallableClassDecl cReturnableClassDecl = mkClassDecl - ([], nameRdrName cReturnableClassName, [openAlpha]) + ([], getRdrName cReturnableClassName, [openAlpha]) [] -- no fds [] -- no sigs Nothing -- no mbinds @@ -139,35 +132,6 @@ openAlpha = IfaceTyVar alpha openTypeKind liftedAlpha = IfaceTyVar alpha liftedTypeKind \end{code} -%************************************************************************ -%* * -\subsection{RdrNames for the primops} -%* * -%************************************************************************ - -These can't be in PrelNames, because we get the RdrName from the PrimOp, -which is above PrelNames in the module hierarchy. - -\begin{code} -eqH_Char_RDR = primOpRdrName CharEqOp -ltH_Char_RDR = primOpRdrName CharLtOp -eqH_Word_RDR = primOpRdrName WordEqOp -ltH_Word_RDR = primOpRdrName WordLtOp -eqH_Addr_RDR = primOpRdrName AddrEqOp -ltH_Addr_RDR = primOpRdrName AddrLtOp -eqH_Float_RDR = primOpRdrName FloatEqOp -ltH_Float_RDR = primOpRdrName FloatLtOp -eqH_Double_RDR = primOpRdrName DoubleEqOp -ltH_Double_RDR = primOpRdrName DoubleLtOp -eqH_Int_RDR = primOpRdrName IntEqOp -ltH_Int_RDR = primOpRdrName IntLtOp -geH_RDR = primOpRdrName IntGeOp -leH_RDR = primOpRdrName IntLeOp -minusH_RDR = primOpRdrName IntSubOp - -tagToEnumH_RDR = primOpRdrName TagToEnumOp -\end{code} - %************************************************************************ %* * diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index a2487ce0eb..aa711d2c03 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -1,32 +1,65 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[PrelNames]{Definitions of prelude modules} +\section[PrelNames]{Definitions of prelude modules and names} + + +-- MetaHaskell Extension +to do -- three things +1) Allocate a key +2) Make a "Name" +3) Add the name to knownKeyNames + The strings identify built-in prelude modules. They are defined here so as to avod -[oh dear, looks like the recursive module monster caught up with - and gobbled whoever was writing the above :-) -- SOF ] +* ModuleNames for prelude modules, + e.g. pREL_BASE_Name :: ModuleName + +* Modules for prelude modules + e.g. pREL_Base :: Module + +* Uniques for Ids, DataCons, TyCons and Classes that the compiler + "knows about" in some way + e.g. intTyConKey :: Unique + minusClassOpKey :: Unique + +* Names for Ids, DataCons, TyCons and Classes that the compiler + "knows about" in some way + e.g. intTyConName :: Name + minusName :: Name + One of these Names contains + (a) the module and occurrence name of the thing + (b) its Unique + The may way the compiler "knows about" one of these things is + where the type checker or desugarer needs to look it up. For + example, when desugaring list comprehensions the desugarer + needs to conjure up 'foldr'. It does this by looking up + foldrName in the environment. + +* RdrNames for Ids, DataCons etc that the compiler may emit into + generated code (e.g. for deriving). It's not necessary to know + the uniques for these guys, only their names + \begin{code} module PrelNames ( Unique, Uniquable(..), hasKey, -- Re-exported for convenience ----------------------------------------------------------- - module PrelNames, -- A huge bunch of (a) RdrNames, e.g. intTyCon_RDR - -- (b) Uniques e.g. intTyConKey + module PrelNames, -- A huge bunch of (a) Names, e.g. intTyConName + -- (b) Uniques e.g. intTyConKey -- So many that we export them all ----------------------------------------------------------- - knownKeyNames, - mkTupNameStr, mkTupConRdrName, + knownKeyNames, templateHaskellNames, + mkTupNameStr, isBuiltInSyntaxName, ------------------------------------------------------------ -- Goups of classes and types needsDataDeclCtxtClassKeys, cCallishClassKeys, noDictClassKeys, fractionalClassKeys, numericClassKeys, standardClassKeys, - derivingOccurrences, -- For a given class C, this tells what other derivableClassKeys, -- things are needed as a result of a -- deriving(C) clause numericTyKeys, cCallishTyKeys, @@ -36,25 +69,33 @@ module PrelNames ( #include "HsVersions.h" -import Module ( ModuleName, mkPrelModule, mkHomeModule, mkModuleName ) -import OccName ( NameSpace, UserFS, varName, dataName, tcName, clsName, +import Module ( ModuleName, mkPrelModule, mkHomeModule, mkModuleName,mkVanillaModule ) +import OccName ( UserFS, dataName, tcName, clsName, mkKindOccFS, mkOccFS ) -import RdrName ( RdrName, mkOrig, mkUnqual ) -import UniqFM + +-- to avoid clashes with Meta.var we must make a local alias for OccName.varName +-- we do this by removing varName from the import of OccName above, making +-- a qualified instance of OccName and using OccNameAlias.varName where varName +-- ws previously used in this file. +import qualified OccName as OccNameAlias + + +import RdrName ( RdrName, nameRdrName, mkOrig, rdrNameOcc ) import Unique ( Unique, Uniquable(..), hasKey, mkPreludeMiscIdUnique, mkPreludeDataConUnique, mkPreludeTyConUnique, mkPreludeClassUnique, - mkTupleTyConUnique + mkTupleTyConUnique, isTupleKey ) -import BasicTypes ( Boxity(..), Arity ) -import UniqFM ( UniqFM, listToUFM ) -import Name ( Name, mkInternalName, mkKnownKeyExternalName, nameRdrName ) -import RdrName ( rdrNameOcc ) -import SrcLoc ( builtinSrcLoc, noSrcLoc ) +import BasicTypes ( Boxity(..) ) +import Name ( Name, mkInternalName, mkKnownKeyExternalName, mkWiredInName, nameUnique ) +import NameSet ( NameSet, mkNameSet ) +import SrcLoc ( noSrcLoc ) import Util ( nOfThem ) import Panic ( panic ) import FastString + + \end{code} @@ -67,20 +108,39 @@ import FastString This *local* name is used by the interactive stuff \begin{code} -itName uniq = mkInternalName uniq (mkOccFS varName FSLIT("it")) noSrcLoc +itName uniq = mkInternalName uniq (mkOccFS OccNameAlias.varName FSLIT("it")) noSrcLoc \end{code} \begin{code} -- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly -- during compiler debugging. mkUnboundName :: RdrName -> Name -mkUnboundName rdr_name = mkInternalName unboundKey (rdrNameOcc rdr_name) builtinSrcLoc +mkUnboundName rdr_name = mkInternalName unboundKey (rdrNameOcc rdr_name) noSrcLoc isUnboundName :: Name -> Bool isUnboundName name = name `hasKey` unboundKey \end{code} +%************************************************************************ +%* * +\subsection{Built-in-syntax names +%* * +%************************************************************************ + +Built-in syntax names are parsed directly into Exact RdrNames. +This predicate just identifies them. + +\begin{code} +isBuiltInSyntaxName :: Name -> Bool +isBuiltInSyntaxName n + = isTupleKey uniq + || uniq `elem` [listTyConKey, nilDataConKey, consDataConKey, + funTyConKey, parrTyConKey] + where + uniq = nameUnique n +\end{code} + %************************************************************************ %* * \subsection{Known key Names} @@ -91,11 +151,13 @@ This section tells what the compiler knows about the assocation of names with uniques. These ones are the *non* wired-in ones. The wired in ones are defined in TysWiredIn etc. + +MetaHaskell Extension +It is here that the names defiend in module Meta must be added \begin{code} knownKeyNames :: [Name] knownKeyNames - = [ - -- Type constructors (synonyms especially) + = [ -- Type constructors (synonyms especially) ioTyConName, ioDataConName, runIOName, orderingTyConName, @@ -118,101 +180,114 @@ knownKeyNames enumClassName, -- derivable monadClassName, functorClassName, - showClassName, -- derivable realClassName, -- numeric integralClassName, -- numeric fractionalClassName, -- numeric floatingClassName, -- numeric realFracClassName, -- numeric realFloatClassName, -- numeric - readClassName, -- derivable - ixClassName, -- derivable (but it isn't Prelude.Ix; hmmm) cCallableClassName, -- mentioned, ccallish cReturnableClassName, -- mentioned, ccallish - -- ClassOps - fromIntegerName, - negateName, - geName, - minusName, - enumFromName, - enumFromThenName, - enumFromToName, - enumFromThenToName, - fromEnumName, - toEnumName, - eqName, - thenMName, - bindMName, - returnMName, - failMName, - fromRationalName, - - -- not class methods, but overloaded (for parallel arrays) - enumFromToPName, - enumFromThenToPName, - - deRefStablePtrName, + -- Numeric stuff + negateName, minusName, + fromRationalName, fromIntegerName, + geName, eqName, + + -- Enum stuff + enumFromName, enumFromThenName, + enumFromThenToName, enumFromToName, + enumFromToPName, enumFromThenToPName, + + -- Monad stuff + thenMName, bindMName, returnMName, failMName, + thenIOName, bindIOName, returnIOName, failIOName, + + -- Ix stuff + ixClassName, + + -- Show stuff + showClassName, + + -- Read stuff + readClassName, + + -- Stable pointers newStablePtrName, - bindIOName, - thenIOName, - returnIOName, - failIOName, -- Strings and lists - mapName, - appendName, - unpackCStringName, - unpackCStringAppendName, - unpackCStringFoldrName, - unpackCStringUtf8Name, + unpackCStringName, unpackCStringAppendName, + unpackCStringFoldrName, unpackCStringUtf8Name, -- List operations - concatName, - filterName, - zipName, - foldrName, - buildName, - augmentName, + concatName, filterName, + zipName, foldrName, buildName, augmentName, appendName, -- Parallel array operations - nullPName, - lengthPName, - replicatePName, - mapPName, - filterPName, - zipPName, - crossPName, - indexPName, - toPName, - bpermutePName, - bpermuteDftPName, - indexOfPName, - + nullPName, lengthPName, replicatePName, mapPName, + filterPName, zipPName, crossPName, indexPName, + toPName, bpermutePName, bpermuteDftPName, indexOfPName, + + -- MetaHaskell Extension, "the smart constructors" + -- text1 from Meta/work/gen.hs + intLName, + charLName, + plitName, + pvarName, + ptupName, + pconName, + ptildeName, + paspatName, + pwildName, + varName, + conName, + litName, + appName, + infixEName, + lamName, + tupName, + doEName, + compName, + listExpName, + condName, + letEName, + caseEName, + infixAppName, + sectionLName, + sectionRName, + guardedName, + normalName, + bindStName, + letStName, + noBindStName, + parStName, + fromName, + fromThenName, + fromToName, + fromThenToName, + liftName, + gensymName, + returnQName, + bindQName, + funName, + valName, + protoName, matchName, clauseName, + exprTyConName, declTyConName, pattTyConName, mtchTyConName, clseTyConName, + qTyConName, expTyConName, matTyConName, clsTyConName, + -- FFI primitive types that are not wired-in. - int8TyConName, - int16TyConName, - int32TyConName, - int64TyConName, - word8TyConName, - word16TyConName, - word32TyConName, - word64TyConName, + int8TyConName, int16TyConName, int32TyConName, int64TyConName, + word8TyConName, word16TyConName, word32TyConName, word64TyConName, -- Others - unsafeCoerceName, - otherwiseIdName, - plusIntegerName, - timesIntegerName, - eqStringName, - assertName, - runSTRepName, - printName, - splitName, fstName, sndName, -- Used by splittery - - -- Others (needed for flattening and not mentioned before) - andName, - orName + unsafeCoerceName, otherwiseIdName, + plusIntegerName, timesIntegerName, + eqStringName, assertName, runSTRepName, + printName, splitName, fstName, sndName, + errorName, + + -- Booleans + andName, orName ] monadNames :: [Name] -- The monad ops need by a HsDo @@ -226,6 +301,8 @@ monadNames = [returnMName, failMName, bindMName, thenMName] %* * %************************************************************************ + +--MetaHaskell Extension Add a new module here \begin{code} pRELUDE_Name = mkModuleName "Prelude" gHC_PRIM_Name = mkModuleName "GHC.Prim" -- Primitive types and values @@ -277,6 +354,10 @@ pREL_FLOAT = mkPrelModule pREL_FLOAT_Name pRELUDE = mkPrelModule pRELUDE_Name iNTERACTIVE = mkHomeModule (mkModuleName "$Interactive") + +-- MetaHaskell Extension text2 from Meta/work/gen.hs +mETA_META_Name = mkModuleName "Language.Haskell.THSyntax" + \end{code} %************************************************************************ @@ -301,31 +382,123 @@ mkTupNameStr Unboxed 2 = (gHC_PRIM_Name, mkFastString "(#,#)") mkTupNameStr Unboxed 3 = (gHC_PRIM_Name, mkFastString "(#,,#)") mkTupNameStr Unboxed 4 = (gHC_PRIM_Name, mkFastString "(#,,,#)") mkTupNameStr Unboxed n = (gHC_PRIM_Name, mkFastString ("(#" ++ nOfThem (n-1) ',' ++ "#)")) - -mkTupConRdrName :: NameSpace -> Boxity -> Arity -> RdrName -mkTupConRdrName space boxity arity = case mkTupNameStr boxity arity of - (mod, occ) -> mkOrig space mod occ \end{code} %************************************************************************ %* * -\subsection{Unqualified RdrNames} + RdrNames %* * %************************************************************************ \begin{code} -main_RDR_Unqual :: RdrName -main_RDR_Unqual = mkUnqual varName FSLIT("main") --- Don't get a RdrName from PrelNames.mainName, because nameRdrName --- gets an Orig RdrName, and we want a Qual or Unqual one. An Unqual --- one will do fine. +getTag_RDR = nameRdrName getTagName + +eq_RDR = nameRdrName eqName +ge_RDR = nameRdrName geName +ne_RDR = varQual_RDR pREL_BASE_Name FSLIT("/=") +le_RDR = varQual_RDR pREL_BASE_Name FSLIT("<=") +gt_RDR = varQual_RDR pREL_BASE_Name FSLIT(">") +compare_RDR = varQual_RDR pREL_BASE_Name FSLIT("compare") +ltTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("LT") +eqTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("EQ") +gtTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("GT") + +eqClass_RDR = nameRdrName eqClassName +numClass_RDR = nameRdrName numClassName +ordClass_RDR = nameRdrName ordClassName +enumClass_RDR = nameRdrName enumClassName +monadClass_RDR = nameRdrName monadClassName +cCallableClass_RDR = nameRdrName cCallableClassName +cReturnableClass_RDR = nameRdrName cReturnableClassName + +map_RDR = varQual_RDR pREL_BASE_Name FSLIT("map") +append_RDR = varQual_RDR pREL_BASE_Name FSLIT("++") + +foldr_RDR = nameRdrName foldrName +build_RDR = nameRdrName buildName +returnM_RDR = nameRdrName returnMName +bindM_RDR = nameRdrName bindMName +failM_RDR = nameRdrName failMName + +false_RDR = nameRdrName falseDataConName +true_RDR = nameRdrName trueDataConName +and_RDR = nameRdrName andName + +error_RDR = nameRdrName errorName + +fromEnum_RDR = varQual_RDR pREL_ENUM_Name FSLIT("fromEnum") +toEnum_RDR = varQual_RDR pREL_ENUM_Name FSLIT("toEnum") +mkInt_RDR = nameRdrName intDataConName + +enumFrom_RDR = nameRdrName enumFromName +enumFromTo_RDR = nameRdrName enumFromToName +enumFromThen_RDR = nameRdrName enumFromThenName +enumFromThenTo_RDR = nameRdrName enumFromThenToName + +ratioDataCon_RDR = nameRdrName ratioDataConName +plusInteger_RDR = nameRdrName plusIntegerName +timesInteger_RDR = nameRdrName timesIntegerName + +ioDataCon_RDR = nameRdrName ioDataConName + +eqString_RDR = nameRdrName eqStringName +unpackCString_RDR = nameRdrName unpackCStringName +unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName +unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name + +newStablePtr_RDR = nameRdrName newStablePtrName + +bindIO_RDR = nameRdrName bindIOName +returnIO_RDR = nameRdrName returnIOName + +fromInteger_RDR = nameRdrName fromIntegerName +fromRational_RDR = nameRdrName fromRationalName +minus_RDR = nameRdrName minusName +times_RDR = varQual_RDR pREL_NUM_Name FSLIT("*") +plus_RDR = varQual_RDR pREL_NUM_Name FSLIT("+") + +compose_RDR = varQual_RDR pREL_BASE_Name FSLIT(".") + +not_RDR = varQual_RDR pREL_BASE_Name FSLIT("not") +succ_RDR = varQual_RDR pREL_ENUM_Name FSLIT("succ") +pred_RDR = varQual_RDR pREL_ENUM_Name FSLIT("pred") +minBound_RDR = varQual_RDR pREL_ENUM_Name FSLIT("minBound") +maxBound_RDR = varQual_RDR pREL_ENUM_Name FSLIT("maxBound") +range_RDR = varQual_RDR pREL_ARR_Name FSLIT("range") +inRange_RDR = varQual_RDR pREL_ARR_Name FSLIT("inRange") +index_RDR = varQual_RDR pREL_ARR_Name FSLIT("index") + +readList_RDR = varQual_RDR pREL_READ_Name FSLIT("readList") +readListDefault_RDR = varQual_RDR pREL_READ_Name FSLIT("readListDefault") +readListPrec_RDR = varQual_RDR pREL_READ_Name FSLIT("readListPrec") +readListPrecDefault_RDR = varQual_RDR pREL_READ_Name FSLIT("readListPrecDefault") +readPrec_RDR = varQual_RDR pREL_READ_Name FSLIT("readPrec") +parens_RDR = varQual_RDR pREL_READ_Name FSLIT("parens") +choose_RDR = varQual_RDR pREL_READ_Name FSLIT("choose") +lexP_RDR = varQual_RDR pREL_READ_Name FSLIT("lexP") + +punc_RDR = dataQual_RDR lEX_Name FSLIT("Punc") +ident_RDR = dataQual_RDR lEX_Name FSLIT("Ident") +symbol_RDR = dataQual_RDR lEX_Name FSLIT("Symbol") + +step_RDR = varQual_RDR rEAD_PREC_Name FSLIT("step") +alt_RDR = varQual_RDR rEAD_PREC_Name FSLIT("+++") +reset_RDR = varQual_RDR rEAD_PREC_Name FSLIT("reset") +prec_RDR = varQual_RDR rEAD_PREC_Name FSLIT("prec") + +showList_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showList") +showList___RDR = varQual_RDR pREL_SHOW_Name FSLIT("showList__") +showsPrec_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showsPrec") +showString_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showString") +showSpace_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showSpace") +showParen_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showParen") \end{code} %************************************************************************ %* * -\subsection{Commonly-used RdrNames} +\subsection{Known-key names} %* * %************************************************************************ @@ -333,6 +506,10 @@ Many of these Names are not really "built in", but some parts of the compiler (notably the deriving mechanism) need to mention their names, and it's convenient to write them all down in one place. +--MetaHaskell Extension add the constrs and the lower case case +-- guys as well (perhaps) e.g. see trueDataConName below + + \begin{code} dollarMainName = varQual mAIN_Name FSLIT("$main") dollarMainKey runIOName = varQual pREL_TOP_HANDLER_Name FSLIT("runIO") runMainKey @@ -376,56 +553,47 @@ threadIdPrimTyConName = tcQual gHC_PRIM_Name FSLIT("ThreadId#") threadI cCallableClassName = clsQual gHC_PRIM_Name FSLIT("CCallable") cCallableClassKey cReturnableClassName = clsQual gHC_PRIM_Name FSLIT("CReturnable") cReturnableClassKey +getTagName = wVarQual gHC_PRIM_Name FSLIT("getTag#") getTagIdKey +unsafeCoerceName = wVarQual gHC_PRIM_Name FSLIT("unsafeCoerce#") unsafeCoerceIdKey +nullAddrName = wVarQual gHC_PRIM_Name FSLIT("nullAddr#") nullAddrIdKey +seqName = wVarQual gHC_PRIM_Name FSLIT("seq") seqIdKey +realWorldName = wVarQual gHC_PRIM_Name FSLIT("realWorld#") realWorldPrimIdKey + -- PrelBase data types and constructors -charTyConName = tcQual pREL_BASE_Name FSLIT("Char") charTyConKey -charDataConName = dataQual pREL_BASE_Name FSLIT("C#") charDataConKey -intTyConName = tcQual pREL_BASE_Name FSLIT("Int") intTyConKey -intDataConName = dataQual pREL_BASE_Name FSLIT("I#") intDataConKey +charTyConName = wTcQual pREL_BASE_Name FSLIT("Char") charTyConKey +charDataConName = wDataQual pREL_BASE_Name FSLIT("C#") charDataConKey +intTyConName = wTcQual pREL_BASE_Name FSLIT("Int") intTyConKey +intDataConName = wDataQual pREL_BASE_Name FSLIT("I#") intDataConKey orderingTyConName = tcQual pREL_BASE_Name FSLIT("Ordering") orderingTyConKey -boolTyConName = tcQual pREL_BASE_Name FSLIT("Bool") boolTyConKey -falseDataConName = dataQual pREL_BASE_Name FSLIT("False") falseDataConKey -trueDataConName = dataQual pREL_BASE_Name FSLIT("True") trueDataConKey -listTyConName = tcQual pREL_BASE_Name FSLIT("[]") listTyConKey -nilDataConName = dataQual pREL_BASE_Name FSLIT("[]") nilDataConKey -consDataConName = dataQual pREL_BASE_Name FSLIT(":") consDataConKey - --- PrelTup -fstName = varQual pREL_TUP_Name FSLIT("fst") fstIdKey -sndName = varQual pREL_TUP_Name FSLIT("snd") sndIdKey +boolTyConName = wTcQual pREL_BASE_Name FSLIT("Bool") boolTyConKey +falseDataConName = wDataQual pREL_BASE_Name FSLIT("False") falseDataConKey +trueDataConName = wDataQual pREL_BASE_Name FSLIT("True") trueDataConKey +listTyConName = wTcQual pREL_BASE_Name FSLIT("[]") listTyConKey +nilDataConName = wDataQual pREL_BASE_Name FSLIT("[]") nilDataConKey +consDataConName = wDataQual pREL_BASE_Name FSLIT(":") consDataConKey +eqName = varQual pREL_BASE_Name FSLIT("==") eqClassOpKey +geName = varQual pREL_BASE_Name FSLIT(">=") geClassOpKey -- Generics crossTyConName = tcQual pREL_BASE_Name FSLIT(":*:") crossTyConKey crossDataConName = dataQual pREL_BASE_Name FSLIT(":*:") crossDataConKey -plusTyConName = tcQual pREL_BASE_Name FSLIT(":+:") plusTyConKey -inlDataConName = dataQual pREL_BASE_Name FSLIT("Inl") inlDataConKey -inrDataConName = dataQual pREL_BASE_Name FSLIT("Inr") inrDataConKey -genUnitTyConName = tcQual pREL_BASE_Name FSLIT("Unit") genUnitTyConKey -genUnitDataConName = dataQual pREL_BASE_Name FSLIT("Unit") genUnitDataConKey - --- Random PrelBase functions -unsafeCoerceName = varQual pREL_BASE_Name FSLIT("unsafeCoerce") - unsafeCoerceIdKey -otherwiseIdName = varQual pREL_BASE_Name FSLIT("otherwise") otherwiseIdKey -appendName = varQual pREL_BASE_Name FSLIT("++") appendIdKey -foldrName = varQual pREL_BASE_Name FSLIT("foldr") foldrIdKey -mapName = varQual pREL_BASE_Name FSLIT("map") mapIdKey -buildName = varQual pREL_BASE_Name FSLIT("build") buildIdKey -augmentName = varQual pREL_BASE_Name FSLIT("augment") augmentIdKey -eqStringName = varQual pREL_BASE_Name FSLIT("eqString") eqStringIdKey -andName = varQual pREL_BASE_Name FSLIT("&&") andIdKey -orName = varQual pREL_BASE_Name FSLIT("||") orIdKey +plusTyConName = wTcQual pREL_BASE_Name FSLIT(":+:") plusTyConKey +inlDataConName = wDataQual pREL_BASE_Name FSLIT("Inl") inlDataConKey +inrDataConName = wDataQual pREL_BASE_Name FSLIT("Inr") inrDataConKey +genUnitTyConName = wTcQual pREL_BASE_Name FSLIT("Unit") genUnitTyConKey +genUnitDataConName = wDataQual pREL_BASE_Name FSLIT("Unit") genUnitDataConKey --- Strings +-- Base strings Strings unpackCStringName = varQual pREL_BASE_Name FSLIT("unpackCString#") unpackCStringIdKey unpackCStringAppendName = varQual pREL_BASE_Name FSLIT("unpackAppendCString#") unpackCStringAppendIdKey unpackCStringFoldrName = varQual pREL_BASE_Name FSLIT("unpackFoldrCString#") unpackCStringFoldrIdKey unpackCStringUtf8Name = varQual pREL_BASE_Name FSLIT("unpackCStringUtf8#") unpackCStringUtf8IdKey +eqStringName = varQual pREL_BASE_Name FSLIT("eqString") eqStringIdKey --- Classes Eq and Ord +-- Base classes (Eq, Ord, Functor) eqClassName = clsQual pREL_BASE_Name FSLIT("Eq") eqClassKey +functorClassName = clsQual pREL_BASE_Name FSLIT("Functor") functorClassKey ordClassName = clsQual pREL_BASE_Name FSLIT("Ord") ordClassKey -eqName = varQual pREL_BASE_Name FSLIT("==") eqClassOpKey -geName = varQual pREL_BASE_Name FSLIT(">=") geClassOpKey -- Class Monad monadClassName = clsQual pREL_BASE_Name FSLIT("Monad") monadClassKey @@ -434,14 +602,21 @@ bindMName = varQual pREL_BASE_Name FSLIT(">>=") bindMClassOpKey returnMName = varQual pREL_BASE_Name FSLIT("return") returnMClassOpKey failMName = varQual pREL_BASE_Name FSLIT("fail") failMClassOpKey --- Class Functor -functorClassName = clsQual pREL_BASE_Name FSLIT("Functor") functorClassKey --- Class Show -showClassName = clsQual pREL_SHOW_Name FSLIT("Show") showClassKey +-- Random PrelBase functions +otherwiseIdName = varQual pREL_BASE_Name FSLIT("otherwise") otherwiseIdKey +foldrName = varQual pREL_BASE_Name FSLIT("foldr") foldrIdKey +buildName = varQual pREL_BASE_Name FSLIT("build") buildIdKey +augmentName = varQual pREL_BASE_Name FSLIT("augment") augmentIdKey +appendName = varQual pREL_BASE_Name FSLIT("++") appendIdKey +andName = varQual pREL_BASE_Name FSLIT("&&") andIdKey +orName = varQual pREL_BASE_Name FSLIT("||") orIdKey +assertName = varQual pREL_BASE_Name FSLIT("assert") assertIdKey +lazyIdName = wVarQual pREL_BASE_Name FSLIT("lazy") lazyIdKey --- Class Read -readClassName = clsQual pREL_READ_Name FSLIT("Read") readClassKey +-- PrelTup +fstName = varQual pREL_TUP_Name FSLIT("fst") fstIdKey +sndName = varQual pREL_TUP_Name FSLIT("snd") sndIdKey -- Module PrelNum numClassName = clsQual pREL_NUM_Name FSLIT("Num") numClassKey @@ -450,9 +625,9 @@ minusName = varQual pREL_NUM_Name FSLIT("-") minusClassOpKey negateName = varQual pREL_NUM_Name FSLIT("negate") negateClassOpKey plusIntegerName = varQual pREL_NUM_Name FSLIT("plusInteger") plusIntegerIdKey timesIntegerName = varQual pREL_NUM_Name FSLIT("timesInteger") timesIntegerIdKey -integerTyConName = tcQual pREL_NUM_Name FSLIT("Integer") integerTyConKey -smallIntegerDataConName = dataQual pREL_NUM_Name FSLIT("S#") smallIntegerDataConKey -largeIntegerDataConName = dataQual pREL_NUM_Name FSLIT("J#") largeIntegerDataConKey +integerTyConName = wTcQual pREL_NUM_Name FSLIT("Integer") integerTyConKey +smallIntegerDataConName = wDataQual pREL_NUM_Name FSLIT("S#") smallIntegerDataConKey +largeIntegerDataConName = wDataQual pREL_NUM_Name FSLIT("J#") largeIntegerDataConKey -- PrelReal types and classes rationalTyConName = tcQual pREL_REAL_Name FSLIT("Rational") rationalTyConKey @@ -465,30 +640,22 @@ fractionalClassName = clsQual pREL_REAL_Name FSLIT("Fractional") fractionalCla fromRationalName = varQual pREL_REAL_Name FSLIT("fromRational") fromRationalClassOpKey -- PrelFloat classes -floatTyConName = tcQual pREL_FLOAT_Name FSLIT("Float") floatTyConKey -floatDataConName = dataQual pREL_FLOAT_Name FSLIT("F#") floatDataConKey -doubleTyConName = tcQual pREL_FLOAT_Name FSLIT("Double") doubleTyConKey -doubleDataConName = dataQual pREL_FLOAT_Name FSLIT("D#") doubleDataConKey +floatTyConName = wTcQual pREL_FLOAT_Name FSLIT("Float") floatTyConKey +floatDataConName = wDataQual pREL_FLOAT_Name FSLIT("F#") floatDataConKey +doubleTyConName = wTcQual pREL_FLOAT_Name FSLIT("Double") doubleTyConKey +doubleDataConName = wDataQual pREL_FLOAT_Name FSLIT("D#") doubleDataConKey floatingClassName = clsQual pREL_FLOAT_Name FSLIT("Floating") floatingClassKey realFloatClassName = clsQual pREL_FLOAT_Name FSLIT("RealFloat") realFloatClassKey -- Class Ix ixClassName = clsQual pREL_ARR_Name FSLIT("Ix") ixClassKey --- Class Enum +-- Enum module (Enum, Bounded) enumClassName = clsQual pREL_ENUM_Name FSLIT("Enum") enumClassKey -toEnumName = varQual pREL_ENUM_Name FSLIT("toEnum") toEnumClassOpKey -fromEnumName = varQual pREL_ENUM_Name FSLIT("fromEnum") fromEnumClassOpKey enumFromName = varQual pREL_ENUM_Name FSLIT("enumFrom") enumFromClassOpKey enumFromToName = varQual pREL_ENUM_Name FSLIT("enumFromTo") enumFromToClassOpKey enumFromThenName = varQual pREL_ENUM_Name FSLIT("enumFromThen") enumFromThenClassOpKey enumFromThenToName = varQual pREL_ENUM_Name FSLIT("enumFromThenTo") enumFromThenToClassOpKey - --- Overloaded via Class Enum -enumFromToPName = varQual pREL_PARR_Name FSLIT("enumFromToP") enumFromToPIdKey -enumFromThenToPName= varQual pREL_PARR_Name FSLIT("enumFromThenToP") enumFromThenToPIdKey - --- Class Bounded boundedClassName = clsQual pREL_ENUM_Name FSLIT("Bounded") boundedClassKey -- List functions @@ -496,22 +663,87 @@ concatName = varQual pREL_LIST_Name FSLIT("concat") concatIdKey filterName = varQual pREL_LIST_Name FSLIT("filter") filterIdKey zipName = varQual pREL_LIST_Name FSLIT("zip") zipIdKey +-- MetaHaskell Extension, "the smart constructors" +-- text3 from Meta/work/gen.hs +intLName = varQual mETA_META_Name FSLIT("intL") intLIdKey +charLName = varQual mETA_META_Name FSLIT("charL") charLIdKey +plitName = varQual mETA_META_Name FSLIT("plit") plitIdKey +pvarName = varQual mETA_META_Name FSLIT("pvar") pvarIdKey +ptupName = varQual mETA_META_Name FSLIT("ptup") ptupIdKey +pconName = varQual mETA_META_Name FSLIT("pcon") pconIdKey +ptildeName = varQual mETA_META_Name FSLIT("ptilde") ptildeIdKey +paspatName = varQual mETA_META_Name FSLIT("paspat") paspatIdKey +pwildName = varQual mETA_META_Name FSLIT("pwild") pwildIdKey +varName = varQual mETA_META_Name FSLIT("var") varIdKey +conName = varQual mETA_META_Name FSLIT("con") conIdKey +litName = varQual mETA_META_Name FSLIT("lit") litIdKey +appName = varQual mETA_META_Name FSLIT("app") appIdKey +infixEName = varQual mETA_META_Name FSLIT("infixE") infixEIdKey +lamName = varQual mETA_META_Name FSLIT("lam") lamIdKey +tupName = varQual mETA_META_Name FSLIT("tup") tupIdKey +doEName = varQual mETA_META_Name FSLIT("doE") doEIdKey +compName = varQual mETA_META_Name FSLIT("comp") compIdKey +listExpName = varQual mETA_META_Name FSLIT("listExp") listExpIdKey +condName = varQual mETA_META_Name FSLIT("cond") condIdKey +letEName = varQual mETA_META_Name FSLIT("letE") letEIdKey +caseEName = varQual mETA_META_Name FSLIT("caseE") caseEIdKey +infixAppName = varQual mETA_META_Name FSLIT("infixApp") infixAppIdKey +sectionLName = varQual mETA_META_Name FSLIT("sectionL") sectionLIdKey +sectionRName = varQual mETA_META_Name FSLIT("sectionR") sectionRIdKey +guardedName = varQual mETA_META_Name FSLIT("guarded") guardedIdKey +normalName = varQual mETA_META_Name FSLIT("normal") normalIdKey +bindStName = varQual mETA_META_Name FSLIT("bindSt") bindStIdKey +letStName = varQual mETA_META_Name FSLIT("letSt") letStIdKey +noBindStName = varQual mETA_META_Name FSLIT("noBindSt") noBindStIdKey +parStName = varQual mETA_META_Name FSLIT("parSt") parStIdKey +fromName = varQual mETA_META_Name FSLIT("from") fromIdKey +fromThenName = varQual mETA_META_Name FSLIT("fromThen") fromThenIdKey +fromToName = varQual mETA_META_Name FSLIT("fromTo") fromToIdKey +fromThenToName = varQual mETA_META_Name FSLIT("fromThenTo") fromThenToIdKey +liftName = varQual mETA_META_Name FSLIT("lift") liftIdKey +gensymName = varQual mETA_META_Name FSLIT("gensym") gensymIdKey +returnQName = varQual mETA_META_Name FSLIT("returnQ") returnQIdKey +bindQName = varQual mETA_META_Name FSLIT("bindQ") bindQIdKey +funName = varQual mETA_META_Name FSLIT("fun") funIdKey +valName = varQual mETA_META_Name FSLIT("val") valIdKey +matchName = varQual mETA_META_Name FSLIT("match") matchIdKey +clauseName = varQual mETA_META_Name FSLIT("clause") clauseIdKey +protoName = varQual mETA_META_Name FSLIT("proto") protoIdKey +exprTyConName = tcQual mETA_META_Name FSLIT("Expr") exprTyConKey +declTyConName = tcQual mETA_META_Name FSLIT("Decl") declTyConKey +pattTyConName = tcQual mETA_META_Name FSLIT("Patt") pattTyConKey +mtchTyConName = tcQual mETA_META_Name FSLIT("Mtch") mtchTyConKey +clseTyConName = tcQual mETA_META_Name FSLIT("Clse") clseTyConKey +stmtTyConName = tcQual mETA_META_Name FSLIT("Stmt") stmtTyConKey + +qTyConName = tcQual mETA_META_Name FSLIT("Q") qTyConKey +expTyConName = tcQual mETA_META_Name FSLIT("Exp") expTyConKey +matTyConName = tcQual mETA_META_Name FSLIT("Mat") matTyConKey +clsTyConName = tcQual mETA_META_Name FSLIT("Cls") clsTyConKey + +-- Class Show +showClassName = clsQual pREL_SHOW_Name FSLIT("Show") showClassKey + +-- Class Read +readClassName = clsQual pREL_READ_Name FSLIT("Read") readClassKey + -- parallel array types and functions -parrTyConName = tcQual pREL_PARR_Name FSLIT("[::]") parrTyConKey -parrDataConName = dataQual pREL_PARR_Name FSLIT("PArr") parrDataConKey -nullPName = varQual pREL_PARR_Name FSLIT("nullP") nullPIdKey -lengthPName = varQual pREL_PARR_Name FSLIT("lengthP") lengthPIdKey -replicatePName = varQual pREL_PARR_Name FSLIT("replicateP") replicatePIdKey -mapPName = varQual pREL_PARR_Name FSLIT("mapP") mapPIdKey -filterPName = varQual pREL_PARR_Name FSLIT("filterP") filterPIdKey -zipPName = varQual pREL_PARR_Name FSLIT("zipP") zipPIdKey -crossPName = varQual pREL_PARR_Name FSLIT("crossP") crossPIdKey -indexPName = varQual pREL_PARR_Name FSLIT("!:") indexPIdKey -toPName = varQual pREL_PARR_Name FSLIT("toP") toPIdKey -bpermutePName = varQual pREL_PARR_Name FSLIT("bpermuteP") bpermutePIdKey -bpermuteDftPName = varQual pREL_PARR_Name FSLIT("bpermuteDftP") - bpermuteDftPIdKey -indexOfPName = varQual pREL_PARR_Name FSLIT("indexOfP") indexOfPIdKey +enumFromToPName = varQual pREL_PARR_Name FSLIT("enumFromToP") enumFromToPIdKey +enumFromThenToPName= varQual pREL_PARR_Name FSLIT("enumFromThenToP") enumFromThenToPIdKey +parrTyConName = wTcQual pREL_PARR_Name FSLIT("[::]") parrTyConKey +parrDataConName = wDataQual pREL_PARR_Name FSLIT("PArr") parrDataConKey +nullPName = varQual pREL_PARR_Name FSLIT("nullP") nullPIdKey +lengthPName = varQual pREL_PARR_Name FSLIT("lengthP") lengthPIdKey +replicatePName = varQual pREL_PARR_Name FSLIT("replicateP") replicatePIdKey +mapPName = varQual pREL_PARR_Name FSLIT("mapP") mapPIdKey +filterPName = varQual pREL_PARR_Name FSLIT("filterP") filterPIdKey +zipPName = varQual pREL_PARR_Name FSLIT("zipP") zipPIdKey +crossPName = varQual pREL_PARR_Name FSLIT("crossP") crossPIdKey +indexPName = varQual pREL_PARR_Name FSLIT("!:") indexPIdKey +toPName = varQual pREL_PARR_Name FSLIT("toP") toPIdKey +bpermutePName = varQual pREL_PARR_Name FSLIT("bpermuteP") bpermutePIdKey +bpermuteDftPName = varQual pREL_PARR_Name FSLIT("bpermuteDftP") bpermuteDftPIdKey +indexOfPName = varQual pREL_PARR_Name FSLIT("indexOfP") indexOfPIdKey -- IOBase things ioTyConName = tcQual pREL_IO_BASE_Name FSLIT("IO") ioTyConKey @@ -530,22 +762,23 @@ int16TyConName = tcQual pREL_INT_Name FSLIT("Int16") int16TyConKey int32TyConName = tcQual pREL_INT_Name FSLIT("Int32") int32TyConKey int64TyConName = tcQual pREL_INT_Name FSLIT("Int64") int64TyConKey -word8TyConName = tcQual pREL_WORD_Name FSLIT("Word8") word8TyConKey -word16TyConName = tcQual pREL_WORD_Name FSLIT("Word16") word16TyConKey -word32TyConName = tcQual pREL_WORD_Name FSLIT("Word32") word32TyConKey -word64TyConName = tcQual pREL_WORD_Name FSLIT("Word64") word64TyConKey - -wordTyConName = tcQual pREL_WORD_Name FSLIT("Word") wordTyConKey -wordDataConName = dataQual pREL_WORD_Name FSLIT("W#") wordDataConKey - -addrTyConName = tcQual aDDR_Name FSLIT("Addr") addrTyConKey -addrDataConName = dataQual aDDR_Name FSLIT("A#") addrDataConKey +-- Word module +word8TyConName = tcQual pREL_WORD_Name FSLIT("Word8") word8TyConKey +word16TyConName = tcQual pREL_WORD_Name FSLIT("Word16") word16TyConKey +word32TyConName = tcQual pREL_WORD_Name FSLIT("Word32") word32TyConKey +word64TyConName = tcQual pREL_WORD_Name FSLIT("Word64") word64TyConKey +wordTyConName = wTcQual pREL_WORD_Name FSLIT("Word") wordTyConKey +wordDataConName = wDataQual pREL_WORD_Name FSLIT("W#") wordDataConKey -ptrTyConName = tcQual pREL_PTR_Name FSLIT("Ptr") ptrTyConKey -ptrDataConName = dataQual pREL_PTR_Name FSLIT("Ptr") ptrDataConKey +-- Addr module +addrTyConName = wTcQual aDDR_Name FSLIT("Addr") addrTyConKey +addrDataConName = wDataQual aDDR_Name FSLIT("A#") addrDataConKey -funPtrTyConName = tcQual pREL_PTR_Name FSLIT("FunPtr") funPtrTyConKey -funPtrDataConName = dataQual pREL_PTR_Name FSLIT("FunPtr") funPtrDataConKey +-- PrelPtr module +ptrTyConName = wTcQual pREL_PTR_Name FSLIT("Ptr") ptrTyConKey +ptrDataConName = wDataQual pREL_PTR_Name FSLIT("Ptr") ptrDataConKey +funPtrTyConName = wTcQual pREL_PTR_Name FSLIT("FunPtr") funPtrTyConKey +funPtrDataConName = wDataQual pREL_PTR_Name FSLIT("FunPtr") funPtrDataConKey -- Byte array types byteArrayTyConName = tcQual pREL_BYTEARR_Name FSLIT("ByteArray") byteArrayTyConKey @@ -554,13 +787,20 @@ mutableByteArrayTyConName = tcQual pREL_BYTEARR_Name FSLIT("MutableByteArray") -- Foreign objects and weak pointers stablePtrTyConName = tcQual pREL_STABLE_Name FSLIT("StablePtr") stablePtrTyConKey stablePtrDataConName = dataQual pREL_STABLE_Name FSLIT("StablePtr") stablePtrDataConKey -deRefStablePtrName = varQual pREL_STABLE_Name FSLIT("deRefStablePtr") deRefStablePtrIdKey newStablePtrName = varQual pREL_STABLE_Name FSLIT("newStablePtr") newStablePtrIdKey -assertName = varQual gHC_PRIM_Name FSLIT("assert") assertIdKey -getTagName = varQual gHC_PRIM_Name FSLIT("getTag#") getTagIdKey - -errorName = varQual pREL_ERR_Name FSLIT("error") errorIdKey +-- Error module +errorName = wVarQual pREL_ERR_Name FSLIT("error") errorIdKey +recSelErrorName = wVarQual pREL_ERR_Name FSLIT("recSelError") recSelErrorIdKey +runtimeErrorName = wVarQual pREL_ERR_Name FSLIT("runtimeError") runtimeErrorIdKey +irrefutPatErrorName = wVarQual pREL_ERR_Name FSLIT("irrefutPatError") irrefutPatErrorIdKey +recConErrorName = wVarQual pREL_ERR_Name FSLIT("recConError") recConErrorIdKey +patErrorName = wVarQual pREL_ERR_Name FSLIT("patError") patErrorIdKey +noMethodBindingErrorName = wVarQual pREL_ERR_Name FSLIT("noMethodBindingError") noMethodBindingErrorIdKey +nonExhaustiveGuardsErrorName + = wVarQual pREL_ERR_Name FSLIT("nonExhaustiveGuardsError") nonExhaustiveGuardsErrorIdKey + +-- PrelST module runSTRepName = varQual pREL_ST_Name FSLIT("runSTRep") runSTRepIdKey -- The "split" Id for splittable implicit parameters @@ -569,136 +809,25 @@ splitName = varQual gLA_EXTS_Name FSLIT("split") splitIdKey %************************************************************************ %* * -\subsection{Known names} +\subsection{Standard groups of names} %* * %************************************************************************ -The following names are known to the compiler, but they don't require -pre-assigned keys. Mostly these names are used in generating deriving -code, which is passed through the renamer anyway. - - THEY ARE ALL ORIGINAL NAMES, HOWEVER - \begin{code} --- Lists and tuples -tupleCon_RDR, tupleTyCon_RDR :: Int -> RdrName -ubxTupleCon_RDR, ubxTupleTyCon_RDR :: Int -> RdrName - -tupleCon_RDR = mkTupConRdrName dataName Boxed -tupleTyCon_RDR = mkTupConRdrName tcName Boxed -ubxTupleCon_RDR = mkTupConRdrName dataName Unboxed -ubxTupleTyCon_RDR = mkTupConRdrName tcName Unboxed - -unitCon_RDR = dataQual_RDR pREL_BASE_Name FSLIT("()") -unitTyCon_RDR = tcQual_RDR pREL_BASE_Name FSLIT("()") - -and_RDR = varQual_RDR pREL_BASE_Name FSLIT("&&") -not_RDR = varQual_RDR pREL_BASE_Name FSLIT("not") -compose_RDR = varQual_RDR pREL_BASE_Name FSLIT(".") -ne_RDR = varQual_RDR pREL_BASE_Name FSLIT("/=") -le_RDR = varQual_RDR pREL_BASE_Name FSLIT("<=") -lt_RDR = varQual_RDR pREL_BASE_Name FSLIT("<") -gt_RDR = varQual_RDR pREL_BASE_Name FSLIT(">") -ltTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("LT") -eqTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("EQ") -gtTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("GT") -max_RDR = varQual_RDR pREL_BASE_Name FSLIT("max") -min_RDR = varQual_RDR pREL_BASE_Name FSLIT("min") -compare_RDR = varQual_RDR pREL_BASE_Name FSLIT("compare") -showList_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showList") -showList___RDR = varQual_RDR pREL_SHOW_Name FSLIT("showList__") -showsPrec_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showsPrec") -showSpace_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showSpace") -showString_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showString") -showParen_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showParen") - -readsPrec_RDR = varQual_RDR pREL_READ_Name FSLIT("readsPrec") -readPrec_RDR = varQual_RDR pREL_READ_Name FSLIT("readPrec") -readListPrec_RDR = varQual_RDR pREL_READ_Name FSLIT("readListPrec") -readList_RDR = varQual_RDR pREL_READ_Name FSLIT("readList") - -readListDefault_RDR = varQual_RDR pREL_READ_Name FSLIT("readListDefault") -readListPrecDefault_RDR = varQual_RDR pREL_READ_Name FSLIT("readListPrecDefault") -parens_RDR = varQual_RDR pREL_READ_Name FSLIT("parens") -choose_RDR = varQual_RDR pREL_READ_Name FSLIT("choose") -lexP_RDR = varQual_RDR pREL_READ_Name FSLIT("lexP") - --- Module ReadPrec -step_RDR = varQual_RDR rEAD_PREC_Name FSLIT("step") -reset_RDR = varQual_RDR rEAD_PREC_Name FSLIT("reset") -alt_RDR = varQual_RDR rEAD_PREC_Name FSLIT("+++") -prec_RDR = varQual_RDR rEAD_PREC_Name FSLIT("prec") - --- Module Lex -symbol_RDR = dataQual_RDR lEX_Name FSLIT("Symbol") -ident_RDR = dataQual_RDR lEX_Name FSLIT("Ident") -punc_RDR = dataQual_RDR lEX_Name FSLIT("Punc") - -times_RDR = varQual_RDR pREL_NUM_Name FSLIT("*") -plus_RDR = varQual_RDR pREL_NUM_Name FSLIT("+") -negate_RDR = varQual_RDR pREL_NUM_Name FSLIT("negate") -range_RDR = varQual_RDR pREL_ARR_Name FSLIT("range") -index_RDR = varQual_RDR pREL_ARR_Name FSLIT("index") -inRange_RDR = varQual_RDR pREL_ARR_Name FSLIT("inRange") -succ_RDR = varQual_RDR pREL_ENUM_Name FSLIT("succ") -pred_RDR = varQual_RDR pREL_ENUM_Name FSLIT("pred") -minBound_RDR = varQual_RDR pREL_ENUM_Name FSLIT("minBound") -maxBound_RDR = varQual_RDR pREL_ENUM_Name FSLIT("maxBound") -assertErr_RDR = varQual_RDR pREL_ERR_Name FSLIT("assertError") -\end{code} - -These RDR names also have known keys, so we need to get back the RDR names to -populate the occurrence list above. - -\begin{code} -funTyCon_RDR = nameRdrName funTyConName -nilCon_RDR = nameRdrName nilDataConName -listTyCon_RDR = nameRdrName listTyConName -parrTyCon_RDR = nameRdrName parrTyConName -ioTyCon_RDR = nameRdrName ioTyConName -intTyCon_RDR = nameRdrName intTyConName -eq_RDR = nameRdrName eqName -ge_RDR = nameRdrName geName -numClass_RDR = nameRdrName numClassName -ordClass_RDR = nameRdrName ordClassName -map_RDR = nameRdrName mapName -append_RDR = nameRdrName appendName -foldr_RDR = nameRdrName foldrName -build_RDR = nameRdrName buildName -enumFromTo_RDR = nameRdrName enumFromToName -returnM_RDR = nameRdrName returnMName -bindM_RDR = nameRdrName bindMName -failM_RDR = nameRdrName failMName -false_RDR = nameRdrName falseDataConName -true_RDR = nameRdrName trueDataConName -error_RDR = nameRdrName errorName -getTag_RDR = nameRdrName getTagName -fromEnum_RDR = nameRdrName fromEnumName -toEnum_RDR = nameRdrName toEnumName -enumFrom_RDR = nameRdrName enumFromName -mkInt_RDR = nameRdrName intDataConName -enumFromThen_RDR = nameRdrName enumFromThenName -enumFromThenTo_RDR = nameRdrName enumFromThenToName -ratioDataCon_RDR = nameRdrName ratioDataConName -plusInteger_RDR = nameRdrName plusIntegerName -timesInteger_RDR = nameRdrName timesIntegerName -enumClass_RDR = nameRdrName enumClassName -monadClass_RDR = nameRdrName monadClassName -ioDataCon_RDR = nameRdrName ioDataConName -cCallableClass_RDR = nameRdrName cCallableClassName -cReturnableClass_RDR = nameRdrName cReturnableClassName -eqClass_RDR = nameRdrName eqClassName -eqString_RDR = nameRdrName eqStringName -unpackCString_RDR = nameRdrName unpackCStringName -unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName -unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name -deRefStablePtr_RDR = nameRdrName deRefStablePtrName -newStablePtr_RDR = nameRdrName newStablePtrName -bindIO_RDR = nameRdrName bindIOName -returnIO_RDR = nameRdrName returnIOName -fromInteger_RDR = nameRdrName fromIntegerName -fromRational_RDR = nameRdrName fromRationalName -minus_RDR = nameRdrName minusName +templateHaskellNames :: NameSet +-- The names that are implicitly mentioned by ``bracket'' +-- Should stay in sync with the import list of DsMeta +templateHaskellNames + = mkNameSet [ intLName,charLName, plitName, pvarName, ptupName, + pconName, ptildeName, paspatName, pwildName, + varName, conName, litName, appName, lamName, + tupName, doEName, compName, + listExpName, condName, letEName, caseEName, + infixAppName, guardedName, normalName, + bindStName, letStName, noBindStName, parStName, + fromName, fromThenName, fromToName, fromThenToName, + funName, valName, liftName,gensymName, bindQName, + appendName, matchName, clauseName ] \end{code} %************************************************************************ @@ -710,20 +839,29 @@ minus_RDR = nameRdrName minusName All these are original names; hence mkOrig \begin{code} -varQual mod str uq = mkKnownKeyExternalName (varQual_RDR mod str) uq -dataQual mod str uq = mkKnownKeyExternalName (dataQual_RDR mod str) uq -tcQual mod str uq = mkKnownKeyExternalName (tcQual_RDR mod str) uq -clsQual mod str uq = mkKnownKeyExternalName (clsQual_RDR mod str) uq - -kindQual str uq = mkInternalName uq (mkKindOccFS tcName str) builtinSrcLoc +varQual = mk_known_key_name OccNameAlias.varName -- Note use of local alias vName +dataQual = mk_known_key_name dataName +tcQual = mk_known_key_name tcName +clsQual = mk_known_key_name clsName + +wVarQual = mk_wired_in_name OccNameAlias.varName -- The wired-in analogues +wDataQual = mk_wired_in_name dataName +wTcQual = mk_wired_in_name tcName + +varQual_RDR mod str = mkOrig mod (mkOccFS OccNameAlias.varName str) -- note use of local alias vName +tcQual_RDR mod str = mkOrig mod (mkOccFS tcName str) +clsQual_RDR mod str = mkOrig mod (mkOccFS clsName str) +dataQual_RDR mod str = mkOrig mod (mkOccFS dataName str) + +mk_known_key_name space mod str uniq + = mkKnownKeyExternalName mod (mkOccFS space str) uniq +mk_wired_in_name space mod str uniq + = mkWiredInName (mkVanillaModule mod) (mkOccFS space str) uniq + +kindQual str uq = mkInternalName uq (mkKindOccFS tcName str) noSrcLoc -- Kinds are not z-encoded in interface file, hence mkKindOccFS -- And they don't come from any particular module; indeed we always -- want to print them unqualified. Hence the LocalName - -varQual_RDR mod str = mkOrig varName mod str -tcQual_RDR mod str = mkOrig tcName mod str -clsQual_RDR mod str = mkOrig clsName mod str -dataQual_RDR mod str = mkOrig dataName mod str \end{code} %************************************************************************ @@ -731,6 +869,7 @@ dataQual_RDR mod str = mkOrig dataName mod str \subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@} %* * %************************************************************************ +--MetaHaskell extension hand allocate keys here \begin{code} boundedClassKey = mkPreludeClassUnique 1 @@ -834,6 +973,18 @@ genUnitTyConKey = mkPreludeTyConUnique 81 -- Parallel array type constructor parrTyConKey = mkPreludeTyConUnique 82 +-- Template Haskell +qTyConKey = mkPreludeTyConUnique 83 +exprTyConKey = mkPreludeTyConUnique 84 +declTyConKey = mkPreludeTyConUnique 85 +pattTyConKey = mkPreludeTyConUnique 86 +mtchTyConKey = mkPreludeTyConUnique 87 +clseTyConKey = mkPreludeTyConUnique 88 +stmtTyConKey = mkPreludeTyConUnique 89 +expTyConKey = mkPreludeTyConUnique 90 +matTyConKey = mkPreludeTyConUnique 91 +clsTyConKey = mkPreludeTyConUnique 92 + unitTyConKey = mkTupleTyConUnique Boxed 0 \end{code} @@ -881,36 +1032,37 @@ parrDataConKey = mkPreludeDataConUnique 24 \begin{code} absentErrorIdKey = mkPreludeMiscIdUnique 1 -appendIdKey = mkPreludeMiscIdUnique 2 +getTagIdKey = mkPreludeMiscIdUnique 2 augmentIdKey = mkPreludeMiscIdUnique 3 -buildIdKey = mkPreludeMiscIdUnique 4 -errorIdKey = mkPreludeMiscIdUnique 5 -foldlIdKey = mkPreludeMiscIdUnique 6 -foldrIdKey = mkPreludeMiscIdUnique 7 -recSelErrIdKey = mkPreludeMiscIdUnique 8 -integerMinusOneIdKey = mkPreludeMiscIdUnique 9 -integerPlusOneIdKey = mkPreludeMiscIdUnique 10 -integerPlusTwoIdKey = mkPreludeMiscIdUnique 11 -integerZeroIdKey = mkPreludeMiscIdUnique 12 -int2IntegerIdKey = mkPreludeMiscIdUnique 13 -seqIdKey = mkPreludeMiscIdUnique 14 -irrefutPatErrorIdKey = mkPreludeMiscIdUnique 15 -eqStringIdKey = mkPreludeMiscIdUnique 16 -noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 17 -nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 18 -runtimeErrorIdKey = mkPreludeMiscIdUnique 19 -parErrorIdKey = mkPreludeMiscIdUnique 20 -parIdKey = mkPreludeMiscIdUnique 21 -patErrorIdKey = mkPreludeMiscIdUnique 22 -realWorldPrimIdKey = mkPreludeMiscIdUnique 23 -recConErrorIdKey = mkPreludeMiscIdUnique 24 -recUpdErrorIdKey = mkPreludeMiscIdUnique 25 -traceIdKey = mkPreludeMiscIdUnique 26 -unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 27 -unpackCStringAppendIdKey = mkPreludeMiscIdUnique 28 -unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 29 -unpackCStringIdKey = mkPreludeMiscIdUnique 30 -ushowListIdKey = mkPreludeMiscIdUnique 31 +appendIdKey = mkPreludeMiscIdUnique 4 +buildIdKey = mkPreludeMiscIdUnique 5 +errorIdKey = mkPreludeMiscIdUnique 6 +foldlIdKey = mkPreludeMiscIdUnique 7 +foldrIdKey = mkPreludeMiscIdUnique 8 +recSelErrorIdKey = mkPreludeMiscIdUnique 9 +integerMinusOneIdKey = mkPreludeMiscIdUnique 10 +integerPlusOneIdKey = mkPreludeMiscIdUnique 11 +integerPlusTwoIdKey = mkPreludeMiscIdUnique 12 +integerZeroIdKey = mkPreludeMiscIdUnique 13 +int2IntegerIdKey = mkPreludeMiscIdUnique 14 +seqIdKey = mkPreludeMiscIdUnique 15 +irrefutPatErrorIdKey = mkPreludeMiscIdUnique 16 +eqStringIdKey = mkPreludeMiscIdUnique 17 +noMethodBindingErrorIdKey = mkPreludeMiscIdUnique 18 +nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 19 +runtimeErrorIdKey = mkPreludeMiscIdUnique 20 +parErrorIdKey = mkPreludeMiscIdUnique 21 +parIdKey = mkPreludeMiscIdUnique 22 +patErrorIdKey = mkPreludeMiscIdUnique 23 +realWorldPrimIdKey = mkPreludeMiscIdUnique 24 +recConErrorIdKey = mkPreludeMiscIdUnique 25 +recUpdErrorIdKey = mkPreludeMiscIdUnique 26 +traceIdKey = mkPreludeMiscIdUnique 27 +unpackCStringUtf8IdKey = mkPreludeMiscIdUnique 28 +unpackCStringAppendIdKey = mkPreludeMiscIdUnique 29 +unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 30 +unpackCStringIdKey = mkPreludeMiscIdUnique 31 + unsafeCoerceIdKey = mkPreludeMiscIdUnique 32 concatIdKey = mkPreludeMiscIdUnique 33 filterIdKey = mkPreludeMiscIdUnique 34 @@ -919,7 +1071,6 @@ bindIOIdKey = mkPreludeMiscIdUnique 36 returnIOIdKey = mkPreludeMiscIdUnique 37 deRefStablePtrIdKey = mkPreludeMiscIdUnique 38 newStablePtrIdKey = mkPreludeMiscIdUnique 39 -getTagIdKey = mkPreludeMiscIdUnique 40 plusIntegerIdKey = mkPreludeMiscIdUnique 41 timesIntegerIdKey = mkPreludeMiscIdUnique 42 printIdKey = mkPreludeMiscIdUnique 43 @@ -930,7 +1081,6 @@ splitIdKey = mkPreludeMiscIdUnique 48 fstIdKey = mkPreludeMiscIdUnique 49 sndIdKey = mkPreludeMiscIdUnique 50 otherwiseIdKey = mkPreludeMiscIdUnique 51 -mapIdKey = mkPreludeMiscIdUnique 52 assertIdKey = mkPreludeMiscIdUnique 53 runSTRepIdKey = mkPreludeMiscIdUnique 54 @@ -943,20 +1093,20 @@ thenIOIdKey = mkPreludeMiscIdUnique 59 lazyIdKey = mkPreludeMiscIdUnique 60 -- Parallel array functions -nullPIdKey = mkPreludeMiscIdUnique 70 -lengthPIdKey = mkPreludeMiscIdUnique 71 -replicatePIdKey = mkPreludeMiscIdUnique 72 -mapPIdKey = mkPreludeMiscIdUnique 73 -filterPIdKey = mkPreludeMiscIdUnique 74 -zipPIdKey = mkPreludeMiscIdUnique 75 -crossPIdKey = mkPreludeMiscIdUnique 76 -indexPIdKey = mkPreludeMiscIdUnique 77 -toPIdKey = mkPreludeMiscIdUnique 78 -enumFromToPIdKey = mkPreludeMiscIdUnique 79 -enumFromThenToPIdKey = mkPreludeMiscIdUnique 80 -bpermutePIdKey = mkPreludeMiscIdUnique 81 -bpermuteDftPIdKey = mkPreludeMiscIdUnique 82 -indexOfPIdKey = mkPreludeMiscIdUnique 83 +nullPIdKey = mkPreludeMiscIdUnique 80 +lengthPIdKey = mkPreludeMiscIdUnique 81 +replicatePIdKey = mkPreludeMiscIdUnique 82 +mapPIdKey = mkPreludeMiscIdUnique 83 +filterPIdKey = mkPreludeMiscIdUnique 84 +zipPIdKey = mkPreludeMiscIdUnique 85 +crossPIdKey = mkPreludeMiscIdUnique 86 +indexPIdKey = mkPreludeMiscIdUnique 87 +toPIdKey = mkPreludeMiscIdUnique 88 +enumFromToPIdKey = mkPreludeMiscIdUnique 89 +enumFromThenToPIdKey = mkPreludeMiscIdUnique 90 +bpermutePIdKey = mkPreludeMiscIdUnique 91 +bpermuteDftPIdKey = mkPreludeMiscIdUnique 92 +indexOfPIdKey = mkPreludeMiscIdUnique 93 \end{code} Certain class operations from Prelude classes. They get their own @@ -966,6 +1116,7 @@ during type checking. \begin{code} -- Just a place holder for unbound variables produced by the renamer: unboundKey = mkPreludeMiscIdUnique 101 + fromIntegerClassOpKey = mkPreludeMiscIdUnique 102 minusClassOpKey = mkPreludeMiscIdUnique 103 fromRationalClassOpKey = mkPreludeMiscIdUnique 104 @@ -979,9 +1130,53 @@ negateClassOpKey = mkPreludeMiscIdUnique 111 failMClassOpKey = mkPreludeMiscIdUnique 112 bindMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=) thenMClassOpKey = mkPreludeMiscIdUnique 114 -- (>>) -fromEnumClassOpKey = mkPreludeMiscIdUnique 115 returnMClassOpKey = mkPreludeMiscIdUnique 117 -toEnumClassOpKey = mkPreludeMiscIdUnique 119 + +-- MetaHaskell Extension, (text4 118) from Meta/work/gen.hs +intLIdKey = mkPreludeMiscIdUnique 118 +charLIdKey = mkPreludeMiscIdUnique 119 +plitIdKey = mkPreludeMiscIdUnique 120 +pvarIdKey = mkPreludeMiscIdUnique 121 +ptupIdKey = mkPreludeMiscIdUnique 122 +pconIdKey = mkPreludeMiscIdUnique 123 +ptildeIdKey = mkPreludeMiscIdUnique 124 +paspatIdKey = mkPreludeMiscIdUnique 125 +pwildIdKey = mkPreludeMiscIdUnique 126 +varIdKey = mkPreludeMiscIdUnique 127 +conIdKey = mkPreludeMiscIdUnique 128 +litIdKey = mkPreludeMiscIdUnique 129 +appIdKey = mkPreludeMiscIdUnique 130 +infixEIdKey = mkPreludeMiscIdUnique 131 +lamIdKey = mkPreludeMiscIdUnique 132 +tupIdKey = mkPreludeMiscIdUnique 133 +doEIdKey = mkPreludeMiscIdUnique 134 +compIdKey = mkPreludeMiscIdUnique 135 +listExpIdKey = mkPreludeMiscIdUnique 137 +condIdKey = mkPreludeMiscIdUnique 138 +letEIdKey = mkPreludeMiscIdUnique 139 +caseEIdKey = mkPreludeMiscIdUnique 140 +infixAppIdKey = mkPreludeMiscIdUnique 141 +sectionLIdKey = mkPreludeMiscIdUnique 142 +sectionRIdKey = mkPreludeMiscIdUnique 143 +guardedIdKey = mkPreludeMiscIdUnique 144 +normalIdKey = mkPreludeMiscIdUnique 145 +bindStIdKey = mkPreludeMiscIdUnique 146 +letStIdKey = mkPreludeMiscIdUnique 147 +noBindStIdKey = mkPreludeMiscIdUnique 148 +parStIdKey = mkPreludeMiscIdUnique 149 +fromIdKey = mkPreludeMiscIdUnique 150 +fromThenIdKey = mkPreludeMiscIdUnique 151 +fromToIdKey = mkPreludeMiscIdUnique 152 +fromThenToIdKey = mkPreludeMiscIdUnique 153 +liftIdKey = mkPreludeMiscIdUnique 154 +gensymIdKey = mkPreludeMiscIdUnique 155 +returnQIdKey = mkPreludeMiscIdUnique 156 +bindQIdKey = mkPreludeMiscIdUnique 157 +funIdKey = mkPreludeMiscIdUnique 158 +valIdKey = mkPreludeMiscIdUnique 159 +protoIdKey = mkPreludeMiscIdUnique 160 +matchIdKey = mkPreludeMiscIdUnique 161 +clauseIdKey = mkPreludeMiscIdUnique 162 \end{code} @@ -1027,62 +1222,6 @@ cCallishTyKeys = %* * %************************************************************************ -@derivableClassKeys@ is also used in checking \tr{deriving} constructs -(@TcDeriv@). - -@derivingOccurrences@ maps a class name to a list of the (qualified) -occurrences that will be mentioned by the derived code for the class -when it is later generated. We don't need to put in things that are -WiredIn (because they are already mapped to their correct name by the -@NameSupply@. The class itself, and all its class ops, is already -flagged as an occurrence so we don't need to mention that either. - -@derivingOccurrences@ has an item for every derivable class, even if -that item is empty, because we treat lookup failure as indicating that -the class is illegal in a deriving clause. - -\begin{code} -derivingOccurrences :: UniqFM [RdrName] -derivingOccurrences = listToUFM deriving_occ_info - -derivableClassKeys = map fst deriving_occ_info - -deriving_occ_info - = [ (eqClassKey, [intTyCon_RDR, and_RDR, not_RDR]) - , (ordClassKey, [intTyCon_RDR, compose_RDR, eqTag_RDR, error_RDR]) - -- EQ (from Ordering) is needed to force in the constructors - -- as well as the type constructor. - , (enumClassKey, [intTyCon_RDR, eq_RDR, ge_RDR, and_RDR, map_RDR, plus_RDR, - error_RDR, showsPrec_RDR, append_RDR]) - -- The last two Enum deps are only used to produce better - -- error msgs for derived toEnum methods. - , (boundedClassKey, [intTyCon_RDR]) - , (showClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, compose_RDR, showString_RDR, - showParen_RDR, showSpace_RDR, showList___RDR]) - , (readClassKey, [intTyCon_RDR, numClass_RDR, ordClass_RDR, - lexP_RDR, readPrec_RDR, - readListDefault_RDR, readListPrecDefault_RDR, - step_RDR, parens_RDR, reset_RDR, prec_RDR, alt_RDR, choose_RDR, - ident_RDR, -- Pulls in the entire Lex.Lexeme data type - bindM_RDR -- Pulls in the entire Monad class decl - ] ) - , (ixClassKey, [intTyCon_RDR, numClass_RDR, and_RDR, map_RDR, enumFromTo_RDR, error_RDR, - foldr_RDR, build_RDR, - -- foldr and build required for list comprehension used - -- with single constructor types -- KSW 2000-06 - returnM_RDR, failM_RDR]) - -- the last two are needed to force returnM, thenM and failM - -- in before typechecking the list(monad) comprehension - -- generated for derived Ix instances (range method) - -- of single constructor types. -- SOF 8/97 - ] - -- intTyCon: Practically any deriving needs Int, either for index calculations, - -- or for taggery. - -- ordClass: really it's the methods that are actually used. - -- numClass: for Int literals -\end{code} - - NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@ even though every numeric class has these two as a superclass, because the list of ambiguous dictionaries hasn't been simplified. @@ -1128,3 +1267,12 @@ noDictClassKeys -- These classes are used only for type annotations; = cCallishClassKeys \end{code} +@derivableClassKeys@ is also used in checking \tr{deriving} constructs +(@TcDeriv@). + +\begin{code} +derivableClassKeys + = [ eqClassKey, ordClassKey, enumClassKey, ixClassKey, + boundedClassKey, showClassKey, readClassKey ] +\end{code} + diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index d7d4201eec..2c2a2e40ab 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -34,7 +34,7 @@ import PrimOp ( PrimOp(..), primOpOcc ) import TysWiredIn ( trueDataConId, falseDataConId ) import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) -import CoreUtils ( exprIsValue, cheapEqExpr, exprIsConApp_maybe ) +import CoreUtils ( cheapEqExpr, exprIsConApp_maybe ) import Type ( tyConAppTyCon, eqType ) import OccName ( occNameUserString) import PrelNames ( unpackCStringFoldrName, unpackCStringFoldrIdKey, hasKey, diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 82a60e0911..94d42a074c 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -7,7 +7,7 @@ module PrimOp ( PrimOp(..), allThePrimOps, primOpType, primOpSig, primOpArity, - mkPrimOpIdName, primOpRdrName, primOpTag, primOpOcc, + mkPrimOpIdName, primOpTag, primOpOcc, commutableOp, @@ -17,7 +17,10 @@ module PrimOp ( getPrimOpResultInfo, PrimOpResultInfo(..), - eqCharName, eqIntName, eqFloatName, eqDoubleName, neqIntName, + eqCharName, eqIntName, neqIntName, + ltCharName, eqWordName, ltWordName, eqAddrName, ltAddrName, + eqFloatName, ltFloatName, eqDoubleName, ltDoubleName, + ltIntName, geIntName, leIntName, minusIntName, tagToEnumName ) where #include "HsVersions.h" @@ -29,14 +32,13 @@ import TysWiredIn import NewDemand import Var ( TyVar ) import Name ( Name, mkWiredInName ) -import RdrName ( RdrName, mkRdrOrig ) import OccName ( OccName, pprOccName, mkVarOcc ) import TyCon ( TyCon, isPrimTyCon, tyConPrimRep ) import Type ( Type, mkForAllTys, mkFunTy, mkFunTys, typePrimRep, tyConAppTyCon ) import PprType () -- get at Outputable Type instance. import Unique ( mkPrimOpIdUnique ) import BasicTypes ( Arity, Boxity(..) ) -import PrelNames ( gHC_PRIM, gHC_PRIM_Name ) +import PrelNames ( gHC_PRIM ) import Outputable import FastTypes \end{code} @@ -399,9 +401,6 @@ mkPrimOpIdName :: PrimOp -> Name mkPrimOpIdName op = mkWiredInName gHC_PRIM (primOpOcc op) (mkPrimOpIdUnique (primOpTag op)) -primOpRdrName :: PrimOp -> RdrName -primOpRdrName op = mkRdrOrig gHC_PRIM_Name (primOpOcc op) - primOpOcc :: PrimOp -> OccName primOpOcc op = case (primOpInfo op) of Dyadic occ _ -> occ @@ -472,12 +471,35 @@ pprPrimOp :: PrimOp -> SDoc pprPrimOp other_op = pprOccName (primOpOcc other_op) \end{code} -Names for some primops (for ndpFlatten/FlattenMonad.lhs) + +%************************************************************************ +%* * + Names for some primops (for ndpFlatten/FlattenMonad.lhs) +%* * +%************************************************************************ \begin{code} -eqCharName = mkPrimOpIdName CharEqOp -eqIntName = mkPrimOpIdName IntEqOp -eqFloatName = mkPrimOpIdName FloatEqOp -eqDoubleName = mkPrimOpIdName DoubleEqOp -neqIntName = mkPrimOpIdName IntNeOp +eqIntName = mkPrimOpIdName IntEqOp +ltIntName = mkPrimOpIdName IntLtOp +geIntName = mkPrimOpIdName IntGeOp +leIntName = mkPrimOpIdName IntLeOp +neqIntName = mkPrimOpIdName IntNeOp +minusIntName = mkPrimOpIdName IntSubOp + +eqCharName = mkPrimOpIdName CharEqOp +ltCharName = mkPrimOpIdName CharLtOp + +eqFloatName = mkPrimOpIdName FloatEqOp +ltFloatName = mkPrimOpIdName FloatLtOp + +eqDoubleName = mkPrimOpIdName DoubleEqOp +ltDoubleName = mkPrimOpIdName DoubleLtOp + +eqWordName = mkPrimOpIdName WordEqOp +ltWordName = mkPrimOpIdName WordLtOp + +eqAddrName = mkPrimOpIdName AddrEqOp +ltAddrName = mkPrimOpIdName AddrLtOp + +tagToEnumName = mkPrimOpIdName TagToEnumOp \end{code} diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 62b2623ad3..08c9e196c6 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -53,7 +53,7 @@ module TysWiredIn ( -- tuples mkTupleTy, tupleTyCon, tupleCon, - unitTyCon, unitDataConId, pairTyCon, + unitTyCon, unitDataCon, unitDataConId, pairTyCon, unboxedSingletonTyCon, unboxedSingletonDataCon, unboxedPairTyCon, unboxedPairDataCon, @@ -88,10 +88,9 @@ import TysPrim -- others: import Constants ( mAX_TUPLE_SIZE ) import Module ( mkPrelModule ) -import Name ( Name, nameRdrName, nameUnique, nameOccName, +import Name ( Name, nameUnique, nameOccName, nameModule, mkWiredInName ) import OccName ( mkOccFS, tcName, dataName, mkWorkerOcc, mkGenOcc1, mkGenOcc2 ) -import RdrName ( rdrNameOcc ) import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) import Var ( TyVar, tyVarKind ) import TyCon ( TyCon, AlgTyConFlavour(..), DataConDetails(..), tyConDataCons, @@ -121,6 +120,9 @@ alpha_beta_tyvars = [alphaTyVar, betaTyVar] %* * %************************************************************************ +If you change which things are wired in, make sure you change their +names in PrelNames, so they use wTcQual, wDataQual, etc + \begin{code} wiredInTyCons :: [TyCon] wiredInTyCons = data_tycons ++ tuple_tycons ++ unboxed_tuple_tycons @@ -143,7 +145,6 @@ data_tycons = genericTyCons ++ genericTyCons :: [TyCon] genericTyCons = [ plusTyCon, crossTyCon, genUnitTyCon ] - tuple_tycons = unitTyCon : [tupleTyCon Boxed i | i <- [2..mAX_TUPLE_SIZE] ] unboxed_tuple_tycons = [tupleTyCon Unboxed i | i <- [1..mAX_TUPLE_SIZE] ] \end{code} @@ -203,8 +204,7 @@ pcDataCon name tyvars context arg_tys tycon [ {- no labelled fields -} ] tyvars context [] [] arg_tys tycon work_id wrap_id - wrap_rdr = nameRdrName name - wrap_occ = rdrNameOcc wrap_rdr + wrap_occ = nameOccName name mod = nameModule name wrap_id = mkDataConWrapId data_con @@ -259,7 +259,8 @@ mk_tuple boxity arity = (tycon, tuple_con) gen_info = mk_tc_gen_info mod tc_uniq tc_name tycon unitTyCon = tupleTyCon Boxed 0 -unitDataConId = dataConWorkId (head (tyConDataCons unitTyCon)) +unitDataCon = head (tyConDataCons unitTyCon) +unitDataConId = dataConWorkId unitDataCon pairTyCon = tupleTyCon Boxed 2 diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs deleted file mode 100644 index 54dadd0c08..0000000000 --- a/ghc/compiler/rename/Rename.lhs +++ /dev/null @@ -1,1048 +0,0 @@ -% -% (c) The GRASP Project, Glasgow University, 1992-1998 -% -\section[Rename]{Renaming and dependency analysis passes} - -\begin{code} -module Rename - ( renameModule - , RnResult(..) - , renameStmt - , renameRdrName - , renameExtCore - , mkGlobalContext - , closeIfaceDecls - , checkOldIface - , slurpIface - ) where - -#include "HsVersions.h" - -import HsSyn -import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation, - RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl, RdrNameImportDecl, - RdrNameStmt - ) -import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl, - RenamedStmt, - instDeclFVs, tyClDeclFVs, ruleDeclFVs - ) - -import CmdLineOpts ( DynFlags, DynFlag(..), opt_InPackage ) -import RnMonad -import RnExpr ( rnStmt ) -import RnNames ( getGlobalNames, exportsFromAvail ) -import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl ) -import RnIfaces ( slurpImpDecls, mkImportInfo, recordLocalSlurps, - closeDecls, - RecompileRequired, outOfDate, recompileRequired - ) -import RnHiFiles ( readIface, loadInterface, - loadExports, loadFixDecls, loadDeprecs, - ) -import RnEnv ( availsToNameSet, - unitAvailEnv, availEnvElts, availNames, - plusAvailEnv, groupAvails, warnUnusedImports, - warnUnusedLocalBinds, warnUnusedModules, - lookupSrcName, getImplicitStmtFVs, mkTopFixityEnv, - getImplicitModuleFVs, newGlobalName, unQualInScope, - ubiquitousNames, lookupOccRn, checkMain, - plusGlobalRdrEnv, mkGlobalRdrEnv - ) -import Module ( Module, ModuleName, WhereFrom(..), - moduleNameUserString, moduleName, - moduleEnvElts - ) -import Name ( Name, nameModule, isExternalName ) -import NameEnv -import NameSet -import RdrName ( foldRdrEnv, isQual, emptyRdrEnv ) -import PrelNames ( iNTERACTIVE, pRELUDE_Name ) -import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass, - printErrorsAndWarnings, errorsFound ) -import Bag ( bagToList ) -import FiniteMap ( FiniteMap, fmToList, emptyFM, lookupFM, - addToFM_C, elemFM, addToFM - ) -import Maybes ( maybeToBool, catMaybes ) -import Outputable -import IO ( openFile, IOMode(..) ) -import HscTypes -- lots of it -import List ( partition, nub ) -\end{code} - - -%********************************************************* -%* * -\subsection{The main wrappers} -%* * -%********************************************************* - -\begin{code} -renameModule :: DynFlags -> GhciMode - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> Module -> RdrNameHsModule - -> IO (PersistentCompilerState, PrintUnqualified, - Maybe (IsExported, ModIface, RnResult)) - -- Nothing => some error occurred in the renamer - -renameModule dflags ghci_mode hit hst pcs this_module rdr_module - = renameSource dflags hit hst pcs this_module $ - rename ghci_mode this_module rdr_module -\end{code} - -\begin{code} -renameStmt :: DynFlags - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> InteractiveContext - -> RdrNameStmt -- parsed stmt - -> IO ( PersistentCompilerState, - PrintUnqualified, - Maybe ([Name], (RenamedStmt, [RenamedHsDecl])) - ) - -renameStmt dflags hit hst pcs ic stmt - = renameSource dflags hit hst pcs iNTERACTIVE $ - - -- load the context module - let InteractiveContext{ ic_rn_gbl_env = rdr_env, - ic_print_unqual = print_unqual, - ic_rn_local_env = local_rdr_env, - ic_type_env = type_env } = ic - in - - extendTypeEnvRn type_env $ - - -- Rename the stmt - initRnMS rdr_env emptyAvailEnv local_rdr_env emptyLocalFixityEnv CmdLineMode ( - rnStmt stmt $ \ stmt' -> - returnRn (([], stmt'), emptyFVs) - ) `thenRn` \ ((binders, stmt), fvs) -> - - -- Bale out if we fail - checkErrsRn `thenRn` \ no_errs_so_far -> - if not no_errs_so_far then - doDump dflags [] stmt [] `thenRn_` returnRn (print_unqual, Nothing) - else - - -- Add implicit free vars, and close decls - getImplicitStmtFVs `thenRn` \ implicit_fvs -> - slurpImpDecls (fvs `plusFV` implicit_fvs) `thenRn` \ decls -> - -- NB: an earlier version deleted (rdrEnvElts local_env) from - -- the fvs. But (a) that isn't necessary, because previously - -- bound things in the local_env will be in the TypeEnv, and - -- the renamer doesn't re-slurp such things, and - -- (b) it's WRONG to delete them. Consider in GHCi: - -- Mod> let x = e :: T - -- Mod> let y = x + 3 - -- We need to pass 'x' among the fvs to slurpImpDecls, so that - -- the latter can see that T is a gate, and hence import the Num T - -- instance decl. (See the InTypEnv case in RnIfaces.slurpSourceRefs.) - - doDump dflags binders stmt decls `thenRn_` - returnRn (print_unqual, Just (binders, (stmt, decls))) - - where - doDump :: DynFlags -> [Name] -> RenamedStmt -> [RenamedHsDecl] - -> RnMG (Either IOError ()) - doDump dflags bndrs stmt decls - = ioToRnM (dumpIfSet_dyn dflags Opt_D_dump_rn "Renamer:" - (vcat [text "Binders:" <+> ppr bndrs, - ppr stmt, text "", - vcat (map ppr decls)])) - - -renameRdrName - :: DynFlags - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> InteractiveContext - -> [RdrName] -- name to rename - -> IO ( PersistentCompilerState, - PrintUnqualified, - Maybe ([Name], [RenamedHsDecl]) - ) - -renameRdrName dflags hit hst pcs ic rdr_names = - renameSource dflags hit hst pcs iNTERACTIVE $ - - -- load the context module - let InteractiveContext{ ic_rn_gbl_env = rdr_env, - ic_print_unqual = print_unqual, - ic_rn_local_env = local_rdr_env, - ic_type_env = type_env } = ic - in - - extendTypeEnvRn type_env $ - - -- rename the rdr_name - initRnMS rdr_env emptyAvailEnv local_rdr_env emptyLocalFixityEnv CmdLineMode - (mapRn (tryRn.lookupOccRn) rdr_names) `thenRn` \ maybe_names -> - let - ok_names = [ a | Right a <- maybe_names ] - in - if null ok_names - then let errs = head [ e | Left e <- maybe_names ] - in setErrsRn errs `thenRn_` - doDump dflags ok_names [] `thenRn_` - returnRn (print_unqual, Nothing) - else - - slurpImpDecls (mkNameSet ok_names) `thenRn` \ decls -> - - doDump dflags ok_names decls `thenRn_` - returnRn (print_unqual, Just (ok_names, decls)) - where - doDump :: DynFlags -> [Name] -> [RenamedHsDecl] -> RnMG (Either IOError ()) - doDump dflags names decls - = ioToRnM (dumpIfSet_dyn dflags Opt_D_dump_rn "Renamer:" - (vcat [ppr names, text "", - vcat (map ppr decls)])) -\end{code} - -\begin{code} -renameExtCore :: DynFlags - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> Module - -> RdrNameHsModule - -> IO (PersistentCompilerState, PrintUnqualified, - Maybe (IsExported, ModIface, [RenamedHsDecl])) - - -- Nothing => some error occurred in the renamer -renameExtCore dflags hit hst pcs this_module - rdr_module@(HsModule _ _ _ _ local_decls _ loc) - -- Rename the (Core) module - = renameSource dflags hit hst pcs this_module $ - pushSrcLocRn loc $ - - -- Rename the source - initIfaceRnMS this_module (rnExtCoreDecls local_decls) `thenRn` \ (rn_local_decls, binders, fvs) -> - recordLocalSlurps binders `thenRn_` - closeDecls rn_local_decls fvs `thenRn` \ final_decls -> - - -- Bail out if we fail (but dump debug output anyway for debugging) - rnDump final_decls `thenRn_` - checkErrsRn `thenRn` \ no_errs_so_far -> - if not no_errs_so_far then - returnRn (print_unqualified, Nothing) - else - let - mod_iface = ModIface { mi_module = this_module, - mi_package = opt_InPackage, - mi_version = initialVersionInfo, - mi_usages = [], - mi_boot = False, - mi_orphan = panic "is_orphan", - -- ToDo: export the data types also. - mi_exports = [(moduleName this_module, - map Avail (nameSetToList binders))], - mi_globals = Nothing, - mi_fixities = mkNameEnv [], - mi_deprecs = NoDeprecs, - mi_decls = panic "mi_decls" - } - - is_exported _ = True - in - returnRn (print_unqualified, Just (is_exported, mod_iface, final_decls)) - - where - print_unqualified = const False -- print everything qualified. - - -rnExtCoreDecls :: [RdrNameHsDecl] - -> RnMS ([RenamedHsDecl], - NameSet, -- Binders - FreeVars) -- Free variables - -rnExtCoreDecls decls - -- Renaming external-core decls is rather like renaming an interface file - -- All the decls are TyClDecls, and all the names are original names - = go [] emptyNameSet emptyNameSet decls - where - go rn_decls bndrs fvs [] = returnRn (rn_decls, bndrs, fvs) - - go rn_decls bndrs fvs (TyClD decl : decls) - = rnTyClDecl decl `thenRn` \ rn_decl -> - go (TyClD rn_decl : rn_decls) - (addListToNameSet bndrs (map fst (tyClDeclSysNames rn_decl ++ tyClDeclNames rn_decl))) - (fvs `plusFV` tyClDeclFVs rn_decl) - decls - - go rn_decls bndrs fvs (decl : decls) - = addErrRn (text "Unexpected decl in ExtCore file" $$ ppr decl) `thenRn_` - go rn_decls bndrs fvs decls -\end{code} - - -%********************************************************* -%* * -\subsection{Make up an interactive context} -%* * -%********************************************************* - -\begin{code} -mkGlobalContext - :: DynFlags -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> [Module] -> [Module] - -> IO (PersistentCompilerState, PrintUnqualified, Maybe GlobalRdrEnv) -mkGlobalContext dflags hit hst pcs toplevs exports - = renameSource dflags hit hst pcs iNTERACTIVE $ - - mapRn getTopLevScope toplevs `thenRn` \ toplev_envs -> - mapRn getModuleExports exports `thenRn` \ export_envs -> - let full_env = foldr plusGlobalRdrEnv emptyRdrEnv - (toplev_envs ++ export_envs) - print_unqual = unQualInScope full_env - in - checkErrsRn `thenRn` \ no_errs_so_far -> - if not no_errs_so_far then - returnRn (print_unqual, Nothing) - else - returnRn (print_unqual, Just full_env) - -contextDoc = text "context for compiling statements" - -getTopLevScope :: Module -> RnM d GlobalRdrEnv -getTopLevScope mod = - loadInterface contextDoc (moduleName mod) ImportByUser `thenRn` \ iface -> - case mi_globals iface of - Nothing -> panic "getTopLevScope" - Just env -> returnRn env - -getModuleExports :: Module -> RnM d GlobalRdrEnv -getModuleExports mod = - loadInterface contextDoc (moduleName mod) ImportByUser `thenRn` \ iface -> - returnRn (foldl add emptyRdrEnv (mi_exports iface)) - where - prov_fn n = NonLocalDef ImplicitImport - add env (mod,avails) = - plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs) -\end{code} - -%********************************************************* -%* * -\subsection{Slurp in a whole module eagerly} -%* * -%********************************************************* - -\begin{code} -slurpIface - :: DynFlags -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState -> Module - -> IO (PersistentCompilerState, PrintUnqualified, - Maybe ([Name], [RenamedHsDecl])) -slurpIface dflags hit hst pcs mod = - renameSource dflags hit hst pcs iNTERACTIVE $ - - let mod_name = moduleName mod - in - loadInterface contextDoc mod_name ImportByUser `thenRn` \ iface -> - let fvs = availsToNameSet [ avail | (mn,avails) <- mi_exports iface, - avail <- avails ] - in - slurpImpDecls fvs `thenRn` \ rn_imp_decls -> - returnRn (alwaysQualify, Just (nameSetToList fvs, rn_imp_decls)) -\end{code} - -%********************************************************* -%* * -\subsection{The main function: rename} -%* * -%********************************************************* - -\begin{code} -renameSource :: DynFlags - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> Module - -> RnMG (PrintUnqualified, Maybe r) - -> IO (PersistentCompilerState, PrintUnqualified, Maybe r) - -- Nothing => some error occurred in the renamer - -renameSource dflags hit hst old_pcs this_module thing_inside - = do { showPass dflags "Renamer" - - -- Initialise the renamer monad - ; (new_pcs, msgs, (print_unqual, maybe_rn_stuff)) - <- initRn dflags hit hst old_pcs this_module thing_inside - - -- Print errors from renaming - ; printErrorsAndWarnings print_unqual msgs ; - - -- Return results. No harm in updating the PCS - ; if errorsFound msgs then - return (new_pcs, print_unqual, Nothing) - else - return (new_pcs, print_unqual, maybe_rn_stuff) - } -\end{code} - -\begin{code} -data RnResult -- A RenamedModule ia passed from renamer to typechecker - = RnResult { rr_mod :: Module, -- Same as in the ModIface, - rr_fixities :: FixityEnv, -- but convenient to have it here - - rr_main :: Maybe Name, -- Just main, for module Main, - -- Nothing for other modules - - rr_decls :: [RenamedHsDecl] - -- The other declarations of the module - -- Fixity and deprecations have already been slurped out - } -- and are now in the ModIface for the module - -rename :: GhciMode -> Module -> RdrNameHsModule - -> RnMG (PrintUnqualified, Maybe (IsExported, ModIface, RnResult)) -rename ghci_mode this_module - contents@(HsModule _ _ exports imports local_decls mod_deprec loc) - = pushSrcLocRn loc $ - - -- FIND THE GLOBAL NAME ENVIRONMENT - getGlobalNames this_module contents `thenRn` \ (gbl_env, local_gbl_env, - (mod_avail_env, global_avail_env)) -> - let - print_unqualified = unQualInScope gbl_env - - full_avail_env :: NameEnv AvailInfo - -- The domain of global_avail_env is just the 'major' things; - -- variables, type constructors, classes. - -- E.g. Functor |-> Functor( Functor, fmap ) - -- The domain of full_avail_env is everything in scope - -- E.g. Functor |-> Functor( Functor, fmap ) - -- fmap |-> Functor( Functor, fmap ) - -- - -- This filled-out avail_env is needed to generate - -- exports (mkExportAvails), and for generating minimal - -- exports (reportUnusedNames) - full_avail_env = mkNameEnv [ (name,avail) - | avail <- availEnvElts global_avail_env, - name <- availNames avail] - in - -- Exit if we've found any errors - checkErrsRn `thenRn` \ no_errs_so_far -> - if not no_errs_so_far then - -- Found errors already, so exit now - returnRn (print_unqualified, Nothing) - else - - -- PROCESS EXPORT LIST - exportsFromAvail mod_name exports mod_avail_env - full_avail_env gbl_env `thenRn` \ export_avails -> - - traceRn (text "Local top-level environment" $$ - nest 4 (pprGlobalRdrEnv local_gbl_env)) `thenRn_` - - -- DEAL WITH DEPRECATIONS - rnDeprecs local_gbl_env mod_deprec - [d | DeprecD d <- local_decls] `thenRn` \ my_deprecs -> - - -- DEAL WITH LOCAL FIXITIES - fixitiesFromLocalDecls local_gbl_env local_decls `thenRn` \ local_fixity_env -> - - -- RENAME THE SOURCE - rnSourceDecls gbl_env global_avail_env - local_fixity_env SourceMode local_decls `thenRn` \ (rn_local_decls, source_fvs) -> - - -- GET ANY IMPLICIT FREE VARIALBES - getImplicitModuleFVs rn_local_decls `thenRn` \ implicit_fvs -> - checkMain ghci_mode mod_name gbl_env `thenRn` \ (maybe_main_name, main_fvs, implicit_main_fvs) -> - let - export_fvs = availsToNameSet export_avails - used_fvs = source_fvs `plusFV` export_fvs `plusFV` main_fvs - -- The export_fvs make the exported names look just as if they - -- occurred in the source program. For the reasoning, see the - -- comments with RnIfaces.mkImportInfo - -- It also helps reportUnusedNames, which of course must not complain - -- that 'f' isn't mentioned if it is mentioned in the export list - - needed_fvs = implicit_fvs `plusFV` implicit_main_fvs `plusFV` used_fvs - -- It's important to do the "plus" this way round, so that - -- when compiling the prelude, locally-defined (), Bool, etc - -- override the implicit ones. - - in - traceRn (text "Needed FVs:" <+> fsep (map ppr (nameSetToList needed_fvs))) `thenRn_` - - -- EXIT IF ERRORS FOUND - -- We exit here if there are any errors in the source, *before* - -- we attempt to slurp the decls from the interfaces, otherwise - -- the slurped decls may get lost when we return up the stack - -- to hscMain/hscExpr. - checkErrsRn `thenRn` \ no_errs_so_far -> - if not no_errs_so_far then - -- Found errors already, so exit now - rnDump rn_local_decls `thenRn_` - returnRn (print_unqualified, Nothing) - else - - -- SLURP IN ALL THE NEEDED DECLARATIONS - slurpImpDecls needed_fvs `thenRn` \ rn_imp_decls -> - - -- GENERATE THE VERSION/USAGE INFO - mkImportInfo mod_name imports `thenRn` \ my_usages -> - - -- BUILD THE MODULE INTERFACE - let - -- We record fixities even for things that aren't exported, - -- so that we can change into the context of this moodule easily - fixities = mkNameEnv [ (name, fixity) - | FixitySig name fixity loc <- nameEnvElts local_fixity_env - ] - - -- Sort the exports to make them easier to compare for versions - my_exports = groupAvails this_module export_avails - - final_decls = rn_local_decls ++ rn_imp_decls - - -- In interactive mode, we don't want to discard any top-level - -- entities at all (eg. do not inline them away during - -- simplification), and retain them all in the TypeEnv so they are - -- available from the command line. - -- - -- isExternalName separates the user-defined top-level names from those - -- introduced by the type checker. - dont_discard :: Name -> Bool - dont_discard | ghci_mode == Interactive = isExternalName - | otherwise = (`elemNameSet` export_fvs) - - mod_iface = ModIface { mi_module = this_module, - mi_package = opt_InPackage, - mi_version = initialVersionInfo, - mi_usages = my_usages, - mi_boot = False, - mi_orphan = panic "is_orphan", - mi_exports = my_exports, - mi_globals = Just gbl_env, - mi_fixities = fixities, - mi_deprecs = my_deprecs, - mi_decls = panic "mi_decls" - } - - rn_result = RnResult { rr_mod = this_module, - rr_fixities = fixities, - rr_decls = final_decls, - rr_main = maybe_main_name } - in - - rnDump final_decls `thenRn_` - rnStats rn_imp_decls `thenRn_` - - -- REPORT UNUSED NAMES, AND DEBUG DUMP - reportUnusedNames mod_iface print_unqualified - imports full_avail_env gbl_env - used_fvs rn_imp_decls `thenRn_` - -- NB: used_fvs: include exports (else we get bogus - -- warnings of unused things) but not implicit FVs. - - returnRn (print_unqualified, Just (dont_discard, mod_iface, rn_result)) - where - mod_name = moduleName this_module -\end{code} - - - -%********************************************************* -%* * -\subsection{Fixities} -%* * -%********************************************************* - -\begin{code} -fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG LocalFixityEnv -fixitiesFromLocalDecls gbl_env decls - = mkTopFixityEnv gbl_env (foldr get_fix_sigs [] decls) `thenRn` \ env -> - traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env))) `thenRn_` - returnRn env - where - get_fix_sigs (FixD fix) acc = fix:acc - get_fix_sigs (TyClD (ClassDecl { tcdSigs = sigs})) acc - = [sig | FixSig sig <- sigs] ++ acc -- Get fixities from class decl sigs too. - get_fix_sigs other_decl acc = acc -\end{code} - - -%********************************************************* -%* * -\subsection{Deprecations} -%* * -%********************************************************* - -For deprecations, all we do is check that the names are in scope. -It's only imported deprecations, dealt with in RnIfaces, that we -gather them together. - -\begin{code} -rnDeprecs :: GlobalRdrEnv -> Maybe DeprecTxt - -> [RdrNameDeprecation] -> RnMG Deprecations -rnDeprecs gbl_env Nothing [] - = returnRn NoDeprecs - -rnDeprecs gbl_env (Just txt) decls - = mapRn (addErrRn . badDeprec) decls `thenRn_` - returnRn (DeprecAll txt) - -rnDeprecs gbl_env Nothing decls - = mapRn rn_deprec decls `thenRn` \ pairs -> - returnRn (DeprecSome (mkNameEnv (catMaybes pairs))) - where - rn_deprec (Deprecation rdr_name txt loc) - = pushSrcLocRn loc $ - lookupSrcName gbl_env rdr_name `thenRn` \ name -> - returnRn (Just (name, (name,txt))) -\end{code} - - -%************************************************************************ -%* * -\subsection{Grabbing the old interface file and checking versions} -%* * -%************************************************************************ - -\begin{code} -checkOldIface :: GhciMode - -> DynFlags - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> Module - -> FilePath - -> Bool -- Source unchanged - -> Maybe ModIface -- Old interface from compilation manager, if any - -> IO (PersistentCompilerState, Bool, (RecompileRequired, Maybe ModIface)) - -- True <=> errors happened - -checkOldIface ghci_mode dflags hit hst pcs mod iface_path source_unchanged maybe_iface - = runRn dflags hit hst pcs (panic "Bogus module") $ - - -- CHECK WHETHER THE SOURCE HAS CHANGED - ( if not source_unchanged then - traceHiDiffsRn (nest 4 (text "Source file changed or recompilation check turned off")) - else returnRn () ) `thenRn_` - - -- If the source has changed and we're in interactive mode, avoid reading - -- an interface; just return the one we might have been supplied with. - if ghci_mode == Interactive && not source_unchanged then - returnRn (outOfDate, maybe_iface) - else - - setModuleRn mod $ - case maybe_iface of - Just old_iface -> -- Use the one we already have - check_versions old_iface - - Nothing -- try and read it from a file - -> readIface iface_path `thenRn` \ read_result -> - case read_result of - Left err -> -- Old interface file not found, or garbled; give up - traceHiDiffsRn ( - text "Cannot read old interface file:" - $$ nest 4 err) `thenRn_` - returnRn (outOfDate, Nothing) - - Right parsed_iface -> - let read_mod_name = pi_mod parsed_iface - wanted_mod_name = moduleName mod - in - if (wanted_mod_name /= read_mod_name) then - traceHiDiffsRn ( - text "Existing interface file has wrong module name: " - <> quotes (ppr read_mod_name) - ) `thenRn_` - returnRn (outOfDate, Nothing) - else - loadOldIface mod parsed_iface `thenRn` \ m_iface -> - check_versions m_iface - where - check_versions :: ModIface -> RnMG (RecompileRequired, Maybe ModIface) - check_versions iface - | not source_unchanged - = returnRn (outOfDate, Just iface) - | otherwise - = -- Check versions - recompileRequired iface_path iface `thenRn` \ recompile -> - returnRn (recompile, Just iface) -\end{code} - -I think the following function should now have a more representative name, -but what? - -\begin{code} -loadOldIface :: Module -> ParsedIface -> RnMG ModIface - -loadOldIface mod parsed_iface - = let iface = parsed_iface - in - initIfaceRnMS mod ( - loadHomeDecls (pi_decls iface) `thenRn` \ decls -> - loadHomeRules (pi_rules iface) `thenRn` \ rules -> - loadHomeInsts (pi_insts iface) `thenRn` \ insts -> - returnRn (decls, rules, insts) - ) - `thenRn` \ ((decls_vers, new_decls), (rule_vers, new_rules), new_insts) -> - - mapRn loadHomeUsage (pi_usages iface) `thenRn` \ usages -> - loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) -> - loadFixDecls mod (pi_fixity iface) `thenRn` \ fix_env -> - loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env -> - let - version = VersionInfo { vers_module = pi_vers iface, - vers_exports = export_vers, - vers_rules = rule_vers, - vers_decls = decls_vers } - - decls = mkIfaceDecls new_decls new_rules new_insts - - mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg parsed_iface, - mi_version = version, - mi_exports = avails, mi_usages = usages, - mi_boot = False, mi_orphan = pi_orphan iface, - mi_fixities = fix_env, mi_deprecs = deprec_env, - mi_decls = decls, - mi_globals = Nothing - } - in - returnRn mod_iface -\end{code} - -\begin{code} -loadHomeDecls :: [(Version, RdrNameTyClDecl)] - -> RnMS (NameEnv Version, [RenamedTyClDecl]) -loadHomeDecls decls = foldlRn loadHomeDecl (emptyNameEnv, []) decls - -loadHomeDecl :: (NameEnv Version, [RenamedTyClDecl]) - -> (Version, RdrNameTyClDecl) - -> RnMS (NameEnv Version, [RenamedTyClDecl]) -loadHomeDecl (version_map, decls) (version, decl) - = rnTyClDecl decl `thenRn` \ decl' -> - returnRn (extendNameEnv version_map (tyClDeclName decl') version, decl':decls) - ------------------- -loadHomeRules :: (Version, [RdrNameRuleDecl]) - -> RnMS (Version, [RenamedRuleDecl]) -loadHomeRules (version, rules) - = mapRn rnIfaceRuleDecl rules `thenRn` \ rules' -> - returnRn (version, rules') - ------------------- -loadHomeInsts :: [RdrNameInstDecl] - -> RnMS [RenamedInstDecl] -loadHomeInsts insts = mapRn rnInstDecl insts - ------------------- -loadHomeUsage :: ImportVersion OccName - -> RnMG (ImportVersion Name) -loadHomeUsage (mod_name, orphans, is_boot, whats_imported) - = rn_imps whats_imported `thenRn` \ whats_imported' -> - returnRn (mod_name, orphans, is_boot, whats_imported') - where - rn_imps NothingAtAll = returnRn NothingAtAll - rn_imps (Everything v) = returnRn (Everything v) - rn_imps (Specifically mv ev items rv) = mapRn rn_imp items `thenRn` \ items' -> - returnRn (Specifically mv ev items' rv) - rn_imp (occ,vers) = newGlobalName mod_name occ `thenRn` \ name -> - returnRn (name,vers) -\end{code} - - - -%********************************************************* -%* * -\subsection{Closing up the interface decls} -%* * -%********************************************************* - -Suppose we discover we don't need to recompile. Then we start from the -IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need. - -\begin{code} -closeIfaceDecls :: DynFlags - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> ModIface -- Get the decls from here - -> IO (PersistentCompilerState, Bool, [RenamedHsDecl]) - -- True <=> errors happened -closeIfaceDecls dflags hit hst pcs - mod_iface@(ModIface { mi_module = mod, mi_decls = iface_decls }) - = runRn dflags hit hst pcs mod $ - - let - rule_decls = dcl_rules iface_decls - inst_decls = dcl_insts iface_decls - tycl_decls = dcl_tycl iface_decls - decls = map RuleD rule_decls ++ - map InstD inst_decls ++ - map TyClD tycl_decls - needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets` - unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets` - unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets` - ubiquitousNames - -- Data type decls with record selectors, - -- which may appear in the decls, need unpackCString - -- and friends. It's easier to just grab them right now. - - local_names = foldl add emptyNameSet tycl_decls - add names decl = addListToNameSet names (map fst (tyClDeclSysNames decl ++ tyClDeclNames decl)) - in - recordLocalSlurps local_names `thenRn_` - - -- Do the transitive closure - closeDecls decls needed `thenRn` \closed_decls -> - rnDump closed_decls `thenRn_` - returnRn closed_decls -\end{code} - -%********************************************************* -%* * -\subsection{Unused names} -%* * -%********************************************************* - -\begin{code} -reportUnusedNames :: ModIface -> PrintUnqualified - -> [RdrNameImportDecl] - -> AvailEnv - -> GlobalRdrEnv - -> NameSet -- Used in this module - -> [RenamedHsDecl] - -> RnMG () -reportUnusedNames my_mod_iface unqual imports avail_env gbl_env - used_names imported_decls - = warnUnusedModules unused_imp_mods `thenRn_` - warnUnusedLocalBinds bad_locals `thenRn_` - warnUnusedImports bad_imp_names `thenRn_` - printMinimalImports this_mod unqual minimal_imports - where - this_mod = mi_module my_mod_iface - - -- Now, a use of C implies a use of T, - -- if C was brought into scope by T(..) or T(C) - really_used_names = used_names `unionNameSets` - mkNameSet [ parent_name - | sub_name <- nameSetToList used_names - - -- Usually, every used name will appear in avail_env, but there - -- is one time when it doesn't: tuples and other built in syntax. When you - -- write (a,b) that gives rise to a *use* of "(,)", so that the - -- instances will get pulled in, but the tycon "(,)" isn't actually - -- in scope. Also, (-x) gives rise to an implicit use of 'negate'; - -- similarly, 3.5 gives rise to an implcit use of :% - -- Hence the silent 'False' in all other cases - - , Just parent_name <- [case lookupNameEnv avail_env sub_name of - Just (AvailTC n _) -> Just n - other -> Nothing] - ] - - -- Collect the defined names from the in-scope environment - -- Look for the qualified ones only, else get duplicates - defined_names :: [GlobalRdrElt] - defined_names = foldRdrEnv add [] gbl_env - add rdr_name ns acc | isQual rdr_name = ns ++ acc - | otherwise = acc - - defined_and_used, defined_but_not_used :: [GlobalRdrElt] - (defined_and_used, defined_but_not_used) = partition used defined_names - used (GRE name _ _) = name `elemNameSet` really_used_names - - -- Filter out the ones only defined implicitly - bad_locals :: [Name] - bad_locals = [n | (GRE n LocalDef _) <- defined_but_not_used] - - bad_imp_names :: [(Name,Provenance)] - bad_imp_names = [(n,p) | GRE n p@(NonLocalDef (UserImport mod _ True)) _ <- defined_but_not_used, - not (module_unused mod)] - - -- inst_mods are directly-imported modules that - -- contain instance decl(s) that the renamer decided to suck in - -- It's not necessarily redundant to import such modules. - -- - -- NOTE: Consider - -- module This - -- import M () - -- - -- The import M() is not *necessarily* redundant, even if - -- we suck in no instance decls from M (e.g. it contains - -- no instance decls, or This contains no code). It may be - -- that we import M solely to ensure that M's orphan instance - -- decls (or those in its imports) are visible to people who - -- import This. Sigh. - -- There's really no good way to detect this, so the error message - -- in RnEnv.warnUnusedModules is weakened instead - inst_mods :: [ModuleName] - inst_mods = [m | InstD (InstDecl _ _ _ (Just dfun) _) <- imported_decls, - let m = moduleName (nameModule dfun), - m `elem` direct_import_mods - ] - - -- To figure out the minimal set of imports, start with the things - -- that are in scope (i.e. in gbl_env). Then just combine them - -- into a bunch of avails, so they are properly grouped - minimal_imports :: FiniteMap ModuleName AvailEnv - minimal_imports0 = emptyFM - minimal_imports1 = foldr add_name minimal_imports0 defined_and_used - minimal_imports = foldr add_inst_mod minimal_imports1 inst_mods - - -- We've carefully preserved the provenance so that we can - -- construct minimal imports that import the name by (one of) - -- the same route(s) as the programmer originally did. - add_name (GRE n (NonLocalDef (UserImport m _ _)) _) acc = addToFM_C plusAvailEnv acc (moduleName m) - (unitAvailEnv (mk_avail n)) - add_name (GRE n other_prov _) acc = acc - - mk_avail n = case lookupNameEnv avail_env n of - Just (AvailTC m _) | n==m -> AvailTC n [n] - | otherwise -> AvailTC m [n,m] - Just avail -> Avail n - Nothing -> pprPanic "mk_avail" (ppr n) - - add_inst_mod m acc - | m `elemFM` acc = acc -- We import something already - | otherwise = addToFM acc m emptyAvailEnv - -- Add an empty collection of imports for a module - -- from which we have sucked only instance decls - - direct_import_mods :: [ModuleName] - direct_import_mods = nub [m | ImportDecl m _ _ _ _ _ <- imports] - - -- unused_imp_mods are the directly-imported modules - -- that are not mentioned in minimal_imports - unused_imp_mods = [m | m <- direct_import_mods, - not (maybeToBool (lookupFM minimal_imports m)), - m /= pRELUDE_Name] - - module_unused :: Module -> Bool - module_unused mod = moduleName mod `elem` unused_imp_mods - - --- ToDo: deal with original imports with 'qualified' and 'as M' clauses -printMinimalImports :: Module -- This module - -> PrintUnqualified - -> FiniteMap ModuleName AvailEnv -- Minimal imports - -> RnMG () -printMinimalImports this_mod unqual imps - = ifOptRn Opt_D_dump_minimal_imports $ - - mapRn to_ies (fmToList imps) `thenRn` \ mod_ies -> - ioToRnM (do { h <- openFile filename WriteMode ; - printForUser h unqual (vcat (map ppr_mod_ie mod_ies)) - }) `thenRn_` - returnRn () - where - filename = moduleNameUserString (moduleName this_mod) ++ ".imports" - ppr_mod_ie (mod_name, ies) - | mod_name == pRELUDE_Name - = empty - | otherwise - = ptext SLIT("import") <+> ppr mod_name <> - parens (fsep (punctuate comma (map ppr ies))) - - to_ies (mod, avail_env) = mapRn to_ie (availEnvElts avail_env) `thenRn` \ ies -> - returnRn (mod, ies) - - to_ie :: AvailInfo -> RnMG (IE Name) - -- The main trick here is that if we're importing all the constructors - -- we want to say "T(..)", but if we're importing only a subset we want - -- to say "T(A,B,C)". So we have to find out what the module exports. - to_ie (Avail n) = returnRn (IEVar n) - to_ie (AvailTC n [m]) = ASSERT( n==m ) - returnRn (IEThingAbs n) - to_ie (AvailTC n ns) - = loadInterface (text "Compute minimal imports from" <+> ppr n_mod) - n_mod ImportBySystem `thenRn` \ iface -> - case [xs | (m,as) <- mi_exports iface, - m == n_mod, - AvailTC x xs <- as, - x == n] of - [xs] | all (`elem` ns) xs -> returnRn (IEThingAll n) - | otherwise -> returnRn (IEThingWith n (filter (/= n) ns)) - other -> pprTrace "to_ie" (ppr n <+> ppr (nameModule n) <+> ppr other) $ - returnRn (IEVar n) - where - n_mod = moduleName (nameModule n) - -rnDump :: [RenamedHsDecl] -- Renamed decls - -> RnMG () -rnDump decls - = doptRn Opt_D_dump_rn_trace `thenRn` \ dump_rn_trace -> - doptRn Opt_D_dump_rn_stats `thenRn` \ dump_rn_stats -> - doptRn Opt_D_dump_rn `thenRn` \ dump_rn -> - getIfacesRn `thenRn` \ ifaces -> - - ioToRnM ( dumpIfSet dump_rn "Renamer:" - (vcat (map ppr decls)) ) - `thenRn_` - - returnRn () - -rnStats :: [RenamedHsDecl] -- Imported decls - -> RnMG () -rnStats imp_decls - = doptRn Opt_D_dump_rn_trace `thenRn` \ dump_rn_trace -> - doptRn Opt_D_dump_rn_stats `thenRn` \ dump_rn_stats -> - doptRn Opt_D_dump_rn `thenRn` \ dump_rn -> - getIfacesRn `thenRn` \ ifaces -> - - ioToRnM (dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn) - "Renamer statistics" - (getRnStats imp_decls ifaces)) `thenRn_` - returnRn () -\end{code} - - -%********************************************************* -%* * -\subsection{Statistics} -%* * -%********************************************************* - -\begin{code} -getRnStats :: [RenamedHsDecl] -> Ifaces -> SDoc -getRnStats imported_decls ifaces - = hcat [text "Renamer stats: ", stats] - where - n_mods = length [() | _ <- moduleEnvElts (iPIT ifaces)] - -- This is really only right for a one-shot compile - - (decls_map, n_decls_slurped) = iDecls ifaces - - n_decls_left = length [decl | (avail, True, (_,decl)) <- nameEnvElts decls_map - -- Data, newtype, and class decls are in the decls_fm - -- under multiple names; the tycon/class, and each - -- constructor/class op too. - -- The 'True' selects just the 'main' decl - ] - - (insts_left, n_insts_slurped) = iInsts ifaces - n_insts_left = length (bagToList insts_left) - - (rules_left, n_rules_slurped) = iRules ifaces - n_rules_left = length (bagToList rules_left) - - stats = vcat - [int n_mods <+> text "interfaces read", - hsep [ int n_decls_slurped, text "type/class/variable imported, out of", - int (n_decls_slurped + n_decls_left), text "read"], - hsep [ int n_insts_slurped, text "instance decls imported, out of", - int (n_insts_slurped + n_insts_left), text "read"], - hsep [ int n_rules_slurped, text "rule decls imported, out of", - int (n_rules_slurped + n_rules_left), text "read"] - ] -\end{code} - - -%************************************************************************ -%* * -\subsection{Errors and warnings} -%* * -%************************************************************************ - -\begin{code} -badDeprec d - = sep [ptext SLIT("Illegal deprecation when whole module is deprecated"), - nest 4 (ppr d)] -\end{code} - - diff --git a/ghc/compiler/rename/RnBinds.hi-boot b/ghc/compiler/rename/RnBinds.hi-boot deleted file mode 100644 index 66637e0467..0000000000 --- a/ghc/compiler/rename/RnBinds.hi-boot +++ /dev/null @@ -1,5 +0,0 @@ -_interface_ RnBinds 1 -_exports_ -RnBinds rnBinds; -_declarations_ -1 rnBinds _:_ _forall_ [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, NameSet.FreeVars)) -> RnMonad.RnMS (b, NameSet.FreeVars) ;; diff --git a/ghc/compiler/rename/RnBinds.hi-boot-5 b/ghc/compiler/rename/RnBinds.hi-boot-5 deleted file mode 100644 index b2fcc90b11..0000000000 --- a/ghc/compiler/rename/RnBinds.hi-boot-5 +++ /dev/null @@ -1,3 +0,0 @@ -__interface RnBinds 1 0 where -__export RnBinds rnBinds; -1 rnBinds :: __forall [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, NameSet.FreeVars)) -> RnMonad.RnMS (b, NameSet.FreeVars) ; diff --git a/ghc/compiler/rename/RnBinds.hi-boot-6 b/ghc/compiler/rename/RnBinds.hi-boot-6 deleted file mode 100644 index 6f2f354394..0000000000 --- a/ghc/compiler/rename/RnBinds.hi-boot-6 +++ /dev/null @@ -1,6 +0,0 @@ -module RnBinds where - -rnBinds :: forall b . RdrHsSyn.RdrNameHsBinds - -> (RnHsSyn.RenamedHsBinds - -> RnMonad.RnMS (b, NameSet.FreeVars)) - -> RnMonad.RnMS (b, NameSet.FreeVars) diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index af0f98253a..7a0c19ea45 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -10,10 +10,8 @@ they may be affected by renaming (which isn't fully worked out yet). \begin{code} module RnBinds ( - rnTopBinds, rnTopMonoBinds, - rnMethodBinds, renameSigs, renameSigsFVs, - rnBinds, - unknownSigErr + rnTopMonoBinds, rnMonoBinds, rnMethodBinds, + renameSigs, renameSigsFVs, unknownSigErr ) where #include "HsVersions.h" @@ -23,11 +21,11 @@ import HsSyn import HsBinds ( eqHsSig, sigName, hsSigDoc ) import RdrHsSyn import RnHsSyn -import RnMonad +import TcRnMonad import RnTypes ( rnHsSigType, rnHsType ) import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupInstDeclBndr, - lookupSigOccRn, bindPatSigTyVars, extendNestedFixityEnv, + lookupSigOccRn, bindPatSigTyVars, bindLocalFixities, warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, ) import CmdLineOpts ( DynFlag(..) ) @@ -35,7 +33,7 @@ import Digraph ( stronglyConnComp, SCC(..) ) import Name ( Name, nameOccName, nameSrcLoc ) import NameSet import RdrName ( RdrName, rdrNameOcc ) -import BasicTypes ( RecFlag(..) ) +import BasicTypes ( RecFlag(..), FixitySig(..) ) import List ( partition ) import Outputable import PrelNames ( isUnboundName ) @@ -150,35 +148,28 @@ it expects the global environment to contain bindings for the binders %* * %************************************************************************ -@rnTopBinds@ assumes that the environment already +@rnTopMonoBinds@ assumes that the environment already contains bindings for the binders of this particular binding. \begin{code} -rnTopBinds :: RdrNameHsBinds -> RnMS (RenamedHsBinds, FreeVars) - -rnTopBinds EmptyBinds = returnRn (EmptyBinds, emptyFVs) -rnTopBinds (MonoBind bind sigs _) = rnTopMonoBinds bind sigs - -- The parser doesn't produce other forms - - rnTopMonoBinds mbinds sigs - = mapRn lookupBndrRn binder_rdr_names `thenRn` \ binder_names -> + = mappM lookupBndrRn binder_rdr_names `thenM` \ binder_names -> bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ let bndr_name_set = mkNameSet binder_names in - renameSigsFVs (okBindSig bndr_name_set) sigs `thenRn` \ (siglist, sig_fvs) -> + renameSigsFVs (okBindSig bndr_name_set) sigs `thenM` \ (siglist, sig_fvs) -> - ifOptRn Opt_WarnMissingSigs ( + ifOptM Opt_WarnMissingSigs ( let type_sig_vars = [n | Sig n _ _ <- siglist] un_sigd_binders = nameSetToList (delListFromNameSet bndr_name_set type_sig_vars) in - mapRn_ missingSigWarn un_sigd_binders - ) `thenRn_` + mappM_ missingSigWarn un_sigd_binders + ) `thenM_` - rn_mono_binds siglist mbinds `thenRn` \ (final_binds, bind_fvs) -> - returnRn (final_binds, bind_fvs `plusFV` sig_fvs) + rn_mono_binds siglist mbinds `thenM` \ (final_binds, bind_fvs) -> + returnM (final_binds, bind_fvs `plusFV` sig_fvs) where binder_rdr_names = collectMonoBinders mbinds \end{code} @@ -200,19 +191,10 @@ rnTopMonoBinds mbinds sigs \end{itemize} % \begin{code} -rnBinds :: RdrNameHsBinds - -> (RenamedHsBinds -> RnMS (result, FreeVars)) - -> RnMS (result, FreeVars) - -rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds -rnBinds (MonoBind bind sigs _) thing_inside = rnMonoBinds bind sigs thing_inside - -- the parser doesn't produce other forms - - rnMonoBinds :: RdrNameMonoBinds -> [RdrNameSig] - -> (RenamedHsBinds -> RnMS (result, FreeVars)) - -> RnMS (result, FreeVars) + -> (RenamedHsBinds -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds = -- Extract all the binders in this group, @@ -224,27 +206,24 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds binder_set = mkNameSet new_mbinders in -- Rename the signatures - renameSigsFVs (okBindSig binder_set) sigs `thenRn` \ (siglist, sig_fvs) -> + renameSigsFVs (okBindSig binder_set) sigs `thenM` \ (siglist, sig_fvs) -> -- Report the fixity declarations in this group that -- don't refer to any of the group's binders. -- Then install the fixity declarations that do apply here -- Notice that they scope over thing_inside too - let - fixity_sigs = [(name,sig) | FixSig sig@(FixitySig name _ _) <- siglist ] - in - extendNestedFixityEnv fixity_sigs $ + bindLocalFixities [sig | FixSig sig <- siglist ] $ - rn_mono_binds siglist mbinds `thenRn` \ (binds, bind_fvs) -> + rn_mono_binds siglist mbinds `thenM` \ (binds, bind_fvs) -> -- Now do the "thing inside", and deal with the free-variable calculations - thing_inside binds `thenRn` \ (result,result_fvs) -> + thing_inside binds `thenM` \ (result,result_fvs) -> let all_fvs = result_fvs `plusFV` bind_fvs `plusFV` sig_fvs unused_binders = nameSetToList (binder_set `minusNameSet` all_fvs) in - warnUnusedLocalBinds unused_binders `thenRn_` - returnRn (result, delListFromNameSet all_fvs new_mbinders) + warnUnusedLocalBinds unused_binders `thenM_` + returnM (result, delListFromNameSet all_fvs new_mbinders) where mbinders_w_srclocs = collectLocatedMonoBinders mbinds doc = text "In the binding group for" <+> pp_bndrs mbinders_w_srclocs @@ -267,7 +246,7 @@ This is done {\em either} by pass 3 (for the top-level bindings), \begin{code} rn_mono_binds :: [RenamedSig] -- Signatures attached to this group -> RdrNameMonoBinds - -> RnMS (RenamedHsBinds, -- Dependency analysed + -> RnM (RenamedHsBinds, -- Dependency analysed FreeVars) -- Free variables rn_mono_binds siglist mbinds @@ -275,7 +254,7 @@ rn_mono_binds siglist mbinds -- Rename the bindings, returning a MonoBindsInfo -- which is a list of indivisible vertices so far as -- the strongly-connected-components (SCC) analysis is concerned - flattenMonoBinds siglist mbinds `thenRn` \ mbinds_info -> + flattenMonoBinds siglist mbinds `thenM` \ mbinds_info -> -- Do the SCC analysis let @@ -286,7 +265,7 @@ rn_mono_binds siglist mbinds -- Deal with bound and free-var calculation rhs_fvs = plusFVs [fvs | (_,fvs,_,_) <- mbinds_info] in - returnRn (final_binds, rhs_fvs) + returnM (final_binds, rhs_fvs) \end{code} @flattenMonoBinds@ is ever-so-slightly magical in that it sticks @@ -298,26 +277,26 @@ in case any of them \fbox{\ ???\ } \begin{code} flattenMonoBinds :: [RenamedSig] -- Signatures -> RdrNameMonoBinds - -> RnMS [FlatMonoBindsInfo] + -> RnM [FlatMonoBindsInfo] -flattenMonoBinds sigs EmptyMonoBinds = returnRn [] +flattenMonoBinds sigs EmptyMonoBinds = returnM [] flattenMonoBinds sigs (AndMonoBinds bs1 bs2) - = flattenMonoBinds sigs bs1 `thenRn` \ flat1 -> - flattenMonoBinds sigs bs2 `thenRn` \ flat2 -> - returnRn (flat1 ++ flat2) + = flattenMonoBinds sigs bs1 `thenM` \ flat1 -> + flattenMonoBinds sigs bs2 `thenM` \ flat2 -> + returnM (flat1 ++ flat2) flattenMonoBinds sigs (PatMonoBind pat grhss locn) - = pushSrcLocRn locn $ - rnPat pat `thenRn` \ (pat', pat_fvs) -> + = addSrcLoc locn $ + rnPat pat `thenM` \ (pat', pat_fvs) -> -- Find which things are bound in this group let names_bound_here = mkNameSet (collectPatBinders pat') in - sigsForMe names_bound_here sigs `thenRn` \ sigs_for_me -> - rnGRHSs grhss `thenRn` \ (grhss', fvs) -> - returnRn + sigsForMe names_bound_here sigs `thenM` \ sigs_for_me -> + rnGRHSs grhss `thenM` \ (grhss', fvs) -> + returnM [(names_bound_here, fvs `plusFV` pat_fvs, PatMonoBind pat' grhss' locn, @@ -325,15 +304,15 @@ flattenMonoBinds sigs (PatMonoBind pat grhss locn) )] flattenMonoBinds sigs (FunMonoBind name inf matches locn) - = pushSrcLocRn locn $ - lookupBndrRn name `thenRn` \ new_name -> + = addSrcLoc locn $ + lookupBndrRn name `thenM` \ new_name -> let names_bound_here = unitNameSet new_name in - sigsForMe names_bound_here sigs `thenRn` \ sigs_for_me -> - mapFvRn (rnMatch (FunRhs name)) matches `thenRn` \ (new_matches, fvs) -> - mapRn_ (checkPrecMatch inf new_name) new_matches `thenRn_` - returnRn + sigsForMe names_bound_here sigs `thenM` \ sigs_for_me -> + mapFvRn (rnMatch (FunRhs name)) matches `thenM` \ (new_matches, fvs) -> + mappM_ (checkPrecMatch inf new_name) new_matches `thenM_` + returnM [(unitNameSet new_name, fvs, FunMonoBind new_name inf new_matches locn, @@ -342,12 +321,12 @@ flattenMonoBinds sigs (FunMonoBind name inf matches locn) sigsForMe names_bound_here sigs - = foldlRn check [] (filter (sigForThisGroup names_bound_here) sigs) + = foldlM check [] (filter (sigForThisGroup names_bound_here) sigs) where check sigs sig = case filter (eqHsSig sig) sigs of - [] -> returnRn (sig:sigs) - other -> dupSigDeclErr sig `thenRn_` - returnRn sigs + [] -> returnM (sig:sigs) + other -> dupSigDeclErr sig `thenM_` + returnM sigs \end{code} @@ -370,28 +349,28 @@ a binder. rnMethodBinds :: Name -- Class name -> [Name] -- Names for generic type variables -> RdrNameMonoBinds - -> RnMS (RenamedMonoBinds, FreeVars) + -> RnM (RenamedMonoBinds, FreeVars) -rnMethodBinds cls gen_tyvars EmptyMonoBinds = returnRn (EmptyMonoBinds, emptyFVs) +rnMethodBinds cls gen_tyvars EmptyMonoBinds = returnM (EmptyMonoBinds, emptyFVs) rnMethodBinds cls gen_tyvars (AndMonoBinds mb1 mb2) - = rnMethodBinds cls gen_tyvars mb1 `thenRn` \ (mb1', fvs1) -> - rnMethodBinds cls gen_tyvars mb2 `thenRn` \ (mb2', fvs2) -> - returnRn (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2) + = rnMethodBinds cls gen_tyvars mb1 `thenM` \ (mb1', fvs1) -> + rnMethodBinds cls gen_tyvars mb2 `thenM` \ (mb2', fvs2) -> + returnM (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2) rnMethodBinds cls gen_tyvars (FunMonoBind name inf matches locn) - = pushSrcLocRn locn $ + = addSrcLoc locn $ - lookupInstDeclBndr cls name `thenRn` \ sel_name -> + lookupInstDeclBndr cls name `thenM` \ sel_name -> -- We use the selector name as the binder - mapFvRn rn_match matches `thenRn` \ (new_matches, fvs) -> - mapRn_ (checkPrecMatch inf sel_name) new_matches `thenRn_` - returnRn (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name) + mapFvRn rn_match matches `thenM` \ (new_matches, fvs) -> + mappM_ (checkPrecMatch inf sel_name) new_matches `thenM_` + returnM (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name) where -- Gruesome; bring into scope the correct members of the generic type variables -- See comments in RnSource.rnSourceDecl(ClassDecl) - rn_match match@(Match (TypePatIn ty : _) _ _) + rn_match match@(Match (TypePat ty : _) _ _) = extendTyVarEnvFVRn gen_tvs (rnMatch (FunRhs name) match) where tvs = map rdrNameOcc (extractHsTyRdrNames ty) @@ -402,8 +381,8 @@ rnMethodBinds cls gen_tyvars (FunMonoBind name inf matches locn) -- Can't handle method pattern-bindings which bind multiple methods. rnMethodBinds cls gen_tyvars mbind@(PatMonoBind other_pat _ locn) - = pushSrcLocRn locn $ - failWithRn (EmptyMonoBinds, emptyFVs) (methodBindErr mbind) + = addSrcLoc locn (addErr (methodBindErr mbind)) `thenM_` + returnM (EmptyMonoBinds, emptyFVs) \end{code} @@ -482,18 +461,18 @@ signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} renameSigsFVs ok_sig sigs - = renameSigs ok_sig sigs `thenRn` \ sigs' -> - returnRn (sigs', hsSigsFVs sigs') + = renameSigs ok_sig sigs `thenM` \ sigs' -> + returnM (sigs', hsSigsFVs sigs') renameSigs :: (RenamedSig -> Bool) -- OK-sig predicate -> [RdrNameSig] - -> RnMS [RenamedSig] + -> RnM [RenamedSig] -renameSigs ok_sig [] = returnRn [] +renameSigs ok_sig [] = returnM [] renameSigs ok_sig sigs = -- Rename the signatures - mapRn renameSig sigs `thenRn` \ sigs' -> + mappM renameSig sigs `thenM` \ sigs' -> -- Check for (a) duplicate signatures -- (b) signatures for things not in this group @@ -504,8 +483,8 @@ renameSigs ok_sig sigs Nothing -> True (goods, bads) = partition ok_sig in_scope in - mapRn_ unknownSigErr bads `thenRn_` - returnRn goods + mappM_ unknownSigErr bads `thenM_` + returnM goods -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: @@ -516,34 +495,34 @@ renameSigs ok_sig sigs -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- Doesn't seem worth much trouble to sort this. -renameSig :: Sig RdrName -> RnMS (Sig Name) +renameSig :: Sig RdrName -> RnM (Sig Name) -- ClassOpSig is renamed elsewhere. renameSig (Sig v ty src_loc) - = pushSrcLocRn src_loc $ - lookupSigOccRn v `thenRn` \ new_v -> - rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty -> - returnRn (Sig new_v new_ty src_loc) + = addSrcLoc src_loc $ + lookupSigOccRn v `thenM` \ new_v -> + rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty -> + returnM (Sig new_v new_ty src_loc) renameSig (SpecInstSig ty src_loc) - = pushSrcLocRn src_loc $ - rnHsType (text "A SPECIALISE instance pragma") ty `thenRn` \ new_ty -> - returnRn (SpecInstSig new_ty src_loc) + = addSrcLoc src_loc $ + rnHsType (text "A SPECIALISE instance pragma") ty `thenM` \ new_ty -> + returnM (SpecInstSig new_ty src_loc) renameSig (SpecSig v ty src_loc) - = pushSrcLocRn src_loc $ - lookupSigOccRn v `thenRn` \ new_v -> - rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty -> - returnRn (SpecSig new_v new_ty src_loc) + = addSrcLoc src_loc $ + lookupSigOccRn v `thenM` \ new_v -> + rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty -> + returnM (SpecSig new_v new_ty src_loc) renameSig (FixSig (FixitySig v fix src_loc)) - = pushSrcLocRn src_loc $ - lookupSigOccRn v `thenRn` \ new_v -> - returnRn (FixSig (FixitySig new_v fix src_loc)) + = addSrcLoc src_loc $ + lookupSigOccRn v `thenM` \ new_v -> + returnM (FixSig (FixitySig new_v fix src_loc)) renameSig (InlineSig b v p src_loc) - = pushSrcLocRn src_loc $ - lookupSigOccRn v `thenRn` \ new_v -> - returnRn (InlineSig b new_v p src_loc) + = addSrcLoc src_loc $ + lookupSigOccRn v `thenM` \ new_v -> + returnM (InlineSig b new_v p src_loc) \end{code} @@ -555,22 +534,22 @@ renameSig (InlineSig b v p src_loc) \begin{code} dupSigDeclErr sig - = pushSrcLocRn loc $ - addErrRn (sep [ptext SLIT("Duplicate") <+> what_it_is <> colon, + = addSrcLoc loc $ + addErr (sep [ptext SLIT("Duplicate") <+> what_it_is <> colon, ppr sig]) where (what_it_is, loc) = hsSigDoc sig unknownSigErr sig - = pushSrcLocRn loc $ - addErrRn (sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, + = addSrcLoc loc $ + addErr (sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, ppr sig]) where (what_it_is, loc) = hsSigDoc sig missingSigWarn var - = pushSrcLocRn (nameSrcLoc var) $ - addWarnRn (sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]) + = addSrcLoc (nameSrcLoc var) $ + addWarn (sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]) methodBindErr mbind = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding")) diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 3e8dd5ba0e..4c91b1b0e9 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -13,41 +13,35 @@ import {-# SOURCE #-} RnHiFiles( loadInterface ) import FlattenInfo ( namesNeededForFlattening ) import HsSyn import RnHsSyn ( RenamedFixitySig ) -import RdrHsSyn ( RdrNameIE, RdrNameHsType, RdrNameFixitySig, extractHsTyRdrTyVars ) +import RdrHsSyn ( RdrNameHsType, extractHsTyRdrTyVars ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, - mkRdrUnqual, mkRdrQual, setRdrNameOcc, - lookupRdrEnv, foldRdrEnv, rdrEnvToList, elemRdrEnv, - unqualifyRdrName + mkRdrUnqual, mkRdrQual, setRdrNameSpace, rdrNameOcc, + lookupRdrEnv, rdrEnvToList, elemRdrEnv, + extendRdrEnv, addListToRdrEnv, emptyRdrEnv, + isExact_maybe, unqualifyRdrName ) import HsTypes ( hsTyVarName, replaceTyVarName ) import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, - ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), AvailEnv, - AvailInfo, Avails, GenAvailInfo(..), NameSupply(..), - ModIface(..), GhciMode(..), - Deprecations(..), lookupDeprec, - extendLocalRdrEnv, lookupFixity + ImportReason(..), GlobalRdrEnv, GlobalRdrElt(..), + GenAvailInfo(..), AvailInfo, Avails, + ModIface(..), NameCache(..), + Deprecations(..), lookupDeprec, isLocalGRE, + extendLocalRdrEnv, availName, availNames, + lookupFixity ) -import RnMonad -import Name ( Name, - getSrcLoc, nameIsLocalOrFrom, - mkInternalName, mkExternalName, - mkIPName, nameOccName, nameModule_maybe, - setNameModuleAndLoc, nameModule - ) -import NameEnv +import TcRnMonad +import Name ( Name, getName, getSrcLoc, nameIsLocalOrFrom, isWiredInName, + mkInternalName, mkExternalName, mkIPName, + nameOccName, setNameModuleAndLoc, nameModule ) import NameSet -import OccName ( OccName, occNameUserString, occNameFlavour, - isDataSymOcc, setOccNameSpace, tcName ) -import Module ( ModuleName, moduleName, mkVanillaModule, - mkSysModuleNameFS, moduleNameFS, WhereFrom(..) ) -import PrelNames ( mkUnboundName, - derivingOccurrences, - mAIN_Name, main_RDR_Unqual, - runIOName, intTyConName, +import OccName ( OccName, tcName, isDataOcc, occNameUserString, occNameFlavour ) +import Module ( Module, ModuleName, moduleName, mkVanillaModule ) +import PrelNames ( mkUnboundName, intTyConName, qTyConName, boolTyConName, funTyConName, unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName, printName, - bindIOName, returnIOName, failIOName, thenIOName + bindIOName, returnIOName, failIOName, thenIOName, + templateHaskellNames ) import TysWiredIn ( unitTyCon ) -- A little odd import FiniteMap @@ -55,12 +49,8 @@ import UniqSupply import SrcLoc ( SrcLoc, noSrcLoc ) import Outputable import ListSetOps ( removeDups, equivClasses ) -import Util ( sortLt ) -import BasicTypes ( mapIPName, defaultFixity ) +import BasicTypes ( mapIPName, FixitySig(..) ) import List ( nub ) -import UniqFM ( lookupWithDefaultUFM ) -import Maybe ( mapMaybe ) -import Maybes ( orElse, catMaybes ) import CmdLineOpts import FastString ( FastString ) \end{code} @@ -72,7 +62,7 @@ import FastString ( FastString ) %********************************************************* \begin{code} -newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name +newTopBinder :: Module -> RdrName -> SrcLoc -> TcRn m Name -- newTopBinder puts into the cache the binder with the -- module information set correctly. When the decl is later renamed, -- the binding site will thereby get the correct module. @@ -81,17 +71,12 @@ newTopBinder :: Module -> RdrName -> SrcLoc -> RnM d Name -- the occurrences, so that doesn't matter newTopBinder mod rdr_name loc - = -- First check the cache + | Just name <- isExact_maybe rdr_name + = returnM name - -- There should never be a qualified name in a binding position (except in instance decls) - -- The parser doesn't check this because the same parser parses instance decls - (if isQual rdr_name then - qualNameErr (text "In its declaration") (rdr_name,loc) - else - returnRn () - ) `thenRn_` - - getNameSupplyRn `thenRn` \ name_supply -> + | otherwise + = -- First check the cache + getNameCache `thenM` \ name_supply -> let occ = rdrNameOcc rdr_name key = (moduleName mod, occ) @@ -106,30 +91,25 @@ newTopBinder mod rdr_name loc -- b) its defining SrcLoc -- So we update this info - Just name -> let - new_name = setNameModuleAndLoc name mod loc - new_cache = addToFM cache key new_name - in - setNameSupplyRn (name_supply {nsNames = new_cache}) `thenRn_` --- traceRn (text "newTopBinder: overwrite" <+> ppr new_name) `thenRn_` - returnRn new_name + Just name + | isWiredInName name -> returnM name + -- Don't mess with wired-in names. Apart from anything + -- else, their wired-in-ness is in the SrcLoca + | otherwise + -> let + new_name = setNameModuleAndLoc name mod loc + new_cache = addToFM cache key new_name + in + setNameCache (name_supply {nsNames = new_cache}) `thenM_` + returnM new_name -- Miss in the cache! -- Build a completely new Name, and put it in the cache -- Even for locally-defined names we use implicitImportProvenance; -- updateProvenances will set it to rights - Nothing -> let - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniq = uniqFromSupply us1 - new_name = mkExternalName uniq mod occ loc - new_cache = addToFM cache key new_name - in - setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_` --- traceRn (text "newTopBinder: new" <+> ppr new_name) `thenRn_` - returnRn new_name - - -newGlobalName :: ModuleName -> OccName -> RnM d Name + Nothing -> addNewName name_supply key mod occ loc + +newGlobalName :: ModuleName -> OccName -> TcRn m Name -- Used for *occurrences*. We make a place-holder Name, really just -- to agree on its unique, which gets overwritten when we read in -- the binding occurence later (newTopBinder) @@ -148,34 +128,46 @@ newGlobalName :: ModuleName -> OccName -> RnM d Name -- (but since it affects DLL-ery it does matter that we get it right -- in the end). newGlobalName mod_name occ - = getNameSupplyRn `thenRn` \ name_supply -> + = getNameCache `thenM` \ name_supply -> let key = (mod_name, occ) cache = nsNames name_supply in case lookupFM cache key of - Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenRn_` - returnRn name - - Nothing -> setNameSupplyRn (name_supply {nsUniqs = us', nsNames = new_cache}) `thenRn_` - -- traceRn (text "newGlobalName: new" <+> ppr name) `thenRn_` - returnRn name - where - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniq = uniqFromSupply us1 - mod = mkVanillaModule mod_name - name = mkExternalName uniq mod occ noSrcLoc - new_cache = addToFM cache key name + Just name -> -- traceRn (text "newGlobalName: hit" <+> ppr name) `thenM_` + returnM name + + Nothing -> -- traceRn (text "newGlobalName: new" <+> ppr name) `thenM_` + addNewName name_supply key (mkVanillaModule mod_name) occ noSrcLoc + +-- Look up a "system name" in the name cache. +-- This is done by the type checker... +-- For *source* declarations, this will put the thing into the name cache +-- For *interface* declarations, RnHiFiles.getSysBinders will already have +-- put it into the cache. +lookupSysName :: Name -- Base name + -> (OccName -> OccName) -- Occurrence name modifier + -> TcRn m Name -- System name +lookupSysName base_name mk_sys_occ + = getNameCache `thenM` \ name_supply -> + let + mod = nameModule base_name + occ = mk_sys_occ (nameOccName base_name) + key = (moduleName mod, occ) + in + case lookupFM (nsNames name_supply) key of + Just name -> returnM name + Nothing -> addNewName name_supply key mod occ noSrcLoc newIPName rdr_name_ip - = getNameSupplyRn `thenRn` \ name_supply -> + = getNameCache `thenM` \ name_supply -> let ipcache = nsIPs name_supply in case lookupFM ipcache key of - Just name_ip -> returnRn name_ip - Nothing -> setNameSupplyRn new_ns `thenRn_` - returnRn name_ip + Just name_ip -> returnM name_ip + Nothing -> setNameCache new_ns `thenM_` + returnM name_ip where (us', us1) = splitUniqSupply (nsUniqs name_supply) uniq = uniqFromSupply us1 @@ -185,6 +177,21 @@ newIPName rdr_name_ip new_ns = name_supply {nsUniqs = us', nsIPs = new_ipcache} where key = rdr_name_ip -- Ensures that ?x and %x get distinct Names + +addNewName :: NameCache -> (ModuleName,OccName) + -> Module -> OccName -> SrcLoc -> TcRn m Name +-- Internal function: extend the name cache, dump it back into +-- the monad, and return the new name +-- (internal, hence the rather redundant interface) +addNewName name_supply key mod occ loc + = setNameCache new_name_supply `thenM_` + returnM name + where + (us', us1) = splitUniqSupply (nsUniqs name_supply) + uniq = uniqFromSupply us1 + name = mkExternalName uniq mod occ loc + new_cache = addToFM (nsNames name_supply) key name + new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} \end{code} %********************************************************* @@ -197,9 +204,9 @@ Looking up a name in the RnEnv. \begin{code} lookupBndrRn rdr_name - = getLocalNameEnv `thenRn` \ local_env -> + = getLocalRdrEnv `thenM` \ local_env -> case lookupRdrEnv local_env rdr_name of - Just name -> returnRn name + Just name -> returnM name Nothing -> lookupTopBndrRn rdr_name lookupTopBndrRn rdr_name @@ -209,47 +216,66 @@ lookupTopBndrRn rdr_name -- A separate function (importsFromLocalDecls) reports duplicate top level -- decls, so here it's safe just to choose an arbitrary one. - | isOrig rdr_name + -- There should never be a qualified name in a binding position + -- The parser could check this, but doesn't (yet) + | isQual rdr_name + = getSrcLocM `thenM` \ loc -> + qualNameErr (text "In its declaration") (rdr_name,loc) `thenM_` + returnM (mkUnboundName rdr_name) + + | otherwise + = ASSERT( not (isOrig rdr_name) ) + -- Original names are used only for occurrences, + -- not binding sites + + getModeRn `thenM` \ mode -> + case mode of + InterfaceMode mod -> + getSrcLocM `thenM` \ loc -> + newTopBinder mod rdr_name loc + + other -> lookupTopSrcBndr rdr_name + +lookupTopSrcBndr :: RdrName -> TcRn m Name +lookupTopSrcBndr rdr_name + = lookupTopSrcBndr_maybe rdr_name `thenM` \ maybe_name -> + case maybe_name of + Just name -> returnM name + Nothing -> unboundName rdr_name + + +lookupTopSrcBndr_maybe :: RdrName -> TcRn m (Maybe Name) +-- Look up a source-code binder + +-- Ignores imported names; for example, this is OK: +-- import Foo( f ) +-- infix 9 f -- The 'f' here does not need to be qualified +-- f x = x -- Nor here, of course + +lookupTopSrcBndr_maybe rdr_name + | Just name <- isExact_maybe rdr_name -- This is here just to catch the PrelBase defn of (say) [] and similar - -- The parser reads the special syntax and returns an Orig RdrName + -- The parser reads the special syntax and returns an Exact RdrName -- But the global_env contains only Qual RdrNames, so we won't -- find it there; instead just get the name via the Orig route -- - = -- This is a binding site for the name, so check first that it + -- We are at a binding site for the name, so check first that it -- the current module is the correct one; otherwise GHC can get -- very confused indeed. This test rejects code like -- data T = (,) Int Int -- unless we are in GHC.Tup - getModuleRn `thenRn` \ mod -> - checkRn (moduleName mod == rdrNameModule rdr_name) - (badOrigBinding rdr_name) `thenRn_` - lookupOrigName rdr_name + = getModule `thenM` \ mod -> + checkErr (moduleName mod == moduleName (nameModule name)) + (badOrigBinding rdr_name) `thenM_` + returnM (Just name) | otherwise - = getModeRn `thenRn` \ mode -> - if isInterfaceMode mode - then lookupSysBinder rdr_name - -- lookupSysBinder uses the Module in the monad to set - -- the correct module for the binder. This is important because - -- when GHCi is reading in an old interface, it just sucks it - -- in entire (Rename.loadHomeDecls) which uses lookupTopBndrRn - -- rather than via the iface file cache which uses newTopBndrRn - -- We must get the correct Module into the thing. - - else - getModuleRn `thenRn` \ mod -> - getGlobalNameEnv `thenRn` \ global_env -> - case lookup_local mod global_env rdr_name of - Just name -> returnRn name - Nothing -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) - -lookup_local mod global_env rdr_name - = case lookupRdrEnv global_env rdr_name of - Nothing -> Nothing - Just gres -> case [n | GRE n _ _ <- gres, nameIsLocalOrFrom mod n] of - [] -> Nothing - (n:ns) -> Just n + = getGlobalRdrEnv `thenM` \ global_env -> + case lookupRdrEnv global_env rdr_name of + Nothing -> returnM Nothing + Just gres -> case [gre_name gre | gre <- gres, isLocalGRE gre] of + [] -> returnM Nothing + (n:ns) -> returnM (Just n) -- lookupSigOccRn is used for type signatures and pragmas @@ -262,42 +288,73 @@ lookup_local mod global_env rdr_name -- The Haskell98 report does not stipulate this, but it will! -- So we must treat the 'f' in the signature in the same way -- as the binding occurrence of 'f', using lookupBndrRn -lookupSigOccRn :: RdrName -> RnMS Name +lookupSigOccRn :: RdrName -> RnM Name lookupSigOccRn = lookupBndrRn -- lookupInstDeclBndr is used for the binders in an -- instance declaration. Here we use the class name to -- disambiguate. -lookupInstDeclBndr :: Name -> RdrName -> RnMS Name +lookupInstDeclBndr :: Name -> RdrName -> RnM Name -- We use the selector name as the binder lookupInstDeclBndr cls_name rdr_name - | isOrig rdr_name -- Occurs in derived instances, where we just - -- refer diectly to the right method - = lookupOrigName rdr_name - - | otherwise - = getGlobalAvails `thenRn` \ avail_env -> - case lookupNameEnv avail_env cls_name of - -- The class itself isn't in scope, so cls_name is unboundName - -- e.g. import Prelude hiding( Ord ) - -- instance Ord T where ... - -- The program is wrong, but that should not cause a crash. - Nothing -> returnRn (mkUnboundName rdr_name) + | isUnqual rdr_name + = -- Find all the things the class op name maps to + -- and pick the one with the right parent name + getGblEnv `thenM` \ gbl_env -> + let + avail_env = imp_env (tcg_imports gbl_env) + in + case lookupAvailEnv avail_env cls_name of + Nothing -> + -- If the class itself isn't in scope, then cls_name will + -- be unboundName, and there'll already be an error for + -- that in the error list. Example: + -- e.g. import Prelude hiding( Ord ) + -- instance Ord T where ... + -- The program is wrong, but that should not cause a crash. + returnM (mkUnboundName rdr_name) + Just (AvailTC _ ns) -> case [n | n <- ns, nameOccName n == occ] of - (n:ns)-> ASSERT( null ns ) returnRn n - [] -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) + (n:ns)-> ASSERT( null ns ) returnM n + [] -> unboundName rdr_name + other -> pprPanic "lookupInstDeclBndr" (ppr cls_name) + + | isQual rdr_name -- Should never have a qualified name in a binding position + = getSrcLocM `thenM` \ loc -> + qualNameErr (text "In an instance method") (rdr_name,loc) `thenM_` + returnM (mkUnboundName rdr_name) + + | otherwise -- Occurs in derived instances, where we just + -- refer directly to the right method, and avail_env + -- isn't available + = ASSERT2( not (isQual rdr_name), ppr rdr_name ) + lookupOrigName rdr_name + where occ = rdrNameOcc rdr_name +lookupSysBndr :: RdrName -> RnM Name +-- Used for the 'system binders' in a data type or class declaration +-- Do *not* look up in the RdrEnv; these system binders are never in scope +-- Instead, get the module from the monad... but remember that +-- where the module is depends on whether we are renaming source or +-- interface file stuff +lookupSysBndr rdr_name + = getSrcLocM `thenM` \ loc -> + getModeRn `thenM` \ mode -> + case mode of + InterfaceMode mod -> newTopBinder mod rdr_name loc + other -> getModule `thenM` \ mod -> + newTopBinder mod rdr_name loc + -- lookupOccRn looks up an occurrence of a RdrName -lookupOccRn :: RdrName -> RnMS Name +lookupOccRn :: RdrName -> RnM Name lookupOccRn rdr_name - = getLocalNameEnv `thenRn` \ local_env -> + = getLocalRdrEnv `thenM` \ local_env -> case lookupRdrEnv local_env rdr_name of - Just name -> returnRn name + Just name -> returnM name Nothing -> lookupGlobalOccRn rdr_name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global @@ -306,18 +363,14 @@ lookupOccRn rdr_name -- class op names in class and instance decls lookupGlobalOccRn rdr_name - = getModeRn `thenRn` \ mode -> - if (isInterfaceMode mode) - then lookupIfaceName rdr_name - else + = getModeRn `thenM` \ mode -> + case mode of + InterfaceMode mod -> lookupIfaceName mod rdr_name + SourceMode -> lookupSrcName rdr_name - getGlobalNameEnv `thenRn` \ global_env -> - case mode of - SourceMode -> lookupSrcName global_env rdr_name - - CmdLineMode + CmdLineMode | not (isQual rdr_name) -> - lookupSrcName global_env rdr_name + lookupSrcName rdr_name -- We allow qualified names on the command line to refer to -- *any* name exported by any module in scope, just as if @@ -328,105 +381,120 @@ lookupGlobalOccRn rdr_name -- it isn't there, we manufacture a new occurrence of an -- original name. | otherwise -> - case lookupRdrEnv global_env rdr_name of - Just _ -> lookupSrcName global_env rdr_name - Nothing -> lookupQualifiedName rdr_name + lookupSrcName_maybe rdr_name `thenM` \ mb_name -> + case mb_name of + Just name -> returnM name + Nothing -> lookupQualifiedName rdr_name --- a qualified name on the command line can refer to any module at all: we +-- A qualified name on the command line can refer to any module at all: we -- try to load the interface if we don't already have it. -lookupQualifiedName :: RdrName -> RnM d Name +lookupQualifiedName :: RdrName -> TcRn m Name lookupQualifiedName rdr_name = let mod = rdrNameModule rdr_name occ = rdrNameOcc rdr_name in - loadInterface (ppr rdr_name) mod ImportByUser `thenRn` \ iface -> + loadInterface (ppr rdr_name) mod (ImportByUser False) `thenM` \ iface -> case [ name | (_,avails) <- mi_exports iface, avail <- avails, name <- availNames avail, nameOccName name == occ ] of - (n:ns) -> ASSERT (null ns) returnRn n - _ -> failWithRn (mkUnboundName rdr_name) (unknownNameErr rdr_name) - -lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name --- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad -lookupSrcName global_env rdr_name - | isOrig rdr_name -- Can occur in source code too - = lookupOrigName rdr_name + (n:ns) -> ASSERT (null ns) returnM n + _ -> unboundName rdr_name + +lookupSrcName :: RdrName -> TcRn m Name +lookupSrcName rdr_name + = lookupSrcName_maybe rdr_name `thenM` \ mb_name -> + case mb_name of + Nothing -> unboundName rdr_name + Just name -> returnM name + +lookupSrcName_maybe :: RdrName -> TcRn m (Maybe Name) +lookupSrcName_maybe rdr_name + | Just name <- isExact_maybe rdr_name -- Can occur in source code too + = returnM (Just name) + + | isOrig rdr_name -- An original name + = newGlobalName (rdrNameModule rdr_name) + (rdrNameOcc rdr_name) `thenM` \ name -> + returnM (Just name) | otherwise - = case lookupRdrEnv global_env rdr_name of - Just [GRE name _ Nothing] -> returnRn name - Just [GRE name _ (Just deprec)] -> warnDeprec name deprec `thenRn_` - returnRn name - Just stuff@(GRE name _ _ : _) -> addNameClashErrRn rdr_name stuff `thenRn_` - returnRn name - Nothing -> failWithRn (mkUnboundName rdr_name) - (unknownNameErr rdr_name) - -lookupOrigName :: RdrName -> RnM d Name -lookupOrigName rdr_name - = -- NO: ASSERT( isOrig rdr_name ) - -- Now that .hi-boot files are read by the main parser, they contain - -- ordinary qualified names (which we treat as Orig names here). - newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) - -lookupIfaceUnqual :: RdrName -> RnM d Name -lookupIfaceUnqual rdr_name - = ASSERT( isUnqual rdr_name ) + = lookupGRE rdr_name `thenM` \ mb_gre -> + case mb_gre of + Nothing -> returnM Nothing + Just gre -> returnM (Just (gre_name gre)) + +lookupGRE :: RdrName -> TcRn m (Maybe GlobalRdrElt) +lookupGRE rdr_name + = getGlobalRdrEnv `thenM` \ global_env -> + case lookupRdrEnv global_env rdr_name of + Just [gre] -> case gre_deprec gre of + Nothing -> returnM (Just gre) + Just _ -> warnDeprec gre `thenM_` + returnM (Just gre) + Just stuff@(gre : _) -> addNameClashErrRn rdr_name stuff `thenM_` + returnM (Just gre) + Nothing -> return Nothing + +lookupIfaceName :: Module -> RdrName -> TcRn m Name -- An Unqual is allowed; interface files contain -- unqualified names for locally-defined things, such as -- constructors of a data type. - getModuleRn `thenRn ` \ mod -> - newGlobalName (moduleName mod) (rdrNameOcc rdr_name) - -lookupIfaceName :: RdrName -> RnM d Name -lookupIfaceName rdr_name - | isUnqual rdr_name = lookupIfaceUnqual rdr_name +lookupIfaceName mod rdr_name + | isUnqual rdr_name = newGlobalName (moduleName mod) (rdrNameOcc rdr_name) | otherwise = lookupOrigName rdr_name -\end{code} -@lookupOrigName@ takes an RdrName representing an {\em original} -name, and adds it to the occurrence pool so that it'll be loaded -later. This is used when language constructs (such as monad -comprehensions, overloaded literals, or deriving clauses) require some -stuff to be loaded that isn't explicitly mentioned in the code. - -This doesn't apply in interface mode, where everything is explicit, -but we don't check for this case: it does no harm to record an -``extra'' occurrence and @lookupOrigNames@ isn't used much in -interface mode (it's only the @Nothing@ clause of @rnDerivs@ that -calls it at all I think). - - \fbox{{\em Jan 98: this comment is wrong: @rnHsType@ uses it quite a bit.}} - -\begin{code} -lookupOrigNames :: [RdrName] -> RnM d NameSet -lookupOrigNames rdr_names - = mapRn lookupOrigName rdr_names `thenRn` \ names -> - returnRn (mkNameSet names) +lookupOrigName :: RdrName -> TcRn m Name + -- Just for original or exact names +lookupOrigName rdr_name + | Just n <- isExact_maybe rdr_name + -- This happens in derived code, which we + -- rename in InterfaceMode + = returnM n + + | otherwise -- Usually Orig, but can be a Qual when + -- we are reading a .hi-boot file + = newGlobalName (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + + +dataTcOccs :: RdrName -> [RdrName] +-- If the input is a data constructor, return both it and a type +-- constructor. This is useful when we aren't sure which we are +-- looking at +dataTcOccs rdr_name + | isDataOcc occ = [rdr_name, rdr_name_tc] + | otherwise = [rdr_name] + where + occ = rdrNameOcc rdr_name + rdr_name_tc = setRdrNameSpace rdr_name tcName \end{code} -lookupSysBinder is used for the "system binders" of a type, class, or -instance decl. It ensures that the module is set correctly in the -name cache, and sets the provenance on the returned name too. The -returned name will end up actually in the type, class, or instance. - \begin{code} -lookupSysBinder rdr_name - = ASSERT( isUnqual rdr_name ) - getModuleRn `thenRn` \ mod -> - getSrcLocRn `thenRn` \ loc -> - newTopBinder mod rdr_name loc +unboundName rdr_name = addErr (unknownNameErr rdr_name) `thenM_` + returnM (mkUnboundName rdr_name) \end{code} - %********************************************************* %* * -\subsection{Looking up fixities} + Fixities %* * %********************************************************* +\begin{code} +-------------------------------- +bindLocalFixities :: [RenamedFixitySig] -> RnM a -> RnM a +-- Used for nested fixity decls +-- No need to worry about type constructors here, +-- Should check for duplicates but we don't +bindLocalFixities fixes thing_inside + | null fixes = thing_inside + | otherwise = extendFixityEnv new_bit thing_inside + where + new_bit = [(n,s) | s@(FixitySig n _ _) <- fixes] +\end{code} + +-------------------------------- lookupFixity is a bit strange. * Nested local fixity decls are put in the local fixity env, which we @@ -441,13 +509,13 @@ lookupFixity is a bit strange. We put them all in the local fixity environment \begin{code} -lookupFixityRn :: Name -> RnMS Fixity +lookupFixityRn :: Name -> RnM Fixity lookupFixityRn name - = getModuleRn `thenRn` \ this_mod -> + = getModule `thenM` \ this_mod -> if nameIsLocalOrFrom this_mod name then -- It's defined in this module - getFixityEnv `thenRn` \ local_fix_env -> - returnRn (lookupLocalFixity local_fix_env name) + getFixityEnv `thenM` \ local_fix_env -> + returnM (lookupFixity local_fix_env name) else -- It's imported -- For imported names, we have to get their fixities by doing a @@ -463,59 +531,11 @@ lookupFixityRn name -- nothing from B will be used). When we come across a use of -- 'f', we need to know its fixity, and it's then, and only -- then, that we load B.hi. That is what's happening here. - loadInterface doc name_mod ImportBySystem `thenRn` \ iface -> - returnRn (lookupFixity (mi_fixities iface) name) + loadInterface doc name_mod ImportBySystem `thenM` \ iface -> + returnM (lookupFixity (mi_fixities iface) name) where doc = ptext SLIT("Checking fixity for") <+> ppr name name_mod = moduleName (nameModule name) - --------------------------------- -lookupLocalFixity :: LocalFixityEnv -> Name -> Fixity -lookupLocalFixity env name - = case lookupNameEnv env name of - Just (FixitySig _ fix _) -> fix - Nothing -> defaultFixity - -extendNestedFixityEnv :: [(Name, RenamedFixitySig)] -> RnMS a -> RnMS a --- Used for nested fixity decls --- No need to worry about type constructors here, --- Should check for duplicates but we don't -extendNestedFixityEnv fixes enclosed_scope - = getFixityEnv `thenRn` \ fix_env -> - let - new_fix_env = extendNameEnvList fix_env fixes - in - setFixityEnv new_fix_env enclosed_scope - -mkTopFixityEnv :: GlobalRdrEnv -> [RdrNameFixitySig] -> RnMG LocalFixityEnv -mkTopFixityEnv gbl_env fix_sigs - = getModuleRn `thenRn` \ mod -> - let - -- GHC extension: look up both the tycon and data con - -- for con-like things - -- If neither are in scope, report an error; otherwise - -- add both to the fixity env - go fix_env (FixitySig rdr_name fixity loc) - = case catMaybes (map (lookup_local mod gbl_env) rdr_names) of - [] -> pushSrcLocRn loc $ - addErrRn (unknownNameErr rdr_name) `thenRn_` - returnRn fix_env - ns -> foldlRn add fix_env ns - - where - add fix_env name - = case lookupNameEnv fix_env name of - Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') `thenRn_` - returnRn fix_env - Nothing -> returnRn (extendNameEnv fix_env name (FixitySig name fixity loc)) - - rdr_names | isDataSymOcc occ = [rdr_name, rdr_name_tc] - | otherwise = [rdr_name] - - occ = rdrNameOcc rdr_name - rdr_name_tc = setRdrNameOcc rdr_name (setOccNameSpace occ tcName) - in - foldlRn go emptyLocalFixityEnv fix_sigs \end{code} @@ -529,65 +549,42 @@ mkTopFixityEnv gbl_env fix_sigs mentioned explicitly, but which might be needed by the type checker. \begin{code} -getImplicitStmtFVs -- Compiling a statement - = returnRn (mkFVs [printName, bindIOName, thenIOName, - returnIOName, failIOName] - `plusFV` ubiquitousNames) +implicitStmtFVs source_fvs -- Compiling a statement + = stmt_fvs `plusFV` implicitModuleFVs source_fvs + where + stmt_fvs = mkFVs [printName, bindIOName, thenIOName, returnIOName, failIOName] -- These are all needed implicitly when compiling a statement -- See TcModule.tc_stmts -getImplicitModuleFVs decls -- Compiling a module - = lookupOrigNames deriv_occs `thenRn` \ deriving_names -> - returnRn (deriving_names `plusFV` ubiquitousNames) - where - -- deriv_classes is now a list of HsTypes, so a "normal" one - -- appears as a (HsClassP c []). The non-normal ones for the new - -- newtype-deriving extension, and they don't require any - -- implicit names, so we can silently filter them out. - deriv_occs = [occ | TyClD (TyData {tcdDerivs = Just deriv_classes}) <- decls, - HsClassP cls [] <- deriv_classes, - occ <- lookupWithDefaultUFM derivingOccurrences [] cls ] +implicitModuleFVs source_fvs + = mkTemplateHaskellFVs source_fvs `plusFV` + namesNeededForFlattening `plusFV` + ubiquitousNames + + -- This is a bit of a hack. When we see the Template-Haskell construct + -- [| expr |] + -- we are going to need lots of the ``smart constructors'' defined in + -- the main Template Haskell data type module. Rather than treat them + -- all as free vars at every occurrence site, we just make the Q type + -- consructor a free var.... and then use that here to haul in the others +mkTemplateHaskellFVs source_fvs +#ifdef GHCI + -- Only if Template Haskell is enabled + | qTyConName `elemNameSet` source_fvs = templateHaskellNames +#endif + | otherwise = emptyFVs -- ubiquitous_names are loaded regardless, because -- they are needed in virtually every program ubiquitousNames = mkFVs [unpackCStringName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName] - -- Virtually every program has error messages in it somewhere - - `plusFV` + -- Virtually every program has error messages in it somewhere + `plusFV` mkFVs [getName unitTyCon, funTyConName, boolTyConName, intTyConName] - -- Add occurrences for very frequently used types. - -- (e.g. we don't want to be bothered with making funTyCon a - -- free var at every function application!) - `plusFV` - namesNeededForFlattening - -- this will be empty unless flattening is activated - -checkMain ghci_mode mod_name gbl_env - -- LOOKUP main IF WE'RE IN MODULE Main - -- The main point of this is to drag in the declaration for 'main', - -- its in another module, and for the Prelude function 'runIO', - -- so that the type checker will find them - -- - -- We have to return the main_name separately, because it's a - -- bona fide 'use', and should be recorded as such, but the others - -- aren't - | mod_name /= mAIN_Name - = returnRn (Nothing, emptyFVs, emptyFVs) - - | not (main_RDR_Unqual `elemRdrEnv` gbl_env) - = complain_no_main `thenRn_` - returnRn (Nothing, emptyFVs, emptyFVs) - - | otherwise - = lookupSrcName gbl_env main_RDR_Unqual `thenRn` \ main_name -> - returnRn (Just main_name, unitFV main_name, unitFV runIOName) - - where - complain_no_main | ghci_mode == Interactive = addWarnRn noMainMsg - | otherwise = addErrRn noMainMsg - -- In interactive mode, only warn about the absence of main + -- Add occurrences for very frequently used types. + -- (e.g. we don't want to be bothered with making + -- funTyCon a free var at every function application!) \end{code} %************************************************************************ @@ -625,22 +622,23 @@ checks the type of the user thing against the type of the standard thing. \begin{code} lookupSyntaxName :: Name -- The standard name - -> RnMS (Name, FreeVars) -- Possibly a non-standard name + -> RnM (Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name - = getModeRn `thenRn` \ mode -> - case mode of { - InterfaceMode -> returnRn (std_name, unitFV std_name) ; + = getModeRn `thenM` \ mode -> + if isInterfaceMode mode then + returnM (std_name, unitFV std_name) -- Happens for 'derived' code -- where we don't want to rebind - other -> + else - doptRn Opt_NoImplicitPrelude `thenRn` \ no_prelude -> + doptM Opt_NoImplicitPrelude `thenM` \ no_prelude -> if not no_prelude then - returnRn (std_name, unitFV std_name) -- Normal case + returnM (std_name, unitFV std_name) -- Normal case + else -- Get the similarly named thing from the local environment - lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenRn` \ usr_name -> - returnRn (usr_name, mkFVs [usr_name, std_name]) } + lookupOccRn (mkRdrUnqual (nameOccName std_name)) `thenM` \ usr_name -> + returnM (usr_name, mkFVs [usr_name, std_name]) \end{code} @@ -652,55 +650,53 @@ lookupSyntaxName std_name \begin{code} newLocalsRn :: [(RdrName,SrcLoc)] - -> RnMS [Name] + -> RnM [Name] newLocalsRn rdr_names_w_loc - = getNameSupplyRn `thenRn` \ name_supply -> + = newUniqueSupply `thenM` \ us -> let - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniqs = uniqsFromSupply us1 + uniqs = uniqsFromSupply us names = [ mkInternalName uniq (rdrNameOcc rdr_name) loc | ((rdr_name,loc), uniq) <- rdr_names_w_loc `zip` uniqs ] in - setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_` - returnRn names + returnM names bindLocatedLocalsRn :: SDoc -- Documentation string for error message -> [(RdrName,SrcLoc)] - -> ([Name] -> RnMS a) - -> RnMS a + -> ([Name] -> RnM a) + -> RnM a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope - = getModeRn `thenRn` \ mode -> - getLocalNameEnv `thenRn` \ local_env -> - getGlobalNameEnv `thenRn` \ global_env -> + = getModeRn `thenM` \ mode -> + getLocalRdrEnv `thenM` \ local_env -> + getGlobalRdrEnv `thenM` \ global_env -> -- Check for duplicate names - checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_` + checkDupOrQualNames doc_str rdr_names_w_loc `thenM_` -- Warn about shadowing, but only in source modules let check_shadow (rdr_name,loc) | rdr_name `elemRdrEnv` local_env || rdr_name `elemRdrEnv` global_env - = pushSrcLocRn loc $ addWarnRn (shadowedNameWarn rdr_name) + = addSrcLoc loc $ addWarn (shadowedNameWarn rdr_name) | otherwise - = returnRn () + = returnM () in (case mode of - SourceMode -> ifOptRn Opt_WarnNameShadowing $ - mapRn_ check_shadow rdr_names_w_loc - other -> returnRn () - ) `thenRn_` + SourceMode -> ifOptM Opt_WarnNameShadowing $ + mappM_ check_shadow rdr_names_w_loc + other -> returnM () + ) `thenM_` - newLocalsRn rdr_names_w_loc `thenRn` \ names -> + newLocalsRn rdr_names_w_loc `thenM` \ names -> let new_local_env = addListToRdrEnv local_env (map fst rdr_names_w_loc `zip` names) in - setLocalNameEnv new_local_env (enclosed_scope names) + setLocalRdrEnv new_local_env (enclosed_scope names) -bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a +bindCoreLocalRn :: RdrName -> (Name -> RnM a) -> RnM a -- A specialised variant when renaming stuff from interface -- files (of which there is a lot) -- * one at a time @@ -708,19 +704,14 @@ bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a -- * always imported -- * deal with free vars bindCoreLocalRn rdr_name enclosed_scope - = getSrcLocRn `thenRn` \ loc -> - getLocalNameEnv `thenRn` \ name_env -> - getNameSupplyRn `thenRn` \ name_supply -> - let - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniq = uniqFromSupply us1 - name = mkInternalName uniq (rdrNameOcc rdr_name) loc - in - setNameSupplyRn (name_supply {nsUniqs = us'}) `thenRn_` + = getSrcLocM `thenM` \ loc -> + getLocalRdrEnv `thenM` \ name_env -> + newUnique `thenM` \ uniq -> let + name = mkInternalName uniq (rdrNameOcc rdr_name) loc new_name_env = extendRdrEnv name_env rdr_name name in - setLocalNameEnv new_name_env (enclosed_scope name) + setLocalRdrEnv new_name_env (enclosed_scope name) bindCoreLocalsRn [] thing_inside = thing_inside [] bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' -> @@ -728,25 +719,25 @@ bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' -> thing_inside (name':names') bindLocalNames names enclosed_scope - = getLocalNameEnv `thenRn` \ name_env -> - setLocalNameEnv (extendLocalRdrEnv name_env names) + = getLocalRdrEnv `thenM` \ name_env -> + setLocalRdrEnv (extendLocalRdrEnv name_env names) enclosed_scope bindLocalNamesFV names enclosed_scope = bindLocalNames names $ - enclosed_scope `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs names) + enclosed_scope `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs names) ------------------------------------- bindLocalRn doc rdr_name enclosed_scope - = getSrcLocRn `thenRn` \ loc -> + = getSrcLocM `thenM` \ loc -> bindLocatedLocalsRn doc [(rdr_name,loc)] $ \ (n:ns) -> ASSERT( null ns ) enclosed_scope n bindLocalsRn doc rdr_names enclosed_scope - = getSrcLocRn `thenRn` \ loc -> + = getSrcLocM `thenM` \ loc -> bindLocatedLocalsRn doc (rdr_names `zip` repeat loc) enclosed_scope @@ -755,21 +746,21 @@ bindLocalsRn doc rdr_names enclosed_scope -- except that it deals with free vars bindLocalsFVRn doc rdr_names enclosed_scope = bindLocalsRn doc rdr_names $ \ names -> - enclosed_scope names `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs names) + enclosed_scope names `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs names) ------------------------------------- -extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) +extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) -- This tiresome function is used only in rnSourceDecl on InstDecl extendTyVarEnvFVRn tyvars enclosed_scope - = bindLocalNames tyvars enclosed_scope `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs tyvars) + = bindLocalNames tyvars enclosed_scope `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs tyvars) bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName] - -> ([HsTyVarBndr Name] -> RnMS a) - -> RnMS a + -> ([HsTyVarBndr Name] -> RnM a) + -> RnM a bindTyVarsRn doc_str tyvar_names enclosed_scope - = getSrcLocRn `thenRn` \ loc -> + = getSrcLocM `thenM` \ loc -> let located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names] in @@ -777,14 +768,14 @@ bindTyVarsRn doc_str tyvar_names enclosed_scope enclosed_scope (zipWith replaceTyVarName tyvar_names names) bindPatSigTyVars :: [RdrNameHsType] - -> RnMS (a, FreeVars) - -> RnMS (a, FreeVars) + -> RnM (a, FreeVars) + -> RnM (a, FreeVars) -- Find the type variables in the pattern type -- signatures that must be brought into scope bindPatSigTyVars tys enclosed_scope - = getLocalNameEnv `thenRn` \ name_env -> - getSrcLocRn `thenRn` \ loc -> + = getLocalRdrEnv `thenM` \ name_env -> + getSrcLocM `thenM` \ loc -> let forall_tyvars = nub [ tv | ty <- tys, tv <- extractHsTyRdrTyVars ty, @@ -798,26 +789,26 @@ bindPatSigTyVars tys enclosed_scope doc_sig = text "In a pattern type-signature" in bindLocatedLocalsRn doc_sig located_tyvars $ \ names -> - enclosed_scope `thenRn` \ (thing, fvs) -> - returnRn (thing, delListFromNameSet fvs names) + enclosed_scope `thenM` \ (thing, fvs) -> + returnM (thing, delListFromNameSet fvs names) ------------------------------------- checkDupOrQualNames, checkDupNames :: SDoc -> [(RdrName, SrcLoc)] - -> RnM d () + -> TcRn m () -- Works in any variant of the renamer monad checkDupOrQualNames doc_str rdr_names_w_loc = -- Check for use of qualified names - mapRn_ (qualNameErr doc_str) quals `thenRn_` + mappM_ (qualNameErr doc_str) quals `thenM_` checkDupNames doc_str rdr_names_w_loc where quals = filter (isQual . fst) rdr_names_w_loc checkDupNames doc_str rdr_names_w_loc = -- Check for duplicated names in a binding group - mapRn_ (dupNamesErr doc_str) dups + mappM_ (dupNamesErr doc_str) dups where (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc \end{code} @@ -864,13 +855,17 @@ mkGlobalRdrEnv this_mod unqual_imp mk_provenance avails deprecs -- duplicates. So the simple thing is to do the fold. add_avail :: GlobalRdrEnv -> AvailInfo -> GlobalRdrEnv - add_avail env avail = foldl add_name env (availNames avail) + add_avail env avail = foldl (add_name (availName avail)) env (availNames avail) - add_name env name -- Add qualified name only - = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt + add_name parent env name -- Add qualified name only + = addOneToGlobalRdrEnv env (mkRdrQual this_mod occ) elt where occ = nameOccName name - elt = GRE name (mk_provenance name) (lookupDeprec deprecs name) + elt = GRE {gre_name = name, + gre_parent = parent, + gre_prov = mk_provenance name, + gre_deprec = lookupDeprec deprecs name} + \end{code} \begin{code} @@ -895,11 +890,12 @@ combine_globals ns_old ns_new -- ns_new is often short choose n m | n `beats` m = n | otherwise = m - (GRE n pn _) `beats` (GRE m pm _) = n==m && pn `hasBetterProv` pm + g1 `beats` g2 = gre_name g1 == gre_name g2 && + gre_prov g1 `hasBetterProv` gre_prov g2 is_duplicate :: GlobalRdrElt -> GlobalRdrElt -> Bool - is_duplicate (GRE n1 LocalDef _) (GRE n2 LocalDef _) = False - is_duplicate (GRE n1 _ _) (GRE n2 _ _) = n1 == n2 + is_duplicate g1 g2 | isLocalGRE g1 && isLocalGRE g2 = False + is_duplicate g1 g2 = gre_name g1 == gre_name g2 \end{code} We treat two bindings of a locally-defined name as a duplicate, @@ -915,159 +911,6 @@ defn of the same name; in this case the names will compare as equal, but will still have different provenances. -@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') --- --- This fn is only efficient if the shared --- partial application is used a lot. -unQualInScope env - = (`elemNameSet` unqual_names) - where - unqual_names :: NameSet - unqual_names = foldRdrEnv add emptyNameSet env - add rdr_name [GRE name _ _] unquals | isUnqual rdr_name = addOneToNameSet unquals name - add _ _ unquals = unquals -\end{code} - - -%************************************************************************ -%* * -\subsection{Avails} -%* * -%************************************************************************ - -\begin{code} -plusAvail (Avail n1) (Avail n2) = Avail n1 -plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (nub (ns1 ++ ns2)) --- Added SOF 4/97 -#ifdef DEBUG -plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) -#endif - -addAvail :: AvailEnv -> AvailInfo -> AvailEnv -addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail - -unitAvailEnv :: AvailInfo -> AvailEnv -unitAvailEnv a = unitNameEnv (availName a) a - -plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv -plusAvailEnv = plusNameEnv_C plusAvail - -availEnvElts = nameEnvElts - -addAvailToNameSet :: NameSet -> AvailInfo -> NameSet -addAvailToNameSet names avail = addListToNameSet names (availNames avail) - -availsToNameSet :: [AvailInfo] -> NameSet -availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails - -availName :: GenAvailInfo name -> name -availName (Avail n) = n -availName (AvailTC n _) = n - -availNames :: GenAvailInfo name -> [name] -availNames (Avail n) = [n] -availNames (AvailTC n ns) = ns - -------------------------------------- -filterAvail :: RdrNameIE -- Wanted - -> AvailInfo -- Available - -> Maybe AvailInfo -- Resulting available; - -- Nothing if (any of the) wanted stuff isn't there - -filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) - | sub_names_ok = Just (AvailTC n (filter is_wanted ns)) - | otherwise = Nothing - where - is_wanted name = nameOccName name `elem` wanted_occs - sub_names_ok = all (`elem` avail_occs) wanted_occs - avail_occs = map nameOccName ns - wanted_occs = map rdrNameOcc (want:wants) - -filterAvail (IEThingAbs _) (AvailTC n ns) = ASSERT( n `elem` ns ) - Just (AvailTC n [n]) - -filterAvail (IEThingAbs _) avail@(Avail n) = Just avail -- Type synonyms - -filterAvail (IEVar _) avail@(Avail n) = Just avail -filterAvail (IEVar v) avail@(AvailTC n ns) = Just (AvailTC n (filter wanted ns)) - where - wanted n = nameOccName n == occ - occ = rdrNameOcc v - -- The second equation happens if we import a class op, thus - -- import A( op ) - -- where op is a class operation - -filterAvail (IEThingAll _) avail@(AvailTC _ _) = Just avail - -- We don't complain even if the IE says T(..), but - -- no constrs/class ops of T are available - -- Instead that's caught with a warning by the caller - -filterAvail ie avail = Nothing - -------------------------------------- -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} - -\begin{code} -pruneAvails :: (Name -> Bool) -- Keep if this is True - -> [AvailInfo] - -> [AvailInfo] -pruneAvails keep avails - = mapMaybe del avails - where - del :: AvailInfo -> Maybe AvailInfo -- Nothing => nothing left! - del (Avail n) | keep n = Just (Avail n) - | otherwise = Nothing - del (AvailTC n ns) | null ns' = Nothing - | otherwise = Just (AvailTC n ns') - where - ns' = filter keep ns -\end{code} - %************************************************************************ %* * \subsection{Free variable manipulation} @@ -1076,11 +919,11 @@ pruneAvails keep avails \begin{code} -- A useful utility -mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> +mapFvRn f xs = mappM f xs `thenM` \ stuff -> let (ys, fvs_s) = unzip stuff in - returnRn (ys, plusFVs fvs_s) + returnM (ys, plusFVs fvs_s) \end{code} @@ -1091,31 +934,31 @@ mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> %************************************************************************ \begin{code} -warnUnusedModules :: [ModuleName] -> RnM d () +warnUnusedModules :: [ModuleName] -> TcRn m () warnUnusedModules mods - = ifOptRn Opt_WarnUnusedImports (mapRn_ (addWarnRn . unused_mod) mods) + = ifOptM Opt_WarnUnusedImports (mappM_ (addWarn . unused_mod) mods) where unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+> text "is imported, but nothing from it is used", - parens (ptext SLIT("except perhaps to re-export instances visible in") <+> + parens (ptext SLIT("except perhaps instances visible in") <+> quotes (ppr m))] -warnUnusedImports :: [(Name,Provenance)] -> RnM d () -warnUnusedImports names - = ifOptRn Opt_WarnUnusedImports (warnUnusedBinds names) +warnUnusedImports, warnUnusedTopBinds :: [GlobalRdrElt] -> TcRn m () +warnUnusedImports gres = ifOptM Opt_WarnUnusedImports (warnUnusedGREs gres) +warnUnusedTopBinds gres = ifOptM Opt_WarnUnusedBinds (warnUnusedGREs gres) -warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d () -warnUnusedLocalBinds names - = ifOptRn Opt_WarnUnusedBinds (warnUnusedBinds [(n,LocalDef) | n<-names]) - -warnUnusedMatches names - = ifOptRn Opt_WarnUnusedMatches (warnUnusedGroup [(n,LocalDef) | n<-names]) +warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> TcRn m () +warnUnusedLocalBinds names = ifOptM Opt_WarnUnusedBinds (warnUnusedLocals names) +warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals names) ------------------------- +-- Helpers +warnUnusedGREs gres = warnUnusedBinds [(n,p) | GRE {gre_name = n, gre_prov = p} <- gres] +warnUnusedLocals names = warnUnusedBinds [(n,LocalDef) | n<-names] -warnUnusedBinds :: [(Name,Provenance)] -> RnM d () +warnUnusedBinds :: [(Name,Provenance)] -> TcRn m () warnUnusedBinds names - = mapRn_ warnUnusedGroup groups + = mappM_ warnUnusedGroup groups where -- Group by provenance groups = equivClasses cmp names @@ -1124,13 +967,13 @@ warnUnusedBinds names ------------------------- -warnUnusedGroup :: [(Name,Provenance)] -> RnM d () +warnUnusedGroup :: [(Name,Provenance)] -> TcRn m () warnUnusedGroup names - | null filtered_names = returnRn () - | not is_local = returnRn () + | null filtered_names = returnM () + | not is_local = returnM () | otherwise - = pushSrcLocRn def_loc $ - addWarnRn $ + = addSrcLoc def_loc $ + addWarn $ sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) filtered_names)))] where filtered_names = filter reportable names @@ -1151,20 +994,18 @@ warnUnusedGroup names \begin{code} addNameClashErrRn rdr_name (np1:nps) - = addErrRn (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), + = addErr (vcat [ptext SLIT("Ambiguous occurrence") <+> quotes (ppr rdr_name), ptext SLIT("It could refer to") <+> vcat (msg1 : msgs)]) where msg1 = ptext SLIT("either") <+> mk_ref np1 msgs = [ptext SLIT(" or") <+> mk_ref np | np <- nps] - mk_ref (GRE name prov _) = quotes (ppr name) <> comma <+> pprNameProvenance name prov + mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre shadowedNameWarn shadow = hsep [ptext SLIT("This binding for"), quotes (ppr shadow), ptext SLIT("shadows an existing binding")] -noMainMsg = ptext SLIT("No 'main' defined in module Main") - unknownNameErr name = sep [text flavour, ptext SLIT("not in scope:"), quotes (ppr name)] where @@ -1175,26 +1016,21 @@ badOrigBinding name -- The rdrNameOcc is because we don't want to print Prelude.(,) qualNameErr descriptor (name,loc) - = pushSrcLocRn loc $ - addErrRn (vcat [ ptext SLIT("Invalid use of qualified name") <+> quotes (ppr name), + = addSrcLoc loc $ + addErr (vcat [ ptext SLIT("Invalid use of qualified name") <+> quotes (ppr name), descriptor]) dupNamesErr descriptor ((name,loc) : dup_things) - = pushSrcLocRn loc $ - addErrRn ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) + = addSrcLoc loc $ + addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) $$ descriptor) -warnDeprec :: Name -> DeprecTxt -> RnM d () -warnDeprec name txt - = ifOptRn Opt_WarnDeprecations $ - addWarnRn (sep [ text (occNameFlavour (nameOccName name)) <+> +warnDeprec :: GlobalRdrElt -> TcRn m () +warnDeprec (GRE {gre_name = name, gre_deprec = Just txt}) + = ifOptM Opt_WarnDeprecations $ + addWarn (sep [ text (occNameFlavour (nameOccName name)) <+> quotes (ppr name) <+> text "is deprecated:", nest 4 (ppr txt) ]) - -dupFixityDecl rdr_name loc1 loc2 - = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), - ptext SLIT("at ") <+> ppr loc1, - ptext SLIT("and") <+> ppr loc2] \end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index f48d7326b8..a4d6a35cec 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -11,18 +11,18 @@ free variables. \begin{code} module RnExpr ( - rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, rnStmt, - checkPrecMatch + rnMatch, rnGRHSs, rnPat, rnExpr, rnExprs, + rnStmt, rnStmts, checkPrecMatch ) where #include "HsVersions.h" -import {-# SOURCE #-} RnBinds ( rnBinds ) +import {-# SOURCE #-} RnSource ( rnSrcDecls, rnBinds ) import HsSyn import RdrHsSyn import RnHsSyn -import RnMonad +import TcRnMonad import RnEnv import RnTypes ( rnHsTypeFVs, precParseErr, sectionPrecErr ) import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts ) @@ -32,20 +32,19 @@ import BasicTypes ( Fixity(..), FixityDirection(..), IPName(..), import PrelNames ( hasKey, assertIdKey, eqClassName, foldrName, buildName, eqStringName, cCallableClassName, cReturnableClassName, - monadClassName, enumClassName, ordClassName, + enumClassName, ordClassName, ratioDataConName, splitName, fstName, sndName, ioDataConName, plusIntegerName, timesIntegerName, - assertErr_RDR, replicatePName, mapPName, filterPName, - falseDataConName, trueDataConName, crossPName, - zipPName, lengthPName, indexPName, toPName, - enumFromToPName, enumFromThenToPName, + crossPName, zipPName, lengthPName, indexPName, toPName, + enumFromToPName, enumFromThenToPName, assertName, fromIntegerName, fromRationalName, minusName, negateName, - monadNames ) + qTyConName, monadNames ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) import TysWiredIn ( intTyCon ) -import Name ( NamedThing(..), mkSystemName, nameSrcLoc ) +import RdrName ( RdrName ) +import Name ( Name, NamedThing(..), mkSystemName, nameSrcLoc, nameOccName ) import NameSet import UnicodeUtil ( stringToUtf8 ) import UniqFM ( isNullUFM ) @@ -64,111 +63,116 @@ import FastString ********************************************************* \begin{code} -rnPat :: RdrNamePat -> RnMS (RenamedPat, FreeVars) +rnPat :: RdrNamePat -> RnM (RenamedPat, FreeVars) -rnPat WildPatIn = returnRn (WildPatIn, emptyFVs) +rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs) -rnPat (VarPatIn name) - = lookupBndrRn name `thenRn` \ vname -> - returnRn (VarPatIn vname, emptyFVs) +rnPat (VarPat name) + = lookupBndrRn name `thenM` \ vname -> + returnM (VarPat vname, emptyFVs) rnPat (SigPatIn pat ty) - = doptRn Opt_GlasgowExts `thenRn` \ glaExts -> + = doptM Opt_GlasgowExts `thenM` \ glaExts -> if glaExts - then rnPat pat `thenRn` \ (pat', fvs1) -> - rnHsTypeFVs doc ty `thenRn` \ (ty', fvs2) -> - returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2) + then rnPat pat `thenM` \ (pat', fvs1) -> + rnHsTypeFVs doc ty `thenM` \ (ty', fvs2) -> + returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2) - else addErrRn (patSigErr ty) `thenRn_` + else addErr (patSigErr ty) `thenM_` rnPat pat where - doc = text "a pattern type-signature" + doc = text "In a pattern type-signature" -rnPat (LitPatIn s@(HsString _)) - = returnRn (LitPatIn s, unitFV eqStringName) +rnPat (LitPat s@(HsString _)) + = returnM (LitPat s, unitFV eqStringName) -rnPat (LitPatIn lit) - = litFVs lit `thenRn` \ fvs -> - returnRn (LitPatIn lit, fvs) +rnPat (LitPat lit) + = litFVs lit `thenM` \ fvs -> + returnM (LitPat lit, fvs) rnPat (NPatIn lit mb_neg) - = rnOverLit lit `thenRn` \ (lit', fvs1) -> + = rnOverLit lit `thenM` \ (lit', fvs1) -> (case mb_neg of - Nothing -> returnRn (Nothing, emptyFVs) - Just _ -> lookupSyntaxName negateName `thenRn` \ (neg, fvs) -> - returnRn (Just neg, fvs) - ) `thenRn` \ (mb_neg', fvs2) -> - returnRn (NPatIn lit' mb_neg', + Nothing -> returnM (Nothing, emptyFVs) + Just _ -> lookupSyntaxName negateName `thenM` \ (neg, fvs) -> + returnM (Just neg, fvs) + ) `thenM` \ (mb_neg', fvs2) -> + returnM (NPatIn lit' mb_neg', fvs1 `plusFV` fvs2 `addOneFV` eqClassName) -- Needed to find equality on pattern rnPat (NPlusKPatIn name lit _) - = rnOverLit lit `thenRn` \ (lit', fvs1) -> - lookupBndrRn name `thenRn` \ name' -> - lookupSyntaxName minusName `thenRn` \ (minus, fvs2) -> - returnRn (NPlusKPatIn name' lit' minus, + = rnOverLit lit `thenM` \ (lit', fvs1) -> + lookupBndrRn name `thenM` \ name' -> + lookupSyntaxName minusName `thenM` \ (minus, fvs2) -> + returnM (NPlusKPatIn name' lit' minus, fvs1 `plusFV` fvs2 `addOneFV` ordClassName) -rnPat (LazyPatIn pat) - = rnPat pat `thenRn` \ (pat', fvs) -> - returnRn (LazyPatIn pat', fvs) +rnPat (LazyPat pat) + = rnPat pat `thenM` \ (pat', fvs) -> + returnM (LazyPat pat', fvs) -rnPat (AsPatIn name pat) - = rnPat pat `thenRn` \ (pat', fvs) -> - lookupBndrRn name `thenRn` \ vname -> - returnRn (AsPatIn vname pat', fvs) +rnPat (AsPat name pat) + = rnPat pat `thenM` \ (pat', fvs) -> + lookupBndrRn name `thenM` \ vname -> + returnM (AsPat vname pat', fvs) -rnPat (ConPatIn con pats) - = lookupOccRn con `thenRn` \ con' -> - mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> - returnRn (ConPatIn con' patslist, fvs `addOneFV` con') +rnPat (ConPatIn con stuff) = rnConPat con stuff -rnPat (ConOpPatIn pat1 con _ pat2) - = rnPat pat1 `thenRn` \ (pat1', fvs1) -> - lookupOccRn con `thenRn` \ con' -> - rnPat pat2 `thenRn` \ (pat2', fvs2) -> - getModeRn `thenRn` \ mode -> - -- See comments with rnExpr (OpApp ...) - (if isInterfaceMode mode - then returnRn (ConOpPatIn pat1' con' defaultFixity pat2') - else lookupFixityRn con' `thenRn` \ fixity -> - mkConOpPatRn pat1' con' fixity pat2' - ) `thenRn` \ pat' -> - returnRn (pat', fvs1 `plusFV` fvs2 `addOneFV` con') - -rnPat (ParPatIn pat) - = rnPat pat `thenRn` \ (pat', fvs) -> - returnRn (ParPatIn pat', fvs) - -rnPat (ListPatIn pats) - = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> - returnRn (ListPatIn patslist, fvs `addOneFV` listTyCon_name) - -rnPat (PArrPatIn pats) - = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> - returnRn (PArrPatIn patslist, +rnPat (ParPat pat) + = rnPat pat `thenM` \ (pat', fvs) -> + returnM (ParPat pat', fvs) + +rnPat (ListPat pats _) + = mapFvRn rnPat pats `thenM` \ (patslist, fvs) -> + returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name) + +rnPat (PArrPat pats _) + = mapFvRn rnPat pats `thenM` \ (patslist, fvs) -> + returnM (PArrPat patslist placeHolderType, fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name) where implicit_fvs = mkFVs [lengthPName, indexPName] -rnPat (TuplePatIn pats boxed) - = mapFvRn rnPat pats `thenRn` \ (patslist, fvs) -> - returnRn (TuplePatIn patslist boxed, fvs `addOneFV` tycon_name) +rnPat (TuplePat pats boxed) + = mapFvRn rnPat pats `thenM` \ (patslist, fvs) -> + returnM (TuplePat patslist boxed, fvs `addOneFV` tycon_name) where tycon_name = tupleTyCon_name boxed (length pats) -rnPat (RecPatIn con rpats) - = lookupOccRn con `thenRn` \ con' -> - rnRpats rpats `thenRn` \ (rpats', fvs) -> - returnRn (RecPatIn con' rpats', fvs `addOneFV` con') +rnPat (TypePat name) = + rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) -> + returnM (TypePat name', fvs) + +------------------------------ +rnConPat con (PrefixCon pats) + = lookupOccRn con `thenM` \ con' -> + mapFvRn rnPat pats `thenM` \ (pats', fvs) -> + returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` con') -rnPat (TypePatIn name) - = rnHsTypeFVs (text "type pattern") name `thenRn` \ (name', fvs) -> - returnRn (TypePatIn name', fvs) +rnConPat con (RecCon rpats) + = lookupOccRn con `thenM` \ con' -> + rnRpats rpats `thenM` \ (rpats', fvs) -> + returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` con') + +rnConPat con (InfixCon pat1 pat2) + = lookupOccRn con `thenM` \ con' -> + rnPat pat1 `thenM` \ (pat1', fvs1) -> + rnPat pat2 `thenM` \ (pat2', fvs2) -> + + getModeRn `thenM` \ mode -> + -- See comments with rnExpr (OpApp ...) + (if isInterfaceMode mode + then returnM (ConPatIn con' (InfixCon pat1' pat2')) + else lookupFixityRn con' `thenM` \ fixity -> + mkConOpPatRn con' fixity pat1' pat2' + ) `thenM` \ pat' -> + returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` con') \end{code} + ************************************************************************ * * \subsection{Match} @@ -176,10 +180,10 @@ rnPat (TypePatIn name) ************************************************************************ \begin{code} -rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnMS (RenamedMatch, FreeVars) +rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnM (RenamedMatch, FreeVars) rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) - = pushSrcLocRn (getMatchLoc match) $ + = addSrcLoc (getMatchLoc match) $ -- Bind pattern-bound type variables let @@ -197,25 +201,25 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) -- f x x = 1 bindLocalsFVRn doc_pat (collectPatsBinders pats) $ \ new_binders -> - mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) -> - rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) -> - doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts -> + mapFvRn rnPat pats `thenM` \ (pats', pat_fvs) -> + rnGRHSs grhss `thenM` \ (grhss', grhss_fvs) -> + doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> (case maybe_rhs_sig of - Nothing -> returnRn (Nothing, emptyFVs) - Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenRn` \ (ty', ty_fvs) -> - returnRn (Just ty', ty_fvs) - | otherwise -> addErrRn (patSigErr ty) `thenRn_` - returnRn (Nothing, emptyFVs) - ) `thenRn` \ (maybe_rhs_sig', ty_fvs) -> + Nothing -> returnM (Nothing, emptyFVs) + Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) -> + returnM (Just ty', ty_fvs) + | otherwise -> addErr (patSigErr ty) `thenM_` + returnM (Nothing, emptyFVs) + ) `thenM` \ (maybe_rhs_sig', ty_fvs) -> let binder_set = mkNameSet new_binders unused_binders = nameSetToList (binder_set `minusNameSet` grhss_fvs) all_fvs = grhss_fvs `plusFV` pat_fvs `plusFV` ty_fvs in - warnUnusedMatches unused_binders `thenRn_` + warnUnusedMatches unused_binders `thenM_` - returnRn (Match pats' maybe_rhs_sig' grhss', all_fvs) + returnM (Match pats' maybe_rhs_sig' grhss', all_fvs) -- The bindLocals and bindTyVars will remove the bound FVs \end{code} @@ -227,24 +231,24 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) %************************************************************************ \begin{code} -rnGRHSs :: RdrNameGRHSs -> RnMS (RenamedGRHSs, FreeVars) +rnGRHSs :: RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars) rnGRHSs (GRHSs grhss binds _) = rnBinds binds $ \ binds' -> - mapFvRn rnGRHS grhss `thenRn` \ (grhss', fvGRHSs) -> - returnRn (GRHSs grhss' binds' placeHolderType, fvGRHSs) + mapFvRn rnGRHS grhss `thenM` \ (grhss', fvGRHSs) -> + returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs) rnGRHS (GRHS guarded locn) - = doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts -> - pushSrcLocRn locn $ + = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> + addSrcLoc locn $ (if not (opt_GlasgowExts || is_standard_guard guarded) then - addWarnRn (nonStdGuardErr guarded) + addWarn (nonStdGuardErr guarded) else - returnRn () - ) `thenRn_` + returnM () + ) `thenM_` - rnStmts guarded `thenRn` \ ((_, guarded'), fvs) -> - returnRn (GRHS guarded' locn, fvs) + rnStmts guarded `thenM` \ ((_, guarded'), fvs) -> + returnM (GRHS guarded' locn, fvs) where -- Standard Haskell 1.4 guards are just a single boolean -- expression, rather than a list of qualifiers as in the @@ -261,20 +265,20 @@ rnGRHS (GRHS guarded locn) %************************************************************************ \begin{code} -rnExprs :: [RdrNameHsExpr] -> RnMS ([RenamedHsExpr], FreeVars) +rnExprs :: [RdrNameHsExpr] -> RnM ([RenamedHsExpr], FreeVars) rnExprs ls = rnExprs' ls emptyUniqSet where - rnExprs' [] acc = returnRn ([], acc) + rnExprs' [] acc = returnM ([], acc) rnExprs' (expr:exprs) acc - = rnExpr expr `thenRn` \ (expr', fvExpr) -> + = rnExpr expr `thenM` \ (expr', fvExpr) -> -- Now we do a "seq" on the free vars because typically it's small -- or empty, especially in very long lists of constants let acc' = acc `plusFV` fvExpr in - (grubby_seqNameSet acc' rnExprs') exprs acc' `thenRn` \ (exprs', fvExprs) -> - returnRn (expr':exprs', fvExprs) + (grubby_seqNameSet acc' rnExprs') exprs acc' `thenM` \ (exprs', fvExprs) -> + returnM (expr':exprs', fvExprs) -- Grubby little function to do "seq" on namesets; replace by proper seq when GHC can do seq grubby_seqNameSet ns result | isNullUFM ns = result @@ -284,216 +288,227 @@ grubby_seqNameSet ns result | isNullUFM ns = result Variables. We look up the variable and return the resulting name. \begin{code} -rnExpr :: RdrNameHsExpr -> RnMS (RenamedHsExpr, FreeVars) +rnExpr :: RdrNameHsExpr -> RnM (RenamedHsExpr, FreeVars) rnExpr (HsVar v) - = lookupOccRn v `thenRn` \ name -> + = lookupOccRn v `thenM` \ name -> if name `hasKey` assertIdKey then -- We expand it to (GHCerr.assert__ location) mkAssertExpr else -- The normal case - returnRn (HsVar name, unitFV name) + returnM (HsVar name, unitFV name) rnExpr (HsIPVar v) - = newIPName v `thenRn` \ name -> + = newIPName v `thenM` \ name -> let fvs = case name of Linear _ -> mkFVs [splitName, fstName, sndName] Dupable _ -> emptyFVs in - returnRn (HsIPVar name, fvs) + returnM (HsIPVar name, fvs) rnExpr (HsLit lit) - = litFVs lit `thenRn` \ fvs -> - returnRn (HsLit lit, fvs) + = litFVs lit `thenM` \ fvs -> + returnM (HsLit lit, fvs) rnExpr (HsOverLit lit) - = rnOverLit lit `thenRn` \ (lit', fvs) -> - returnRn (HsOverLit lit', fvs) + = rnOverLit lit `thenM` \ (lit', fvs) -> + returnM (HsOverLit lit', fvs) rnExpr (HsLam match) - = rnMatch LambdaExpr match `thenRn` \ (match', fvMatch) -> - returnRn (HsLam match', fvMatch) + = rnMatch LambdaExpr match `thenM` \ (match', fvMatch) -> + returnM (HsLam match', fvMatch) rnExpr (HsApp fun arg) - = rnExpr fun `thenRn` \ (fun',fvFun) -> - rnExpr arg `thenRn` \ (arg',fvArg) -> - returnRn (HsApp fun' arg', fvFun `plusFV` fvArg) + = rnExpr fun `thenM` \ (fun',fvFun) -> + rnExpr arg `thenM` \ (arg',fvArg) -> + returnM (HsApp fun' arg', fvFun `plusFV` fvArg) rnExpr (OpApp e1 op _ e2) - = rnExpr e1 `thenRn` \ (e1', fv_e1) -> - rnExpr e2 `thenRn` \ (e2', fv_e2) -> - rnExpr op `thenRn` \ (op'@(HsVar op_name), fv_op) -> + = rnExpr e1 `thenM` \ (e1', fv_e1) -> + rnExpr e2 `thenM` \ (e2', fv_e2) -> + rnExpr op `thenM` \ (op'@(HsVar op_name), fv_op) -> -- Deal with fixity -- When renaming code synthesised from "deriving" declarations -- we're in Interface mode, and we should ignore fixity; assume -- that the deriving code generator got the association correct -- Don't even look up the fixity when in interface mode - getModeRn `thenRn` \ mode -> + getModeRn `thenM` \ mode -> (if isInterfaceMode mode - then returnRn (OpApp e1' op' defaultFixity e2') - else lookupFixityRn op_name `thenRn` \ fixity -> + then returnM (OpApp e1' op' defaultFixity e2') + else lookupFixityRn op_name `thenM` \ fixity -> mkOpAppRn e1' op' fixity e2' - ) `thenRn` \ final_e -> + ) `thenM` \ final_e -> - returnRn (final_e, + returnM (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) rnExpr (NegApp e _) - = rnExpr e `thenRn` \ (e', fv_e) -> - lookupSyntaxName negateName `thenRn` \ (neg_name, fv_neg) -> - mkNegAppRn e' neg_name `thenRn` \ final_e -> - returnRn (final_e, fv_e `plusFV` fv_neg) + = rnExpr e `thenM` \ (e', fv_e) -> + lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) -> + mkNegAppRn e' neg_name `thenM` \ final_e -> + returnM (final_e, fv_e `plusFV` fv_neg) rnExpr (HsPar e) - = rnExpr e `thenRn` \ (e', fvs_e) -> - returnRn (HsPar e', fvs_e) + = rnExpr e `thenM` \ (e', fvs_e) -> + returnM (HsPar e', fvs_e) + +-- Template Haskell extensions +rnExpr (HsBracket br_body) + = checkGHCI (thErr "bracket") `thenM_` + rnBracket br_body `thenM` \ (body', fvs_e) -> + returnM (HsBracket body', fvs_e `addOneFV` qTyConName) + -- We use the Q tycon as a proxy to haul in all the smart + -- constructors; see the hack in RnIfaces + +rnExpr (HsSplice n e) + = checkGHCI (thErr "splice") `thenM_` + getSrcLocM `thenM` \ loc -> + newLocalsRn [(n,loc)] `thenM` \ [n'] -> + rnExpr e `thenM` \ (e', fvs_e) -> + returnM (HsSplice n' e', fvs_e) rnExpr section@(SectionL expr op) - = rnExpr expr `thenRn` \ (expr', fvs_expr) -> - rnExpr op `thenRn` \ (op', fvs_op) -> - checkSectionPrec InfixL section op' expr' `thenRn_` - returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr) + = rnExpr expr `thenM` \ (expr', fvs_expr) -> + rnExpr op `thenM` \ (op', fvs_op) -> + checkSectionPrec InfixL section op' expr' `thenM_` + returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr) rnExpr section@(SectionR op expr) - = rnExpr op `thenRn` \ (op', fvs_op) -> - rnExpr expr `thenRn` \ (expr', fvs_expr) -> - checkSectionPrec InfixR section op' expr' `thenRn_` - returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr) + = rnExpr op `thenM` \ (op', fvs_op) -> + rnExpr expr `thenM` \ (expr', fvs_expr) -> + checkSectionPrec InfixR section op' expr' `thenM_` + returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr) rnExpr (HsCCall fun args may_gc is_casm _) -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls - = lookupOrigNames [] `thenRn` \ implicit_fvs -> - rnExprs args `thenRn` \ (args', fvs_args) -> - returnRn (HsCCall fun args' may_gc is_casm placeHolderType, + = rnExprs args `thenM` \ (args', fvs_args) -> + returnM (HsCCall fun args' may_gc is_casm placeHolderType, fvs_args `plusFV` mkFVs [cCallableClassName, cReturnableClassName, ioDataConName]) rnExpr (HsSCC lbl expr) - = rnExpr expr `thenRn` \ (expr', fvs_expr) -> - returnRn (HsSCC lbl expr', fvs_expr) + = rnExpr expr `thenM` \ (expr', fvs_expr) -> + returnM (HsSCC lbl expr', fvs_expr) rnExpr (HsCase expr ms src_loc) - = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (new_expr, e_fvs) -> - mapFvRn (rnMatch CaseAlt) ms `thenRn` \ (new_ms, ms_fvs) -> - returnRn (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs) + = addSrcLoc src_loc $ + rnExpr expr `thenM` \ (new_expr, e_fvs) -> + mapFvRn (rnMatch CaseAlt) ms `thenM` \ (new_ms, ms_fvs) -> + returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs) rnExpr (HsLet binds expr) = rnBinds binds $ \ binds' -> - rnExpr expr `thenRn` \ (expr',fvExpr) -> - returnRn (HsLet binds' expr', fvExpr) + rnExpr expr `thenM` \ (expr',fvExpr) -> + returnM (HsLet binds' expr', fvExpr) rnExpr (HsWith expr binds is_with) - = warnCheckRn (not is_with) withWarning `thenRn_` - rnExpr expr `thenRn` \ (expr',fvExpr) -> - rnIPBinds binds `thenRn` \ (binds',fvBinds) -> - returnRn (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds) + = warnIf is_with withWarning `thenM_` + rnExpr expr `thenM` \ (expr',fvExpr) -> + rnIPBinds binds `thenM` \ (binds',fvBinds) -> + returnM (HsWith expr' binds' is_with, fvExpr `plusFV` fvBinds) rnExpr e@(HsDo do_or_lc stmts _ ty src_loc) - = pushSrcLocRn src_loc $ - rnStmts stmts `thenRn` \ ((_, stmts'), fvs) -> + = addSrcLoc src_loc $ + rnStmts stmts `thenM` \ ((_, stmts'), fvs) -> -- Check the statement list ends in an expression case last stmts' of { - ResultStmt _ _ -> returnRn () ; - _ -> addErrRn (doStmtListErr e) - } `thenRn_` + ResultStmt _ _ -> returnM () ; + _ -> addErr (doStmtListErr e) + } `thenM_` -- Generate the rebindable syntax for the monad (case do_or_lc of - DoExpr -> mapAndUnzipRn lookupSyntaxName monadNames - other -> returnRn ([], []) - ) `thenRn` \ (monad_names', monad_fvs) -> + DoExpr -> mapAndUnzipM lookupSyntaxName monadNames + other -> returnM ([], []) + ) `thenM` \ (monad_names', monad_fvs) -> - returnRn (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc, + returnM (HsDo do_or_lc stmts' monad_names' placeHolderType src_loc, fvs `plusFV` implicit_fvs `plusFV` plusFVs monad_fvs) where implicit_fvs = case do_or_lc of PArrComp -> mkFVs [replicatePName, mapPName, filterPName, - falseDataConName, trueDataConName, crossPName, - zipPName] + crossPName, zipPName] ListComp -> mkFVs [foldrName, buildName] - other -> emptyFVs - -- monadClassName pulls in the standard names - -- Monad stuff should not be necessary for a list comprehension - -- but the typechecker looks up the bind and return Ids anyway - -- Oh well. + DoExpr -> emptyFVs rnExpr (ExplicitList _ exps) - = rnExprs exps `thenRn` \ (exps', fvs) -> - returnRn (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name) + = rnExprs exps `thenM` \ (exps', fvs) -> + returnM (ExplicitList placeHolderType exps', fvs `addOneFV` listTyCon_name) rnExpr (ExplicitPArr _ exps) - = rnExprs exps `thenRn` \ (exps', fvs) -> - returnRn (ExplicitPArr placeHolderType exps', + = rnExprs exps `thenM` \ (exps', fvs) -> + returnM (ExplicitPArr placeHolderType exps', fvs `addOneFV` toPName `addOneFV` parrTyCon_name) rnExpr (ExplicitTuple exps boxity) - = rnExprs exps `thenRn` \ (exps', fvs) -> - returnRn (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name) + = rnExprs exps `thenM` \ (exps', fvs) -> + returnM (ExplicitTuple exps' boxity, fvs `addOneFV` tycon_name) where tycon_name = tupleTyCon_name boxity (length exps) rnExpr (RecordCon con_id rbinds) - = lookupOccRn con_id `thenRn` \ conname -> - rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) -> - returnRn (RecordCon conname rbinds', fvRbinds `addOneFV` conname) + = lookupOccRn con_id `thenM` \ conname -> + rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) -> + returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname) rnExpr (RecordUpd expr rbinds) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) -> - returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds) + = rnExpr expr `thenM` \ (expr', fvExpr) -> + rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) -> + returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds) rnExpr (ExprWithTySig expr pty) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnHsTypeFVs (text "an expression type signature") pty `thenRn` \ (pty', fvTy) -> - returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) + = rnExpr expr `thenM` \ (expr', fvExpr) -> + rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) -> + returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) + where + doc = text "In an expression type signature" rnExpr (HsIf p b1 b2 src_loc) - = pushSrcLocRn src_loc $ - rnExpr p `thenRn` \ (p', fvP) -> - rnExpr b1 `thenRn` \ (b1', fvB1) -> - rnExpr b2 `thenRn` \ (b2', fvB2) -> - returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2]) + = addSrcLoc src_loc $ + rnExpr p `thenM` \ (p', fvP) -> + rnExpr b1 `thenM` \ (b1', fvB1) -> + rnExpr b2 `thenM` \ (b2', fvB2) -> + returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2]) rnExpr (HsType a) - = rnHsTypeFVs doc a `thenRn` \ (t, fvT) -> - returnRn (HsType t, fvT) + = rnHsTypeFVs doc a `thenM` \ (t, fvT) -> + returnM (HsType t, fvT) where - doc = text "in a type argument" + doc = text "In a type argument" rnExpr (ArithSeqIn seq) - = rn_seq seq `thenRn` \ (new_seq, fvs) -> - returnRn (ArithSeqIn new_seq, fvs `addOneFV` enumClassName) + = rn_seq seq `thenM` \ (new_seq, fvs) -> + returnM (ArithSeqIn new_seq, fvs `addOneFV` enumClassName) where rn_seq (From expr) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - returnRn (From expr', fvExpr) + = rnExpr expr `thenM` \ (expr', fvExpr) -> + returnM (From expr', fvExpr) rn_seq (FromThen expr1 expr2) - = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - returnRn (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) + = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) rn_seq (FromTo expr1 expr2) - = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) + = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) rn_seq (FromThenTo expr1 expr2 expr3) - = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - rnExpr expr3 `thenRn` \ (expr3', fvExpr3) -> - returnRn (FromThenTo expr1' expr2' expr3', + = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + rnExpr expr3 `thenM` \ (expr3', fvExpr3) -> + returnM (FromThenTo expr1' expr2' expr3', plusFVs [fvExpr1, fvExpr2, fvExpr3]) rnExpr (PArrSeqIn seq) - = rn_seq seq `thenRn` \ (new_seq, fvs) -> - returnRn (PArrSeqIn new_seq, + = rn_seq seq `thenM` \ (new_seq, fvs) -> + returnM (PArrSeqIn new_seq, fvs `plusFV` mkFVs [enumFromToPName, enumFromThenToPName]) where @@ -503,14 +518,14 @@ rnExpr (PArrSeqIn seq) rn_seq (FromThen _ _) = panic "RnExpr.rnExpr: Infinite parallel array!" rn_seq (FromTo expr1 expr2) - = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - returnRn (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) + = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) rn_seq (FromThenTo expr1 expr2 expr3) - = rnExpr expr1 `thenRn` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenRn` \ (expr2', fvExpr2) -> - rnExpr expr3 `thenRn` \ (expr3', fvExpr3) -> - returnRn (FromThenTo expr1' expr2' expr3', + = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + rnExpr expr3 `thenM` \ (expr3', fvExpr3) -> + returnM (FromThenTo expr1' expr2' expr3', plusFVs [fvExpr1, fvExpr2, fvExpr3]) \end{code} @@ -519,14 +534,14 @@ Since all the symbols are reservedops we can simply reject them. We return a (bogus) EWildPat in each case. \begin{code} -rnExpr e@EWildPat = addErrRn (patSynErr e) `thenRn_` - returnRn (EWildPat, emptyFVs) +rnExpr e@EWildPat = addErr (patSynErr e) `thenM_` + returnM (EWildPat, emptyFVs) -rnExpr e@(EAsPat _ _) = addErrRn (patSynErr e) `thenRn_` - returnRn (EWildPat, emptyFVs) +rnExpr e@(EAsPat _ _) = addErr (patSynErr e) `thenM_` + returnM (EWildPat, emptyFVs) -rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_` - returnRn (EWildPat, emptyFVs) +rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_` + returnM (EWildPat, emptyFVs) \end{code} @@ -539,32 +554,32 @@ rnExpr e@(ELazyPat _) = addErrRn (patSynErr e) `thenRn_` \begin{code} rnRbinds str rbinds - = mapRn_ field_dup_err dup_fields `thenRn_` - mapFvRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind) -> - returnRn (rbinds', fvRbind) + = mappM_ field_dup_err dup_fields `thenM_` + mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) -> + returnM (rbinds', fvRbind) where - (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rbinds ] + (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ] - field_dup_err dups = addErrRn (dupFieldErr str dups) + field_dup_err dups = addErr (dupFieldErr str dups) - rn_rbind (field, expr, pun) - = lookupGlobalOccRn field `thenRn` \ fieldname -> - rnExpr expr `thenRn` \ (expr', fvExpr) -> - returnRn ((fieldname, expr', pun), fvExpr `addOneFV` fieldname) + rn_rbind (field, expr) + = lookupGlobalOccRn field `thenM` \ fieldname -> + rnExpr expr `thenM` \ (expr', fvExpr) -> + returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname) rnRpats rpats - = mapRn_ field_dup_err dup_fields `thenRn_` - mapFvRn rn_rpat rpats `thenRn` \ (rpats', fvs) -> - returnRn (rpats', fvs) + = mappM_ field_dup_err dup_fields `thenM_` + mapFvRn rn_rpat rpats `thenM` \ (rpats', fvs) -> + returnM (rpats', fvs) where - (_, dup_fields) = removeDups compare [ f | (f,_,_) <- rpats ] + (_, dup_fields) = removeDups compare [ f | (f,_) <- rpats ] - field_dup_err dups = addErrRn (dupFieldErr "pattern" dups) + field_dup_err dups = addErr (dupFieldErr "pattern" dups) - rn_rpat (field, pat, pun) - = lookupGlobalOccRn field `thenRn` \ fieldname -> - rnPat pat `thenRn` \ (pat', fvs) -> - returnRn ((fieldname, pat', pun), fvs `addOneFV` fieldname) + rn_rpat (field, pat) + = lookupGlobalOccRn field `thenM` \ fieldname -> + rnPat pat `thenM` \ (pat', fvs) -> + returnM ((fieldname, pat'), fvs `addOneFV` fieldname) \end{code} %************************************************************************ @@ -574,13 +589,34 @@ rnRpats rpats %************************************************************************ \begin{code} -rnIPBinds [] = returnRn ([], emptyFVs) +rnIPBinds [] = returnM ([], emptyFVs) rnIPBinds ((n, expr) : binds) - = newIPName n `thenRn` \ name -> - rnExpr expr `thenRn` \ (expr',fvExpr) -> - rnIPBinds binds `thenRn` \ (binds',fvBinds) -> - returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds) + = newIPName n `thenM` \ name -> + rnExpr expr `thenM` \ (expr',fvExpr) -> + rnIPBinds binds `thenM` \ (binds',fvBinds) -> + returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds) + +\end{code} + +%************************************************************************ +%* * + Template Haskell brackets +%* * +%************************************************************************ +\begin{code} +rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) -> + returnM (ExpBr e', fvs) +rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) -> + returnM (PatBr p', fvs) +rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) -> + returnM (TypBr t', fvs) + where + doc = ptext SLIT("In a Template-Haskell quoted type") +rnBracket (DecBr ds) = rnSrcDecls ds `thenM` \ (tcg_env, ds', fvs) -> + -- Discard the tcg_env; it contains the extended global RdrEnv + -- because there is no scope that these decls cover (yet!) + returnM (DecBr ds', fvs) \end{code} %************************************************************************ @@ -599,66 +635,66 @@ Quals. \begin{code} rnStmts :: [RdrNameStmt] - -> RnMS (([Name], [RenamedStmt]), FreeVars) + -> RnM (([Name], [RenamedStmt]), FreeVars) rnStmts [] - = returnRn (([], []), emptyFVs) + = returnM (([], []), emptyFVs) rnStmts (stmt:stmts) - = getLocalNameEnv `thenRn` \ name_env -> + = getLocalRdrEnv `thenM` \ name_env -> rnStmt stmt $ \ stmt' -> - rnStmts stmts `thenRn` \ ((binders, stmts'), fvs) -> - returnRn ((binders, stmt' : stmts'), fvs) + rnStmts stmts `thenM` \ ((binders, stmts'), fvs) -> + returnM ((binders, stmt' : stmts'), fvs) rnStmt :: RdrNameStmt - -> (RenamedStmt -> RnMS (([Name], a), FreeVars)) - -> RnMS (([Name], a), FreeVars) + -> (RenamedStmt -> RnM (([Name], a), FreeVars)) + -> RnM (([Name], a), FreeVars) -- The thing list of names returned is the list returned by the -- thing_inside, plus the binders of the arguments stmt rnStmt (ParStmt stmtss) thing_inside - = mapFvRn rnStmts stmtss `thenRn` \ (bndrstmtss, fv_stmtss) -> + = mapFvRn rnStmts stmtss `thenM` \ (bndrstmtss, fv_stmtss) -> let binderss = map fst bndrstmtss checkBndrs all_bndrs bndrs - = checkRn (null (intersectBy eqOcc all_bndrs bndrs)) err `thenRn_` - returnRn (bndrs ++ all_bndrs) + = checkErr (null (intersectBy eqOcc all_bndrs bndrs)) err `thenM_` + returnM (bndrs ++ all_bndrs) eqOcc n1 n2 = nameOccName n1 == nameOccName n2 err = text "duplicate binding in parallel list comprehension" in - foldlRn checkBndrs [] binderss `thenRn` \ new_binders -> + foldlM checkBndrs [] binderss `thenM` \ new_binders -> bindLocalNamesFV new_binders $ - thing_inside (ParStmtOut bndrstmtss)`thenRn` \ ((rest_bndrs, result), fv_rest) -> - returnRn ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest) + thing_inside (ParStmtOut bndrstmtss)`thenM` \ ((rest_bndrs, result), fv_rest) -> + returnM ((new_binders ++ rest_bndrs, result), fv_stmtss `plusFV` fv_rest) rnStmt (BindStmt pat expr src_loc) thing_inside - = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (expr', fv_expr) -> + = addSrcLoc src_loc $ + rnExpr expr `thenM` \ (expr', fv_expr) -> bindPatSigTyVars (collectSigTysFromPat pat) $ bindLocalsFVRn doc (collectPatBinders pat) $ \ new_binders -> - rnPat pat `thenRn` \ (pat', fv_pat) -> - thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ ((rest_binders, result), fvs) -> - returnRn ((new_binders ++ rest_binders, result), + rnPat pat `thenM` \ (pat', fv_pat) -> + thing_inside (BindStmt pat' expr' src_loc) `thenM` \ ((rest_binders, result), fvs) -> + returnM ((new_binders ++ rest_binders, result), fv_expr `plusFV` fvs `plusFV` fv_pat) where doc = text "In a pattern in 'do' binding" rnStmt (ExprStmt expr _ src_loc) thing_inside - = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (expr', fv_expr) -> - thing_inside (ExprStmt expr' placeHolderType src_loc) `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `plusFV` fvs) + = addSrcLoc src_loc $ + rnExpr expr `thenM` \ (expr', fv_expr) -> + thing_inside (ExprStmt expr' placeHolderType src_loc) `thenM` \ (result, fvs) -> + returnM (result, fv_expr `plusFV` fvs) rnStmt (ResultStmt expr src_loc) thing_inside - = pushSrcLocRn src_loc $ - rnExpr expr `thenRn` \ (expr', fv_expr) -> - thing_inside (ResultStmt expr' src_loc) `thenRn` \ (result, fvs) -> - returnRn (result, fv_expr `plusFV` fvs) + = addSrcLoc src_loc $ + rnExpr expr `thenM` \ (expr', fv_expr) -> + thing_inside (ResultStmt expr' src_loc) `thenM` \ (result, fvs) -> + returnM (result, fv_expr `plusFV` fvs) rnStmt (LetStmt binds) thing_inside = rnBinds binds $ \ binds' -> let new_binders = collectHsBinders binds' in - thing_inside (LetStmt binds') `thenRn` \ ((rest_binders, result), fvs) -> - returnRn ((new_binders ++ rest_binders, result), fvs ) + thing_inside (LetStmt binds') `thenM` \ ((rest_binders, result), fvs) -> + returnM ((new_binders ++ rest_binders, result), fvs ) \end{code} %************************************************************************ @@ -682,18 +718,18 @@ mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged -> RenamedHsExpr -> Fixity -- Operator and fixity -> RenamedHsExpr -- Right operand (not an OpApp, but might -- be a NegApp) - -> RnMS RenamedHsExpr + -> RnM RenamedHsExpr --------------------------- -- (e11 `op1` e12) `op2` e2 mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2 | nofix_error - = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_` - returnRn (OpApp e1 op2 fix2 e2) + = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` + returnM (OpApp e1 op2 fix2 e2) | associate_right - = mkOpAppRn e12 op2 fix2 e2 `thenRn` \ new_e -> - returnRn (OpApp e11 op1 fix1 new_e) + = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e -> + returnM (OpApp e11 op1 fix1 new_e) where (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -701,12 +737,12 @@ mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2 -- (- neg_arg) `op` e2 mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2 | nofix_error - = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenRn_` - returnRn (OpApp e1 op2 fix2 e2) + = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_` + returnM (OpApp e1 op2 fix2 e2) | associate_right - = mkOpAppRn neg_arg op2 fix2 e2 `thenRn` \ new_e -> - returnRn (NegApp new_e neg_name) + = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e -> + returnM (NegApp new_e neg_name) where (nofix_error, associate_right) = compareFixity negateFixity fix2 @@ -714,8 +750,8 @@ mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2 -- e1 `op` - neg_arg mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _) -- NegApp can occur on the right | not associate_right -- We *want* right association - = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_` - returnRn (OpApp e1 op1 fix1 e2) + = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_` + returnM (OpApp e1 op1 fix1 e2) where (_, associate_right) = compareFixity fix1 negateFixity @@ -725,7 +761,7 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment = ASSERT2( right_op_ok fix e2, ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 ) - returnRn (OpApp e1 op fix e2) + returnM (OpApp e1 op fix e2) -- Parser left-associates everything, but -- derived instances may have correctly-associated things to @@ -741,60 +777,62 @@ right_op_ok fix1 other mkNegAppRn neg_arg neg_name = #ifdef DEBUG - getModeRn `thenRn` \ mode -> + getModeRn `thenM` \ mode -> ASSERT( not_op_app mode neg_arg ) #endif - returnRn (NegApp neg_arg neg_name) + returnM (NegApp neg_arg neg_name) not_op_app SourceMode (OpApp _ _ _ _) = False not_op_app mode other = True \end{code} \begin{code} -mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat - -> RnMS RenamedPat +mkConOpPatRn :: Name -> Fixity -> RenamedPat -> RenamedPat + -> RnM RenamedPat -mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12) - op2 fix2 p2 - | nofix_error - = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenRn_` - returnRn (ConOpPatIn p1 op2 fix2 p2) - - | associate_right - = mkConOpPatRn p12 op2 fix2 p2 `thenRn` \ new_p -> - returnRn (ConOpPatIn p11 op1 fix1 new_p) - - where - (nofix_error, associate_right) = compareFixity fix1 fix2 +mkConOpPatRn op2 fix2 p1@(ConPatIn op1 (InfixCon p11 p12)) p2 + = lookupFixityRn op1 `thenM` \ fix1 -> + let + (nofix_error, associate_right) = compareFixity fix1 fix2 + in + if nofix_error then + addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` + returnM (ConPatIn op2 (InfixCon p1 p2)) + else + if associate_right then + mkConOpPatRn op2 fix2 p12 p2 `thenM` \ new_p -> + returnM (ConPatIn op1 (InfixCon p11 new_p)) + else + returnM (ConPatIn op2 (InfixCon p1 p2)) -mkConOpPatRn p1 op fix p2 -- Default case, no rearrangment +mkConOpPatRn op fix p1 p2 -- Default case, no rearrangment = ASSERT( not_op_pat p2 ) - returnRn (ConOpPatIn p1 op fix p2) + returnM (ConPatIn op (InfixCon p1 p2)) -not_op_pat (ConOpPatIn _ _ _ _) = False -not_op_pat other = True +not_op_pat (ConPatIn _ (InfixCon _ _)) = False +not_op_pat other = True \end{code} \begin{code} -checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS () +checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM () checkPrecMatch False fn match - = returnRn () + = returnM () checkPrecMatch True op (Match (p1:p2:_) _ _) -- True indicates an infix lhs - = getModeRn `thenRn` \ mode -> + = getModeRn `thenM` \ mode -> -- See comments with rnExpr (OpApp ...) if isInterfaceMode mode - then returnRn () - else checkPrec op p1 False `thenRn_` + then returnM () + else checkPrec op p1 False `thenM_` checkPrec op p2 True checkPrecMatch True op _ = panic "checkPrecMatch" -checkPrec op (ConOpPatIn _ op1 _ _) right - = lookupFixityRn op `thenRn` \ op_fix@(Fixity op_prec op_dir) -> - lookupFixityRn op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) -> +checkPrec op (ConPatIn op1 (InfixCon _ _)) right + = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) -> + lookupFixityRn op1 `thenM` \ op1_fix@(Fixity op1_prec op1_dir) -> let inf_ok = op1_prec > op_prec || (op1_prec == op_prec && @@ -805,10 +843,10 @@ checkPrec op (ConOpPatIn _ op1 _ _) right info1 = (ppr_op op1, op1_fix) (infol, infor) = if right then (info, info1) else (info1, info) in - checkRn inf_ok (precParseErr infol infor) + checkErr inf_ok (precParseErr infol infor) checkPrec op pat right - = returnRn () + = returnM () -- Check precedence of (arg op) or (op arg) respectively -- If arg is itself an operator application, then either @@ -818,12 +856,12 @@ checkSectionPrec direction section op arg = case arg of OpApp _ op fix _ -> go_for_it (ppr_op op) fix NegApp _ _ -> go_for_it pp_prefix_minus negateFixity - other -> returnRn () + other -> returnM () where HsVar op_name = op go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc) - = lookupFixityRn op_name `thenRn` \ op_fix@(Fixity op_prec _) -> - checkRn (op_prec < arg_prec + = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) -> + checkErr (op_prec < arg_prec || op_prec == arg_prec && direction == assoc) (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section) @@ -842,24 +880,24 @@ are made available. \begin{code} litFVs (HsChar c) - = checkRn (inCharRange c) (bogusCharError c) `thenRn_` - returnRn (unitFV charTyCon_name) - -litFVs (HsCharPrim c) = returnRn (unitFV (getName charPrimTyCon)) -litFVs (HsString s) = returnRn (mkFVs [listTyCon_name, charTyCon_name]) -litFVs (HsStringPrim s) = returnRn (unitFV (getName addrPrimTyCon)) -litFVs (HsInt i) = returnRn (unitFV (getName intTyCon)) -litFVs (HsIntPrim i) = returnRn (unitFV (getName intPrimTyCon)) -litFVs (HsFloatPrim f) = returnRn (unitFV (getName floatPrimTyCon)) -litFVs (HsDoublePrim d) = returnRn (unitFV (getName doublePrimTyCon)) -litFVs (HsLitLit l bogus_ty) = returnRn (unitFV cCallableClassName) + = checkErr (inCharRange c) (bogusCharError c) `thenM_` + returnM (unitFV charTyCon_name) + +litFVs (HsCharPrim c) = returnM (unitFV (getName charPrimTyCon)) +litFVs (HsString s) = returnM (mkFVs [listTyCon_name, charTyCon_name]) +litFVs (HsStringPrim s) = returnM (unitFV (getName addrPrimTyCon)) +litFVs (HsInt i) = returnM (unitFV (getName intTyCon)) +litFVs (HsIntPrim i) = returnM (unitFV (getName intPrimTyCon)) +litFVs (HsFloatPrim f) = returnM (unitFV (getName floatPrimTyCon)) +litFVs (HsDoublePrim d) = returnM (unitFV (getName doublePrimTyCon)) +litFVs (HsLitLit l bogus_ty) = returnM (unitFV cCallableClassName) litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear -- in post-typechecker translations rnOverLit (HsIntegral i _) - = lookupSyntaxName fromIntegerName `thenRn` \ (from_integer_name, fvs) -> + = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) -> if inIntRange i then - returnRn (HsIntegral i from_integer_name, fvs) + returnM (HsIntegral i from_integer_name, fvs) else let extra_fvs = mkFVs [plusIntegerName, timesIntegerName] -- Big integer literals are built, using + and *, @@ -868,10 +906,10 @@ rnOverLit (HsIntegral i _) -- they are used to construct the argument to fromInteger, -- which is the rebindable one.] in - returnRn (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs) + returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs) rnOverLit (HsFractional i _) - = lookupSyntaxName fromRationalName `thenRn` \ (from_rat_name, fvs) -> + = lookupSyntaxName fromRationalName `thenM` \ (from_rat_name, fvs) -> let extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName] -- We have to make sure that the Ratio type is imported with @@ -882,7 +920,7 @@ rnOverLit (HsFractional i _) -- The plus/times integer operations may be needed to construct the numerator -- and denominator (see DsUtils.mkIntegerLit) in - returnRn (HsFractional i from_rat_name, fvs `plusFV` extra_fvs) + returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs) \end{code} %************************************************************************ @@ -892,30 +930,30 @@ rnOverLit (HsFractional i _) %************************************************************************ \begin{code} -mkAssertExpr :: RnMS (RenamedHsExpr, FreeVars) -mkAssertExpr = - lookupOrigName assertErr_RDR `thenRn` \ name -> - getSrcLocRn `thenRn` \ sloc -> +mkAssertExpr :: RnM (RenamedHsExpr, FreeVars) +mkAssertExpr + = getSrcLocM `thenM` \ sloc -> -- if we're ignoring asserts, return (\ _ e -> e) -- if not, return (assertError "src-loc") - if opt_IgnoreAsserts then - getUniqRn `thenRn` \ uniq -> - let - vname = mkSystemName uniq FSLIT("v") - expr = HsLam ignorePredMatch - loc = nameSrcLoc vname - ignorePredMatch = mkSimpleMatch [WildPatIn, VarPatIn vname] (HsVar vname) placeHolderType loc - in - returnRn (expr, unitFV name) - else - let - expr = - HsApp (HsVar name) + if opt_IgnoreAsserts then + newUnique `thenM` \ uniq -> + let + vname = mkSystemName uniq FSLIT("v") + expr = HsLam ignorePredMatch + loc = nameSrcLoc vname + ignorePredMatch = mkSimpleMatch [WildPat placeHolderType, VarPat vname] + (HsVar vname) placeHolderType loc + in + returnM (expr, emptyFVs) + else + let + expr = + HsApp (HsVar assertName) (HsLit (HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc)))))) - in - returnRn (expr, unitFV name) + in + returnM (expr, unitFV assertName) \end{code} %************************************************************************ @@ -946,6 +984,10 @@ patSynErr e = sep [ptext SLIT("Pattern syntax in expression context:"), nest 4 (ppr e)] +thErr what + = ptext SLIT("Template Haskell") <+> text what <+> + ptext SLIT("illegal in a stage-1 compiler") + doStmtListErr e = sep [ptext SLIT("`do' statements must end in expression:"), nest 4 (ppr e)] diff --git a/ghc/compiler/rename/RnHiFiles.hi-boot-5 b/ghc/compiler/rename/RnHiFiles.hi-boot-5 index da5dcc3c47..27817b05f6 100644 --- a/ghc/compiler/rename/RnHiFiles.hi-boot-5 +++ b/ghc/compiler/rename/RnHiFiles.hi-boot-5 @@ -1,3 +1,4 @@ __interface RnHiFiles 1 0 where __export RnHiFiles loadInterface; -1 loadInterface :: __forall [d] => Outputable.SDoc -> Module.ModuleName -> Module.WhereFrom -> RnMonad.RnM d HscTypes.ModIface; +1 loadInterface :: __forall [m] => Outputable.SDoc -> Module.ModuleName -> TcRnTypes.WhereFrom + -> TcRnTypes.TcRn m HscTypes.ModIface; diff --git a/ghc/compiler/rename/RnHiFiles.hi-boot-6 b/ghc/compiler/rename/RnHiFiles.hi-boot-6 index 2fe3df599f..2209be6fab 100644 --- a/ghc/compiler/rename/RnHiFiles.hi-boot-6 +++ b/ghc/compiler/rename/RnHiFiles.hi-boot-6 @@ -3,5 +3,5 @@ module RnHiFiles where loadInterface :: Outputable.SDoc -> Module.ModuleName - -> Module.WhereFrom - -> RnMonad.RnM d HscTypes.ModIface + -> TcRnTypes.WhereFrom + -> TcRnTypes.TcRn m HscTypes.ModIface diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index bd414fb83c..931c5cf59e 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -5,11 +5,10 @@ \begin{code} module RnHiFiles ( - readIface, findAndReadIface, loadInterface, loadHomeInterface, - tryLoadInterface, loadOrphanModules, - loadExports, loadFixDecls, loadDeprecs, - - getTyClDeclBinders + readIface, loadInterface, loadHomeInterface, + loadOrphanModules, + loadOldIface, + ParsedIface(..) ) where #include "HsVersions.h" @@ -18,34 +17,45 @@ import DriverState ( v_GhcMode, isCompManagerMode ) import DriverUtil ( splitFilename ) import CmdLineOpts ( opt_IgnoreIfacePragmas ) import Parser ( parseIface ) -import HscTypes ( ModuleLocation(..), - ModIface(..), emptyModIface, +import HscTypes ( ModIface(..), emptyModIface, + ExternalPackageState(..), VersionInfo(..), ImportedModuleInfo, - lookupIfaceByModName, RdrExportItem, + lookupIfaceByModName, RdrExportItem, WhatsImported(..), ImportVersion, WhetherHasOrphans, IsBootInterface, - DeclsMap, GatedDecl, IfaceInsts, IfaceRules, - AvailInfo, GenAvailInfo(..), Avails, Deprecations(..) + DeclsMap, GatedDecl, IfaceInsts, IfaceRules, mkIfaceDecls, + AvailInfo, GenAvailInfo(..), ParsedIface(..), IfaceDeprecs, + Avails, availNames, availName, Deprecations(..) ) -import HsSyn ( TyClDecl(..), InstDecl(..), RuleDecl(..), - tyClDeclNames, tyClDeclSysNames, hsTyVarNames, - getHsInstHead, +import HsSyn ( TyClDecl(..), InstDecl(..), RuleDecl(..), ConDecl(..), + hsTyVarNames, splitHsInstDeclTy, tyClDeclName, tyClDeclNames ) import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl ) -import RnHsSyn ( extractHsTyNames_s ) -import BasicTypes ( Version ) +import RnHsSyn ( RenamedInstDecl, RenamedRuleDecl, RenamedTyClDecl, + extractHsTyNames_s ) +import BasicTypes ( Version, FixitySig(..), Fixity(..), FixityDirection(..) ) +import RnSource ( rnIfaceRuleDecl, rnTyClDecl, rnInstDecl ) import RnTypes ( rnHsType ) import RnEnv -import RnMonad +import TcRnMonad import PrelNames ( gHC_PRIM_Name, gHC_PRIM ) +import PrelInfo ( ghcPrimExports, cCallableClassDecl, cReturnableClassDecl, assertDecl ) import Name ( Name {-instance NamedThing-}, - nameModule, isInternalName - ) + nameModule, isInternalName ) import NameEnv import NameSet -import Module -import RdrName ( rdrNameOcc ) -import SrcLoc ( mkSrcLoc ) +import Id ( idName ) +import MkId ( seqId ) +import Packages ( preludePackage ) +import Module ( Module, ModuleName, ModLocation(ml_hi_file), + moduleName, isHomeModule, mkVanillaModule, + extendModuleEnv + ) +import RdrName ( RdrName, mkRdrUnqual, rdrNameOcc, nameRdrName ) +import OccName ( OccName, mkWorkerOcc, mkClassTyConOcc, mkClassDataConOcc, + mkSuperDictSelOcc, mkGenOcc1, mkGenOcc2 ) +import TyCon ( DataConDetails(..) ) +import SrcLoc ( noSrcLoc, mkSrcLoc ) import Maybes ( maybeToBool ) import StringBuffer ( hGetStringBuffer ) import FastString ( mkFastString ) @@ -56,17 +66,14 @@ import FiniteMap import ListSetOps ( minusList ) import Outputable import Bag -import BinIface ( {- just instances -} ) -import qualified Binary +import BinIface ( readBinIface ) import Panic import Config import EXCEPTION as Exception -import DYNAMIC ( fromDynamic ) import DATA_IOREF ( readIORef ) import Directory -import List ( isSuffixOf ) \end{code} @@ -77,53 +84,51 @@ import List ( isSuffixOf ) %********************************************************* \begin{code} -loadHomeInterface :: SDoc -> Name -> RnM d ModIface +loadHomeInterface :: SDoc -> Name -> TcRn m ModIface loadHomeInterface doc_str name = ASSERT2( not (isInternalName name), ppr name <+> parens doc_str ) loadInterface doc_str (moduleName (nameModule name)) ImportBySystem -loadOrphanModules :: [ModuleName] -> RnM d () +loadOrphanModules :: [ModuleName] -> TcRn m () loadOrphanModules mods - | null mods = returnRn () + | null mods = returnM () | otherwise = traceRn (text "Loading orphan modules:" <+> - fsep (map ppr mods)) `thenRn_` - mapRn_ load mods `thenRn_` - returnRn () + fsep (map ppr mods)) `thenM_` + mappM_ load mods `thenM_` + returnM () where load mod = loadInterface (mk_doc mod) mod ImportBySystem mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module") -loadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d ModIface -loadInterface doc mod from - = tryLoadInterface doc mod from `thenRn` \ (ifaces, maybe_err) -> - case maybe_err of - Nothing -> returnRn ifaces - Just err -> failWithRn ifaces (elaborate err) - where - elaborate err = hang (ptext SLIT("failed to load interface for") <+> quotes (ppr mod) <> colon) - 4 err - -tryLoadInterface :: SDoc -> ModuleName -> WhereFrom -> RnM d (ModIface, Maybe Message) - -- Returns (Just err) if an error happened - -- It *doesn't* add an error to the monad, because sometimes it's ok to fail... - -- Specifically, when we read the usage information from an interface file, - -- we try to read the interfaces it mentions. But it's OK to fail; perhaps - -- the module has changed, and that interface is no longer used. +loadInterface :: SDoc -> ModuleName -> WhereFrom -> TcRn m ModIface + -- Returns Nothing if failed + -- If we can't find an interface file, and we are doing ImportForUsage, + -- just fail in the monad, and modify anything else + -- Otherwise, if we can't find an interface file, + -- add an error message to the monad (the first time only) + -- and return emptyIface + -- The "first time only" part is done by modifying the PackageIfaceTable + -- to have an empty entry + -- + -- The ImportForUsage case is because when we read the usage information from + -- an interface file, we try to read the interfaces it mentions. + -- But it's OK to fail; perhaps the module has changed, and that interface + -- is no longer used. - -- tryLoadInterface guarantees to return with iImpModInfo m --> (..., True) + -- tryLoadInterface guarantees to return with eps_mod_info m --> (..., True) -- (If the load fails, we plug in a vanilla placeholder) -tryLoadInterface doc_str mod_name from - = getHomeIfaceTableRn `thenRn` \ hit -> - getModuleRn `thenRn` \ this_mod -> - getIfacesRn `thenRn` \ ifaces@(Ifaces { iPIT = pit }) -> +loadInterface doc_str mod_name from + = getHpt `thenM` \ hpt -> + getModule `thenM` \ this_mod -> + getEps `thenM` \ eps@(EPS { eps_PIT = pit }) -> -- CHECK WHETHER WE HAVE IT ALREADY - case lookupIfaceByModName hit pit mod_name of { + case lookupIfaceByModName hpt pit mod_name of { Just iface | case from of - ImportByUser -> not (mi_boot iface) - ImportByUserSource -> mi_boot iface - ImportBySystem -> True - -> returnRn (iface, Nothing) ; -- Already loaded + ImportByUser src_imp -> src_imp == mi_boot iface + ImportForUsage src_imp -> src_imp == mi_boot iface + ImportBySystem -> True + -> returnM iface ; -- Already loaded -- The not (mi_boot iface) test checks that the already-loaded -- interface isn't a boot iface. This can conceivably happen, -- if the version checking happened to load a boot interface @@ -131,13 +136,13 @@ tryLoadInterface doc_str mod_name from other -> let - mod_map = iImpModInfo ifaces + mod_map = eps_imp_mods eps mod_info = lookupFM mod_map mod_name hi_boot_file = case (from, mod_info) of - (ImportByUser, _) -> False -- Not hi-boot - (ImportByUserSource, _) -> True -- hi-boot + (ImportByUser is_boot, _) -> is_boot + (ImportForUsage is_boot, _) -> is_boot (ImportBySystem, Just (_, is_boot)) -> is_boot (ImportBySystem, Nothing) -> False -- We're importing a module we know absolutely @@ -147,41 +152,50 @@ tryLoadInterface doc_str mod_name from redundant_source_import = case (from, mod_info) of - (ImportByUserSource, Just (_,False)) -> True - other -> False + (ImportByUser True, Just (_,False)) -> True + other -> False in -- Issue a warning for a redundant {- SOURCE -} import -- NB that we arrange to read all the ordinary imports before -- any of the {- SOURCE -} imports - warnCheckRn (not redundant_source_import) - (warnRedundantSourceImport mod_name) `thenRn_` + warnIf redundant_source_import + (warnRedundantSourceImport mod_name) `thenM_` -- Check that we aren't importing ourselves. -- That only happens in Rename.checkOldIface, - -- which doesn't call tryLoadInterface - warnCheckRn - (not (isHomeModule this_mod) || moduleName this_mod /= mod_name) - (warnSelfImport this_mod) `thenRn_` + -- which doesn't call loadInterface + warnIf + (isHomeModule this_mod && moduleName this_mod == mod_name) + (warnSelfImport this_mod) `thenM_` -- READ THE MODULE IN findAndReadIface doc_str mod_name hi_boot_file - `thenRn` \ read_result -> + `thenM` \ read_result -> case read_result of { - Left err -> -- Not found, so add an empty export env to the Ifaces map - -- so that we don't look again - let - fake_mod = mkVanillaModule mod_name - fake_iface = emptyModIface fake_mod - new_ifaces = ifaces { iPIT = extendModuleEnv pit fake_mod fake_iface } - in - setIfacesRn new_ifaces `thenRn_` - returnRn (fake_iface, Just err) ; + Left err + | case from of { ImportForUsage _ -> True ; other -> False } + -> failM -- Fail with no error messages + + | otherwise + -> let -- Not found, so add an empty export env to + -- the EPS map so that we don't look again + fake_mod = mkVanillaModule mod_name + fake_iface = emptyModIface fake_mod + new_eps = eps { eps_PIT = extendModuleEnv pit fake_mod fake_iface } + in + setEps new_eps `thenM_` + addErr (elaborate err) `thenM_` + returnM fake_iface + where + elaborate err = hang (ptext SLIT("Failed to load interface for") <+> + quotes (ppr mod_name) <> colon) 4 err + ; -- Found and parsed! Right (mod, iface) -> - -- LOAD IT INTO Ifaces + -- LOAD IT INTO EPS -- NB: *first* we do loadDecl, so that the provenance of all the locally-defined --- names is done correctly (notably, whether this is an .hi file or .hi-boot file). @@ -196,13 +210,16 @@ tryLoadInterface doc_str mod_name from isHomeModule mod, ppr mod ) - loadDecls mod (iDecls ifaces) (pi_decls iface) `thenRn` \ (decls_vers, new_decls) -> - loadRules mod (iRules ifaces) (pi_rules iface) `thenRn` \ (rule_vers, new_rules) -> - loadInstDecls mod (iInsts ifaces) (pi_insts iface) `thenRn` \ new_insts -> - loadExports (pi_exports iface) `thenRn` \ (export_vers, avails) -> - loadFixDecls mod (pi_fixity iface) `thenRn` \ fix_env -> - loadDeprecs mod (pi_deprecs iface) `thenRn` \ deprec_env -> - let + initRn (InterfaceMode mod) $ + -- Set the module, for use when looking up occurrences + -- of names in interface decls and rules + loadDecls mod (eps_decls eps) (pi_decls iface) `thenM` \ (decls_vers, new_decls) -> + loadRules mod (eps_rules eps) (pi_rules iface) `thenM` \ (rule_vers, new_rules) -> + loadInstDecls mod (eps_insts eps) (pi_insts iface) `thenM` \ new_insts -> + loadExports (pi_exports iface) `thenM` \ (export_vers, avails) -> + loadFixDecls (pi_fixity iface) `thenM` \ fix_env -> + loadDeprecs (pi_deprecs iface) `thenM` \ deprec_env -> + let version = VersionInfo { vers_module = pi_vers iface, vers_exports = export_vers, vers_rules = rule_vers, @@ -211,14 +228,20 @@ tryLoadInterface doc_str mod_name from -- For an explicit user import, add to mod_map info about -- the things the imported module depends on, extracted -- from its usage info; and delete the module itself, which is now in the PIT + usages = pi_usages iface mod_map1 = case from of - ImportByUser -> addModDeps mod is_loaded (pi_usages iface) mod_map - other -> mod_map + ImportByUser _ -> addModDeps mod is_loaded usages mod_map + other -> mod_map mod_map2 = delFromFM mod_map1 mod_name + -- mod_deps is a pruned version of usages that records only what + -- module imported, but nothing about versions. + -- This info is used when demand-linking the dependencies + mod_deps = [ (mod,orph,boot,NothingAtAll) | (mod,orph,boot,_) <- usages] + this_mod_name = moduleName this_mod is_loaded m = m == this_mod_name - || maybeToBool (lookupIfaceByModName hit pit m) + || maybeToBool (lookupIfaceByModName hpt pit m) -- We treat the currently-being-compiled module as 'loaded' because -- even though it isn't yet in the HIT or PIT; otherwise it gets -- put into iImpModInfo, and then spat out into its own interface @@ -232,19 +255,20 @@ tryLoadInterface doc_str mod_name from mi_orphan = has_orphans, mi_boot = hi_boot_file, mi_exports = avails, mi_fixities = fix_env, mi_deprecs = deprec_env, - mi_usages = [], -- Will be filled in later - mi_decls = panic "No mi_decls in PIT", - mi_globals = Nothing + mi_usages = mod_deps, -- Used for demand-loading, + -- not for version info + mi_decls = panic "No mi_decls in PIT", + mi_globals = Nothing } - new_ifaces = ifaces { iPIT = new_pit, - iDecls = new_decls, - iInsts = new_insts, - iRules = new_rules, - iImpModInfo = mod_map2 } + new_eps = eps { eps_PIT = new_pit, + eps_decls = new_decls, + eps_insts = new_insts, + eps_rules = new_rules, + eps_imp_mods = mod_map2 } in - setIfacesRn new_ifaces `thenRn_` - returnRn (mod_iface, Nothing) + setEps new_eps `thenM_` + returnM mod_iface }} ----------------------------------------------------- @@ -284,24 +308,24 @@ addModDeps mod is_loaded new_deps mod_deps -- Loading the export list ----------------------------------------------------- -loadExports :: (Version, [RdrExportItem]) -> RnM d (Version, [(ModuleName,Avails)]) +loadExports :: (Version, [RdrExportItem]) -> TcRn m (Version, [(ModuleName,Avails)]) loadExports (vers, items) - = mapRn loadExport items `thenRn` \ avails_s -> - returnRn (vers, avails_s) + = mappM loadExport items `thenM` \ avails_s -> + returnM (vers, avails_s) -loadExport :: RdrExportItem -> RnM d (ModuleName, Avails) +loadExport :: RdrExportItem -> TcRn m (ModuleName, Avails) loadExport (mod, entities) - = mapRn (load_entity mod) entities `thenRn` \ avails -> - returnRn (mod, avails) + = mappM (load_entity mod) entities `thenM` \ avails -> + returnM (mod, avails) where load_entity mod (Avail occ) - = newGlobalName mod occ `thenRn` \ name -> - returnRn (Avail name) + = newGlobalName mod occ `thenM` \ name -> + returnM (Avail name) load_entity mod (AvailTC occ occs) - = newGlobalName mod occ `thenRn` \ name -> - mapRn (newGlobalName mod) occs `thenRn` \ names -> - returnRn (AvailTC name names) + = newGlobalName mod occ `thenM` \ name -> + mappM (newGlobalName mod) occs `thenM` \ names -> + returnM (AvailTC name names) ----------------------------------------------------- @@ -311,13 +335,14 @@ loadExport (mod, entities) loadDecls :: Module -> DeclsMap -> [(Version, RdrNameTyClDecl)] - -> RnM d (NameEnv Version, DeclsMap) + -> TcRn m (NameEnv Version, DeclsMap) loadDecls mod (decls_map, n_slurped) decls - = foldlRn (loadDecl mod) (emptyNameEnv, decls_map) decls `thenRn` \ (vers, decls_map') -> - returnRn (vers, (decls_map', n_slurped)) + = foldlM (loadDecl mod) (emptyNameEnv, decls_map) decls `thenM` \ (vers, decls_map') -> + returnM (vers, (decls_map', n_slurped)) loadDecl mod (version_map, decls_map) (version, decl) - = getTyClDeclBinders mod decl `thenRn` \ (avail, sys_names) -> + = getTyClDeclBinders mod decl `thenM` \ avail -> + getSysBinders mod decl `thenM` \ sys_names -> let full_avail = case avail of Avail n -> avail @@ -329,36 +354,85 @@ loadDecl mod (version_map, decls_map) (version, decl) new_version_map = extendNameEnv version_map main_name version in - traceRn (text "Loading" <+> ppr full_avail) `thenRn_` - returnRn (new_version_map, new_decls_map) + traceRn (text "Loading" <+> ppr full_avail) `thenM_` + returnM (new_version_map, new_decls_map) + + + +----------------- +getTyClDeclBinders :: Module -> RdrNameTyClDecl -> TcRn m AvailInfo + +getTyClDeclBinders mod (IfaceSig {tcdName = var, tcdLoc = src_loc}) + = newTopBinder mod var src_loc `thenM` \ var_name -> + returnM (Avail var_name) + +getTyClDeclBinders mod tycl_decl + = mapM new (tyClDeclNames tycl_decl) `thenM` \ names@(main_name:_) -> + returnM (AvailTC main_name names) + where + new (nm,loc) = newTopBinder mod nm loc + +-------------------------------- +-- The "system names" are extra implicit names *bound* by the decl. + +getSysBinders :: Module -> TyClDecl RdrName -> TcRn m [Name] +-- Similar to tyClDeclNames, but returns the "implicit" +-- or "system" names of the declaration. And it only works +-- on RdrNames, returning OccNames + +getSysBinders mod (ClassDecl {tcdName = cname, tcdCtxt = cxt, tcdLoc = loc}) + = sequenceM [new_sys_bndr mod n loc | n <- sys_occs] + where + -- C.f. TcClassDcl.tcClassDecl1 + sys_occs = tc_occ : data_occ : dw_occ : sc_sel_occs + cls_occ = rdrNameOcc cname + data_occ = mkClassDataConOcc cls_occ + dw_occ = mkWorkerOcc data_occ + tc_occ = mkClassTyConOcc cls_occ + sc_sel_occs = [mkSuperDictSelOcc n cls_occ | n <- [1..length cxt]] + +getSysBinders mod (TyData {tcdName = tc_name, tcdCons = DataCons cons, + tcdGeneric = Just want_generic, tcdLoc = loc}) + -- The 'Just' is because this is an interface-file decl + -- so it will say whether to derive generic stuff for it or not + = sequenceM ([new_sys_bndr mod n loc | n <- gen_occs] ++ + map con_sys_occ cons) + where + -- c.f. TcTyDecls.tcTyDecl + tc_occ = rdrNameOcc tc_name + gen_occs | want_generic = [mkGenOcc1 tc_occ, mkGenOcc2 tc_occ] + | otherwise = [] + con_sys_occ (ConDecl name _ _ _ loc) + = new_sys_bndr mod (mkWorkerOcc (rdrNameOcc name)) loc + +getSysBinders mod decl = returnM [] + +new_sys_bndr mod occ loc = newTopBinder mod (mkRdrUnqual occ) loc + ----------------------------------------------------- -- Loading fixity decls ----------------------------------------------------- -loadFixDecls mod decls - = mapRn (loadFixDecl mod_name) decls `thenRn` \ to_add -> - returnRn (mkNameEnv to_add) - where - mod_name = moduleName mod +loadFixDecls decls + = mappM loadFixDecl decls `thenM` \ to_add -> + returnM (mkNameEnv to_add) -loadFixDecl mod_name (rdr_name, fixity) - = newGlobalName mod_name (rdrNameOcc rdr_name) `thenRn` \ name -> - returnRn (name, fixity) +loadFixDecl (FixitySig rdr_name fixity loc) + = lookupGlobalOccRn rdr_name `thenM` \ name -> + returnM (name, FixitySig name fixity loc) ----------------------------------------------------- -- Loading instance decls ----------------------------------------------------- -loadInstDecls :: Module - -> IfaceInsts +loadInstDecls :: Module -> IfaceInsts -> [RdrNameInstDecl] - -> RnM d IfaceInsts + -> RnM IfaceInsts loadInstDecls mod (insts, n_slurped) decls - = setModuleRn mod $ - foldlRn (loadInstDecl mod) insts decls `thenRn` \ insts' -> - returnRn (insts', n_slurped) + = foldlM (loadInstDecl mod) insts decls `thenM` \ insts' -> + returnM (insts', n_slurped) loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _) @@ -387,19 +461,19 @@ loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _) -- NOTICE that we rename the type before extracting its free -- variables. The free-variable finder for a renamed HsType -- does the Right Thing for built-in syntax like [] and (,). - initIfaceRnMS mod ( - rnHsType (text "In an interface instance decl") inst_ty - ) `thenRn` \ inst_ty' -> + rnHsType (text "In an interface instance decl") inst_ty `thenM` \ inst_ty' -> let - (tvs,(cls,tys)) = getHsInstHead inst_ty' + (tvs,_,cls,tys) = splitHsInstDeclTy inst_ty' free_tcs = nameSetToList (extractHsTyNames_s tys) `minusList` hsTyVarNames tvs gate_fn vis_fn = vis_fn cls && (null free_tcs || any vis_fn free_tcs) + -- The 'vis_fn' returns True for visible names -- Here is the implementation of HOWEVER above -- (Note that we do let the inst decl in if it mentions -- no tycons at all. Hence the null free_ty_names.) in - returnRn ((gate_fn, (mod, decl)) `consBag` insts) + traceRn ((text "Load instance for" <+> ppr inst_ty') $$ ppr free_tcs) `thenM_` + returnM ((gate_fn, (mod, decl)) `consBag` insts) @@ -407,81 +481,121 @@ loadInstDecl mod insts decl@(InstDecl inst_ty _ _ _ _) -- Loading Rules ----------------------------------------------------- -loadRules :: Module -> IfaceRules +loadRules :: Module + -> IfaceRules -> (Version, [RdrNameRuleDecl]) - -> RnM d (Version, IfaceRules) + -> RnM (Version, IfaceRules) loadRules mod (rule_bag, n_slurped) (version, rules) | null rules || opt_IgnoreIfacePragmas - = returnRn (version, (rule_bag, n_slurped)) + = returnM (version, (rule_bag, n_slurped)) | otherwise - = setModuleRn mod $ - mapRn (loadRule mod) rules `thenRn` \ new_rules -> - returnRn (version, (rule_bag `unionBags` listToBag new_rules, n_slurped)) + = mappM (loadRule mod) rules `thenM` \ new_rules -> + returnM (version, (rule_bag `unionBags` listToBag new_rules, n_slurped)) -loadRule :: Module -> RdrNameRuleDecl -> RnM d (GatedDecl RdrNameRuleDecl) +loadRule :: Module -> RdrNameRuleDecl -> RnM (GatedDecl RdrNameRuleDecl) -- "Gate" the rule simply by whether the rule variable is -- needed. We can refine this later. loadRule mod decl@(IfaceRule _ _ _ var _ _ src_loc) - = lookupIfaceName var `thenRn` \ var_name -> - returnRn (\vis_fn -> vis_fn var_name, (mod, decl)) + = lookupGlobalOccRn var `thenM` \ var_name -> + returnM (\vis_fn -> vis_fn var_name, (mod, decl)) ----------------------------------------------------- -- Loading Deprecations ----------------------------------------------------- -loadDeprecs :: Module -> IfaceDeprecs -> RnM d Deprecations -loadDeprecs m Nothing = returnRn NoDeprecs -loadDeprecs m (Just (Left txt)) = returnRn (DeprecAll txt) -loadDeprecs m (Just (Right prs)) = setModuleRn m $ - foldlRn loadDeprec emptyNameEnv prs `thenRn` \ env -> - returnRn (DeprecSome env) +loadDeprecs :: IfaceDeprecs -> RnM Deprecations +loadDeprecs Nothing = returnM NoDeprecs +loadDeprecs (Just (Left txt)) = returnM (DeprecAll txt) +loadDeprecs (Just (Right prs)) = foldlM loadDeprec emptyNameEnv prs `thenM` \ env -> + returnM (DeprecSome env) loadDeprec deprec_env (n, txt) - = lookupIfaceName n `thenRn` \ name -> - traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenRn_` - returnRn (extendNameEnv deprec_env name (name,txt)) + = lookupGlobalOccRn n `thenM` \ name -> + traceRn (text "Loaded deprecation(s) for" <+> ppr name <> colon <+> ppr txt) `thenM_` + returnM (extendNameEnv deprec_env name (name,txt)) \end{code} -%********************************************************* +%******************************************************** %* * -\subsection{Getting binders out of a declaration} + Load the ParsedIface for the *current* module + into a ModIface; then it can be checked + for up-to-date-ness %* * -%********************************************************* - -@getDeclBinders@ returns the names for a @RdrNameHsDecl@. -It's used for both source code (from @availsFromDecl@) and interface files -(from @loadDecl@). - -It doesn't deal with source-code specific things: @ValD@, @DefD@. They -are handled by the sourc-code specific stuff in @RnNames@. - - *** See "THE NAMING STORY" in HsDecls **** - +%******************************************************** \begin{code} -getTyClDeclBinders - :: Module - -> RdrNameTyClDecl - -> RnM d (AvailInfo, [Name]) -- The [Name] are the system names - ------------------ -getTyClDeclBinders mod (IfaceSig {tcdName = var, tcdLoc = src_loc}) - = newTopBinder mod var src_loc `thenRn` \ var_name -> - returnRn (Avail var_name, []) +loadOldIface :: ParsedIface -> RnM ModIface + +loadOldIface iface + = loadHomeDecls (pi_decls iface) `thenM` \ (decls_vers, new_decls) -> + loadHomeRules (pi_rules iface) `thenM` \ (rule_vers, new_rules) -> + loadHomeInsts (pi_insts iface) `thenM` \ new_insts -> + mappM loadHomeUsage (pi_usages iface) `thenM` \ usages -> + loadExports (pi_exports iface) `thenM` \ (export_vers, avails) -> + loadFixDecls (pi_fixity iface) `thenM` \ fix_env -> + loadDeprecs (pi_deprecs iface) `thenM` \ deprec_env -> + + getModeRn `thenM` \ (InterfaceMode mod) -> + -- Caller sets the module before the call; also needed + -- by the newGlobalName stuff in some of the loadHomeX calls + let + version = VersionInfo { vers_module = pi_vers iface, + vers_exports = export_vers, + vers_rules = rule_vers, + vers_decls = decls_vers } -getTyClDeclBinders mod (CoreDecl {tcdName = var, tcdLoc = src_loc}) - = newTopBinder mod var src_loc `thenRn` \ var_name -> - returnRn (Avail var_name, []) + decls = mkIfaceDecls new_decls new_rules new_insts -getTyClDeclBinders mod tycl_decl - = new_top_bndrs mod (tyClDeclNames tycl_decl) `thenRn` \ names@(main_name:_) -> - new_top_bndrs mod (tyClDeclSysNames tycl_decl) `thenRn` \ sys_names -> - returnRn (AvailTC main_name names, sys_names) + mod_iface = ModIface { mi_module = mod, mi_package = pi_pkg iface, + mi_version = version, + mi_exports = avails, mi_usages = usages, + mi_boot = False, mi_orphan = pi_orphan iface, + mi_fixities = fix_env, mi_deprecs = deprec_env, + mi_decls = decls, + mi_globals = Nothing + } + in + returnM mod_iface +\end{code} ------------------ -new_top_bndrs mod names_w_locs - = sequenceRn [newTopBinder mod name loc | (name,loc) <- names_w_locs] +\begin{code} +loadHomeDecls :: [(Version, RdrNameTyClDecl)] + -> RnM (NameEnv Version, [RenamedTyClDecl]) +loadHomeDecls decls = foldlM loadHomeDecl (emptyNameEnv, []) decls + +loadHomeDecl :: (NameEnv Version, [RenamedTyClDecl]) + -> (Version, RdrNameTyClDecl) + -> RnM (NameEnv Version, [RenamedTyClDecl]) +loadHomeDecl (version_map, decls) (version, decl) + = rnTyClDecl decl `thenM` \ decl' -> + returnM (extendNameEnv version_map (tyClDeclName decl') version, decl':decls) + +------------------ +loadHomeRules :: (Version, [RdrNameRuleDecl]) + -> RnM (Version, [RenamedRuleDecl]) +loadHomeRules (version, rules) + = mappM rnIfaceRuleDecl rules `thenM` \ rules' -> + returnM (version, rules') + +------------------ +loadHomeInsts :: [RdrNameInstDecl] + -> RnM [RenamedInstDecl] +loadHomeInsts insts = mappM rnInstDecl insts + +------------------ +loadHomeUsage :: ImportVersion OccName + -> TcRn m (ImportVersion Name) +loadHomeUsage (mod_name, orphans, is_boot, whats_imported) + = rn_imps whats_imported `thenM` \ whats_imported' -> + returnM (mod_name, orphans, is_boot, whats_imported') + where + rn_imps NothingAtAll = returnM NothingAtAll + rn_imps (Everything v) = returnM (Everything v) + rn_imps (Specifically mv ev items rv) = mappM rn_imp items `thenM` \ items' -> + returnM (Specifically mv ev items' rv) + rn_imp (occ,vers) = newGlobalName mod_name occ `thenM` \ name -> + returnM (name,vers) \end{code} @@ -495,50 +609,39 @@ new_top_bndrs mod names_w_locs findAndReadIface :: SDoc -> ModuleName -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file - -> RnM d (Either Message (Module, ParsedIface)) + -> TcRn m (Either Message (Module, ParsedIface)) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed + -- It *doesn't* add an error to the monad, because + -- sometimes it's ok to fail... see notes with loadInterface + findAndReadIface doc_str mod_name hi_boot_file - = traceRn trace_msg `thenRn_` + = traceRn trace_msg `thenM_` -- Check for GHC.Prim, and return its static interface if mod_name == gHC_PRIM_Name - then returnRn (Right (gHC_PRIM, ghcPrimIface)) + then returnM (Right (gHC_PRIM, ghcPrimIface)) else - -- In interactive or --make mode, we are *not allowed* to demand-load - -- a home package .hi file. So don't even look for them. - -- This helps in the case where you are sitting in eg. ghc/lib/std - -- and start up GHCi - it won't complain that all the modules it tries - -- to load are found in the home location. - ioToRnM_no_fail (readIORef v_GhcMode) `thenRn` \ mode -> - let home_allowed = hi_boot_file || not (isCompManagerMode mode) - in - - ioToRnM (if home_allowed - then findModule mod_name - else findPackageModule mod_name) `thenRn` \ maybe_found -> + ioToTcRn (findHiFile mod_name hi_boot_file) `thenM` \ maybe_found -> case maybe_found of + Nothing -> + traceRn (ptext SLIT("...not found")) `thenM_` + returnM (Left (noIfaceErr mod_name hi_boot_file)) - Right (Just (wanted_mod,locn)) - -> mkHiPath hi_boot_file locn `thenRn` \ file -> - readIface file `thenRn` \ read_result -> - case read_result of - Left bad -> returnRn (Left bad) - Right iface -> -- check that the module names agree - let read_mod_name = pi_mod iface - wanted_mod_name = moduleName wanted_mod - in - checkRn - (wanted_mod_name == read_mod_name) - (hiModuleNameMismatchWarn wanted_mod_name read_mod_name) - `thenRn_` - returnRn (Right (wanted_mod, iface)) - -- Can't find it - other -> traceRn (ptext SLIT("...not found")) `thenRn_` - returnRn (Left (noIfaceErr mod_name hi_boot_file)) + Just (wanted_mod, file_path) -> + traceRn (ptext SLIT("readIFace") <+> text file_path) `thenM_` + + readIface wanted_mod file_path hi_boot_file `thenM` \ read_result -> + -- Catch exceptions here + + case read_result of + Left exn -> returnM (Left (badIfaceFile file_path + (text (showException exn)))) + + Right iface -> returnM (Right (wanted_mod, iface)) where trace_msg = sep [hsep [ptext SLIT("Reading"), @@ -547,67 +650,105 @@ findAndReadIface doc_str mod_name hi_boot_file ppr mod_name <> semi], nest 4 (ptext SLIT("reason:") <+> doc_str)] -mkHiPath hi_boot_file locn - | hi_boot_file = - ioToRnM_no_fail (doesFileExist hi_boot_ver_path) `thenRn` \ b -> - if b then returnRn hi_boot_ver_path - else returnRn hi_boot_path - | otherwise = returnRn hi_path - where hi_path = ml_hi_file locn - (hi_base, _hi_suf) = splitFilename hi_path - hi_boot_path = hi_base ++ ".hi-boot" - hi_boot_ver_path = hi_base ++ ".hi-boot-" ++ cHscIfaceFileVersion +findHiFile :: ModuleName -> IsBootInterface -> IO (Maybe (Module, FilePath)) +findHiFile mod_name hi_boot_file + = do { + -- In interactive or --make mode, we are *not allowed* to demand-load + -- a home package .hi file. So don't even look for them. + -- This helps in the case where you are sitting in eg. ghc/lib/std + -- and start up GHCi - it won't complain that all the modules it tries + -- to load are found in the home location. + ghci_mode <- readIORef v_GhcMode ; + let { home_allowed = hi_boot_file || + not (isCompManagerMode ghci_mode) } ; + maybe_found <- if home_allowed + then findModule mod_name + else findPackageModule mod_name ; + + case maybe_found of { + Nothing -> return Nothing ; + + Just (mod,loc) -> do { + + -- Return the path to M.hi, M.hi-boot, or M.hi-boot-n as appropriate + let { hi_path = ml_hi_file loc ; + (hi_base, _hi_suf) = splitFilename hi_path ; + hi_boot_path = hi_base ++ ".hi-boot" ; + hi_boot_ver_path = hi_base ++ ".hi-boot-" ++ cHscIfaceFileVersion } ; + + if not hi_boot_file then + return (Just (mod, hi_path)) + else do { + hi_ver_exists <- doesFileExist hi_boot_ver_path ; + if hi_ver_exists then return (Just (mod, hi_boot_ver_path)) + else return (Just (mod, hi_boot_path)) + }}}} \end{code} @readIface@ tries just the one file. \begin{code} -readIface :: String -> RnM d (Either Message ParsedIface) +readIface :: Module -> String -> IsBootInterface -> TcRn m (Either IOError ParsedIface) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed -readIface file_path - = --ioToRnM (putStrLn ("reading iface " ++ file_path)) `thenRn_` - traceRn (ptext SLIT("readIFace") <+> text file_path) `thenRn_` - - let hi_boot_ver = "hi-boot-" ++ cHscIfaceFileVersion in - if ".hi-boot" `isSuffixOf` file_path - || hi_boot_ver `isSuffixOf` file_path then - - ioToRnM (hGetStringBuffer file_path) `thenRn` \ read_result -> - case read_result of { - Left io_error -> bale_out (text (show io_error)); - Right contents -> - - case parseIface contents (mkPState loc exts) of { - POk _ iface -> returnRn (Right iface); - PFailed err -> bale_out err - }} - - else - ioToRnM_no_fail (myTry (Binary.getBinFileWithDict file_path)) - `thenRn` \ either_iface -> - - case either_iface of - Right iface -> returnRn (Right iface) - Left (DynException d) | Just e <- fromDynamic d - -> bale_out (text (show (e :: GhcException))) - - Left err -> bale_out (text (show err)) - where +readIface mod file_path is_hi_boot_file + = ioToTcRn_no_fail (read_iface mod file_path is_hi_boot_file) + +read_iface mod file_path is_hi_boot_file + | is_hi_boot_file -- Read ascii + = do { buffer <- hGetStringBuffer file_path ; + case parseIface buffer (mkPState loc exts) of + POk _ iface | wanted_mod_name == actual_mod_name + -> return iface + | otherwise + -> throwDyn (ProgramError (showSDoc err)) + -- 'showSDoc' is a bit yukky + where + wanted_mod_name = moduleName mod + actual_mod_name = pi_mod iface + err = hiModuleNameMismatchWarn wanted_mod_name actual_mod_name + + PFailed err -> throwDyn (ProgramError (showSDoc err)) + } + + | otherwise -- Read binary + = readBinIface file_path + + where exts = ExtFlags {glasgowExtsEF = True, ffiEF = True, withEF = True, parrEF = True} loc = mkSrcLoc (mkFastString file_path) 1 +\end{code} - bale_out err = returnRn (Left (badIfaceFile file_path err)) -#if __GLASGOW_HASKELL__ < 501 -myTry = Exception.tryAllIO -#else -myTry = Exception.try -#endif +%********************************************************* +%* * + Wired-in interface for GHC.Prim +%* * +%********************************************************* + +\begin{code} +ghcPrimIface :: ParsedIface +ghcPrimIface = ParsedIface { + pi_mod = gHC_PRIM_Name, + pi_pkg = preludePackage, + pi_vers = 1, + pi_orphan = False, + pi_usages = [], + pi_exports = (1, [(gHC_PRIM_Name, ghcPrimExports)]), + pi_decls = [(1,cCallableClassDecl), + (1,cReturnableClassDecl), + (1,assertDecl)], + pi_fixity = [FixitySig (nameRdrName (idName seqId)) + (Fixity 0 InfixR) noSrcLoc], + -- seq is infixr 0 + pi_insts = [], + pi_rules = (1,[]), + pi_deprecs = Nothing + } \end{code} %********************************************************* diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 6b6d949d79..83a098a64d 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -11,39 +11,40 @@ module RnHsSyn where import HsSyn import HsCore import Class ( FunDep, DefMeth(..) ) -import TyCon ( visibleDataCons ) +import TyCon ( visibleDataCons, tyConName ) import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon ) import Name ( Name, getName, isTyVarName ) import NameSet -import BasicTypes ( Boxity ) +import BasicTypes ( Boxity, FixitySig ) import Outputable \end{code} \begin{code} -type RenamedHsDecl = HsDecl Name RenamedPat -type RenamedArithSeqInfo = ArithSeqInfo Name RenamedPat +type RenamedHsDecl = HsDecl Name +type RenamedArithSeqInfo = ArithSeqInfo Name type RenamedClassOpSig = Sig Name type RenamedConDecl = ConDecl Name type RenamedContext = HsContext Name -type RenamedRuleDecl = RuleDecl Name RenamedPat -type RenamedTyClDecl = TyClDecl Name RenamedPat +type RenamedRuleDecl = RuleDecl Name +type RenamedTyClDecl = TyClDecl Name type RenamedDefaultDecl = DefaultDecl Name type RenamedForeignDecl = ForeignDecl Name -type RenamedGRHS = GRHS Name RenamedPat -type RenamedGRHSs = GRHSs Name RenamedPat -type RenamedHsBinds = HsBinds Name RenamedPat -type RenamedHsExpr = HsExpr Name RenamedPat -type RenamedInstDecl = InstDecl Name RenamedPat +type RenamedCoreDecl = CoreDecl Name +type RenamedGRHS = GRHS Name +type RenamedGRHSs = GRHSs Name +type RenamedHsBinds = HsBinds Name +type RenamedHsExpr = HsExpr Name +type RenamedInstDecl = InstDecl Name type RenamedMatchContext = HsMatchContext Name -type RenamedMatch = Match Name RenamedPat -type RenamedMonoBinds = MonoBinds Name RenamedPat +type RenamedMatch = Match Name +type RenamedMonoBinds = MonoBinds Name type RenamedPat = InPat Name type RenamedHsType = HsType Name type RenamedHsPred = HsPred Name -type RenamedRecordBinds = HsRecordBinds Name RenamedPat +type RenamedRecordBinds = HsRecordBinds Name type RenamedSig = Sig Name -type RenamedStmt = Stmt Name RenamedPat +type RenamedStmt = Stmt Name type RenamedFixitySig = FixitySig Name type RenamedDeprecation = DeprecDecl Name \end{code} @@ -125,6 +126,13 @@ In all cases this is set up for interface-file declarations: *** See "THE NAMING STORY" in HsDecls **** \begin{code} +---------------- +impDeclFVs :: RenamedHsDecl -> NameSet + -- Just the ones that come from imports +impDeclFVs (InstD d) = instDeclFVs d +impDeclFVs (TyClD d) = tyClDeclFVs d + +---------------- tyClDeclFVs :: RenamedTyClDecl -> NameSet tyClDeclFVs (ForeignType {}) = emptyFVs @@ -158,9 +166,6 @@ tyClDeclFVs (ClassDecl {tcdCtxt = context, tcdTyVars = tyvars, tcdFDs = fds, Just _ -> emptyFVs -- Source code, so the default methods -- are *bound* not *free* -tyClDeclFVs (CoreDecl {tcdType = ty, tcdRhs = rhs}) - = extractHsTyNames ty `plusFV` ufExprFVs rhs - ---------------- hsSigsFVs sigs = plusFVs (map hsSigFVs sigs) @@ -183,12 +188,12 @@ ruleDeclFVs (IfaceRule _ _ vars _ args rhs _) ufExprFVs rhs `plusFV` plusFVs (map ufExprFVs args) ---------------- -conDeclFVs (ConDecl _ _ tyvars context details _) +conDeclFVs (ConDecl _ tyvars context details _) = delFVs (map hsTyVarName tyvars) $ extractHsCtxtTyNames context `plusFV` conDetailsFVs details -conDetailsFVs (VanillaCon btys) = plusFVs (map bangTyFVs btys) +conDetailsFVs (PrefixCon btys) = plusFVs (map bangTyFVs btys) conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2 conDetailsFVs (RecCon flds) = plusFVs [bangTyFVs bty | (_, bty) <- flds] @@ -228,9 +233,11 @@ ufConFVs other = emptyFVs ufNoteFVs (UfCoerce ty) = extractHsTyNames ty ufNoteFVs note = emptyFVs -hsTupConFVs (HsTupCon n _ _) = unitFV n +hsTupConFVs (HsTupCon bx n) = unitFV (tyConName (tupleTyCon bx n)) + -- Always return the TyCon; that'll suck in the data con \end{code} + %************************************************************************ %* * \subsection{A few functions on generic defintions @@ -245,7 +252,7 @@ maybeGenericMatch :: RenamedMatch -> Maybe (RenamedHsType, RenamedMatch) -- Tells whether a Match is for a generic definition -- and extract the type from a generic match and put it at the front -maybeGenericMatch (Match (TypePatIn ty : pats) sig_ty grhss) +maybeGenericMatch (Match (TypePat ty : pats) sig_ty grhss) = Just (ty, Match pats sig_ty grhss) maybeGenericMatch other_match = Nothing diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index c591bb3a17..9e7c53ad8d 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -1,17 +1,12 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[RnIfaces]{Cacheing and Renaming of Interfaces} +section +\%[RnIfaces]{Cacheing and Renaming of Interfaces} \begin{code} module RnIfaces - ( - recordLocalSlurps, - mkImportInfo, - - slurpImpDecls, closeDecls, - - RecompileRequired, outOfDate, upToDate, recompileRequired + ( slurpImpDecls, importSupportingDecls, + RecompileRequired, outOfDate, upToDate, checkVersions ) where @@ -19,236 +14,39 @@ where import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_NoPruneDecls ) import HscTypes -import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), ConDetails(..), +import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), HsConDetails(..), InstDecl(..), HsType(..), hsTyVarNames, getBangType ) -import HsImpExp ( ImportDecl(..) ) import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl ) import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, extractHsTyNames, extractHsCtxtTyNames, - tyClDeclFVs, ruleDeclFVs, instDeclFVs - ) -import RnHiFiles ( tryLoadInterface, loadHomeInterface, - loadOrphanModules + tyClDeclFVs, ruleDeclFVs, impDeclFVs ) +import RnHiFiles ( loadInterface, loadHomeInterface, loadOrphanModules ) import RnSource ( rnTyClDecl, rnInstDecl, rnIfaceRuleDecl ) -import RnEnv -import RnMonad +import TcEnv ( getInGlobalScope, tcLookupGlobal_maybe ) +import TcRnMonad import Id ( idType, idName, globalIdDetails ) import IdInfo ( GlobalIdDetails(..) ) -import TcType ( namesOfType ) +import TcType ( tyClsNamesOfType, classNamesOfTheta ) import FieldLabel ( fieldLabelTyCon ) import DataCon ( dataConTyCon ) import TyCon ( visibleDataCons, isSynTyCon, getSynTyConDefn, tyConClass_maybe, tyConName ) -import Class ( className ) -import Name ( Name {-instance NamedThing-}, nameOccName, - nameModule, isInternalName, NamedThing(..) +import Class ( className, classSCTheta ) +import Name ( Name {-instance NamedThing-}, isWiredInName, isInternalName, nameModule, NamedThing(..) ) -import NameEnv ( elemNameEnv, delFromNameEnv, lookupNameEnv ) +import NameEnv ( delFromNameEnv, lookupNameEnv ) import NameSet -import Module ( Module, ModuleEnv, - moduleName, isHomeModule, - ModuleName, WhereFrom(..), - emptyModuleEnv, - extendModuleEnv_C, foldModuleEnv, lookupModuleEnv, - elemModuleSet, extendModuleSet - ) -import PrelInfo ( wiredInThingEnv, hasKey, fractionalClassKey, numClassKey, +import Module ( Module, isHomeModule, extendModuleSet ) +import PrelInfo ( hasKey, fractionalClassKey, numClassKey, integerTyConName, doubleTyConName ) -import Maybe ( isJust ) import FiniteMap import Outputable import Bag -import Util ( sortLt, seqList ) +import Maybe( fromJust ) \end{code} -%********************************************************* -%* * -\subsection{Keeping track of what we've slurped, and version numbers} -%* * -%********************************************************* - -mkImportInfo 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 ; -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} -mkImportInfo :: ModuleName -- Name of this module - -> [ImportDecl n] -- The import decls - -> RnMG [ImportVersion Name] - -mkImportInfo this_mod imports - = getIfacesRn `thenRn` \ ifaces -> - getHomeIfaceTableRn `thenRn` \ hit -> - let - (imp_pkg_mods, imp_home_names) = iVSlurp ifaces - pit = iPIT ifaces - - import_all_mods :: [ModuleName] - -- Modules where we imported all the names - -- (apart from hiding some, perhaps) - import_all_mods = [ m | ImportDecl m _ _ _ imp_list _ <- imports, - import_all imp_list ] - where - import_all (Just (False, _)) = False -- Imports are spec'd explicitly - import_all other = True -- Everything is imported - - -- 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 imp_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 import_info0 hit - 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 opened, 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 (iImpModInfo ifaces) ] - - - 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` imp_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. - seqList import_info (returnRn import_info) -\end{code} - %********************************************************* %* * \subsection{Slurping declarations} @@ -257,27 +55,31 @@ mkImportInfo this_mod imports \begin{code} ------------------------------------------------------- +slurpImpDecls :: FreeVars -> TcRn m [RenamedHsDecl] slurpImpDecls source_fvs - = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_` + = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenM_` - -- The current slurped-set records all local things - slurpSourceRefs source_fvs `thenRn` \ (decls, needed) -> + -- Slurp in things which might be 'gates' for instance + -- declarations, plus the instance declarations themselves + slurpSourceRefs source_fvs `thenM` \ (gate_decls, bndrs) -> -- Then get everything else - closeDecls decls needed + let + needed = foldr (plusFV . impDeclFVs) emptyFVs gate_decls + in + import_supporting_decls (gate_decls, bndrs) needed ------------------------------------------------------- slurpSourceRefs :: FreeVars -- Variables referenced in source - -> RnMG ([RenamedHsDecl], - FreeVars) -- Un-satisfied needs --- The declaration (and hence home module) of each gate has --- already been loaded + -> TcRn m ([RenamedHsDecl], -- Needed declarations + NameSet) -- Names bound by those declarations +-- Slurp imported declarations needed directly by the source code; +-- and some of the ones they need. The goal is to find all the 'gates' +-- for instance declarations. slurpSourceRefs source_fvs - = go_outer [] -- Accumulating decls - emptyFVs -- Unsatisfied needs - emptyFVs -- Accumulating gates + = go_outer [] emptyFVs -- Accumulating decls (nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet where -- The outer loop repeatedly slurps the decls for the current gates @@ -294,137 +96,203 @@ slurpSourceRefs source_fvs -- so that its superclasses are discovered. The point is that Wib is a gate too. -- We do this for tycons too, so that we look through type synonyms. - go_outer decls fvs all_gates [] - = returnRn (decls, fvs) - - go_outer decls fvs all_gates refs -- refs are not necessarily slurped yet - = traceRn (text "go_outer" <+> ppr refs) `thenRn_` - foldlRn go_inner (decls, fvs, emptyFVs) refs `thenRn` \ (decls1, fvs1, gates1) -> - getImportedInstDecls (all_gates `plusFV` gates1) `thenRn` \ inst_decls -> - rnIfaceInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) -> - go_outer decls2 fvs2 (all_gates `plusFV` gates2) - (nameSetToList (gates2 `minusNameSet` all_gates)) - -- Knock out the all_gates because even if we don't slurp any new - -- decls we can get some apparently-new gates from wired-in names - -- and we get an infinite loop - - go_inner (decls, fvs, gates) wanted_name - = importDecl wanted_name `thenRn` \ import_result -> + go_outer decls bndrs [] = returnM (decls, bndrs) + + go_outer decls bndrs refs -- 'refs' are not necessarily slurped yet + = traceRn (text "go_outer" <+> ppr refs) `thenM_` + foldlM go_inner (decls, bndrs, emptyFVs) refs `thenM` \ (decls1, bndrs1, gates1) -> + getImportedInstDecls gates1 `thenM` \ (inst_decls, new_gates) -> + rnIfaceDecls rnInstDecl inst_decls `thenM` \ inst_decls' -> + go_outer (map InstD inst_decls' ++ decls1) + bndrs1 + (nameSetToList (new_gates `plusFV` plusFVs (map getInstDeclGates inst_decls'))) + -- NB: we go round again to fetch the decls for any gates of any decls + -- we have loaded. For example, if we mention + -- print :: Show a => a -> String + -- then we must load the decl for Show before stopping, to ensure + -- that instances from its home module are available + + go_inner (decls, bndrs, gates) wanted_name + = importDecl bndrs wanted_name `thenM` \ import_result -> case import_result of - AlreadySlurped -> returnRn (decls, fvs, gates) - InTypeEnv ty_thing -> returnRn (decls, fvs, gates `plusFV` getWiredInGates ty_thing) - - HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) -> - returnRn (TyClD new_decl : decls, - fvs1 `plusFV` fvs, - gates `plusFV` getGates source_fvs new_decl) + AlreadySlurped -> returnM (decls, bndrs, gates) + + InTypeEnv ty_thing + -> returnM (decls, + bndrs `addOneFV` wanted_name, -- Avoid repeated calls to getWiredInGates + gates `plusFV` getWiredInGates ty_thing) + + HereItIs decl new_bndrs + -> rnIfaceDecl rnTyClDecl decl `thenM` \ new_decl -> + returnM (TyClD new_decl : decls, + bndrs `plusFV` new_bndrs, + gates `plusFV` getGates source_fvs new_decl) \end{code} - \begin{code} ------------------------------------------------------- --- closeDecls keeps going until the free-var set is empty -closeDecls decls needed - = slurpIfaceDecls decls needed `thenRn` \ decls1 -> - getImportedRules `thenRn` \ rule_decls -> +-- import_supporting_decls keeps going until the free-var set is empty +importSupportingDecls needed + = import_supporting_decls ([], emptyNameSet) needed + +import_supporting_decls + :: ([RenamedHsDecl], NameSet) -- Some imported decls, with their binders + -> FreeVars -- Remaining un-slurped names + -> TcRn m [RenamedHsDecl] +import_supporting_decls decls needed + = slurpIfaceDecls decls needed `thenM` \ (decls1, bndrs1) -> + getImportedRules bndrs1 `thenM` \ rule_decls -> case rule_decls of - [] -> returnRn decls1 -- No new rules, so we are done - other -> rnIfaceDecls rnIfaceRuleDecl rule_decls `thenRn` \ rule_decls' -> + [] -> returnM decls1 -- No new rules, so we are done + other -> rnIfaceDecls rnIfaceRuleDecl rule_decls `thenM` \ rule_decls' -> let - rule_fvs = plusFVs (map ruleDeclFVs rule_decls') + rule_fvs = plusFVs (map ruleDeclFVs rule_decls') + decls2 = decls1 ++ map RuleD rule_decls' in traceRn (text "closeRules" <+> ppr rule_decls' $$ - fsep (map ppr (nameSetToList rule_fvs))) `thenRn_` - closeDecls (map RuleD rule_decls' ++ decls1) rule_fvs - + fsep (map ppr (nameSetToList rule_fvs))) `thenM_` + import_supporting_decls (decls2, bndrs1) rule_fvs + ------------------------------------------------------- -- Augment decls with any decls needed by needed, -- and so on transitively -slurpIfaceDecls :: [RenamedHsDecl] -> FreeVars -> RnMG [RenamedHsDecl] -slurpIfaceDecls decls needed - = slurp decls (nameSetToList needed) +slurpIfaceDecls :: ([RenamedHsDecl], NameSet) -- Already slurped + -> FreeVars -- Still needed + -> TcRn m ([RenamedHsDecl], NameSet) +slurpIfaceDecls (decls, bndrs) needed + = slurp decls bndrs (nameSetToList needed) where - slurp decls [] = returnRn decls - slurp decls (n:ns) = slurp_one decls n `thenRn` \ decls1 -> - slurp decls1 ns - - slurp_one decls wanted_name - = importDecl wanted_name `thenRn` \ import_result -> + slurp decls bndrs [] = returnM (decls, bndrs) + slurp decls bndrs (n:ns) + = importDecl bndrs n `thenM` \ import_result -> case import_result of - HereItIs decl -> -- Found a declaration... rename it - -- and get the things it needs - rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs) -> - slurp (TyClD new_decl : decls) (nameSetToList fvs) + HereItIs decl new_bndrs -- Found a declaration... rename it + -> rnIfaceDecl rnTyClDecl decl `thenM` \ new_decl -> + slurp (TyClD new_decl : decls) + (bndrs `plusFV` new_bndrs) + (nameSetToList (tyClDeclFVs new_decl) ++ ns) other -> -- No declaration... (wired in thing, or deferred, - -- or already slurped) - returnRn decls - + -- or already slurped) + slurp decls (bndrs `addOneFV` n) ns ------------------------------------------------------- -rnIfaceDecls rn decls = mapRn (rnIfaceDecl rn) decls -rnIfaceDecl rn (mod, decl) = initIfaceRnMS mod (rn decl) +rnIfaceDecls rn decls = mappM (rnIfaceDecl rn) decls +rnIfaceDecl rn (mod, decl) = initRn (InterfaceMode mod) (rn decl) +\end{code} -rnIfaceInstDecls decls fvs gates inst_decls - = rnIfaceDecls rnInstDecl inst_decls `thenRn` \ inst_decls' -> - returnRn (map InstD inst_decls' ++ decls, - fvs `plusFV` plusFVs (map instDeclFVs inst_decls'), - gates `plusFV` plusFVs (map getInstDeclGates inst_decls')) -rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl) `thenRn` \ decl' -> - returnRn (decl', tyClDeclFVs decl') +\begin{code} + -- Tiresomely, we must get the "main" name for the + -- thing, because that's what VSlurp contains, and what + -- is recorded in the usage information +get_main_name (AClass cl) = className cl +get_main_name (ATyCon tc) + | Just clas <- tyConClass_maybe tc = get_main_name (AClass clas) + | otherwise = tyConName tc +get_main_name (AnId id) + = case globalIdDetails id of + DataConId dc -> get_main_name (ATyCon (dataConTyCon dc)) + DataConWrapId dc -> get_main_name (ATyCon (dataConTyCon dc)) + RecordSelId lbl -> get_main_name (ATyCon (fieldLabelTyCon lbl)) + other -> idName id + + +recordUsage :: Name -> TcRn m () +-- Record that the Name has been used, for +-- later generation of usage info in the interface file +recordUsage name = updUsages (upd_usg name) + +upd_usg name usages + | isHomeModule mod = usages { usg_home = addOneToNameSet (usg_home usages) name } + | otherwise = usages { usg_ext = extendModuleSet (usg_ext usages) mod } + where + mod = nameModule name \end{code} +%********************************************************* +%* * +\subsection{Getting in a declaration} +%* * +%********************************************************* + \begin{code} -recordDeclSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped), - iSlurp = slurped_names, - iVSlurp = vslurp }) - avail - = ASSERT2( not (isInternalName (availName avail)), ppr avail ) - ifaces { iDecls = (new_decls_map, n_slurped+1), - iSlurp = new_slurped_names, - iVSlurp = updateVSlurp vslurp (availName avail) } - where - new_decls_map = foldl delFromNameEnv decls_map (availNames avail) - new_slurped_names = addAvailToNameSet slurped_names avail +importDecl :: NameSet -> Name -> TcRn m ImportDeclResult +data ImportDeclResult + = AlreadySlurped + | InTypeEnv TyThing + | HereItIs (Module, RdrNameTyClDecl) NameSet + -- The NameSet is the bunch of names bound by this decl + +importDecl already_slurped name + = -- STEP 0: Check if it's from this module + -- Doing this catches a common case quickly + getModule `thenM` \ this_mod -> + if isInternalName name || nameModule name == this_mod then + -- Variables defined on the GHCi command line (e.g. let x = 3) + -- are Internal names (which don't have a Module) + returnM AlreadySlurped + else --- recordTypeEnvSlurp is used when we slurp something that's --- already in the type environment, that was not slurped in an earlier compilation. --- We record it in the iVSlurp set, because that's used to --- generate usage information + -- STEP 1: Check if we've slurped it in while compiling this module + if name `elemNameSet` already_slurped then + returnM AlreadySlurped + else -recordTypeEnvSlurp ifaces ty_thing - = ifaces { iVSlurp = updateVSlurp (iVSlurp ifaces) (get_main_name ty_thing) } - where - -- Tiresomely, we must get the "main" name for the - -- thing, because that's what VSlurp contains, and what - -- is recorded in the usage information - get_main_name (AClass cl) = className cl - get_main_name (ATyCon tc) - | Just clas <- tyConClass_maybe tc = get_main_name (AClass clas) - | otherwise = tyConName tc - get_main_name (AnId id) - = case globalIdDetails id of - DataConId dc -> get_main_name (ATyCon (dataConTyCon dc)) - DataConWrapId dc -> get_main_name (ATyCon (dataConTyCon dc)) - RecordSelId lbl -> get_main_name (ATyCon (fieldLabelTyCon lbl)) - other -> idName id - -updateVSlurp (imp_mods, imp_names) main_name - | isHomeModule mod = (imp_mods, addOneToNameSet imp_names main_name) - | otherwise = (extendModuleSet imp_mods mod, imp_names) + -- STEP 2: Check if it's already in the type environment + tcLookupGlobal_maybe name `thenM` \ maybe_thing -> + case maybe_thing of { + + Just ty_thing + | isWiredInName name + -> -- When we find a wired-in name we must load its home + -- module so that we find any instance decls lurking therein + loadHomeInterface wi_doc name `thenM_` + returnM (InTypeEnv ty_thing) + + | otherwise + -> -- We have slurp something that's already in the type environment, + -- that was not slurped in an earlier compilation. + -- Must still record it in the Usages info, because that's used to + -- generate usage information + + traceRn (text "not wired in" <+> ppr name) `thenM_` + recordUsage (get_main_name ty_thing) `thenM_` + returnM (InTypeEnv ty_thing) ; + + Nothing -> + + -- STEP 4: OK, we have to slurp it in from an interface file + -- First load the interface file + traceRn nd_doc `thenM_` + loadHomeInterface nd_doc name `thenM_` + + -- STEP 4: Get the declaration out + getEps `thenM` \ eps -> + let + (decls_map, n_slurped) = eps_decls eps + in + case lookupNameEnv decls_map name of + Just (avail,_,decl) -> setEps eps' `thenM_` + recordUsage (availName avail) `thenM_` + returnM (HereItIs decl (mkFVs avail_names)) + where + avail_names = availNames avail + new_decls_map = foldl delFromNameEnv decls_map avail_names + eps' = eps { eps_decls = (new_decls_map, n_slurped+1) } + + Nothing -> addErr (getDeclErr name) `thenM_` + returnM AlreadySlurped + } where - mod = nameModule main_name - -recordLocalSlurps new_names - = getIfacesRn `thenRn` \ ifaces -> - setIfacesRn (ifaces { iSlurp = iSlurp ifaces `unionNameSets` new_names }) -\end{code} + wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name + nd_doc = ptext SLIT("need decl for") <+> ppr name +\end{code} %********************************************************* @@ -449,7 +317,11 @@ Each has its set of 'gates': {C, T1, T2} in the above example. More precisely, the gates of a module are the types and classes that are mentioned in: - a) the source code + a) the source code [Note: in fact these don't seem + to be treated as gates, perhaps + because no imported instance decl + can mention them; mutter mutter + recursive modules.] b) the type of an Id that's mentioned in the source code [includes constructors and selectors] c) the RHS of a type synonym that is a gate @@ -458,28 +330,34 @@ that are mentioned in: We slurp in an instance decl from the gated instance pool iff - all its gates are either in the gates of the module, - or are a previously-loaded tycon or class. + all its gates are either in the gates of the module, + or the gates of a previously-loaded module The latter constraint is because there might have been an instance decl slurped in during an earlier compilation, like this: instance Foo a => Baz (Maybe a) where ... -In the module being compiled we might need (Baz (Maybe T)), where T -is defined in this module, and hence we need (Foo T). So @Foo@ becomes -a gate. But there's no way to 'see' that. More generally, types -might be involved as well: +In the module being compiled we might need (Baz (Maybe T)), where T is +defined in this module, and hence we need the instance for (Foo T). +So @Foo@ becomes a gate. But there's no way to 'see' that. More +generally, types might be involved as well: - instance Foo2 T a => Baz2 a where ... + instance Foo2 S a => Baz2 a where ... -Now we must treat T as a gate too, as well as Foo. So the solution +Now we must treat S as a gate too, as well as Foo2. So the solution we adopt is: - we simply treat all previously-loaded - tycons and classes as gates. + we simply treat the gates of all previously-loaded + modules as gates of this one + +So the gates are remembered across invocations of the renamer in the +PersistentRenamerState. This gloss mainly affects ghc --make and ghc +--interactive. -This gloss only affects ghc --make and ghc --interactive. +(We used to use the persistent type environment for this purpose, +but it has too much. For a start, it contains all tuple types, +because they are in the wired-in type env!) Consructors and class operations @@ -515,7 +393,6 @@ getGates source_fvs decl get_gates is_used (ForeignType {tcdName = tycon}) = unitNameSet tycon get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty -get_gates is_used (CoreDecl {tcdType = ty}) = extractHsTyNames ty get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs}) = (super_cls_and_sigs `addOneToNameSet` cls) `unionNameSets` @@ -537,13 +414,13 @@ get_gates is_used (TyData {tcdCtxt = ctxt, tcdName = tycon, tcdTyVars = tvs, tcd (hsTyVarNames tvs) `addOneToNameSet` tycon where - get (ConDecl n _ tvs ctxt details _) + get (ConDecl n tvs ctxt details _) | is_used n -- If the constructor is method, get fvs from all its fields = delListFromNameSet (get_details details `plusFV` extractHsCtxtTyNames ctxt) (hsTyVarNames tvs) - get (ConDecl n _ tvs ctxt (RecCon fields) _) + get (ConDecl n tvs ctxt (RecCon fields) _) -- Even if the constructor isn't mentioned, the fields -- might be, as selectors. They can't mention existentially -- bound tyvars (typechecker checks for that) so no need for @@ -552,12 +429,12 @@ get_gates is_used (TyData {tcdCtxt = ctxt, tcdName = tycon, tcdTyVars = tvs, tcd get other_con = emptyFVs - get_details (VanillaCon tys) = plusFVs (map get_bang tys) + get_details (PrefixCon tys) = plusFVs (map get_bang tys) get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2 get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields] - get_field (fs,t) | any is_used fs = get_bang t - | otherwise = emptyFVs + get_field (f,t) | is_used f = get_bang t + | otherwise = emptyFVs get_bang bty = extractHsTyNames (getBangType bty) @@ -586,85 +463,89 @@ getWiredInGates :: TyThing -> FreeVars -- The TyThing is one that we already have in our type environment, either -- a) because the TyCon or Id is wired in, or -- b) from a previous compile +-- -- Either way, we might have instance decls in the (persistent) collection -- of parsed-but-not-slurped instance decls that should be slurped in. -- This might be the first module that mentions both the type and the class -- for that instance decl, even though both the type and the class were -- mentioned in other modules, and hence are in the type environment -getWiredInGates (AnId the_id) = namesOfType (idType the_id) -getWiredInGates (AClass cl) = implicitClassGates (getName cl) - -- The superclasses must also be previously - -- loaded, and hence are automatically gates - -- All previously-loaded classes are automatically gates - -- See "The gating story" above +getWiredInGates (AClass cl) + = unitFV (getName cl) `plusFV` mkFVs super_classes + where + super_classes = classNamesOfTheta (classSCTheta cl) + +getWiredInGates (AnId the_id) = tyClsNamesOfType (idType the_id) getWiredInGates (ATyCon tc) - | isSynTyCon tc = delListFromNameSet (namesOfType ty) (map getName tyvars) + | isSynTyCon tc = tyClsNamesOfType ty | otherwise = unitFV (getName tc) where - (tyvars,ty) = getSynTyConDefn tc + (_,ty) = getSynTyConDefn tc getInstDeclGates (InstDecl inst_ty _ _ _ _) = extractHsTyNames inst_ty \end{code} \begin{code} -getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameInstDecl)] +getImportedInstDecls :: NameSet -> TcRn m ([(Module,RdrNameInstDecl)], NameSet) + -- Returns the gates that are new since last time getImportedInstDecls gates = -- First, load any orphan-instance modules that aren't aready loaded -- Orphan-instance modules are recorded in the module dependecnies - getIfacesRn `thenRn` \ ifaces -> + getEps `thenM` \ eps -> let - orphan_mods = - [mod | (mod, (True, _)) <- fmToList (iImpModInfo ifaces)] + old_gates = eps_inst_gates eps + new_gates = gates `minusNameSet` old_gates + all_gates = new_gates `unionNameSets` old_gates + orphan_mods = [mod | (mod, (True, _)) <- fmToList (eps_imp_mods eps)] in - loadOrphanModules orphan_mods `thenRn_` + loadOrphanModules orphan_mods `thenM_` -- Now we're ready to grab the instance declarations -- Find the un-gated ones and return them, - -- removing them from the bag kept in Ifaces - getIfacesRn `thenRn` \ ifaces -> - getTypeEnvRn `thenRn` \ lookup -> + -- removing them from the bag kept in EPS + -- Don't foget to get the EPS a second time... + -- loadOrphanModules may have side-effected it! + getEps `thenM` \ eps -> let - available n = n `elemNameSet` gates || isJust (lookup n) - -- See "The gating story" above for the isJust thing - - (decls, new_insts) = selectGated available (iInsts ifaces) + available n = n `elemNameSet` all_gates + (decls, new_insts) = selectGated available (eps_insts eps) in - setIfacesRn (ifaces { iInsts = new_insts }) `thenRn_` + setEps (eps { eps_insts = new_insts, + eps_inst_gates = all_gates }) `thenM_` traceRn (sep [text "getImportedInstDecls:", - nest 4 (fsep (map ppr gate_list)), + nest 4 (fsep (map ppr (nameSetToList gates))), + nest 4 (fsep (map ppr (nameSetToList all_gates))), + nest 4 (fsep (map ppr (nameSetToList new_gates))), text "Slurped" <+> int (length decls) <+> text "instance declarations", - nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenRn_` - returnRn decls - where - gate_list = nameSetToList gates + nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenM_` + returnM (decls, new_gates) ppr_brief_inst_decl (mod, InstDecl inst_ty _ _ _ _) = case inst_ty of HsForAllTy _ _ tau -> ppr tau other -> ppr inst_ty -getImportedRules :: RnMG [(Module,RdrNameRuleDecl)] -getImportedRules - | opt_IgnoreIfacePragmas = returnRn [] +getImportedRules :: NameSet -- Slurped already + -> TcRn m [(Module,RdrNameRuleDecl)] +getImportedRules slurped + | opt_IgnoreIfacePragmas = returnM [] | otherwise - = getIfacesRn `thenRn` \ ifaces -> - getTypeEnvRn `thenRn` \ lookup -> + = getEps `thenM` \ eps -> + getInGlobalScope `thenM` \ in_type_env -> let -- Slurp rules for anything that is slurped, - -- either now or previously - gates = iSlurp ifaces - available n = n `elemNameSet` gates || isJust (lookup n) - (decls, new_rules) = selectGated available (iRules ifaces) + -- either now, or previously + available n = n `elemNameSet` slurped || in_type_env n + (decls, new_rules) = selectGated available (eps_rules eps) in if null decls then - returnRn [] + returnM [] else - setIfacesRn (ifaces { iRules = new_rules }) `thenRn_` + setEps (eps { eps_rules = new_rules }) `thenM_` traceRn (sep [text "getImportedRules:", - text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_` - returnRn decls + text "Slurped" <+> int (length decls) <+> text "rules"]) `thenM_` + returnM decls selectGated :: (Name->Bool) -> GatedDecls d -> ([(Module,d)], GatedDecls d) @@ -688,70 +569,6 @@ selectGated available (decl_bag, n_slurped) \end{code} -%********************************************************* -%* * -\subsection{Getting in a declaration} -%* * -%********************************************************* - -\begin{code} -importDecl :: Name -> RnMG ImportDeclResult - -data ImportDeclResult - = AlreadySlurped - | InTypeEnv TyThing - | HereItIs (Module, RdrNameTyClDecl) - -importDecl name - = -- STEP 1: Check if we've slurped it in while compiling this module - getIfacesRn `thenRn` \ ifaces -> - if name `elemNameSet` iSlurp ifaces then - returnRn AlreadySlurped - else - - - -- STEP 2: Check if it's already in the type environment - getTypeEnvRn `thenRn` \ lookup -> - case lookup name of { - Just ty_thing - | name `elemNameEnv` wiredInThingEnv - -> -- When we find a wired-in name we must load its home - -- module so that we find any instance decls lurking therein - loadHomeInterface wi_doc name `thenRn_` - returnRn (InTypeEnv ty_thing) - - | otherwise - -> -- Very important: record that we've seen it - -- See comments with recordTypeEnvSlurp - setIfacesRn (recordTypeEnvSlurp ifaces ty_thing) `thenRn_` - returnRn (InTypeEnv ty_thing) ; - - Nothing -> - - -- STEP 3: OK, we have to slurp it in from an interface file - -- First load the interface file - traceRn nd_doc `thenRn_` - loadHomeInterface nd_doc name `thenRn_` - getIfacesRn `thenRn` \ ifaces -> - - -- STEP 4: Get the declaration out - let - (decls_map, _) = iDecls ifaces - in - case lookupNameEnv decls_map name of - Just (avail,_,decl) -> setIfacesRn (recordDeclSlurp ifaces avail) `thenRn_` - returnRn (HereItIs decl) - - Nothing -> addErrRn (getDeclErr name) `thenRn_` - returnRn AlreadySlurped - } - where - wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name - nd_doc = ptext SLIT("need decl for") <+> ppr name - -\end{code} - - %******************************************************** %* * \subsection{Checking usage information} @@ -768,26 +585,30 @@ type RecompileRequired = Bool upToDate = False -- Recompile not required outOfDate = True -- Recompile required -recompileRequired :: FilePath -- Only needed for debug msgs - -> ModIface -- Old interface - -> RnMG RecompileRequired -recompileRequired iface_path iface - = traceHiDiffsRn (text "Considering whether compilation is required for" <+> text iface_path <> colon) `thenRn_` +checkVersions :: Bool -- True <=> source unchanged + -> ModIface -- Old interface + -> TcRn m RecompileRequired +checkVersions source_unchanged iface + | not source_unchanged + = returnM outOfDate + | otherwise + = traceHiDiffs (text "Considering whether compilation is required for" <+> + ppr (mi_module iface) <> colon) `thenM_` -- Source code unchanged and no errors yet... carry on checkList [checkModUsage u | u <- mi_usages iface] -checkList :: [RnMG RecompileRequired] -> RnMG RecompileRequired -checkList [] = returnRn upToDate -checkList (check:checks) = check `thenRn` \ recompile -> +checkList :: [TcRn m RecompileRequired] -> TcRn m RecompileRequired +checkList [] = returnM upToDate +checkList (check:checks) = check `thenM` \ recompile -> if recompile then - returnRn outOfDate + returnM outOfDate else checkList checks \end{code} \begin{code} -checkModUsage :: ImportVersion Name -> RnMG RecompileRequired +checkModUsage :: ImportVersion Name -> TcRn m RecompileRequired -- Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out -- whether M needs to be recompiled. @@ -804,76 +625,81 @@ checkModUsage (mod_name, _, is_boot, whats_imported) = -- Load the imported interface is possible -- We use tryLoadInterface, because failure is not an error -- (might just be that the old .hi file for this module is out of date) - -- We use ImportByUser/ImportByUserSource as the 'from' flag, - -- a) because we need to know whether to load the .hi-boot file - -- b) because loadInterface things matters are amiss if we - -- ImportBySystem an interface it knows nothing about let doc_str = sep [ptext SLIT("need version info for"), ppr mod_name] - from | is_boot = ImportByUserSource - | otherwise = ImportByUser + from = ImportForUsage is_boot in - traceHiDiffsRn (text "Checking usages for module" <+> ppr mod_name) `thenRn_` - tryLoadInterface doc_str mod_name from `thenRn` \ (iface, maybe_err) -> + traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_` - case maybe_err of { - Just err -> out_of_date (sep [ptext SLIT("Can't find version number for module"), - ppr mod_name]) ; + recoverM (returnM Nothing) + (loadInterface doc_str mod_name from `thenM` \ iface -> + returnM (Just iface)) `thenM` \ mb_iface -> + + case mb_iface of { + Nothing -> (out_of_date (sep [ptext SLIT("Can't find version number for module"), + ppr mod_name])); -- Couldn't find or parse a module mentioned in the -- old interface file. Don't complain -- it might just be that -- the current module doesn't need that import and it's been deleted - Nothing -> + Just iface -> let - new_vers = mi_version iface - new_decl_vers = vers_decls new_vers + new_vers = mi_version iface + new_mod_vers = vers_module new_vers + new_decl_vers = vers_decls new_vers + new_export_vers = vers_exports new_vers + new_rule_vers = vers_rules new_vers in case whats_imported of { -- NothingAtAll dealt with earlier - Everything old_mod_vers -> checkModuleVersion old_mod_vers new_vers `thenRn` \ recompile -> + Everything old_mod_vers -> checkModuleVersion old_mod_vers new_mod_vers `thenM` \ recompile -> if recompile then out_of_date (ptext SLIT("...and I needed the whole module")) else - returnRn upToDate ; + returnM upToDate ; Specifically old_mod_vers maybe_old_export_vers old_decl_vers old_rule_vers -> -- CHECK MODULE - checkModuleVersion old_mod_vers new_vers `thenRn` \ recompile -> + checkModuleVersion old_mod_vers new_mod_vers `thenM` \ recompile -> if not recompile then - returnRn upToDate + returnM upToDate else -- CHECK EXPORT LIST - if checkExportList maybe_old_export_vers new_vers then - out_of_date (ptext SLIT("Export list changed")) + if checkExportList maybe_old_export_vers new_export_vers then + out_of_date_vers (ptext SLIT(" Export list changed")) + (fromJust maybe_old_export_vers) + new_export_vers else -- CHECK RULES - if old_rule_vers /= vers_rules new_vers then - out_of_date (ptext SLIT("Rules changed")) + if old_rule_vers /= new_rule_vers then + out_of_date_vers (ptext SLIT(" Rules changed")) + old_rule_vers new_rule_vers else -- CHECK ITEMS ONE BY ONE - checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenRn` \ recompile -> + checkList [checkEntityUsage new_decl_vers u | u <- old_decl_vers] `thenM` \ recompile -> if recompile then - returnRn outOfDate -- This one failed, so just bail out now + returnM outOfDate -- This one failed, so just bail out now else - up_to_date (ptext SLIT("...but the bits I use haven't.")) + up_to_date (ptext SLIT(" Great! The bits I use are up to date")) }} ------------------------ -checkModuleVersion old_mod_vers new_vers - | vers_module new_vers == old_mod_vers +checkModuleVersion old_mod_vers new_mod_vers + | new_mod_vers == old_mod_vers = up_to_date (ptext SLIT("Module version unchanged")) | otherwise - = out_of_date (ptext SLIT("Module version has changed")) + = out_of_date_vers (ptext SLIT(" Module version has changed")) + old_mod_vers new_mod_vers ------------------------ checkExportList Nothing new_vers = upToDate -checkExportList (Just v) new_vers = v /= vers_exports new_vers +checkExportList (Just v) new_vers = v /= new_vers ------------------------ checkEntityUsage new_vers (name,old_vers) @@ -883,13 +709,15 @@ checkEntityUsage new_vers (name,old_vers) out_of_date (sep [ptext SLIT("No longer exported:"), ppr name]) Just new_vers -- It's there, but is it up to date? - | new_vers == old_vers -> traceHiDiffsRn (text "Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenRn_` - returnRn upToDate - | otherwise -> out_of_date (sep [ptext SLIT("Out of date:"), ppr name, ppr - old_vers, ptext SLIT("->"), ppr new_vers]) - -up_to_date msg = traceHiDiffsRn msg `thenRn_` returnRn upToDate -out_of_date msg = traceHiDiffsRn msg `thenRn_` returnRn outOfDate + | new_vers == old_vers -> traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenM_` + returnM upToDate + | otherwise -> out_of_date_vers (ptext SLIT(" Out of date:") <+> ppr name) + old_vers new_vers + +up_to_date msg = traceHiDiffs msg `thenM_` returnM upToDate +out_of_date msg = traceHiDiffs msg `thenM_` returnM outOfDate +out_of_date_vers msg old_vers new_vers + = out_of_date (hsep [msg, ppr old_vers, ptext SLIT("->"), ppr new_vers]) \end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs deleted file mode 100644 index 254b8eceac..0000000000 --- a/ghc/compiler/rename/RnMonad.lhs +++ /dev/null @@ -1,760 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[RnMonad]{The monad used by the renamer} - -\begin{code} -module RnMonad( - module RnMonad, - - module RdrName, -- Re-exports - module Name, -- from these two - - Module, - FiniteMap, - Bag, - RdrNameHsDecl, - RdrNameInstDecl, - Version, - NameSet, - OccName, - Fixity - ) where - -#include "HsVersions.h" - -import HsSyn -import RdrHsSyn -import RnHsSyn ( RenamedFixitySig ) -import HscTypes ( AvailEnv, emptyAvailEnv, lookupType, - NameSupply(..), - ImportedModuleInfo, WhetherHasOrphans, ImportVersion, - PersistentRenamerState(..), RdrExportItem, - DeclsMap, IfaceInsts, IfaceRules, - HomeSymbolTable, TyThing, - PersistentCompilerState(..), GlobalRdrEnv, - LocalRdrEnv, - HomeIfaceTable, PackageIfaceTable ) -import BasicTypes ( Version, defaultFixity, - Fixity(..), FixityDirection(..) ) -import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, - Message, Messages, errorsFound, warningsFound, - printErrorsAndWarnings - ) -import RdrName ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc, - RdrNameEnv, emptyRdrEnv, extendRdrEnv, - addListToRdrEnv, rdrEnvToList, rdrEnvElts - ) -import Id ( idName ) -import MkId ( seqId ) -import Name ( Name, OccName, NamedThing(..), - nameOccName, nameRdrName, - decode, mkInternalName - ) -import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, - extendNameEnvList ) -import Module ( Module, ModuleName, ModuleSet, emptyModuleSet, - PackageName, preludePackage ) -import PrelInfo ( ghcPrimExports, - cCallableClassDecl, cReturnableClassDecl, assertDecl ) -import PrelNames ( mkUnboundName, gHC_PRIM_Name ) -import NameSet -import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) -import SrcLoc ( SrcLoc, generatedSrcLoc, noSrcLoc ) -import Unique ( Unique ) -import FiniteMap ( FiniteMap ) -import Maybes ( seqMaybe ) -import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) -import UniqSupply -import Outputable - -import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef ) -import UNSAFE_IO ( unsafePerformIO ) -import FIX_IO ( fixIO ) - -import IO ( hPutStr, stderr ) - -infixr 9 `thenRn`, `thenRn_` -\end{code} - - -%************************************************************************ -%* * -\subsection{Somewhat magical interface to other monads} -%* * -%************************************************************************ - -\begin{code} -ioToRnM :: IO r -> RnM d (Either IOError r) -ioToRnM io rn_down g_down = (io >>= \ ok -> return (Right ok)) - `catch` - (\ err -> return (Left err)) - -ioToRnM_no_fail :: IO r -> RnM d r -ioToRnM_no_fail io rn_down g_down - = (io >>= \ ok -> return ok) - `catch` - (\ err -> panic "ioToRnM_no_fail: the I/O operation failed!") - -traceRn :: SDoc -> RnM d () -traceRn msg = ifOptRn Opt_D_dump_rn_trace (putDocRn msg) - -traceHiDiffsRn :: SDoc -> RnM d () -traceHiDiffsRn msg = ifOptRn Opt_D_dump_hi_diffs (putDocRn msg) - -putDocRn :: SDoc -> RnM d () -putDocRn msg = ioToRnM (printErrs alwaysQualify msg) `thenRn_` - returnRn () -\end{code} - - -%************************************************************************ -%* * -\subsection{Data types} -%* * -%************************************************************************ - -%=================================================== -\subsubsection{ MONAD TYPES} -%=================================================== - -\begin{code} -type RnM d r = RnDown -> d -> IO r -type RnMS r = RnM SDown r -- Renaming source -type RnMG r = RnM () r -- Getting global names etc - - -- Common part -data RnDown - = RnDown { - rn_mod :: Module, -- This module - rn_loc :: SrcLoc, -- Current locn - - rn_dflags :: DynFlags, - - rn_hit :: HomeIfaceTable, - rn_done :: Name -> Maybe TyThing, -- Tells what things (both in the - -- home package and other packages) - -- were already available (i.e. in - -- the relevant SymbolTable) before - -- compiling this module - -- The Name passed to rn_done is guaranteed to be a Global, - -- so it has a Module, so it can be looked up - - rn_errs :: IORef Messages, - rn_ns :: IORef NameSupply, - rn_ifaces :: IORef Ifaces - } - - -- For renaming source code -data SDown = SDown { - rn_mode :: RnMode, - - rn_genv :: GlobalRdrEnv, -- Top level environment - - rn_avails :: AvailEnv, - -- Top level AvailEnv; contains all the things that - -- are nameable in the top-level scope, regardless of - -- *how* they can be named (qualified, unqualified...) - -- It is used only to map a Class to its class ops, and - -- hence to resolve the binders in an instance decl - - rn_lenv :: LocalRdrEnv, -- Local name envt - -- Does *not* include global name envt; may shadow it - -- Includes both ordinary variables and type variables; - -- they are kept distinct because tyvar have a different - -- occurrence contructor (Name.TvOcc) - -- We still need the unsullied global name env so that - -- we can look up record field names - - rn_fixenv :: LocalFixityEnv -- Local fixities (for non-top-level - -- declarations) - -- The global fixities are held in the - -- HIT or PIT. Why? See the comments - -- with RnIfaces.lookupLocalFixity - } - -data RnMode = SourceMode -- Renaming source code - | InterfaceMode -- Renaming interface declarations. - | CmdLineMode -- Renaming a command-line expression - -isInterfaceMode InterfaceMode = True -isInterfaceMode _ = False - -isCmdLineMode CmdLineMode = True -isCmdLineMode _ = False -\end{code} - -\begin{code} -type LocalFixityEnv = NameEnv RenamedFixitySig - -- We keep the whole fixity sig so that we - -- can report line-number info when there is a duplicate - -- fixity declaration - -emptyLocalFixityEnv :: LocalFixityEnv -emptyLocalFixityEnv = emptyNameEnv -\end{code} - - -%************************************************************************ -%* * -\subsection{Interface file stuff} -%* * -%************************************************************************ - -\begin{code} -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 :: [(RdrName,Fixity)], -- Local fixity declarations, - pi_insts :: [RdrNameInstDecl], -- Local instance declarations - pi_rules :: (Version, [RdrNameRuleDecl]), -- Rules, with their version - pi_deprecs :: IfaceDeprecs -- Deprecations - } -\end{code} - -%************************************************************************ -%* * -\subsection{Wired-in interfaces} -%* * -%************************************************************************ - -\begin{code} -ghcPrimIface :: ParsedIface -ghcPrimIface = ParsedIface { - pi_mod = gHC_PRIM_Name, - pi_pkg = preludePackage, - pi_vers = 1, - pi_orphan = False, - pi_usages = [], - pi_exports = (1, [(gHC_PRIM_Name, ghcPrimExports)]), - pi_decls = [(1,cCallableClassDecl), - (1,cReturnableClassDecl), - (1,assertDecl)], - pi_fixity = [(nameRdrName (idName seqId), Fixity 0 InfixR)], - -- seq is infixr 0 - pi_insts = [], - pi_rules = (1,[]), - pi_deprecs = Nothing - } -\end{code} - -%************************************************************************ -%* * -\subsection{The renamer state} -%* * -%************************************************************************ - -\begin{code} -data Ifaces = Ifaces { - -- PERSISTENT FIELDS - iPIT :: PackageIfaceTable, - -- The ModuleIFaces for modules in other packages - -- whose interfaces we have opened - -- The declarations in these interface files are held in - -- iDecls, iInsts, iRules (below), not in the mi_decls fields - -- of the iPIT. What _is_ in the iPIT is: - -- * The Module - -- * Version info - -- * Its exports - -- * Fixities - -- * Deprecations - -- The iPIT field is initialised from the compiler's persistent - -- package symbol table, and the renamer incrementally adds - -- to it. - - iImpModInfo :: 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 - - iDecls :: DeclsMap, - -- A single, global map of Names to unslurped decls - - iInsts :: 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. - - iRules :: IfaceRules, - -- Similar to instance decls, only for rules - - -- EPHEMERAL FIELDS - -- These fields persist during the compilation of a single module only - iSlurp :: NameSet, - -- All the names (whether "big" or "small", whether wired-in or not, - -- whether locally defined or not) that have been slurped in so far. - -- - -- It's used for two things: - -- a) To record what we've already slurped, so - -- we can no-op if we try to slurp it again - -- b) As the 'gates' for importing rules. We import a rule - -- if all its LHS free vars have been slurped - - iVSlurp :: (ModuleSet, NameSet) - -- The Names are all the (a) non-wired-in - -- (b) "big" - -- (c) non-locally-defined - -- (d) home-package - -- names that have been slurped in so far, with their versions. - -- This is used to generate the "usage" information for this module. - -- Subset of the previous field. - -- - -- The module set is the non-home-package modules from which we have - -- slurped at least one name. - -- It's worth keeping separately, because there's no very easy - -- way to distinguish the "big" names from the "non-big" ones. - -- But this is a decision we might want to revisit. - } -\end{code} - - -%************************************************************************ -%* * -\subsection{Main monad code} -%* * -%************************************************************************ - -\begin{code} -runRn dflags hit hst pcs mod do_rn - = do { (pcs, msgs, r) <- initRn dflags hit hst pcs mod do_rn ; - printErrorsAndWarnings alwaysQualify msgs ; - return (pcs, errorsFound msgs, r) - } - -initRn :: DynFlags - -> HomeIfaceTable -> HomeSymbolTable - -> PersistentCompilerState - -> Module - -> RnMG t - -> IO (PersistentCompilerState, Messages, t) - -initRn dflags hit hst pcs mod do_rn - = do - let prs = pcs_PRS pcs - let pte = pcs_PTE pcs - let ifaces = Ifaces { iPIT = pcs_PIT pcs, - iDecls = prsDecls prs, - iInsts = prsInsts prs, - iRules = prsRules prs, - - iImpModInfo = prsImpMods prs, - iSlurp = unitNameSet (mkUnboundName dummyRdrVarName), - -- Pretend that the dummy unbound name has already been - -- slurped. This is what's returned for an out-of-scope name, - -- and we don't want thereby to try to suck it in! - iVSlurp = (emptyModuleSet, emptyNameSet) - } - names_var <- newIORef (prsOrig prs) - errs_var <- newIORef (emptyBag,emptyBag) - iface_var <- newIORef ifaces - let rn_down = RnDown { rn_mod = mod, - rn_loc = noSrcLoc, - - rn_dflags = dflags, - rn_hit = hit, - rn_done = lookupType hst pte, - - rn_ns = names_var, - rn_errs = errs_var, - rn_ifaces = iface_var, - } - - -- do the business - res <- do_rn rn_down () - - -- Grab state and record it - (warns, errs) <- readIORef errs_var - new_ifaces <- readIORef iface_var - new_orig <- readIORef names_var - let new_prs = prs { prsOrig = new_orig, - prsImpMods = iImpModInfo new_ifaces, - prsDecls = iDecls new_ifaces, - prsInsts = iInsts new_ifaces, - prsRules = iRules new_ifaces } - let new_pcs = pcs { pcs_PIT = iPIT new_ifaces, - pcs_PRS = new_prs } - - return (new_pcs, (warns, errs), res) - -initRnMS :: GlobalRdrEnv -> AvailEnv -> LocalRdrEnv -> LocalFixityEnv -> RnMode - -> RnMS a -> RnM d a - -initRnMS rn_env avails local_env fixity_env mode thing_inside rn_down g_down - -- The fixity_env appears in both the rn_fixenv field - -- and in the HIT. See comments with RnHiFiles.lookupFixityRn - = let - s_down = SDown { rn_genv = rn_env, rn_avails = avails, - rn_lenv = local_env, rn_fixenv = fixity_env, - rn_mode = mode } - in - thing_inside rn_down s_down - -initIfaceRnMS :: Module -> RnMS r -> RnM d r -initIfaceRnMS mod thing_inside - = initRnMS emptyRdrEnv emptyAvailEnv emptyRdrEnv - emptyLocalFixityEnv InterfaceMode - (setModuleRn mod thing_inside) -\end{code} - -@renameDerivedCode@ is used to rename stuff ``out-of-line''; -that is, not as part of the main renamer. -Sole examples: derived definitions, -which are only generated in the type checker. - -The @NameSupply@ includes a @UniqueSupply@, so if you call it more than -once you must either split it, or install a fresh unique supply. - -\begin{code} -renameDerivedCode :: DynFlags - -> Module - -> PersistentRenamerState - -> RnMS r - -> r - -renameDerivedCode dflags mod prs thing_inside - = unsafePerformIO $ - -- It's not really unsafe! When renaming source code we - -- only do any I/O if we need to read in a fixity declaration; - -- and that doesn't happen in pragmas etc - - do { us <- mkSplitUniqSupply 'r' - ; names_var <- newIORef ((prsOrig prs) { nsUniqs = us }) - ; errs_var <- newIORef (emptyBag,emptyBag) - - ; let rn_down = RnDown { rn_dflags = dflags, - rn_loc = generatedSrcLoc, rn_ns = names_var, - rn_errs = errs_var, - rn_mod = mod, - rn_done = bogus "rn_done", - rn_hit = bogus "rn_hit", - rn_ifaces = bogus "rn_ifaces" - } - ; let s_down = SDown { rn_mode = InterfaceMode, - -- So that we can refer to PrelBase.True etc - rn_avails = emptyAvailEnv, - rn_genv = emptyRdrEnv, rn_lenv = emptyRdrEnv, - rn_fixenv = emptyLocalFixityEnv } - - ; result <- thing_inside rn_down s_down - ; messages <- readIORef errs_var - - ; if bad messages then - do { hPutStr stderr "Urk! renameDerivedCode found errors or warnings" - ; printErrorsAndWarnings alwaysQualify messages - } - else - return() - - ; return result - } - where -#ifdef DEBUG - bad messages = errorsFound messages || warningsFound messages -#else - bad messages = errorsFound messages -#endif - -bogus s = panic ("rnameSourceCode: " ++ s) -- Used for unused record fields - -{-# INLINE thenRn #-} -{-# INLINE thenRn_ #-} -{-# INLINE returnRn #-} -{-# INLINE andRn #-} - -returnRn :: a -> RnM d a -thenRn :: RnM d a -> (a -> RnM d b) -> RnM d b -thenRn_ :: RnM d a -> RnM d b -> RnM d b -andRn :: (a -> a -> a) -> RnM d a -> RnM d a -> RnM d a -mapRn :: (a -> RnM d b) -> [a] -> RnM d [b] -mapRn_ :: (a -> RnM d b) -> [a] -> RnM d () -mapMaybeRn :: (a -> RnM d (Maybe b)) -> [a] -> RnM d [b] -flatMapRn :: (a -> RnM d [b]) -> [a] -> RnM d [b] -sequenceRn :: [RnM d a] -> RnM d [a] -sequenceRn_ :: [RnM d a] -> RnM d () -foldlRn :: (b -> a -> RnM d b) -> b -> [a] -> RnM d b -mapAndUnzipRn :: (a -> RnM d (b,c)) -> [a] -> RnM d ([b],[c]) -fixRn :: (a -> RnM d a) -> RnM d a - -returnRn v gdown ldown = return v -thenRn m k gdown ldown = m gdown ldown >>= \ r -> k r gdown ldown -thenRn_ m k gdown ldown = m gdown ldown >> k gdown ldown -fixRn m gdown ldown = fixIO (\r -> m r gdown ldown) -andRn combiner m1 m2 gdown ldown - = m1 gdown ldown >>= \ res1 -> - m2 gdown ldown >>= \ res2 -> - return (combiner res1 res2) - -sequenceRn [] = returnRn [] -sequenceRn (m:ms) = m `thenRn` \ r -> - sequenceRn ms `thenRn` \ rs -> - returnRn (r:rs) - -sequenceRn_ [] = returnRn () -sequenceRn_ (m:ms) = m `thenRn_` sequenceRn_ ms - -mapRn f [] = returnRn [] -mapRn f (x:xs) - = f x `thenRn` \ r -> - mapRn f xs `thenRn` \ rs -> - returnRn (r:rs) - -mapRn_ f [] = returnRn () -mapRn_ f (x:xs) = - f x `thenRn_` - mapRn_ f xs - -foldlRn k z [] = returnRn z -foldlRn k z (x:xs) = k z x `thenRn` \ z' -> - foldlRn k z' xs - -mapAndUnzipRn f [] = returnRn ([],[]) -mapAndUnzipRn f (x:xs) - = f x `thenRn` \ (r1, r2) -> - mapAndUnzipRn f xs `thenRn` \ (rs1, rs2) -> - returnRn (r1:rs1, r2:rs2) - -mapAndUnzip3Rn f [] = returnRn ([],[],[]) -mapAndUnzip3Rn f (x:xs) - = f x `thenRn` \ (r1, r2, r3) -> - mapAndUnzip3Rn f xs `thenRn` \ (rs1, rs2, rs3) -> - returnRn (r1:rs1, r2:rs2, r3:rs3) - -mapMaybeRn f [] = returnRn [] -mapMaybeRn f (x:xs) = f x `thenRn` \ maybe_r -> - mapMaybeRn f xs `thenRn` \ rs -> - case maybe_r of - Nothing -> returnRn rs - Just r -> returnRn (r:rs) - -flatMapRn f [] = returnRn [] -flatMapRn f (x:xs) = f x `thenRn` \ r -> - flatMapRn f xs `thenRn` \ rs -> - returnRn (r ++ rs) -\end{code} - - - -%************************************************************************ -%* * -\subsection{Boring plumbing for common part} -%* * -%************************************************************************ - - -%================ -\subsubsection{ Errors and warnings} -%===================== - -\begin{code} -failWithRn :: a -> Message -> RnM d a -failWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down - = readIORef errs_var >>= \ (warns,errs) -> - writeIORef errs_var (warns, errs `snocBag` err) >> - return res - where - err = addShortErrLocLine loc msg - -warnWithRn :: a -> Message -> RnM d a -warnWithRn res msg (RnDown {rn_errs = errs_var, rn_loc = loc}) l_down - = readIORef errs_var >>= \ (warns,errs) -> - writeIORef errs_var (warns `snocBag` warn, errs) >> - return res - where - warn = addShortWarnLocLine loc msg - -tryRn :: RnM d a -> RnM d (Either Messages a) -tryRn try_this down@(RnDown {rn_errs = errs_var}) l_down - = do current_msgs <- readIORef errs_var - writeIORef errs_var (emptyBag,emptyBag) - a <- try_this down l_down - (warns, errs) <- readIORef errs_var - writeIORef errs_var current_msgs - if (isEmptyBag errs) - then return (Right a) - else return (Left (warns,errs)) - -setErrsRn :: Messages -> RnM d () -setErrsRn msgs down@(RnDown {rn_errs = errs_var}) l_down - = do writeIORef errs_var msgs; return () - -addErrRn :: Message -> RnM d () -addErrRn err = failWithRn () err - -checkRn :: Bool -> Message -> RnM d () -- Check that a condition is true -checkRn False err = addErrRn err -checkRn True err = returnRn () - -warnCheckRn :: Bool -> Message -> RnM d () -- Check that a condition is true -warnCheckRn False err = addWarnRn err -warnCheckRn True err = returnRn () - -addWarnRn :: Message -> RnM d () -addWarnRn warn = warnWithRn () warn - -checkErrsRn :: RnM d Bool -- True <=> no errors so far -checkErrsRn (RnDown {rn_errs = errs_var}) l_down - = readIORef errs_var >>= \ (warns,errs) -> - return (isEmptyBag errs) - -doptRn :: DynFlag -> RnM d Bool -doptRn dflag (RnDown { rn_dflags = dflags}) l_down - = return (dopt dflag dflags) - -ifOptRn :: DynFlag -> RnM d a -> RnM d () -ifOptRn dflag thing_inside down@(RnDown { rn_dflags = dflags}) l_down - | dopt dflag dflags = thing_inside down l_down >> return () - | otherwise = return () - -getDOptsRn :: RnM d DynFlags -getDOptsRn (RnDown { rn_dflags = dflags}) l_down - = return dflags -\end{code} - - -%================ -\subsubsection{Source location} -%===================== - -\begin{code} -pushSrcLocRn :: SrcLoc -> RnM d a -> RnM d a -pushSrcLocRn loc' m down l_down - = m (down {rn_loc = loc'}) l_down - -getSrcLocRn :: RnM d SrcLoc -getSrcLocRn down l_down - = return (rn_loc down) -\end{code} - -%================ -\subsubsection{The finder and home symbol table} -%===================== - -\begin{code} -getHomeIfaceTableRn :: RnM d HomeIfaceTable -getHomeIfaceTableRn down l_down = return (rn_hit down) - -getTypeEnvRn :: RnM d (Name -> Maybe TyThing) -getTypeEnvRn down l_down = return (rn_done down) - -extendTypeEnvRn :: NameEnv TyThing -> RnM d a -> RnM d a -extendTypeEnvRn env inside down l_down - = inside down{rn_done=new_rn_done} l_down - where new_rn_done = \nm -> lookupNameEnv env nm `seqMaybe` rn_done down nm -\end{code} - -%================ -\subsubsection{Name supply} -%===================== - -\begin{code} -getNameSupplyRn :: RnM d NameSupply -getNameSupplyRn rn_down l_down - = readIORef (rn_ns rn_down) - -setNameSupplyRn :: NameSupply -> RnM d () -setNameSupplyRn names' (RnDown {rn_ns = names_var}) l_down - = writeIORef names_var names' - -getUniqRn :: RnM d Unique -getUniqRn (RnDown {rn_ns = names_var}) l_down - = readIORef names_var >>= \ ns -> - let - (us1,us') = splitUniqSupply (nsUniqs ns) - in - writeIORef names_var (ns {nsUniqs = us'}) >> - return (uniqFromSupply us1) -\end{code} - -%================ -\subsubsection{ Module} -%===================== - -\begin{code} -getModuleRn :: RnM d Module -getModuleRn (RnDown {rn_mod = mod}) l_down - = return mod - -setModuleRn :: Module -> RnM d a -> RnM d a -setModuleRn new_mod enclosed_thing rn_down l_down - = enclosed_thing (rn_down {rn_mod = new_mod}) l_down -\end{code} - - -%************************************************************************ -%* * -\subsection{Plumbing for rename-source part} -%* * -%************************************************************************ - -%================ -\subsubsection{ RnEnv} -%===================== - -\begin{code} -getLocalNameEnv :: RnMS LocalRdrEnv -getLocalNameEnv rn_down (SDown {rn_lenv = local_env}) - = return local_env - -getGlobalNameEnv :: RnMS GlobalRdrEnv -getGlobalNameEnv rn_down (SDown {rn_genv = global_env}) - = return global_env - -getGlobalAvails :: RnMS AvailEnv -getGlobalAvails rn_down (SDown {rn_avails = avails}) - = return avails - -setLocalNameEnv :: LocalRdrEnv -> RnMS a -> RnMS a -setLocalNameEnv local_env' m rn_down l_down - = m rn_down (l_down {rn_lenv = local_env'}) - -getFixityEnv :: RnMS LocalFixityEnv -getFixityEnv rn_down (SDown {rn_fixenv = fixity_env}) - = return fixity_env - -setFixityEnv :: LocalFixityEnv -> RnMS a -> RnMS a -setFixityEnv fixes enclosed_scope rn_down l_down - = enclosed_scope rn_down (l_down {rn_fixenv = fixes}) -\end{code} - -%================ -\subsubsection{ Mode} -%===================== - -\begin{code} -getModeRn :: RnMS RnMode -getModeRn rn_down (SDown {rn_mode = mode}) - = return mode - -setModeRn :: RnMode -> RnMS a -> RnMS a -setModeRn new_mode thing_inside rn_down l_down - = thing_inside rn_down (l_down {rn_mode = new_mode}) -\end{code} - - -%************************************************************************ -%* * -\subsection{Plumbing for rename-globals part} -%* * -%************************************************************************ - -\begin{code} -getIfacesRn :: RnM d Ifaces -getIfacesRn (RnDown {rn_ifaces = iface_var}) _ - = readIORef iface_var - -setIfacesRn :: Ifaces -> RnM d () -setIfacesRn ifaces (RnDown {rn_ifaces = iface_var}) _ - = writeIORef iface_var ifaces -\end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 1eefbc3925..a5b0f84864 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -5,132 +5,142 @@ \begin{code} module RnNames ( - ExportAvails, getGlobalNames, exportsFromAvail + rnImports, importsFromLocalDecls, exportsFromAvail, + reportUnusedNames ) where #include "HsVersions.h" +import {-# SOURCE #-} RnHiFiles ( loadInterface ) + import CmdLineOpts ( DynFlag(..) ) -import HsSyn ( HsModule(..), HsDecl(..), IE(..), ieName, ImportDecl(..), +import HsSyn ( HsDecl(..), IE(..), ieName, ImportDecl(..), ForeignDecl(..), - collectLocatedHsBinders - ) -import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, - RdrNameHsModule, RdrNameHsDecl + collectLocatedHsBinders, tyClDeclNames ) -import RnIfaces ( recordLocalSlurps ) -import RnHiFiles ( getTyClDeclBinders, loadInterface ) +import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, RdrNameHsDecl ) import RnEnv -import RnMonad +import TcRnMonad import FiniteMap -import PrelNames ( pRELUDE_Name, mAIN_Name, isUnboundName ) -import Module ( ModuleName, moduleName, WhereFrom(..) ) -import Name ( Name, nameSrcLoc, nameOccName ) +import PrelNames ( pRELUDE_Name, mAIN_Name, isBuiltInSyntaxName ) +import Module ( Module, ModuleName, moduleName, + moduleNameUserString, + unitModuleEnvByName, lookupModuleEnvByName, + moduleEnvElts ) +import Name ( Name, nameSrcLoc, nameOccName, nameModule ) import NameSet import NameEnv +import OccName ( OccName, dataName, isTcOcc ) import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv, - GenAvailInfo(..), AvailInfo, Avails, AvailEnv, - Deprecations(..), ModIface(..), emptyAvailEnv + GenAvailInfo(..), AvailInfo, Avails, IsBootInterface, + availName, availNames, availsToNameSet, + Deprecations(..), ModIface(..), + GlobalRdrElt(..), unQualInScope, isLocalGRE ) -import RdrName ( rdrNameOcc, setRdrNameOcc ) -import OccName ( setOccNameSpace, dataName ) -import NameSet ( elemNameSet, emptyNameSet ) +import RdrName ( rdrNameOcc, setRdrNameSpace, emptyRdrEnv, foldRdrEnv, isQual ) +import SrcLoc ( noSrcLoc ) import Outputable import Maybes ( maybeToBool, catMaybes ) import ListSetOps ( removeDups ) import Util ( sortLt, notNull ) import List ( partition ) +import IO ( openFile, IOMode(..) ) \end{code} %************************************************************************ %* * -\subsection{Get global names} + rnImports %* * %************************************************************************ \begin{code} -getGlobalNames :: Module -> RdrNameHsModule - -> RnMG (GlobalRdrEnv, -- Maps all in-scope things - GlobalRdrEnv, -- Maps just *local* things - ExportAvails) -- The exported stuff - -getGlobalNames this_mod (HsModule _ _ _ imports decls _ mod_loc) - = -- PROCESS LOCAL DECLS - -- Do these *first* so that the correct provenance gets - -- into the global name cache. - importsFromLocalDecls this_mod decls `thenRn` \ (local_gbl_env, local_mod_avails) -> - - -- PROCESS IMPORT DECLS +rnImports :: [RdrNameImportDecl] + -> TcRn m (GlobalRdrEnv, ImportAvails) + +rnImports imports + = -- PROCESS IMPORT DECLS -- Do the non {- SOURCE -} ones first, so that we get a helpful -- warning for {- SOURCE -} ones that are unnecessary - doptRn Opt_NoImplicitPrelude `thenRn` \ opt_no_prelude -> + getModule `thenM` \ this_mod -> + getSrcLocM `thenM` \ loc -> + doptM Opt_NoImplicitPrelude `thenM` \ opt_no_prelude -> let - all_imports = mk_prel_imports opt_no_prelude ++ imports + all_imports = mk_prel_imports this_mod loc opt_no_prelude ++ imports (source, ordinary) = partition is_source_import all_imports - is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True - is_source_import other = False + is_source_import (ImportDecl _ is_boot _ _ _ _) = is_boot - get_imports = importsFromImportDecl this_mod_name + get_imports = importsFromImportDecl (moduleName this_mod) in - mapAndUnzipRn get_imports ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) -> - mapAndUnzipRn get_imports source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) -> + mappM get_imports ordinary `thenM` \ stuff1 -> + mappM get_imports source `thenM` \ stuff2 -> -- COMBINE RESULTS - -- We put the local env second, so that a local provenance - -- "wins", even if a module imports itself. let + (imp_gbl_envs, imp_avails) = unzip (stuff1 ++ stuff2) gbl_env :: GlobalRdrEnv - imp_gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv (imp_gbl_envs2 ++ imp_gbl_envs1) - gbl_env = imp_gbl_env `plusGlobalRdrEnv` local_gbl_env + gbl_env = foldr plusGlobalRdrEnv emptyRdrEnv imp_gbl_envs - all_avails :: ExportAvails - all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1) + all_avails :: ImportAvails + all_avails = foldr plusImportAvails emptyImportAvails imp_avails in - -- ALL DONE - returnRn (gbl_env, local_gbl_env, all_avails) + returnM (gbl_env, all_avails) where - this_mod_name = moduleName this_mod - -- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); - -- because the former doesn't even look at Prelude.hi for instance declarations, - -- whereas the latter does. - mk_prel_imports no_prelude - | this_mod_name == pRELUDE_Name || - explicit_prelude_import || - no_prelude + -- because the former doesn't even look at Prelude.hi for instance + -- declarations, whereas the latter does. + mk_prel_imports this_mod loc no_prelude + | moduleName this_mod == pRELUDE_Name + || explicit_prelude_import + || no_prelude = [] - | otherwise = [ImportDecl pRELUDE_Name - ImportByUser - False {- Not qualified -} - Nothing {- No "as" -} - Nothing {- No import list -} - mod_loc] - + | otherwise = [preludeImportDecl loc] + explicit_prelude_import - = notNull [ () | (ImportDecl mod _ _ _ _ _) <- imports, mod == pRELUDE_Name ] + = notNull [ () | (ImportDecl mod _ _ _ _ _) <- imports, + mod == pRELUDE_Name ] + +preludeImportDecl loc + = ImportDecl pRELUDE_Name + False {- Not a boot interface -} + False {- Not qualified -} + Nothing {- No "as" -} + Nothing {- No import list -} + loc \end{code} \begin{code} importsFromImportDecl :: ModuleName -> RdrNameImportDecl - -> RnMG (GlobalRdrEnv, - ExportAvails) + -> TcRn m (GlobalRdrEnv, ImportAvails) + +importsFromImportDecl this_mod_name + (ImportDecl imp_mod_name is_boot qual_only as_mod import_spec iloc) + = addSrcLoc iloc $ + let + doc = ppr imp_mod_name <+> ptext SLIT("is directly imported") + in + + -- If there's an error in loadInterface, (e.g. interface + -- file not found) we get lots of spurious errors from 'filterImports' + recoverM (returnM Nothing) + (loadInterface doc imp_mod_name (ImportByUser is_boot) `thenM` \ iface -> + returnM (Just iface)) `thenM` \ mb_iface -> -importsFromImportDecl this_mod_name (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc) - = pushSrcLocRn iloc $ + case mb_iface of { + Nothing -> returnM (emptyRdrEnv, emptyImportAvails ) ; + Just iface -> - loadInterface (ppr imp_mod_name <+> ptext SLIT("is directly imported")) - imp_mod_name from `thenRn` \ iface -> let imp_mod = mi_module iface avails_by_module = mi_exports iface deprecs = mi_deprecs iface + dir_imp = unitModuleEnvByName imp_mod_name (imp_mod, import_all import_spec) avails :: Avails avails = [ avail | (mod_name, avails) <- avails_by_module, @@ -154,39 +164,53 @@ importsFromImportDecl this_mod_name (ImportDecl imp_mod_name from qual_only as_m -- then you'll get a 'B does not export AType' message. Oh well. in - if null avails_by_module then - -- If there's an error in loadInterface, (e.g. interface - -- file not found) we get lots of spurious errors from 'filterImports' - returnRn (emptyRdrEnv, mkEmptyExportAvails imp_mod_name) - else - -- Complain if we import a deprecated module - ifOptRn Opt_WarnDeprecations ( + ifOptM Opt_WarnDeprecations ( case deprecs of - DeprecAll txt -> addWarnRn (moduleDeprec imp_mod_name txt) - other -> returnRn () - ) `thenRn_` + DeprecAll txt -> addWarn (moduleDeprec imp_mod_name txt) + other -> returnM () + ) `thenM_` -- Filter the imports according to the import list - filterImports imp_mod_name from import_spec avails `thenRn` \ (filtered_avails, explicits) -> + filterImports imp_mod_name is_boot import_spec avails `thenM` \ (filtered_avails, explicits) -> let - unqual_imp = not qual_only -- Maybe want unqualified names + unqual_imp = not qual_only -- Maybe want unqualified names qual_mod = case as_mod of Nothing -> imp_mod_name Just another_name -> another_name mk_prov name = NonLocalDef (UserImport imp_mod iloc (name `elemNameSet` explicits)) gbl_env = mkGlobalRdrEnv qual_mod unqual_imp mk_prov filtered_avails deprecs - exports = mkExportAvails qual_mod unqual_imp gbl_env filtered_avails + imports = mkImportAvails qual_mod unqual_imp gbl_env filtered_avails in - returnRn (gbl_env, exports) + returnM (gbl_env, imports { imp_mods = dir_imp}) + } + +import_all (Just (False, _)) = False -- Imports are spec'd explicitly +import_all other = True -- Everything is imported \end{code} +%************************************************************************ +%* * + importsFromLocalDecls +%* * +%************************************************************************ + +From the top-level declarations of this module produce + * the lexical environment + * the ImportAvails +created by its bindings. + +Complain about duplicate bindings + \begin{code} -importsFromLocalDecls this_mod decls - = mapRn (getLocalDeclBinders this_mod) decls `thenRn` \ avails_s -> +importsFromLocalDecls :: [RdrNameHsDecl] + -> TcRn m (GlobalRdrEnv, ImportAvails) +importsFromLocalDecls decls + = getModule `thenM` \ this_mod -> + mappM (getLocalDeclBinders this_mod) decls `thenM` \ avails_s -> -- The avails that are returned don't include the "system" names let avails = concat avails_s @@ -201,17 +225,15 @@ importsFromLocalDecls this_mod decls -- The complaint will come out as "Multiple declarations of Foo.f" because -- since 'f' is in the env twice, the unQualInScope used by the error-msg -- printer returns False. It seems awkward to fix, unfortunately. - mapRn_ (addErrRn . dupDeclErr) dups `thenRn_` - + mappM_ (addErr . dupDeclErr) dups `thenM_` - -- Record that locally-defined things are available - recordLocalSlurps (availsToNameSet avails) `thenRn_` + doptM Opt_NoImplicitPrelude `thenM` \ implicit_prelude -> let mod_name = moduleName this_mod unqual_imp = True -- Want unqualified names mk_prov n = LocalDef -- Provenance is local - gbl_env = mkGlobalRdrEnv mod_name unqual_imp mk_prov avails NoDeprecs + gbl_env = mkGlobalRdrEnv mod_name unqual_imp mk_prov avails NoDeprecs -- NoDeprecs: don't complain about locally defined names -- For a start, we may be exporting a deprecated thing -- Also we may use a deprecated thing in the defn of another @@ -219,41 +241,78 @@ importsFromLocalDecls this_mod decls -- the defn of a non-deprecated thing, when changing a module's -- interface - exports = mkExportAvails mod_name unqual_imp gbl_env avails + + -- Optimisation: filter out names for built-in syntax + -- They just clutter up the environment (esp tuples), and the parser + -- will generate Exact RdrNames for them, so the cluttered + -- envt is no use. To avoid doing this filter all the type, + -- we use -fno-implicit-prelude as a clue that the filter is + -- worth while. Really, it's only useful for Base and Tuple. + -- + -- It's worth doing because it makes the environment smaller for + -- every module that imports the Prelude + -- + -- Note: don't filter the gbl_env (hence avails, not avails' in + -- defn of gbl_env above). Stupid reason: when parsing + -- data type decls, the constructors start as Exact tycon-names, + -- and then get turned into data con names by zapping the name space; + -- but that stops them being Exact, so they get looked up. Sigh. + -- It doesn't matter because it only affects the Data.Tuple really. + -- The important thing is to trim down the exports. + imports = mkImportAvails mod_name unqual_imp gbl_env avails' + avails' | implicit_prelude = filter not_built_in_syntax avails + | otherwise = avails + not_built_in_syntax a = not (all isBuiltInSyntaxName (availNames a)) + -- Only filter it if all the names of the avail are built-in + -- In particular, lists have (:) which is not built in syntax + -- so we don't filter it out. in - returnRn (gbl_env, exports) + returnM (gbl_env, imports) +\end{code} + + +%********************************************************* +%* * +\subsection{Getting binders out of a declaration} +%* * +%********************************************************* + +@getLocalDeclBinders@ returns the names for a @RdrNameHsDecl@. It's +used for both source code (from @importsFromLocalDecls@) and interface +files (@loadDecl@ calls @getTyClDeclBinders@). ---------------------------- -getLocalDeclBinders :: Module -> RdrNameHsDecl -> RnMG [AvailInfo] + *** See "THE NAMING STORY" in HsDecls **** + +\begin{code} +getLocalDeclBinders :: Module -> RdrNameHsDecl -> TcRn m [AvailInfo] getLocalDeclBinders mod (TyClD tycl_decl) = -- For type and class decls, we generate Global names, with -- no export indicator. They need to be global because they get -- permanently bound into the TyCons and Classes. They don't need -- an export indicator because they are all implicitly exported. - getTyClDeclBinders mod tycl_decl `thenRn` \ (avail, sys_names) -> - - -- Record that the system names are available - recordLocalSlurps (mkNameSet sys_names) `thenRn_` - returnRn [avail] + mapM new (tyClDeclNames tycl_decl) `thenM` \ names@(main_name:_) -> + returnM [AvailTC main_name names] + where + new (nm,loc) = newTopBinder mod nm loc getLocalDeclBinders mod (ValD binds) - = mapRn new (collectLocatedHsBinders binds) `thenRn` \ avails -> - returnRn avails + = mappM new (collectLocatedHsBinders binds) `thenM` \ avails -> + returnM avails where - new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenRn` \ name -> - returnRn (Avail name) + new (rdr_name, loc) = newTopBinder mod rdr_name loc `thenM` \ name -> + returnM (Avail name) getLocalDeclBinders mod (ForD (ForeignImport nm _ _ _ loc)) - = newTopBinder mod nm loc `thenRn` \ name -> - returnRn [Avail name] + = newTopBinder mod nm loc `thenM` \ name -> + returnM [Avail name] getLocalDeclBinders mod (ForD _) - = returnRn [] + = returnM [] -getLocalDeclBinders mod (FixD _) = returnRn [] -getLocalDeclBinders mod (DeprecD _) = returnRn [] -getLocalDeclBinders mod (DefD _) = returnRn [] -getLocalDeclBinders mod (InstD _) = returnRn [] -getLocalDeclBinders mod (RuleD _) = returnRn [] +getLocalDeclBinders mod (FixD _) = returnM [] +getLocalDeclBinders mod (DeprecD _) = returnM [] +getLocalDeclBinders mod (DefD _) = returnM [] +getLocalDeclBinders mod (InstD _) = returnM [] +getLocalDeclBinders mod (RuleD _) = returnM [] \end{code} @@ -268,21 +327,21 @@ available, and filters it through the import spec (if any). \begin{code} filterImports :: ModuleName -- The module being imported - -> WhereFrom -- Tells whether it's a {-# SOURCE #-} import + -> IsBootInterface -- Tells whether it's a {-# SOURCE #-} import -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding -> [AvailInfo] -- What's available - -> RnMG ([AvailInfo], -- What's imported + -> TcRn m ([AvailInfo], -- What's imported NameSet) -- What was imported explicitly -- Complains if import spec mentions things that the module doesn't export -- Warns/informs if import spec contains duplicates. filterImports mod from Nothing imports - = returnRn (imports, emptyNameSet) + = returnM (imports, emptyNameSet) filterImports mod from (Just (want_hiding, import_items)) total_avails - = flatMapRn get_item import_items `thenRn` \ avails_w_explicits -> + = mappM get_item import_items `thenM` \ avails_w_explicits_s -> let - (item_avails, explicits_s) = unzip avails_w_explicits + (item_avails, explicits_s) = unzip (concat avails_w_explicits_s) explicits = foldl addListToNameSet emptyNameSet explicits_s in if want_hiding then @@ -290,10 +349,10 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails hidden = availsToNameSet item_avails keep n = not (n `elemNameSet` hidden) in - returnRn (pruneAvails keep total_avails, emptyNameSet) + returnM (pruneAvails keep total_avails, emptyNameSet) else -- Just item_avails imported; nothing to be hidden - returnRn (item_avails, explicits) + returnM (item_avails, explicits) where import_fm :: FiniteMap OccName AvailInfo import_fm = listToFM [ (nameOccName name, avail) @@ -303,10 +362,10 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails -- they won't make any difference because naked entities like T -- in an import list map to TcOccs, not VarOccs. - bale_out item = addErrRn (badImportItemErr mod from item) `thenRn_` - returnRn [] + bale_out item = addErr (badImportItemErr mod from item) `thenM_` + returnM [] - get_item :: RdrNameIE -> RnMG [(AvailInfo, [Name])] + get_item :: RdrNameIE -> TcRn m [(AvailInfo, [Name])] -- Empty list for a bad item. -- Singleton is typical case. -- Can have two when we are hiding, and mention C which might be @@ -320,24 +379,24 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails Just avail@(AvailTC _ [n]) -> -- This occurs when you import T(..), but -- only export T abstractly. The single [n] -- in the AvailTC is the type or class itself - ifOptRn Opt_WarnMisc (addWarnRn (dodgyImportWarn mod item)) `thenRn_` - returnRn [(avail, [availName avail])] - Just avail -> returnRn [(avail, [availName avail])] + ifOptM Opt_WarnMisc (addWarn (dodgyImportWarn mod item)) `thenM_` + returnM [(avail, [availName avail])] + Just avail -> returnM [(avail, [availName avail])] get_item item@(IEThingAbs n) | want_hiding -- hiding( C ) -- Here the 'C' can be a data constructor *or* a type/class = case catMaybes [check_item item, check_item (IEVar data_n)] of [] -> bale_out item - avails -> returnRn [(a, []) | a <- avails] + avails -> returnM [(a, []) | a <- avails] -- The 'explicits' list is irrelevant when hiding where - data_n = setRdrNameOcc n (setOccNameSpace (rdrNameOcc n) dataName) + data_n = setRdrNameSpace n dataName get_item item = case check_item item of Nothing -> bale_out item - Just avail -> returnRn [(avail, availNames avail)] + Just avail -> returnM [(avail, availNames avail)] check_item item | not (maybeToBool maybe_in_import_avails) || @@ -356,52 +415,41 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails Just filtered_avail = maybe_filtered_avail \end{code} - - -%************************************************************************ -%* * -\subsection{Qualifiying imports} -%* * -%************************************************************************ - \begin{code} -type ExportAvails - = (FiniteMap ModuleName Avails, - -- Used to figure out "module M" export specifiers - -- Includes avails only from *unqualified* imports - -- (see 1.4 Report Section 5.1.1) - - AvailEnv) -- All the things that are available. - -- Its domain is all the "main" things; - -- i.e. *excluding* class ops and constructors - -- (which appear inside their parent AvailTC) - -mkEmptyExportAvails :: ModuleName -> ExportAvails -mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyNameEnv) - -plusExportA