diff options
215 files changed, 3048 insertions, 2446 deletions
diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h index 6a01f6858d..23d67ebe50 100644 --- a/ghc/compiler/HsVersions.h +++ b/ghc/compiler/HsVersions.h @@ -25,7 +25,30 @@ you will screw up the layout where they are used in case expressions! #else #define ASSERT(e) #endif -#define CHK_Ubiq() import Ubiq + +#if __STDC__ +#define CAT2(a,b)a##b +#else +#define CAT2(a,b)a/**/b +#endif + +#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 200 +# define REALLY_HASKELL_1_3 +# define SYN_IE(a) a +# define IMPORT_DELOOPER(mod) import CAT2(mod,_1_3) +# define IMPORT_1_3(mod) import mod +# define _tagCmp compare +# define _LT LT +# define _EQ EQ +# define _GT GT +# define Text Show +#else +# define SYN_IE(a) a(..) +# define IMPORT_DELOOPER(mod) import mod +# define IMPORT_1_3(mod) {--} +#endif +#define IMP_Ubiq() IMPORT_DELOOPER(Ubiq) +#define CHK_Ubiq() IMPORT_DELOOPER(Ubiq) #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 26 #define trace _trace @@ -76,7 +99,7 @@ you will screw up the layout where they are used in case expressions! #endif {- ! __GLASGOW_HASKELL__ -} -#if __GLASGOW_HASKELL__ >= 23 +#if __GLASGOW_HASKELL__ >= 23 && __GLASGOW_HASKELL__ < 200 #define USE_FAST_STRINGS 1 #define FAST_STRING _PackedString #define SLIT(x) (_packCString (A# x#)) diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile index 58072a1075..a47b639c5f 100644 --- a/ghc/compiler/Jmakefile +++ b/ghc/compiler/Jmakefile @@ -27,6 +27,12 @@ SuffixRules_flexish() SuffixRule_c_o() LitSuffixRule(.lprl,.prl) /* for makeSymbolList.prl */ +.SUFFIXES: .lhi +.lhi.hi: + $(RM) $@ + $(GHC_UNLIT) $< $@ + @chmod 444 $@ + /* assume ALL source is in subdirectories one level below they don't have Jmakefiles; this Jmakefile controls everything */ @@ -356,6 +362,28 @@ SIMPL_SRCS_LHS \ STG_SRCS_LHS \ BACKSRCS_LHS NATIVEGEN_SRCS_LHS +#if GhcBuilderVersion >= 200 +# define loop_hi(f) CAT3(f,_1_3,.hi) +#else +# define loop_hi(f) CAT2(f,.hi) +#endif + +DELOOP_HIs = \ +utils/Ubiq.hi \ +absCSyn/AbsCLoop.hi \ +basicTypes/IdLoop.hi \ +codeGen/CgLoop1.hi \ +codeGen/CgLoop2.hi \ +deSugar/DsLoop.hi \ +hsSyn/HsLoop.hi \ +nativeGen/NcgLoop.hi \ +prelude/PrelLoop.hi \ +rename/RnLoop.hi \ +simplCore/SmplLoop.hi \ +typecheck/TcMLoop.hi \ +typecheck/TcLoop.hi \ +types/TyLoop.hi + /* \ */ @@ -471,36 +499,6 @@ HaskellCompileWithExtraFlags_Recursive(module,isuf,o,-c,extra_flags) /* OK, here we go: */ -utils/Ubiq.hi : utils/Ubiq.lhi - $(GHC_UNLIT) utils/Ubiq.lhi utils/Ubiq.hi - -absCSyn/AbsCLoop.hi : absCSyn/AbsCLoop.lhi - $(GHC_UNLIT) absCSyn/AbsCLoop.lhi absCSyn/AbsCLoop.hi -basicTypes/IdLoop.hi : basicTypes/IdLoop.lhi - $(GHC_UNLIT) basicTypes/IdLoop.lhi basicTypes/IdLoop.hi -codeGen/CgLoop1.hi : codeGen/CgLoop1.lhi - $(GHC_UNLIT) codeGen/CgLoop1.lhi codeGen/CgLoop1.hi -codeGen/CgLoop2.hi : codeGen/CgLoop2.lhi - $(GHC_UNLIT) codeGen/CgLoop2.lhi codeGen/CgLoop2.hi -deSugar/DsLoop.hi : deSugar/DsLoop.lhi - $(GHC_UNLIT) deSugar/DsLoop.lhi deSugar/DsLoop.hi -hsSyn/HsLoop.hi : hsSyn/HsLoop.lhi - $(GHC_UNLIT) hsSyn/HsLoop.lhi hsSyn/HsLoop.hi -nativeGen/NcgLoop.hi : nativeGen/NcgLoop.lhi - $(GHC_UNLIT) nativeGen/NcgLoop.lhi nativeGen/NcgLoop.hi -prelude/PrelLoop.hi : prelude/PrelLoop.lhi - $(GHC_UNLIT) prelude/PrelLoop.lhi prelude/PrelLoop.hi -rename/RnLoop.hi : rename/RnLoop.lhi - $(GHC_UNLIT) rename/RnLoop.lhi rename/RnLoop.hi -simplCore/SmplLoop.hi : simplCore/SmplLoop.lhi - $(GHC_UNLIT) simplCore/SmplLoop.lhi simplCore/SmplLoop.hi -typecheck/TcMLoop.hi : typecheck/TcMLoop.lhi - $(GHC_UNLIT) typecheck/TcMLoop.lhi typecheck/TcMLoop.hi -typecheck/TcLoop.hi : typecheck/TcLoop.lhi - $(GHC_UNLIT) typecheck/TcLoop.lhi typecheck/TcLoop.hi -types/TyLoop.hi : types/TyLoop.lhi - $(GHC_UNLIT) types/TyLoop.lhi types/TyLoop.hi - rename/ParseIface.hs : rename/ParseIface.y $(RM) rename/ParseIface.hs rename/ParseIface.hinfo happy -g -i rename/ParseIface.hinfo rename/ParseIface.y @@ -620,7 +618,7 @@ compile(reader/RdrHsSyn,lhs,) compile(rename/ParseIface,hs,) compile(rename/ParseUtils,lhs,) compile(rename/RnHsSyn,lhs,) -compile(rename/RnMonad,lhs,) +compile(rename/RnMonad,lhs,if_ghc(-fvia-C)) compile(rename/Rename,lhs,) compile(rename/RnNames,lhs,) compile(rename/RnSource,lhs,) @@ -672,7 +670,7 @@ compile(deforest/Deforest,lhs,) compile(deforest/TreelessForm,lhs,) #endif -compile(specialise/Specialise,lhs,) +compile(specialise/Specialise,lhs,-H12m if_ghc(-Onot)) /* -Onot for compile-space reasons */ compile(specialise/SpecEnv,lhs,) compile(specialise/SpecUtils,lhs,) @@ -702,7 +700,7 @@ compile(typecheck/TcInstDcls,lhs,) compile(typecheck/TcInstUtil,lhs,) compile(typecheck/TcMatches,lhs,) compile(typecheck/TcModule,lhs,) -compile(typecheck/TcMonad,lhs,) +compile(typecheck/TcMonad,lhs,if_ghc(-fvia-C)) compile(typecheck/TcKind,lhs,) compile(typecheck/TcType,lhs,) compile(typecheck/TcEnv,lhs,) @@ -716,7 +714,7 @@ compile(typecheck/Unify,lhs,) compile(types/Class,lhs,) compile(types/Kind,lhs,) -compile(types/PprType,lhs,) +compile(types/PprType,lhs,if_ghc26(-Onot)) /* avoid a 0.26 bug */ compile(types/TyCon,lhs,) compile(types/TyVar,lhs,) compile(types/Usage,lhs,) @@ -822,17 +820,17 @@ InstallBinaryTarget(hsp,$(INSTLIBDIR_GHC)) YaccRunWithExpectMsg(parser/hsparser,12,0) -UgenTarget(parser/constr) -UgenTarget(parser/binding) -UgenTarget(parser/pbinding) -UgenTarget(parser/entidt) -UgenTarget(parser/list) -UgenTarget(parser/literal) -UgenTarget(parser/maybe) -UgenTarget(parser/either) -UgenTarget(parser/qid) -UgenTarget(parser/tree) -UgenTarget(parser/ttype) +UgenTarget(parser,constr) +UgenTarget(parser,binding) +UgenTarget(parser,pbinding) +UgenTarget(parser,entidt) +UgenTarget(parser,list) +UgenTarget(parser,literal) +UgenTarget(parser,maybe) +UgenTarget(parser,either) +UgenTarget(parser,qid) +UgenTarget(parser,tree) +UgenTarget(parser,ttype) UGENS_C = parser/constr.c \ parser/binding.c \ @@ -884,6 +882,7 @@ MKDEPENDHS_OPTS= -o .hc -I$(MAIN_INCLUDE_DIR) -I$(COMPINFO_DIR) -x HsVersions.h #if HaskellCompilerType != HC_USE_HC_FILES /* otherwise, the dependencies jeopardize our .hc files -- which are all we have! */ +depend :: $(DELOOP_HIs) HaskellDependTarget( $(DEPSRCS) ) #endif diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index e518dcd6d6..41ee1f391b 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -35,7 +35,7 @@ module AbsCSyn {- ( CostRes(Cost) )-} where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CgCompInfo ( mAX_Vanilla_REG, mAX_Float_REG, mAX_Double_REG, lIVENESS_R1, lIVENESS_R2, diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index a074524793..af1f7af9c7 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -19,7 +19,7 @@ module AbsCUtils ( -- printing/forcing stuff comes from PprAbsC ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import AbsCSyn diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index f35342ca4b..c4f8ae6e61 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -16,7 +16,9 @@ module CLabel ( mkConEntryLabel, mkStaticConEntryLabel, mkRednCountsLabel, + mkConInfoTableLabel, mkPhantomInfoTableLabel, + mkStaticClosureLabel, mkStaticInfoTableLabel, mkVapEntryLabel, mkVapInfoTableLabel, @@ -45,12 +47,12 @@ module CLabel ( #endif ) where -import Ubiq{-uitous-} -import AbsCLoop ( CtrlReturnConvention(..), +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(AbsCLoop) ( CtrlReturnConvention(..), ctrlReturnConvAlg ) #if ! OMIT_NATIVE_CODEGEN -import NcgLoop ( underscorePrefix, fmtAsmLbl ) +IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl ) #endif import CStrings ( pp_cSEP ) @@ -110,26 +112,25 @@ unspecialised constructors are compared. \begin{code} data CLabelId = CLabelId Id +instance Ord3 CLabelId where + cmp (CLabelId a) (CLabelId b) = cmpId_withSpecDataCon a b + instance Eq CLabelId where - CLabelId a == CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> True; _ -> False } - CLabelId a /= CLabelId b = case cmpId_withSpecDataCon a b of { EQ_ -> False; _ -> True } + CLabelId a == CLabelId b = case (a `cmp` b) of { EQ_ -> True; _ -> False } + CLabelId a /= CLabelId b = case (a `cmp` b) of { EQ_ -> False; _ -> True } instance Ord CLabelId where - CLabelId a <= CLabelId b = case cmpId_withSpecDataCon a b - of { LT_ -> True; EQ_ -> True; GT__ -> False } - CLabelId a < CLabelId b = case cmpId_withSpecDataCon a b - of { LT_ -> True; EQ_ -> False; GT__ -> False } - CLabelId a >= CLabelId b = case cmpId_withSpecDataCon a b - of { LT_ -> False; EQ_ -> True; GT__ -> True } - CLabelId a > CLabelId b = case cmpId_withSpecDataCon a b - of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp (CLabelId a) (CLabelId b) = case cmpId_withSpecDataCon a b - of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } + CLabelId a <= CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } + CLabelId a < CLabelId b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } + CLabelId a >= CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } + CLabelId a > CLabelId b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } + _tagCmp (CLabelId a) (CLabelId b) = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } \end{code} \begin{code} data IdLabelInfo = Closure -- Label for (static???) closure + | StaticClosure -- Static closure -- e.g., nullary constructor | InfoTbl -- Info table for a closure; always read-only @@ -139,14 +140,15 @@ data IdLabelInfo -- encoded into the name) | ConEntry -- the only kind of entry pt for constructors - | StaticConEntry -- static constructor entry point + | ConInfoTbl -- corresponding info table + | StaticConEntry -- static constructor entry point | StaticInfoTbl -- corresponding info table | PhantomInfoTbl -- for phantom constructors that only exist in regs | VapInfoTbl Bool -- True <=> the update-reqd version; False <=> the no-update-reqd version - | VapEntry Bool + | VapEntry Bool -- Ticky-ticky counting | RednCounts -- Label of place to keep reduction-count info for this Id @@ -195,18 +197,28 @@ data RtsLabelInfo \end{code} \begin{code} -mkClosureLabel id = IdLabel (CLabelId id) Closure -mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl -mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd +mkClosureLabel id = IdLabel (CLabelId id) Closure +mkInfoTableLabel id = IdLabel (CLabelId id) InfoTbl +mkStdEntryLabel id = IdLabel (CLabelId id) EntryStd mkFastEntryLabel id arity = ASSERT(arity > 0) - IdLabel (CLabelId id) (EntryFast arity) -mkConEntryLabel id = IdLabel (CLabelId id) ConEntry -mkStaticConEntryLabel id = IdLabel (CLabelId id) StaticConEntry -mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts -mkPhantomInfoTableLabel id = IdLabel (CLabelId id) PhantomInfoTbl -mkStaticInfoTableLabel id = IdLabel (CLabelId id) StaticInfoTbl -mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag) -mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag) + IdLabel (CLabelId id) (EntryFast arity) + +mkStaticClosureLabel con = ASSERT(isDataCon con) + IdLabel (CLabelId con) StaticClosure +mkStaticInfoTableLabel con = ASSERT(isDataCon con) + IdLabel (CLabelId con) StaticInfoTbl +mkConInfoTableLabel con = ASSERT(isDataCon con) + IdLabel (CLabelId con) ConInfoTbl +mkPhantomInfoTableLabel con = ASSERT(isDataCon con) + IdLabel (CLabelId con) PhantomInfoTbl +mkConEntryLabel con = ASSERT(isDataCon con) + IdLabel (CLabelId con) ConEntry +mkStaticConEntryLabel con = ASSERT(isDataCon con) + IdLabel (CLabelId con) StaticConEntry + +mkRednCountsLabel id = IdLabel (CLabelId id) RednCounts +mkVapEntryLabel id upd_flag = IdLabel (CLabelId id) (VapEntry upd_flag) +mkVapInfoTableLabel id upd_flag = IdLabel (CLabelId id) (VapInfoTbl upd_flag) mkConUpdCodePtrVecLabel tycon tag = TyConLabel tycon (VecConUpdCode tag) mkStdUpdCodePtrVecLabel tycon tag = TyConLabel tycon (StdUpdCode tag) @@ -258,11 +270,12 @@ needsCDecl other = True Whether the labelled thing can be put in C "text space": \begin{code} -isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes -isReadOnly (IdLabel _ StaticInfoTbl) = True -- and so on, for other -isReadOnly (IdLabel _ PhantomInfoTbl) = True -isReadOnly (IdLabel _ (VapInfoTbl _)) = True -isReadOnly (IdLabel _ other) = False -- others: pessimistically, no +isReadOnly (IdLabel _ InfoTbl) = True -- info-tables: yes +isReadOnly (IdLabel _ ConInfoTbl) = True -- and so on, for other +isReadOnly (IdLabel _ StaticInfoTbl) = True +isReadOnly (IdLabel _ PhantomInfoTbl) = True +isReadOnly (IdLabel _ (VapInfoTbl _)) = True +isReadOnly (IdLabel _ other) = False -- others: pessimistically, no isReadOnly (TyConLabel _ _) = True isReadOnly (CaseLabel _ _) = True @@ -378,7 +391,9 @@ ppFlavor x = uppBeside pp_cSEP EntryStd -> uppPStr SLIT("entry") EntryFast arity -> --false:ASSERT (arity > 0) uppBeside (uppPStr SLIT("fast")) (uppInt arity) - ConEntry -> uppPStr SLIT("entry") + StaticClosure -> uppPStr SLIT("static_closure") + ConEntry -> uppPStr SLIT("con_entry") + ConInfoTbl -> uppPStr SLIT("con_info") StaticConEntry -> uppPStr SLIT("static_entry") StaticInfoTbl -> uppPStr SLIT("static_info") PhantomInfoTbl -> uppPStr SLIT("inregs_info") diff --git a/ghc/compiler/absCSyn/CStrings.lhs b/ghc/compiler/absCSyn/CStrings.lhs index aaf04bcfdc..4697911f89 100644 --- a/ghc/compiler/absCSyn/CStrings.lhs +++ b/ghc/compiler/absCSyn/CStrings.lhs @@ -18,6 +18,12 @@ CHK_Ubiq() -- debugging consistency check import Pretty import Unpretty( uppChar ) + +IMPORT_1_3(Char (isAlphanum)) +#ifdef REALLY_HASKELL_1_3 +ord = fromEnum :: Char -> Int +chr = toEnum :: Int -> Char +#endif \end{code} diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs index 8f5e4d72db..bf68114882 100644 --- a/ghc/compiler/absCSyn/Costs.lhs +++ b/ghc/compiler/absCSyn/Costs.lhs @@ -57,7 +57,7 @@ module Costs( costs, addrModeCosts, CostRes(Cost), nullCosts, Side(..) ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import AbsCSyn import PrimOp ( primOpNeedsWrapper, PrimOp(..) ) diff --git a/ghc/compiler/absCSyn/HeapOffs.lhs b/ghc/compiler/absCSyn/HeapOffs.lhs index e37b4b2e3c..0ce2a41725 100644 --- a/ghc/compiler/absCSyn/HeapOffs.lhs +++ b/ghc/compiler/absCSyn/HeapOffs.lhs @@ -31,9 +31,9 @@ module HeapOffs ( SpARelOffset(..), SpBRelOffset(..) ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} #if ! OMIT_NATIVE_CODEGEN -import AbsCLoop ( fixedHdrSizeInWords, varHdrSizeInWords ) +IMPORT_DELOOPER(AbsCLoop) ( fixedHdrSizeInWords, varHdrSizeInWords ) #endif import Maybes ( catMaybes ) diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 18053a7e91..75cbf2b16c 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -18,8 +18,8 @@ module PprAbsC ( #endif ) where -import Ubiq{-uitous-} -import AbsCLoop -- break its dependence on ClosureInfo +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(AbsCLoop) -- break its dependence on ClosureInfo import AbsCSyn @@ -62,10 +62,10 @@ call to a cost evaluation function @GRAN_EXEC@. For that, @pprAbsC@ has a new ``costs'' argument. %% HWL \begin{code} -writeRealC :: _FILE -> AbstractC -> IO () +writeRealC :: Handle -> AbstractC -> IO () -writeRealC file absC - = uppAppendFile file 80 ( +writeRealC handle absC + = uppPutStr handle 80 ( uppAbove (pprAbsC PprForC absC (costs absC)) (uppChar '\n') ) diff --git a/ghc/compiler/basicTypes/FieldLabel.lhs b/ghc/compiler/basicTypes/FieldLabel.lhs index d8f61d3393..53a1b5758c 100644 --- a/ghc/compiler/basicTypes/FieldLabel.lhs +++ b/ghc/compiler/basicTypes/FieldLabel.lhs @@ -8,7 +8,7 @@ module FieldLabel where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Name ( Name{-instance Eq/Outputable-} ) import Type ( Type(..) ) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index d302df49ae..5704027260 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -36,7 +36,7 @@ module Id {- ( getMentionedTyConsAndClassesFromId, dataConTag, dataConStrictMarks, - dataConSig, dataConArgTys, + dataConSig, dataConRawArgTys, dataConArgTys, dataConTyCon, dataConArity, dataConFieldLabels, @@ -44,6 +44,7 @@ module Id {- ( -- PREDICATES isDataCon, isTupleCon, + isNullaryDataCon, isSpecId_maybe, isSpecPragmaId_maybe, toplevelishId, externallyVisibleId, isTopLevId, isWorkerId, isWrapperId, @@ -94,9 +95,9 @@ module Id {- ( GenIdSet(..), IdSet(..) )-} where -import Ubiq -import IdLoop -- for paranoia checking -import TyLoop -- for paranoia checking +IMP_Ubiq() +IMPORT_DELOOPER(IdLoop) -- for paranoia checking +IMPORT_DELOOPER(TyLoop) -- for paranoia checking import Bag import Class ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp ) @@ -1043,17 +1044,17 @@ mkSuperDictSelId u c sc ty info n = mkCompoundName u SLIT("sdsel") [origName cname, origName sc] cname -mkMethodSelId u c op ty info - = Id u n ty (MethodSelId c op) NoPragmaInfo info +mkMethodSelId u rec_c op ty info + = Id u n ty (MethodSelId rec_c op) NoPragmaInfo info where - cname = getName c -- we get other info out of here + cname = getName rec_c -- we get other info out of here n = mkCompoundName u SLIT("meth") [origName cname, Unqual (classOpString op)] cname -mkDefaultMethodId u c op gen ty info - = Id u n ty (DefaultMethodId c op gen) NoPragmaInfo info +mkDefaultMethodId u rec_c op gen ty info + = Id u n ty (DefaultMethodId rec_c op gen) NoPragmaInfo info where - cname = getName c -- we get other info out of here + cname = getName rec_c -- we get other info out of here n = mkCompoundName u SLIT("defm") [origName cname, Unqual (classOpString op)] cname @@ -1227,6 +1228,8 @@ dataConArity id@(Id _ _ _ _ _ id_info) Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id) Just i -> i +isNullaryDataCon con = dataConArity con == 0 -- function of convenience + addIdArity :: Id -> Int -> Id addIdArity (Id u n ty details pinfo info) arity = Id u n ty details pinfo (info `addInfo` (mkArityInfo arity)) @@ -1405,6 +1408,9 @@ dataConStrictMarks (Id _ _ _ (DataConId _ stricts _ _ _ _ _) _ _) = stricts dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _) = nOfThem arity NotMarkedStrict +dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience +dataConRawArgTys con = case (dataConSig con) of { (_,_, arg_tys,_) -> arg_tys } + dataConArgTys :: DataCon -> [Type] -- Instantiated at these types -> [Type] -- Needs arguments of these types @@ -1583,15 +1589,15 @@ instance Ord3 (GenId ty) where cmp = cmpId instance Eq (GenId ty) where - a == b = case cmpId a b of { EQ_ -> True; _ -> False } - a /= b = case cmpId a b of { EQ_ -> False; _ -> True } + a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } + a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } instance Ord (GenId ty) where - a <= b = case cmpId a b of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case cmpId a b of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case cmpId a b of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case cmpId a b of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp a b = case cmpId a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } + a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } + a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } + a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } + a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } + _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } \end{code} @cmpId_withSpecDataCon@ ensures that any spectys are taken into diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 4d2a2a138c..6946df3883 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -67,9 +67,9 @@ module IdInfo ( ) where -import Ubiq +IMP_Ubiq() -import IdLoop -- IdInfo is a dependency-loop ranch, and +IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and -- we break those loops by using IdLoop and -- *not* importing much of anything else, -- except from the very general "utils". @@ -77,6 +77,7 @@ import IdLoop -- IdInfo is a dependency-loop ranch, and import CmdLineOpts ( opt_OmitInterfacePragmas ) import Maybes ( firstJust ) import MatchEnv ( nullMEnv, isEmptyMEnv, mEnvToList ) +import OccurAnal ( occurAnalyseGlobalExpr ) import Outputable ( ifPprInterface, Outputable(..){-instances-} ) import PprStyle ( PprStyle(..) ) import Pretty @@ -84,10 +85,13 @@ import SrcLoc ( mkUnknownSrcLoc ) import Type ( eqSimpleTy, splitFunTyExpandingDicts ) import Util ( mapAccumL, panic, assertPanic, pprPanic ) +#ifdef REALLY_HASKELL_1_3 +ord = fromEnum :: Char -> Int +#endif + applySubstToTy = panic "IdInfo.applySubstToTy" showTypeCategory = panic "IdInfo.showTypeCategory" mkFormSummary = panic "IdInfo.mkFormSummary" -occurAnalyseGlobalExpr = panic "IdInfo.occurAnalyseGlobalExpr" isWrapperFor = panic "IdInfo.isWrapperFor" pprCoreUnfolding = panic "IdInfo.pprCoreUnfolding" \end{code} @@ -607,7 +611,11 @@ as the worker requires. Hence we have to give up altogether, and call the wrapper only; so under these circumstances we return \tr{False}. \begin{code} +#ifdef REALLY_HASKELL_1_3 +instance Read Demand where +#else instance Text Demand where +#endif readList str = read_em [{-acc-}] str where read_em acc [] = [(reverse acc, "")] @@ -626,6 +634,9 @@ instance Text Demand where read_em acc other = panic ("IdInfo.readem:"++other) +#ifdef REALLY_HASKELL_1_3 +instance Show Demand where +#endif showList wrap_args rest = (concat (map show1 wrap_args)) ++ rest where show1 (WwLazy False) = "L" @@ -725,7 +736,7 @@ pp_strictness sty for_this_id_maybe better_id_fn inline_env \begin{code} mkUnfolding guide expr - = GenForm False (mkFormSummary NoStrictnessInfo expr) + = GenForm (mkFormSummary NoStrictnessInfo expr) (occurAnalyseGlobalExpr expr) guide \end{code} @@ -735,8 +746,8 @@ noInfo_UF = NoUnfoldingDetails getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _) = case unfolding of - GenForm _ _ _ BadUnfolding -> NoUnfoldingDetails - unfolding_as_was -> unfolding_as_was + GenForm _ _ BadUnfolding -> NoUnfoldingDetails + unfolding_as_was -> unfolding_as_was -- getInfo_UF ensures that any BadUnfoldings are never returned -- We had to delay the test required in TcPragmas until now due @@ -757,9 +768,9 @@ pp_unfolding sty for_this_id inline_env uf_details pp (MagicForm tag _) = ppCat [ppPStr SLIT("_MF_"), ppPStr tag] - pp (GenForm _ _ _ BadUnfolding) = pp_NONE + pp (GenForm _ _ BadUnfolding) = pp_NONE - pp (GenForm _ _ template guide) + pp (GenForm _ template guide) = let untagged = unTagBinders template in @@ -798,7 +809,11 @@ updateInfoMaybe (SomeUpdateInfo u) = Just u Text instance so that the update annotations can be read in. \begin{code} +#ifdef REALLY_HASKELL_1_3 +instance Read UpdateInfo where +#else instance Text UpdateInfo where +#endif readsPrec p s | null s = panic "IdInfo: empty update pragma?!" | otherwise = [(SomeUpdateInfo (map ok_digit s),"")] where diff --git a/ghc/compiler/basicTypes/IdLoop.lhi b/ghc/compiler/basicTypes/IdLoop.lhi index abd59f3566..deeae88b42 100644 --- a/ghc/compiler/basicTypes/IdLoop.lhi +++ b/ghc/compiler/basicTypes/IdLoop.lhi @@ -65,11 +65,9 @@ data MagicUnfoldingFun data FormSummary = WhnfForm | BottomForm | OtherForm data UnfoldingDetails = NoUnfoldingDetails - | LitForm Literal | OtherLitForm [Literal] - | ConForm (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) [GenCoreArg (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique] | OtherConForm [GenId (GenType (GenTyVar (GenUsage Unique)) Unique)] - | GenForm Bool FormSummary (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) UnfoldingGuidance + | GenForm FormSummary (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) UnfoldingGuidance | MagicForm _PackedString MagicUnfoldingFun data UnfoldingGuidance diff --git a/ghc/compiler/basicTypes/IdUtils.lhs b/ghc/compiler/basicTypes/IdUtils.lhs index 043b37dea4..afdc973f48 100644 --- a/ghc/compiler/basicTypes/IdUtils.lhs +++ b/ghc/compiler/basicTypes/IdUtils.lhs @@ -8,19 +8,19 @@ module IdUtils ( primOpNameInfo, primOpId ) where -import Ubiq -import PrelLoop -- here for paranoia checking +IMP_Ubiq() +IMPORT_DELOOPER(PrelLoop) -- here for paranoia checking import CoreSyn import CoreUnfold ( UnfoldingGuidance(..) ) -import Id ( mkPreludeId ) +import Id ( mkPreludeId, mkTemplateLocals ) import IdInfo -- quite a few things import Name ( mkBuiltinName ) import PrelMods ( pRELUDE_BUILTIN ) import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str, PrimOpInfo(..), PrimOpResultInfo(..) ) import RnHsSyn ( RnName(..) ) -import Type ( mkForAllTys, mkFunTys, applyTyCon ) +import Type ( mkForAllTys, mkFunTys, mkTyVarTy, applyTyCon ) import TysWiredIn ( boolTy ) import Unique ( mkPrimOpIdUnique ) import Util ( panic ) @@ -81,15 +81,12 @@ The functions to make common unfoldings are tedious. \begin{code} mk_prim_unfold :: PrimOp -> [TyVar] -> [Type] -> CoreExpr{-template-} -mk_prim_unfold prim_op tvs arg_tys - = panic "IdUtils.mk_prim_unfold" -{- +mk_prim_unfold prim_op tyvars arg_tys = let - (inst_env, tyvars, tyvar_tys) = instantiateTyVars tvs (map uniqueOf tvs) - inst_arg_tys = map (instantiateTauTy inst_env) arg_tys - vars = mkTemplateLocals inst_arg_tys + vars = mkTemplateLocals arg_tys in - mkLam tyvars vars (Prim prim_op tyvar_tys [VarArg v | v <- vars]) --} + mkLam tyvars vars $ + Prim prim_op + ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++ [VarArg v | v <- vars]) \end{code} diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index 8fb477ee0b..1330a3d328 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[Literal]{@Literal@: Machine literals (unboxed, of course)} @@ -13,11 +13,9 @@ module Literal ( literalType, literalPrimRep, showLiteral, isNoRepLit, isLitLitLit - - -- and to make the interface self-sufficient.... ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} -- friends: import PrimRep ( PrimRep(..) ) -- non-abstract @@ -27,10 +25,10 @@ import TysPrim ( getPrimRepInfo, -- others: import CStrings ( stringToC, charToC, charToEasyHaskell ) -import TysWiredIn ( integerTy, rationalTy, stringTy ) +import TysWiredIn ( stringTy ) import Pretty -- pretty-printing stuff import PprStyle ( PprStyle(..), codeStyle ) -import Util ( panic ) +import Util ( thenCmp, panic ) \end{code} So-called @Literals@ are {\em either}: @@ -58,10 +56,10 @@ data Literal PrimRep | NoRepStr FAST_STRING -- the uncommitted ones - | NoRepInteger Integer - | NoRepRational Rational + | NoRepInteger Integer Type{-save what we learned in the typechecker-} + | NoRepRational Rational Type{-ditto-} - deriving (Eq, Ord) + -- deriving (Eq, Ord): no, don't want to compare Types -- The Ord is needed for the FiniteMap used in the lookForConstructor -- in SimplEnv. If you declared that lookForConstructor *ignores* -- constructor-applications with LitArg args, then you could get @@ -71,12 +69,56 @@ mkMachInt, mkMachWord :: Integer -> Literal mkMachInt x = MachInt x True{-signed-} mkMachWord x = MachInt x False{-unsigned-} + +instance Ord3 Literal where + cmp (MachChar a) (MachChar b) = a `tcmp` b + cmp (MachStr a) (MachStr b) = a `tcmp` b + cmp (MachAddr a) (MachAddr b) = a `tcmp` b + cmp (MachInt a b) (MachInt c d) = (a `tcmp` c) `thenCmp` (b `tcmp` d) + cmp (MachFloat a) (MachFloat b) = a `tcmp` b + cmp (MachDouble a) (MachDouble b) = a `tcmp` b + cmp (MachLitLit a b) (MachLitLit c d) = (a `tcmp` c) `thenCmp` (b `tcmp` d) + cmp (NoRepStr a) (NoRepStr b) = a `tcmp` b + cmp (NoRepInteger a _) (NoRepInteger b _) = a `tcmp` b + cmp (NoRepRational a _) (NoRepRational b _) = a `tcmp` b + + -- now we *know* the tags are different, so... + cmp other_1 other_2 + | tag1 _LT_ tag2 = LT_ + | otherwise = GT_ + where + tag1 = tagof other_1 + tag2 = tagof other_2 + + tagof (MachChar _) = ILIT(1) + tagof (MachStr _) = ILIT(2) + tagof (MachAddr _) = ILIT(3) + tagof (MachInt _ _) = ILIT(4) + tagof (MachFloat _) = ILIT(5) + tagof (MachDouble _) = ILIT(6) + tagof (MachLitLit _ _) = ILIT(7) + tagof (NoRepStr _) = ILIT(8) + tagof (NoRepInteger _ _) = ILIT(9) + tagof (NoRepRational _ _) = ILIT(10) + +tcmp x y = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ } + +instance Eq Literal where + a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } + a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } + +instance Ord Literal where + a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } + a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } + a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } + a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } + _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } \end{code} \begin{code} isNoRepLit (NoRepStr _) = True -- these are not primitive typed! -isNoRepLit (NoRepInteger _) = True -isNoRepLit (NoRepRational _) = True +isNoRepLit (NoRepInteger _ _) = True +isNoRepLit (NoRepRational _ _) = True isNoRepLit _ = False isLitLitLit (MachLitLit _ _) = True @@ -93,8 +135,8 @@ literalType (MachInt _ signed) = if signed then intPrimTy else wordPrimTy literalType (MachFloat _) = floatPrimTy literalType (MachDouble _) = doublePrimTy literalType (MachLitLit _ k) = case (getPrimRepInfo k) of { (_,t,_) -> t } -literalType (NoRepInteger _) = integerTy -literalType (NoRepRational _)= rationalTy +literalType (NoRepInteger _ t) = t +literalType (NoRepRational _ t) = t literalType (NoRepStr _) = stringTy \end{code} @@ -109,9 +151,9 @@ literalPrimRep (MachFloat _) = FloatRep literalPrimRep (MachDouble _) = DoubleRep literalPrimRep (MachLitLit _ k) = k #ifdef DEBUG -literalPrimRep (NoRepInteger _) = panic "literalPrimRep:NoRepInteger" -literalPrimRep (NoRepRational _)= panic "literalPrimRep:NoRepRational" -literalPrimRep (NoRepStr _) = panic "literalPrimRep:NoRepString" +literalPrimRep (NoRepInteger _ _) = panic "literalPrimRep:NoRepInteger" +literalPrimRep (NoRepRational _ _) = panic "literalPrimRep:NoRepRational" +literalPrimRep (NoRepStr _) = panic "literalPrimRep:NoRepString" #endif \end{code} @@ -160,12 +202,12 @@ instance Outputable Literal where ppr sty (MachFloat f) = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f, if_ubxd sty] ppr sty (MachDouble d) = ppBesides [ppRational d, if_ubxd sty, if_ubxd sty] - ppr sty (NoRepInteger i) + ppr sty (NoRepInteger i _) | codeStyle sty = ppInteger i | ufStyle sty = ppCat [ppStr "_NOREP_I_", ppInteger i] | otherwise = ppBesides [ppInteger i, ppChar 'I'] - ppr sty (NoRepRational r) + ppr sty (NoRepRational r _) | ufStyle sty = ppCat [ppStr "_NOREP_R_", ppInteger (numerator r), ppInteger (denominator r)] | codeStyle sty = panic "ppr.ForC.NoRepRational" | otherwise = ppBesides [ppRational r, ppChar 'R'] diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 905c4bcbe1..b6b07af74b 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -52,7 +52,7 @@ module Name ( isLexConId, isLexConSym, isLexVarId, isLexVarSym ) where -import Ubiq +IMP_Ubiq() import CStrings ( identToC, cSEP ) import Outputable ( Outputable(..) ) @@ -64,6 +64,10 @@ import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique, pprUnique, Unique ) import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic ) + +#ifdef REALLY_HASKELL_1_3 +ord = fromEnum :: Char -> Int +#endif \end{code} %************************************************************************ diff --git a/ghc/compiler/basicTypes/PprEnv.lhs b/ghc/compiler/basicTypes/PprEnv.lhs index d29b8755b3..07dd8ec372 100644 --- a/ghc/compiler/basicTypes/PprEnv.lhs +++ b/ghc/compiler/basicTypes/PprEnv.lhs @@ -23,7 +23,7 @@ module PprEnv ( -- lookupValVar, lookupTyVar, lookupUVar ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Pretty ( Pretty(..) ) import Unique ( initRenumberingUniques ) diff --git a/ghc/compiler/basicTypes/PragmaInfo.lhs b/ghc/compiler/basicTypes/PragmaInfo.lhs index fb02b0adb2..b1bf499774 100644 --- a/ghc/compiler/basicTypes/PragmaInfo.lhs +++ b/ghc/compiler/basicTypes/PragmaInfo.lhs @@ -8,7 +8,7 @@ module PragmaInfo where -import Ubiq +IMP_Ubiq() \end{code} \begin{code} diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index 650de416a4..03fb6c2364 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -22,7 +22,7 @@ module SrcLoc ( unpackSrcLoc ) where -import Ubiq +IMP_Ubiq() import PprStyle ( PprStyle(..) ) import Pretty diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs index bc6da1645f..1f45155020 100644 --- a/ghc/compiler/basicTypes/UniqSupply.lhs +++ b/ghc/compiler/basicTypes/UniqSupply.lhs @@ -21,7 +21,7 @@ module UniqSupply ( splitUniqSupply ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Unique import Util diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 7e7b7193bd..34172e678d 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -46,6 +46,7 @@ module Unique ( addrDataConKey, addrPrimTyConKey, addrTyConKey, + andandIdKey, appendIdKey, arrayPrimTyConKey, augmentIdKey, @@ -56,12 +57,11 @@ module Unique ( byteArrayPrimTyConKey, cCallableClassKey, cReturnableClassKey, - voidTyConKey, charDataConKey, charPrimTyConKey, charTyConKey, + composeIdKey, consDataConKey, - evalClassKey, doubleDataConKey, doublePrimTyConKey, doubleTyConKey, @@ -74,6 +74,7 @@ module Unique ( eqClassOpKey, eqDataConKey, errorIdKey, + evalClassKey, falseDataConKey, floatDataConKey, floatPrimTyConKey, @@ -81,12 +82,16 @@ module Unique ( floatingClassKey, foldlIdKey, foldrIdKey, + foreignObjDataConKey, + foreignObjPrimTyConKey, + foreignObjTyConKey, forkIdKey, fractionalClassKey, fromIntClassOpKey, fromIntegerClassOpKey, fromRationalClassOpKey, funTyConKey, + functorClassKey, geClassOpKey, gtDataConKey, iOTyConKey, @@ -100,23 +105,25 @@ module Unique ( integerTyConKey, integerZeroIdKey, integralClassKey, + irrefutPatErrorIdKey, ixClassKey, + lexIdKey, liftDataConKey, liftTyConKey, listTyConKey, ltDataConKey, mainIdKey, mainPrimIOIdKey, - foreignObjDataConKey, - foreignObjPrimTyConKey, - foreignObjTyConKey, monadClassKey, - monadZeroClassKey, monadPlusClassKey, - functorClassKey, + monadZeroClassKey, mutableArrayPrimTyConKey, mutableByteArrayPrimTyConKey, nilDataConKey, + noDefaultMethodErrorIdKey, + nonExhaustiveGuardsErrorIdKey, + nonExplicitMethodErrorIdKey, + notIdKey, numClassKey, ordClassKey, orderingTyConKey, @@ -124,22 +131,20 @@ module Unique ( parErrorIdKey, parIdKey, patErrorIdKey, - recConErrorIdKey, - recUpdErrorIdKey, - irrefutPatErrorIdKey, - nonExhaustiveGuardsErrorIdKey, - noDefaultMethodErrorIdKey, - nonExplicitMethodErrorIdKey, primIoTyConKey, + primIoDataConKey, ratioDataConKey, ratioTyConKey, rationalTyConKey, readClassKey, + readParenIdKey, realClassKey, realFloatClassKey, realFracClassKey, realWorldPrimIdKey, realWorldTyConKey, + recConErrorIdKey, + recUpdErrorIdKey, return2GMPsDataConKey, return2GMPsTyConKey, returnIntAndGMPDataConKey, @@ -147,7 +152,11 @@ module Unique ( runSTIdKey, seqIdKey, showClassKey, + showParenIdKey, + showSpaceIdKey, + showStringIdKey, stTyConKey, + stDataConKey, stablePtrDataConKey, stablePtrPrimTyConKey, stablePtrTyConKey, @@ -163,10 +172,10 @@ module Unique ( stateAndDoublePrimTyConKey, stateAndFloatPrimDataConKey, stateAndFloatPrimTyConKey, - stateAndIntPrimDataConKey, - stateAndIntPrimTyConKey, stateAndForeignObjPrimDataConKey, stateAndForeignObjPrimTyConKey, + stateAndIntPrimDataConKey, + stateAndIntPrimTyConKey, stateAndMutableArrayPrimDataConKey, stateAndMutableArrayPrimTyConKey, stateAndMutableByteArrayPrimDataConKey, @@ -182,19 +191,22 @@ module Unique ( stateDataConKey, statePrimTyConKey, stateTyConKey, - stringTyConKey, synchVarPrimTyConKey, + thenMClassOpKey, traceIdKey, trueDataConKey, unpackCString2IdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey, unpackCStringIdKey, - voidPrimIdKey, - voidPrimTyConKey, + ureadListIdKey, + ushowListIdKey, + voidIdKey, + voidTyConKey, wordDataConKey, wordPrimTyConKey, - wordTyConKey + wordTyConKey, + zeroClassOpKey , copyableIdKey , noFollowIdKey , parAtAbsIdKey @@ -207,7 +219,7 @@ module Unique ( import PreludeGlaST -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Pretty import Util @@ -325,7 +337,6 @@ instance Outputable Unique where instance Text Unique where showsPrec p uniq rest = _UNPK_ (showUnique uniq) - readsPrec p = panic "no readsPrec for Unique" \end{code} %************************************************************************ @@ -498,10 +509,10 @@ stateAndStablePtrPrimTyConKey = mkPreludeTyConUnique 45 stateAndWordPrimTyConKey = mkPreludeTyConUnique 46 statePrimTyConKey = mkPreludeTyConUnique 47 stateTyConKey = mkPreludeTyConUnique 48 -stringTyConKey = mkPreludeTyConUnique 49 + -- 49 is spare stTyConKey = mkPreludeTyConUnique 50 primIoTyConKey = mkPreludeTyConUnique 51 -voidPrimTyConKey = mkPreludeTyConUnique 52 + -- 52 is spare wordPrimTyConKey = mkPreludeTyConUnique 53 wordTyConKey = mkPreludeTyConUnique 54 voidTyConKey = mkPreludeTyConUnique 55 @@ -540,7 +551,7 @@ stateAndCharPrimDataConKey = mkPreludeDataConUnique 28 stateAndDoublePrimDataConKey = mkPreludeDataConUnique 29 stateAndFloatPrimDataConKey = mkPreludeDataConUnique 30 stateAndIntPrimDataConKey = mkPreludeDataConUnique 31 -stateAndForeignObjPrimDataConKey = mkPreludeDataConUnique 32 +stateAndForeignObjPrimDataConKey = mkPreludeDataConUnique 32 stateAndMutableArrayPrimDataConKey = mkPreludeDataConUnique 33 stateAndMutableByteArrayPrimDataConKey = mkPreludeDataConUnique 34 stateAndSynchVarPrimDataConKey = mkPreludeDataConUnique 35 @@ -550,6 +561,8 @@ stateAndWordPrimDataConKey = mkPreludeDataConUnique 38 stateDataConKey = mkPreludeDataConUnique 39 trueDataConKey = mkPreludeDataConUnique 40 wordDataConKey = mkPreludeDataConUnique 41 +stDataConKey = mkPreludeDataConUnique 42 +primIoDataConKey = mkPreludeDataConUnique 43 \end{code} %************************************************************************ @@ -560,61 +573,73 @@ wordDataConKey = mkPreludeDataConUnique 41 \begin{code} absentErrorIdKey = mkPreludeMiscIdUnique 1 -appendIdKey = mkPreludeMiscIdUnique 2 -augmentIdKey = mkPreludeMiscIdUnique 3 -buildIdKey = mkPreludeMiscIdUnique 4 -errorIdKey = mkPreludeMiscIdUnique 5 -foldlIdKey = mkPreludeMiscIdUnique 6 -foldrIdKey = mkPreludeMiscIdUnique 7 -forkIdKey = mkPreludeMiscIdUnique 8 -int2IntegerIdKey = mkPreludeMiscIdUnique 9 -integerMinusOneIdKey = mkPreludeMiscIdUnique 10 -integerPlusOneIdKey = mkPreludeMiscIdUnique 11 -integerPlusTwoIdKey = mkPreludeMiscIdUnique 12 -integerZeroIdKey = mkPreludeMiscIdUnique 13 -packCStringIdKey = mkPreludeMiscIdUnique 14 -parErrorIdKey = mkPreludeMiscIdUnique 15 -parIdKey = mkPreludeMiscIdUnique 16 -patErrorIdKey = mkPreludeMiscIdUnique 17 -realWorldPrimIdKey = mkPreludeMiscIdUnique 18 -runSTIdKey = mkPreludeMiscIdUnique 19 -seqIdKey = mkPreludeMiscIdUnique 20 -traceIdKey = mkPreludeMiscIdUnique 21 -unpackCString2IdKey = mkPreludeMiscIdUnique 22 -unpackCStringAppendIdKey = mkPreludeMiscIdUnique 23 -unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 24 -unpackCStringIdKey = mkPreludeMiscIdUnique 25 -voidPrimIdKey = mkPreludeMiscIdUnique 26 -mainIdKey = mkPreludeMiscIdUnique 27 -mainPrimIOIdKey = mkPreludeMiscIdUnique 28 -recConErrorIdKey = mkPreludeMiscIdUnique 29 -recUpdErrorIdKey = mkPreludeMiscIdUnique 30 -irrefutPatErrorIdKey = mkPreludeMiscIdUnique 31 -nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 32 -noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 33 -nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 34 - -copyableIdKey = mkPreludeMiscIdUnique 35 -noFollowIdKey = mkPreludeMiscIdUnique 36 -parAtAbsIdKey = mkPreludeMiscIdUnique 37 -parAtForNowIdKey = mkPreludeMiscIdUnique 38 -parAtIdKey = mkPreludeMiscIdUnique 39 -parAtRelIdKey = mkPreludeMiscIdUnique 40 -parGlobalIdKey = mkPreludeMiscIdUnique 41 -parLocalIdKey = mkPreludeMiscIdUnique 42 +andandIdKey = mkPreludeMiscIdUnique 2 +appendIdKey = mkPreludeMiscIdUnique 3 +augmentIdKey = mkPreludeMiscIdUnique 4 +buildIdKey = mkPreludeMiscIdUnique 5 +composeIdKey = mkPreludeMiscIdUnique 6 +errorIdKey = mkPreludeMiscIdUnique 7 +foldlIdKey = mkPreludeMiscIdUnique 8 +foldrIdKey = mkPreludeMiscIdUnique 9 +forkIdKey = mkPreludeMiscIdUnique 10 +int2IntegerIdKey = mkPreludeMiscIdUnique 11 +integerMinusOneIdKey = mkPreludeMiscIdUnique 12 +integerPlusOneIdKey = mkPreludeMiscIdUnique 13 +integerPlusTwoIdKey = mkPreludeMiscIdUnique 14 +integerZeroIdKey = mkPreludeMiscIdUnique 15 +irrefutPatErrorIdKey = mkPreludeMiscIdUnique 16 +lexIdKey = mkPreludeMiscIdUnique 17 +mainIdKey = mkPreludeMiscIdUnique 18 +mainPrimIOIdKey = mkPreludeMiscIdUnique 19 +noDefaultMethodErrorIdKey = mkPreludeMiscIdUnique 20 +nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 21 +nonExplicitMethodErrorIdKey = mkPreludeMiscIdUnique 22 +notIdKey = mkPreludeMiscIdUnique 23 +packCStringIdKey = mkPreludeMiscIdUnique 24 +parErrorIdKey = mkPreludeMiscIdUnique 25 +parIdKey = mkPreludeMiscIdUnique 26 +patErrorIdKey = mkPreludeMiscIdUnique 27 +readParenIdKey = mkPreludeMiscIdUnique 28 +realWorldPrimIdKey = mkPreludeMiscIdUnique 29 +recConErrorIdKey = mkPreludeMiscIdUnique 30 +recUpdErrorIdKey = mkPreludeMiscIdUnique 31 +runSTIdKey = mkPreludeMiscIdUnique 32 +seqIdKey = mkPreludeMiscIdUnique 33 +showParenIdKey = mkPreludeMiscIdUnique 34 +showSpaceIdKey = mkPreludeMiscIdUnique 35 +showStringIdKey = mkPreludeMiscIdUnique 36 +traceIdKey = mkPreludeMiscIdUnique 37 +unpackCString2IdKey = mkPreludeMiscIdUnique 38 +unpackCStringAppendIdKey = mkPreludeMiscIdUnique 39 +unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 40 +unpackCStringIdKey = mkPreludeMiscIdUnique 41 +voidIdKey = mkPreludeMiscIdUnique 42 +ushowListIdKey = mkPreludeMiscIdUnique 43 +ureadListIdKey = mkPreludeMiscIdUnique 44 + +copyableIdKey = mkPreludeMiscIdUnique 45 +noFollowIdKey = mkPreludeMiscIdUnique 46 +parAtAbsIdKey = mkPreludeMiscIdUnique 47 +parAtForNowIdKey = mkPreludeMiscIdUnique 48 +parAtIdKey = mkPreludeMiscIdUnique 49 +parAtRelIdKey = mkPreludeMiscIdUnique 50 +parGlobalIdKey = mkPreludeMiscIdUnique 51 +parLocalIdKey = mkPreludeMiscIdUnique 52 \end{code} Certain class operations from Prelude classes. They get their own uniques so we can look them up easily when we want to conjure them up during type checking. \begin{code} -fromIntClassOpKey = mkPreludeMiscIdUnique 37 -fromIntegerClassOpKey = mkPreludeMiscIdUnique 38 -fromRationalClassOpKey = mkPreludeMiscIdUnique 39 -enumFromClassOpKey = mkPreludeMiscIdUnique 40 -enumFromThenClassOpKey = mkPreludeMiscIdUnique 41 -enumFromToClassOpKey = mkPreludeMiscIdUnique 42 -enumFromThenToClassOpKey= mkPreludeMiscIdUnique 43 -eqClassOpKey = mkPreludeMiscIdUnique 44 -geClassOpKey = mkPreludeMiscIdUnique 45 +fromIntClassOpKey = mkPreludeMiscIdUnique 53 +fromIntegerClassOpKey = mkPreludeMiscIdUnique 54 +fromRationalClassOpKey = mkPreludeMiscIdUnique 55 +enumFromClassOpKey = mkPreludeMiscIdUnique 56 +enumFromThenClassOpKey = mkPreludeMiscIdUnique 57 +enumFromToClassOpKey = mkPreludeMiscIdUnique 58 +enumFromThenToClassOpKey= mkPreludeMiscIdUnique 59 +eqClassOpKey = mkPreludeMiscIdUnique 60 +geClassOpKey = mkPreludeMiscIdUnique 61 +zeroClassOpKey = mkPreludeMiscIdUnique 62 +thenMClassOpKey = mkPreludeMiscIdUnique 63 -- (>>=) \end{code} diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index b00aca77fa..8edd5bd9dc 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -26,8 +26,8 @@ module CgBindery ( rebindToAStack, rebindToBStack ) where -import Ubiq{-uitous-} -import CgLoop1 -- here for paranoia-checking +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(CgLoop1) -- here for paranoia-checking import AbsCSyn import CgMonad diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 2d0f3aebd1..17d61261c1 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -12,8 +12,8 @@ module CgCase ( cgCase, saveVolatileVarsAndRegs ) where -import Ubiq{-uitous-} -import CgLoop2 ( cgExpr, getPrimOpArgAmodes ) +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(CgLoop2) ( cgExpr, getPrimOpArgAmodes ) import CgMonad import StgSyn @@ -41,7 +41,7 @@ import CgStackery ( allocAStack, allocBStack, allocAStackTop, allocBStackTop ) import CgTailCall ( tailCallBusiness, performReturn ) import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot ) import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel, - mkAltLabel, mkClosureLabel + mkAltLabel ) import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon ) import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) @@ -645,7 +645,6 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging where lf_info = mkConLFInfo con tag = dataConTag con - closure_lbl = mkClosureLabel con -- alloc_code generates code to allocate constructor con, whose args are -- in the arguments to alloc_code, assigning the result to Node. diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 81ff55f65c..cfd5ceade1 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -12,8 +12,8 @@ with {\em closures} on the RHSs of let(rec)s. See also module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where -import Ubiq{-uitous-} -import CgLoop2 ( cgExpr, cgSccExpr ) +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(CgLoop2) ( cgExpr, cgSccExpr ) import CgMonad import AbsCSyn @@ -451,7 +451,10 @@ closureCodeBody binder_info closure_info cc all_args body ViaNode | is_concurrent -> [] other -> panic "closureCodeBody:arg_regs" - stk_args = drop (length arg_regs) all_args + num_arg_regs = length arg_regs + + (reg_args, stk_args) = splitAt num_arg_regs all_args + (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets) = mkVirtStkOffsets 0 0 -- Initial virtual SpA, SpB @@ -509,7 +512,7 @@ closureCodeBody binder_info closure_info cc all_args body -- Bind args to regs/stack as appropriate, and -- record expected position of sps - bindArgsToRegs all_args arg_regs `thenC` + bindArgsToRegs reg_args arg_regs `thenC` mapCs bindNewToAStack stk_bxd_w_offsets `thenC` mapCs bindNewToBStack stk_ubxd_w_offsets `thenC` setRealAndVirtualSps spA_stk_args spB_stk_args `thenC` @@ -863,8 +866,6 @@ setupUpdate closure_info code `thenC` returnFC amode - closure_label = mkClosureLabel (closureId closure_info) - vector = case (closureType closure_info) of Nothing -> CReg StdUpdRetVecReg diff --git a/ghc/compiler/codeGen/CgCompInfo.lhs b/ghc/compiler/codeGen/CgCompInfo.lhs index 9b14dcdaf9..561f8bf477 100644 --- a/ghc/compiler/codeGen/CgCompInfo.lhs +++ b/ghc/compiler/codeGen/CgCompInfo.lhs @@ -63,9 +63,6 @@ module CgCompInfo ( spARelToInt, spBRelToInt - - -- and to make the interface self-sufficient... --- RegRelative ) where -- This magical #include brings in all the everybody-knows-these magic diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 0d0e620cf6..cb5337be61 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -16,7 +16,7 @@ module CgCon ( cgReturnDataCon ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CgMonad import AbsCSyn @@ -33,9 +33,8 @@ import CgCompInfo ( mAX_INTLIKE, mIN_INTLIKE ) import CgHeapery ( allocDynClosure ) import CgRetConv ( dataReturnConvAlg, DataReturnConvention(..) ) import CgTailCall ( performReturn, mkStaticAlgReturnCode ) -import CLabel ( mkClosureLabel, mkInfoTableLabel, - mkPhantomInfoTableLabel, - mkConEntryLabel, mkStdEntryLabel +import CLabel ( mkClosureLabel, mkStaticClosureLabel, + mkConInfoTableLabel, mkPhantomInfoTableLabel ) import ClosureInfo ( mkClosureLFInfo, mkConLFInfo, mkLFArgument, layOutDynCon, layOutDynClosure, @@ -157,13 +156,9 @@ cgTopRhsCon name con args all_zero_size_args -- RETURN returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info) where - con_tycon = dataConTyCon con - lf_info = mkConLFInfo con - - closure_label = mkClosureLabel name - info_label = mkInfoTableLabel con - con_entry_label = mkConEntryLabel con - entry_label = mkStdEntryLabel name + con_tycon = dataConTyCon con + lf_info = mkConLFInfo con + closure_label = mkClosureLabel name \end{code} The general case is: @@ -277,7 +272,7 @@ at all. buildDynCon binder cc con args all_zero_size_args@True = ASSERT(isDataCon con) returnFC (stableAmodeIdInfo binder - (CLbl (mkClosureLabel con) PtrRep) + (CLbl (mkStaticClosureLabel con) PtrRep) (mkConLFInfo con)) \end{code} @@ -427,7 +422,7 @@ cgReturnDataCon con amodes all_zero_size_args live_vars -- MAKE NODE POINT TO IT let reg_assts = move_to_reg amode node - info_lbl = mkInfoTableLabel con + info_lbl = mkConInfoTableLabel con in -- RETURN diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index 98c5a1deed..7745466706 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -8,7 +8,7 @@ module CgConTbls ( genStaticConBits ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import AbsCSyn import CgMonad @@ -23,7 +23,7 @@ import CgRetConv ( mkLiveRegsMask, ) import CgTailCall ( performReturn, mkStaticAlgReturnCode ) import CgUsages ( getHpRelOffset ) -import CLabel ( mkConEntryLabel, mkClosureLabel, +import CLabel ( mkConEntryLabel, mkStaticClosureLabel, mkConUpdCodePtrVecLabel, mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel ) @@ -35,7 +35,7 @@ import ClosureInfo ( layOutStaticClosure, layOutDynCon, import CostCentre ( dontCareCostCentre ) import FiniteMap ( fmToList ) import HeapOffs ( zeroOff, VirtualHeapOffset(..) ) -import Id ( dataConTag, dataConSig, +import Id ( dataConTag, dataConRawArgTys, dataConArity, fIRST_TAG, emptyIdSet, GenId{-instance NamedThing-} @@ -240,10 +240,10 @@ genConInfo comp_info tycon data_con zero_size arg_ty = getPrimRepSize (typePrimRep arg_ty) == 0 - (_,_,arg_tys,_) = dataConSig data_con - con_arity = dataConArity data_con - entry_label = mkConEntryLabel data_con - closure_label = mkClosureLabel data_con + arg_tys = dataConRawArgTys data_con + con_arity = dataConArity data_con + entry_label = mkConEntryLabel data_con + closure_label = mkStaticClosureLabel data_con \end{code} The entry code for a constructor now loads the info ptr by indirecting @@ -288,7 +288,7 @@ mkConCodeAndInfo con ReturnInHeap -> let - (_, _, arg_tys, _) = dataConSig con + arg_tys = dataConRawArgTys con (closure_info, arg_things) = layOutDynCon con typePrimRep arg_tys diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index dd0b7f4d4f..a4a0746d3d 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -12,8 +12,8 @@ module CgExpr ( cgExpr, cgSccExpr, getPrimOpArgAmodes ) where -import Ubiq{-uitous-} -import CgLoop2 -- here for paranoia-checking +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(CgLoop2) -- here for paranoia-checking import StgSyn import CgMonad diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index fa8f1e0bdb..888908f612 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -14,7 +14,7 @@ module CgHeapery ( , heapCheckOnly, fetchAndReschedule, yield ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import AbsCSyn import CgMonad diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs index f59ef4eb7c..3748ddd657 100644 --- a/ghc/compiler/codeGen/CgLetNoEscape.lhs +++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs @@ -12,8 +12,8 @@ module CgLetNoEscape ( cgLetNoEscapeClosure ) where -import Ubiq{-uitious-} -import CgLoop2 ( cgExpr ) +IMP_Ubiq(){-uitious-} +IMPORT_DELOOPER(CgLoop2) ( cgExpr ) import StgSyn import CgMonad @@ -169,9 +169,9 @@ cgLetNoEscapeBody :: [Id] -- Args cgLetNoEscapeBody all_args rhs = getVirtSps `thenFC` \ (vA, vB) -> let - arg_kinds = map idPrimRep all_args - (arg_regs, _) = assignRegs [{-nothing live-}] arg_kinds - stk_args = drop (length arg_regs) all_args + arg_kinds = map idPrimRep all_args + (arg_regs, _) = assignRegs [{-nothing live-}] arg_kinds + (reg_args, stk_args) = splitAt (length arg_regs) all_args -- stk_args is the args which are passed on the stack at the fast-entry point -- Using them, we define the stack layout @@ -183,7 +183,7 @@ cgLetNoEscapeBody all_args rhs in -- Bind args to appropriate regs/stk locns - bindArgsToRegs all_args arg_regs `thenC` + bindArgsToRegs reg_args arg_regs `thenC` mapCs bindNewToAStack stk_bxd_w_offsets `thenC` mapCs bindNewToBStack stk_ubxd_w_offsets `thenC` setRealAndVirtualSps spA_stk_args spB_stk_args `thenC` diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index 428d6f6881..ab22daeb24 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -47,8 +47,8 @@ module CgMonad ( CompilationInfo(..) ) where -import Ubiq{-uitous-} -import CgLoop1 -- stuff from CgBindery and CgUsages +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(CgLoop1) -- stuff from CgBindery and CgUsages import AbsCSyn import AbsCUtils ( mkAbsCStmts ) diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index 14e59f4526..fa3644038b 100644 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -20,12 +20,10 @@ module CgRetConv ( assignPrimOpResultRegs, makePrimOpArgsRobust, assignRegs - - -- and to make the interface self-sufficient... ) where -import Ubiq{-uitous-} -import AbsCLoop -- paranoia checking +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(AbsCLoop) -- paranoia checking import AbsCSyn -- quite a few things import AbsCUtils ( mkAbstractCs, getAmodeRep, @@ -36,7 +34,7 @@ import CgCompInfo ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS, mAX_Double_REG ) import CmdLineOpts ( opt_ReturnInRegsThreshold ) -import Id ( isDataCon, dataConSig, +import Id ( isDataCon, dataConRawArgTys, DataCon(..), GenId{-instance Eq-} ) import Maybes ( catMaybes ) @@ -123,7 +121,7 @@ dataReturnConvAlg data_con [] -> ReturnInRegs reg_assignment other -> ReturnInHeap -- Didn't fit in registers where - (_, _, arg_tys, _) = dataConSig data_con + arg_tys = dataConRawArgTys data_con (reg_assignment, leftover_kinds) = assignRegs [node, infoptr] -- taken... diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs index 8e1c90a58e..caf38104dd 100644 --- a/ghc/compiler/codeGen/CgStackery.lhs +++ b/ghc/compiler/codeGen/CgStackery.lhs @@ -16,7 +16,7 @@ module CgStackery ( mkVirtStkOffsets, mkStkAmodes ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CgMonad import AbsCSyn diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 15b2ae249b..770c4b52df 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -19,7 +19,7 @@ module CgTailCall ( tailCallBusiness ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CgMonad import AbsCSyn diff --git a/ghc/compiler/codeGen/CgUpdate.lhs b/ghc/compiler/codeGen/CgUpdate.lhs index ff1a5546b9..70e344b7d9 100644 --- a/ghc/compiler/codeGen/CgUpdate.lhs +++ b/ghc/compiler/codeGen/CgUpdate.lhs @@ -8,7 +8,7 @@ module CgUpdate ( pushUpdateFrame ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CgMonad import AbsCSyn diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs index eec6be6067..e7e7b962cb 100644 --- a/ghc/compiler/codeGen/CgUsages.lhs +++ b/ghc/compiler/codeGen/CgUsages.lhs @@ -7,6 +7,8 @@ This module provides the functions to access (\tr{get*} functions) and modify (\tr{set*} functions) the stacks and heap usage information. \begin{code} +#include "HsVersions.h" + module CgUsages ( initHeapUsage, setVirtHp, getVirtAndRealHp, setRealHp, setRealAndVirtualSps, @@ -18,8 +20,8 @@ module CgUsages ( freeBStkSlot ) where -import Ubiq{-uitous-} -import CgLoop1 -- here for paranoia-checking +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(CgLoop1) -- here for paranoia-checking import AbsCSyn ( RegRelative(..), AbstractC, CAddrMode ) import CgMonad diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index e45fdeccf6..960e6a9803 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -50,8 +50,8 @@ module ClosureInfo ( dataConLiveness -- concurrency ) where -import Ubiq{-uitous-} -import AbsCLoop -- here for paranoia-checking +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(AbsCLoop) -- here for paranoia-checking import AbsCSyn import StgSyn @@ -68,6 +68,7 @@ import CgRetConv ( assignRegs, dataReturnConvAlg, ) import CLabel ( mkStdEntryLabel, mkFastEntryLabel, mkPhantomInfoTableLabel, mkInfoTableLabel, + mkConInfoTableLabel, mkBlackHoleInfoTableLabel, mkVapInfoTableLabel, mkStaticInfoTableLabel, mkStaticConEntryLabel, mkConEntryLabel, mkClosureLabel, mkVapEntryLabel @@ -78,9 +79,9 @@ import HeapOffs ( intOff, addOff, totHdrSize, varHdrSize, VirtualHeapOffset(..) ) import Id ( idType, idPrimRep, getIdArity, - externallyVisibleId, dataConSig, + externallyVisibleId, dataConTag, fIRST_TAG, - isDataCon, dataConArity, dataConTyCon, + isDataCon, isNullaryDataCon, dataConTyCon, isTupleCon, DataCon(..), GenId{-instance Eq-} ) @@ -425,7 +426,7 @@ mkClosureLFInfo False -- don't bother if at top-level offset_into_int_maybe = intOffsetIntoGoods the_offset Just offset_into_int = offset_into_int_maybe is_single_constructor = maybeToBool (maybeTyConSingleCon tycon) - (_,_,_, tycon) = dataConSig con + tycon = dataConTyCon con \end{code} Same kind of thing, looking for vector-apply thunks, of the form: @@ -477,14 +478,8 @@ isUpdatable Updatable = True mkConLFInfo :: DataCon -> LambdaFormInfo mkConLFInfo con - = ASSERT(isDataCon con) - let - arity = dataConArity con - in - if isTupleCon con then - LFTuple con (arity == 0) - else - LFCon con (arity == 0) + = -- the isNullaryDataCon will do this: ASSERT(isDataCon con) + (if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon con) \end{code} @@ -865,8 +860,8 @@ data EntryConvention Int -- Its arity [MagicId] -- Its register assignments (possibly empty) -getEntryConvention :: Id -- Function being applied - -> LambdaFormInfo -- Its info +getEntryConvention :: Id -- Function being applied + -> LambdaFormInfo -- Its info -> [PrimRep] -- Available arguments -> FCode EntryConvention @@ -894,13 +889,14 @@ getEntryConvention id lf_info arg_kinds -> let itbl = if zero_arity then mkPhantomInfoTableLabel con else - mkInfoTableLabel con - in StdEntry (mkStdEntryLabel con) (Just itbl) - -- Should have no args + mkConInfoTableLabel con + in + --false:ASSERT (null arg_kinds) -- Should have no args (meaning what?) + StdEntry (mkConEntryLabel con) (Just itbl) + LFTuple tup zero_arity - -> StdEntry (mkStdEntryLabel tup) - (Just (mkInfoTableLabel tup)) - -- Should have no args + -> --false:ASSERT (null arg_kinds) -- Should have no args (meaning what?) + StdEntry (mkConEntryLabel tup) (Just (mkConInfoTableLabel tup)) LFThunk _ _ updatable std_form_info -> if updatable @@ -1213,17 +1209,19 @@ infoTableLabelFromCI (MkClosureInfo id lf_info rep) else -} mkInfoTableLabel id mkConInfoPtr :: Id -> SMRep -> CLabel -mkConInfoPtr id rep = - case rep of - PhantomRep -> mkPhantomInfoTableLabel id - StaticRep _ _ -> mkStaticInfoTableLabel id - _ -> mkInfoTableLabel id +mkConInfoPtr con rep + = ASSERT(isDataCon con) + case rep of + PhantomRep -> mkPhantomInfoTableLabel con + StaticRep _ _ -> mkStaticInfoTableLabel con + _ -> mkConInfoTableLabel con mkConEntryPtr :: Id -> SMRep -> CLabel -mkConEntryPtr id rep = - case rep of - StaticRep _ _ -> mkStaticConEntryLabel id - _ -> mkConEntryLabel id +mkConEntryPtr con rep + = ASSERT(isDataCon con) + case rep of + StaticRep _ _ -> mkStaticConEntryLabel con + _ -> mkConEntryLabel con closureLabelFromCI (MkClosureInfo id _ _) = mkClosureLabel id diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 016bd99ec3..590aa9f65e 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -19,7 +19,7 @@ functions drive the mangling of top-level bindings. module CodeGen ( codeGen ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import StgSyn import CgMonad diff --git a/ghc/compiler/codeGen/SMRep.lhs b/ghc/compiler/codeGen/SMRep.lhs index 99432c7643..7c46adff06 100644 --- a/ghc/compiler/codeGen/SMRep.lhs +++ b/ghc/compiler/codeGen/SMRep.lhs @@ -17,7 +17,7 @@ module SMRep ( isIntLikeRep ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Pretty ( ppStr ) import Util ( panic ) diff --git a/ghc/compiler/coreSyn/AnnCoreSyn.lhs b/ghc/compiler/coreSyn/AnnCoreSyn.lhs index f1095d8cdd..4e0a6a0355 100644 --- a/ghc/compiler/coreSyn/AnnCoreSyn.lhs +++ b/ghc/compiler/coreSyn/AnnCoreSyn.lhs @@ -18,7 +18,7 @@ module AnnCoreSyn ( deAnnotate -- we may eventually export some of the other deAnners ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CoreSyn \end{code} diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs index 664231e378..a14bf3d557 100644 --- a/ghc/compiler/coreSyn/CoreLift.lhs +++ b/ghc/compiler/coreSyn/CoreLift.lhs @@ -17,7 +17,7 @@ module CoreLift ( ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CoreSyn import CoreUtils ( coreExprType ) diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 304b30ecd7..31e8ea588e 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -11,7 +11,7 @@ module CoreLint ( lintUnfolding ) where -import Ubiq +IMP_Ubiq() import CoreSyn @@ -33,6 +33,7 @@ import PrimRep ( PrimRep(..) ) import SrcLoc ( SrcLoc ) import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,mkForAllTys,getForAllTy_maybe, getFunTyExpandingDicts_maybe, + getForAllTyExpandingDicts_maybe, isPrimType,typeKind,instantiateTy,splitSigmaTy, mkForAllUsageTy,getForAllUsageTy,instantiateUsage, maybeAppDataTyConExpandingDicts, eqTy @@ -285,7 +286,7 @@ lintCoreArg e ty a@(TyArg arg_ty) = -- ToDo: Check that ty is well-kinded and has no unbound tyvars checkIfSpecDoneL (not (isPrimType arg_ty)) (mkSpecTyAppMsg a) `seqL` - case (getForAllTy_maybe ty) of + case (getForAllTyExpandingDicts_maybe ty) of Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing Just (tyvar,body) -> diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 49e66879a5..d66f7b6561 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -50,12 +50,9 @@ module CoreSyn ( SimplifiableCoreArg(..), SimplifiableCoreCaseAlts(..), SimplifiableCoreCaseDefault(..) - - -- and to make the interface self-sufficient ... - ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} -- ToDo:rm: --import PprCore ( GenCoreExpr{-instance-} ) diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index fe034d6bea..c0f61a31ab 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -20,17 +20,17 @@ module CoreUnfold ( FormSummary(..), mkFormSummary, - mkGenForm, + mkGenForm, mkLitForm, mkConForm, + whnfDetails, mkMagicUnfolding, - modifyUnfoldingDetails, calcUnfoldingGuidance, mentionedInUnfolding ) where -import Ubiq -import IdLoop -- for paranoia checking; +IMP_Ubiq() +IMPORT_DELOOPER(IdLoop) -- for paranoia checking; -- and also to get mkMagicUnfoldingFun -import PrelLoop -- for paranoia checking +IMPORT_DELOOPER(PrelLoop) -- for paranoia checking import Bag ( emptyBag, unitBag, unionBags, Bag ) import BinderInfo ( oneTextualOcc, oneSafeOcc ) @@ -70,16 +70,9 @@ getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromTy data UnfoldingDetails = NoUnfoldingDetails - | LitForm - Literal - | OtherLitForm [Literal] -- It is a literal, but definitely not one of these - | ConForm - Id -- The constructor - [CoreArg] -- Type/value arguments; NB OutArgs, already cloned - | OtherConForm [Id] -- It definitely isn't one of these constructors -- This captures the situation in the default branch of @@ -97,10 +90,6 @@ data UnfoldingDetails | GenForm - Bool -- True <=> At most one textual occurrence of the - -- binder in its scope, *or* - -- if we are happy to duplicate this - -- binding. FormSummary -- Tells whether the template is a WHNF or bottom TemplateOutExpr -- The template UnfoldingGuidance -- Tells about the *size* of the template. @@ -140,6 +129,12 @@ mkFormSummary si expr -- | manifestlyBottom expr = BottomForm | otherwise = OtherForm + +whnfDetails :: UnfoldingDetails -> Bool -- True => thing is evaluated +whnfDetails (GenForm WhnfForm _ _) = True +whnfDetails (OtherLitForm _) = True +whnfDetails (OtherConForm _) = True +whnfDetails other = False \end{code} \begin{code} @@ -191,46 +186,25 @@ instance Outputable UnfoldingGuidance where %************************************************************************ %* * -\subsection{@mkGenForm@ and @modifyUnfoldingDetails@} +\subsection{@mkGenForm@ and friends} %* * %************************************************************************ \begin{code} -mkGenForm :: Bool -- Ok to Dup code down different case branches, - -- because of either a flag saying so, - -- or alternatively the object is *SMALL* - -> BinderInfo -- - -> FormSummary +mkGenForm :: FormSummary -> TemplateOutExpr -- Template -> UnfoldingGuidance -- Tells about the *size* of the template. -> UnfoldingDetails -mkGenForm safe_to_dup occ_info WhnfForm template guidance - = GenForm (oneTextualOcc safe_to_dup occ_info) WhnfForm template guidance - -mkGenForm safe_to_dup occ_info form_summary template guidance - | oneSafeOcc safe_to_dup occ_info -- Non-WHNF with only safe occurrences - = GenForm True form_summary template guidance - - | otherwise -- Not a WHNF, many occurrences - = NoUnfoldingDetails -\end{code} +mkGenForm = GenForm -\begin{code} -modifyUnfoldingDetails - :: Bool -- OK to dup - -> BinderInfo -- New occurrence info for the thing - -> UnfoldingDetails - -> UnfoldingDetails +-- two shorthand variants: +mkLitForm lit = mk_go_for_it (Lit lit) +mkConForm con args = mk_go_for_it (Con con args) -modifyUnfoldingDetails ok_to_dup occ_info - (GenForm only_one form_summary template guidance) - | only_one = mkGenForm ok_to_dup occ_info form_summary template guidance - -modifyUnfoldingDetails ok_to_dup occ_info other = other +mk_go_for_it expr = mkGenForm WhnfForm expr UnfoldAlways \end{code} - %************************************************************************ %* * \subsection[calcUnfoldingGuidance]{Calculate ``unfolding guidance'' for an expression} diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 6e6d7baf30..bb73e01864 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -25,13 +25,14 @@ module CoreUtils ( -} ) where -import Ubiq -import IdLoop -- for pananoia-checking purposes +IMP_Ubiq() +IMPORT_DELOOPER(IdLoop) -- for pananoia-checking purposes import CoreSyn import CostCentre ( isDictCC ) import Id ( idType, mkSysLocal, getIdArity, isBottomingId, + toplevelishId, mkIdWithNewUniq, applyTypeEnvToId, addOneToIdEnv, growIdEnvList, lookupIdEnv, isNullIdEnv, IdEnv(..), GenId{-instances-} @@ -46,7 +47,9 @@ import Pretty ( ppAboves ) import PrelVals ( augmentId, buildId ) import PrimOp ( primOpType, fragilePrimOp, PrimOp(..) ) import SrcLoc ( mkUnknownSrcLoc ) -import TyVar ( isNullTyVarEnv, TyVarEnv(..) ) +import TyVar ( cloneTyVar, + isNullTyVarEnv, addOneToTyVarEnv, TyVarEnv(..) + ) import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy, getFunTy_maybe, applyTy, isPrimType, splitSigmaTy, splitFunTy, eqTy, applyTypeEnvToTy @@ -61,7 +64,6 @@ import Util ( zipEqual, panic, pprPanic, assertPanic ) type TypeEnv = TyVarEnv Type applyUsage = panic "CoreUtils.applyUsage:ToDo" -dup_binder = panic "CoreUtils.dup_binder" \end{code} %************************************************************************ @@ -728,11 +730,21 @@ do_CoreExpr venv tenv (Prim op as) do_PrimOp other_op = returnUs other_op -do_CoreExpr venv tenv (Lam binder expr) +do_CoreExpr venv tenv (Lam (ValBinder binder) expr) = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) -> let new_venv = addOneToIdEnv venv old new in do_CoreExpr new_venv tenv expr `thenUs` \ new_expr -> - returnUs (Lam new_binder new_expr) + returnUs (Lam (ValBinder new_binder) new_expr) + +do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr) + = dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) -> + let + new_tenv = addOneToTyVarEnv tenv old new + in + do_CoreExpr venv new_tenv expr `thenUs` \ new_expr -> + returnUs (Lam (TyBinder new_tyvar) new_expr) + +do_CoreExpr venv tenv (Lam _ expr) = panic "CoreUtils.do_CoreExpr:Lam UsageBinder" do_CoreExpr venv tenv (App expr arg) = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> @@ -787,3 +799,28 @@ do_CoreExpr venv tenv (Coerce c ty expr) = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr) \end{code} + +\begin{code} +dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, Type)) +dup_tyvar tyvar + = getUnique `thenUs` \ uniq -> + let new_tyvar = cloneTyVar tyvar uniq in + returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar)) + +-- same thing all over again -------------------- + +dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, CoreExpr)) +dup_binder tenv b + = if (toplevelishId b) then + -- binder is "top-level-ish"; -- it should *NOT* be renamed + -- ToDo: it's unsavoury that we return something to heave in env + returnUs (b, (b, Var b)) + + else -- otherwise, the full business + getUnique `thenUs` \ uniq -> + let + new_b1 = mkIdWithNewUniq b uniq + new_b2 = applyTypeEnvToId tenv new_b1 + in + returnUs (new_b2, (b, Var new_b2)) +\end{code} diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs index e6987a826f..38de36c814 100644 --- a/ghc/compiler/coreSyn/FreeVars.lhs +++ b/ghc/compiler/coreSyn/FreeVars.lhs @@ -20,7 +20,7 @@ module FreeVars ( FVInfo(..), LeakInfo(..) ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import AnnCoreSyn -- output diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 8fa61e5e7a..fd2e03d31f 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -23,7 +23,7 @@ module PprCore ( #endif ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CoreSyn import CostCentre ( showCostCentre ) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 1e29075706..a1be8b473b 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -8,7 +8,7 @@ module Desugar ( deSugar, DsMatchContext, pprDsWarnings ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import HsSyn ( HsBinds, HsExpr ) import TcHsSyn ( TypecheckedHsBinds(..), TypecheckedHsExpr(..) ) diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index bc5bc9ac76..82380970e7 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -12,8 +12,8 @@ lower levels it is preserved with @let@/@letrec@s). module DsBinds ( dsBinds, dsInstBinds ) where -import Ubiq -import DsLoop -- break dsExpr-ish loop +IMP_Ubiq() +IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop import HsSyn -- lots of things hiding ( collectBinders{-also in CoreSyn-} ) diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index fbae35c89b..47eb7c1b56 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -8,7 +8,7 @@ module DsCCall ( dsCCall ) where -import Ubiq +IMP_Ubiq() import CoreSyn @@ -23,15 +23,13 @@ import PprType ( GenType{-instances-} ) import Pretty import PrelVals ( packStringForCId ) import PrimOp ( PrimOp(..) ) -import Type ( isPrimType, maybeAppDataTyConExpandingDicts, eqTy ) +import Type ( isPrimType, maybeAppDataTyConExpandingDicts, eqTy, maybeBoxedPrimType ) import TysPrim ( byteArrayPrimTy, realWorldTy, realWorldStatePrimTy ) import TysWiredIn ( getStatePairingConInfo, realWorldStateTy, stateDataCon, stringTy ) import Util ( pprPanic, pprError, panic ) - -maybeBoxedPrimType = panic "DsCCall.maybeBoxedPrimType" \end{code} Desugaring of @ccall@s consists of adding some state manipulation, diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 8d059a2671..f679a7809c 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -8,18 +8,23 @@ module DsExpr ( dsExpr ) where -import Ubiq -import DsLoop -- partly to get dsBinds, partly to chk dsExpr +IMP_Ubiq() +IMPORT_DELOOPER(DsLoop) -- partly to get dsBinds, partly to chk dsExpr -import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), - Match, Qual, HsBinds, Stmt, PolyType ) +import HsSyn ( failureFreePat, + HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..), + Stmt(..), Match(..), Qual, HsBinds, PolyType, + GRHSsAndBinds + ) import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..), - TypecheckedRecordBinds(..), TypecheckedPat(..) + TypecheckedRecordBinds(..), TypecheckedPat(..), + TypecheckedStmt(..) ) import CoreSyn import DsMonad import DsCCall ( dsCCall ) +import DsHsSyn ( outPatType ) import DsListComp ( dsListComp ) import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom, mkErrorAppDs, showForErr, EquationInfo, @@ -42,21 +47,20 @@ import MagicUFs ( MagicUnfoldingFun ) import Name ( Name{--O only-} ) import PprStyle ( PprStyle(..) ) import PprType ( GenType ) -import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID ) +import PrelVals ( rEC_CON_ERROR_ID, rEC_UPD_ERROR_ID, voidId ) import Pretty ( ppShow, ppBesides, ppPStr, ppStr ) import TyCon ( isDataTyCon, isNewTyCon ) import Type ( splitSigmaTy, splitFunTy, typePrimRep, - getAppDataTyConExpandingDicts, getAppTyCon, applyTy + getAppDataTyConExpandingDicts, getAppTyCon, applyTy, + maybeBoxedPrimType ) -import TysWiredIn ( mkTupleTy, unitTy, nilDataCon, consDataCon, +import TysWiredIn ( mkTupleTy, voidTy, nilDataCon, consDataCon, charDataCon, charTy ) import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} ) import Usage ( UVar(..) ) import Util ( zipEqual, pprError, panic, assertPanic ) -maybeBoxedPrimType = panic "DsExpr.maybeBoxedPrimType" - mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility... \end{code} @@ -149,11 +153,11 @@ dsExpr (HsLitOut (HsLitLit s) ty) -> pprError "ERROR: ``literal-literal'' not a single-constructor type: " (ppBesides [ppPStr s, ppStr "; type: ", ppr PprDebug ty]) -dsExpr (HsLitOut (HsInt i) _) - = returnDs (Lit (NoRepInteger i)) +dsExpr (HsLitOut (HsInt i) ty) + = returnDs (Lit (NoRepInteger i ty)) -dsExpr (HsLitOut (HsFrac r) _) - = returnDs (Lit (NoRepRational r)) +dsExpr (HsLitOut (HsFrac r) ty) + = returnDs (Lit (NoRepRational r ty)) -- others where we know what to do: @@ -268,9 +272,9 @@ dsExpr (HsLet binds expr) dsExpr expr `thenDs` \ core_expr -> returnDs ( mkCoLetsAny core_binds core_expr ) -dsExpr (HsDoOut stmts m_id mz_id src_loc) +dsExpr (HsDoOut stmts then_id zero_id src_loc) = putSrcLocDs src_loc $ - panic "dsExpr:HsDoOut" + dsDo then_id zero_id stmts dsExpr (HsIf guard_expr then_expr else_expr src_loc) = putSrcLocDs src_loc $ @@ -278,7 +282,6 @@ dsExpr (HsIf guard_expr then_expr else_expr src_loc) dsExpr then_expr `thenDs` \ core_then -> dsExpr else_expr `thenDs` \ core_else -> returnDs (mkCoreIfThenElse core_guard core_then core_else) - \end{code} @@ -498,7 +501,7 @@ dsExpr (Dictionary dicts methods) `thenDs` \ core_d_and_ms -> (case num_of_d_and_ms of - 0 -> returnDs cocon_unit -- unit + 0 -> returnDs (Var voidId) 1 -> returnDs (head core_d_and_ms) -- just a single Id @@ -515,7 +518,7 @@ dsExpr (Dictionary dicts methods) dsExpr (ClassDictLam dicts methods expr) = dsExpr expr `thenDs` \ core_expr -> case num_of_d_and_ms of - 0 -> newSysLocalDs unitTy `thenDs` \ new_x -> + 0 -> newSysLocalDs voidTy `thenDs` \ new_x -> returnDs (mkValLam [new_x] core_expr) 1 -> -- no untupling @@ -543,7 +546,6 @@ dsExpr (ExprWithTySig _ _) = panic "dsExpr:ExprWithTySig" dsExpr (ArithSeqIn _) = panic "dsExpr:ArithSeqIn" #endif -cocon_unit = mkCon (mkTupleCon 0) [] [] [] -- out here to avoid CAF (sigh) out_of_range_msg -- ditto = " out of range: [" ++ show minInt ++ ", " ++ show maxInt ++ "]\n" \end{code} @@ -593,7 +595,7 @@ dsApp (HsVar v) args Nothing -> -- we're only saturating constructors and PrimOps case getIdUnfolding v of - GenForm _ _ the_unfolding EssentialUnfolding + GenForm _ the_unfolding EssentialUnfolding -> do_unfold nullTyVarEnv nullIdEnv (unTagBinders the_unfolding) args _ -> apply_to_args (Var v) args @@ -653,3 +655,48 @@ do_unfold ty_env val_env body args -- Apply result to remaining arguments apply_to_args body' args \end{code} + +Basically does the translation given in the Haskell~1.3 report: +\begin{code} +dsDo :: Id -- id for: (>>=) m + -> Id -- id for: zero m + -> [TypecheckedStmt] + -> DsM CoreExpr + +dsDo then_id zero_id (stmt:stmts) + = case stmt of + ExprStmt expr locn -> ASSERT( null stmts ) do_expr expr locn + + ExprStmtOut expr locn a b -> + do_expr expr locn `thenDs` \ expr2 -> + ds_rest `thenDs` \ rest -> + dsApp (HsVar then_id) [TyArg a, TyArg b, VarArg expr2, VarArg rest] + + LetStmt binds -> + dsBinds binds `thenDs` \ binds2 -> + ds_rest `thenDs` \ rest -> + returnDs (mkCoLetsAny binds2 rest) + + BindStmtOut pat expr locn a b -> + do_expr expr locn `thenDs` \ expr2 -> + let + zero_expr = TyApp (HsVar zero_id) [b] + main_match + = PatMatch pat (SimpleMatch (HsDoOut stmts then_id zero_id locn)) + the_matches + = if failureFreePat pat + then [main_match] + else [main_match, PatMatch (WildPat a) (SimpleMatch zero_expr)] + in + matchWrapper DoBindMatch the_matches "`do' statement" + `thenDs` \ (binders, matching_code) -> + dsApp (HsVar then_id) [TyArg a, TyArg b, + VarArg expr2, VarArg (mkValLam binders matching_code)] + where + ds_rest = dsDo then_id zero_id stmts + do_expr expr locn = putSrcLocDs locn (dsExpr expr) + +#ifdef DEBUG +dsDo then_expr zero_expr [] = panic "dsDo:[]" +#endif +\end{code} diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index a1a41b4fdb..fd8bec3b10 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -8,8 +8,8 @@ module DsGRHSs ( dsGuarded, dsGRHSs ) where -import Ubiq -import DsLoop -- break dsExpr/dsBinds-ish loop +IMP_Ubiq() +IMPORT_DELOOPER(DsLoop) -- break dsExpr/dsBinds-ish loop import HsSyn ( GRHSsAndBinds(..), GRHS(..), HsExpr, HsBinds ) diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs index b54d8a2698..fa3f0fe6f6 100644 --- a/ghc/compiler/deSugar/DsHsSyn.lhs +++ b/ghc/compiler/deSugar/DsHsSyn.lhs @@ -8,7 +8,7 @@ module DsHsSyn where -import Ubiq +IMP_Ubiq() import HsSyn ( OutPat(..), HsBinds(..), Bind(..), MonoBinds(..), Sig, HsExpr, GRHSsAndBinds, Match, HsLit ) diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index 5508cb1b40..ac712c70ab 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -4,10 +4,12 @@ \section[DsListComp]{Desugaring list comprehensions} \begin{code} +#include "HsVersions.h" + module DsListComp ( dsListComp ) where -import Ubiq -import DsLoop -- break dsExpr-ish loop +IMP_Ubiq() +IMPORT_DELOOPER(DsLoop) -- break dsExpr-ish loop import HsSyn ( Qual(..), HsExpr, HsBinds ) import TcHsSyn ( TypecheckedQual(..), TypecheckedHsExpr(..) , TypecheckedHsBinds(..) ) diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 6236b69f4e..618f8c910f 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -24,7 +24,7 @@ module DsMonad ( DsMatchContext(..), DsMatchKind(..), pprDsWarnings ) where -import Ubiq +IMP_Ubiq() import Bag ( emptyBag, snocBag, bagToList ) import CmdLineOpts ( opt_SccGroup ) @@ -247,6 +247,7 @@ data DsMatchKind | CaseMatch | LambdaMatch | PatBindMatch + | DoBindMatch pprDsWarnings :: PprStyle -> Bag DsMatchContext -> Pretty pprDsWarnings sty warns @@ -274,5 +275,9 @@ pprDsWarnings sty warns = ppHang (ppPStr SLIT("in a lambda abstraction:")) 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) + pp_match DoBindMatch pats + = ppHang (ppPStr SLIT("in a `do' pattern binding:")) + 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) + pp_arrow_dotdotdot = ppPStr SLIT("-> ...") \end{code} diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 579062820d..528607cf81 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -27,8 +27,8 @@ module DsUtils ( showForErr ) where -import Ubiq -import DsLoop ( match, matchSimply ) +IMP_Ubiq() +IMPORT_DELOOPER(DsLoop) ( match, matchSimply ) import HsSyn ( HsExpr(..), OutPat(..), HsLit(..), Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo ) @@ -40,7 +40,7 @@ import DsMonad import CoreUtils ( coreExprType, mkCoreIfThenElse ) import PprStyle ( PprStyle(..) ) -import PrelVals ( iRREFUT_PAT_ERROR_ID ) +import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId ) import Pretty ( ppShow ) import Id ( idType, dataConArgTys, mkTupleCon, pprId{-ToDo:rm-}, @@ -50,6 +50,7 @@ import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons ) import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys, mkTheta, isUnboxedType, applyTyCon, getAppTyCon ) +import TysWiredIn ( voidTy ) import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) ) import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} ) import PprCore{-ToDo:rm-} @@ -551,13 +552,13 @@ which is of course utterly wrong. Rather than drop the condition that only boxed types can be let-bound, we just turn the fail into a function for the primitive case: \begin{verbatim} - let fail.33 :: () -> Int# + let fail.33 :: Void -> Int# fail.33 = \_ -> error "Help" in case x of p1 -> ... - p2 -> fail.33 () - p3 -> fail.33 () + p2 -> fail.33 void + p3 -> fail.33 void p4 -> ... \end{verbatim} @@ -572,19 +573,16 @@ mkFailurePair :: Type -- Result type of the whole case expression -- applied to unit tuple mkFailurePair ty | isUnboxedType ty - = newFailLocalDs (mkFunTys [unit_ty] ty) `thenDs` \ fail_fun_var -> - newSysLocalDs unit_ty `thenDs` \ fail_fun_arg -> + = newFailLocalDs (mkFunTys [voidTy] ty) `thenDs` \ fail_fun_var -> + newSysLocalDs voidTy `thenDs` \ fail_fun_arg -> returnDs (\ body -> NonRec fail_fun_var (Lam (ValBinder fail_fun_arg) body), - App (Var fail_fun_var) (VarArg unit_id)) + App (Var fail_fun_var) (VarArg voidId)) | otherwise = newFailLocalDs ty `thenDs` \ fail_var -> returnDs (\ body -> NonRec fail_var body, Var fail_var) +\end{code} + -unit_id :: Id -- out here to avoid CAF (sigh) -unit_id = mkTupleCon 0 -unit_ty :: Type -unit_ty = idType unit_id -\end{code} diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 82c5a8ea8f..a1d8fc7502 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -8,8 +8,8 @@ module Match ( match, matchWrapper, matchSimply ) where -import Ubiq -import DsLoop -- here for paranoia-checking reasons +IMP_Ubiq() +IMPORT_DELOOPER(DsLoop) -- here for paranoia-checking reasons -- and to break dsExpr/dsBinds-ish loop import HsSyn hiding ( collectBinders{-also from CoreSyn-} ) @@ -26,7 +26,7 @@ import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals ) import FieldLabel ( allFieldLabelTags, fieldLabelTag ) -import Id ( idType, mkTupleCon, dataConSig, +import Id ( idType, mkTupleCon, dataConArgTys, recordSelectorFieldLabel, GenId{-instance-} ) @@ -43,7 +43,7 @@ import TysPrim ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy, import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy, charTy, charDataCon, intTy, intDataCon, floatTy, floatDataCon, doubleTy, - doubleDataCon, integerTy, stringTy, addrTy, + doubleDataCon, stringTy, addrTy, addrDataCon, wordTy, wordDataCon ) import Unique ( Unique{-instance Eq-} ) @@ -209,9 +209,9 @@ match vars@(v:vs) eqns_info shadows unmix_eqns [] = [] unmix_eqns [eqn] = [ [eqn] ] unmix_eqns (eq1@(EqnInfo (p1:p1s) _) : eq2@(EqnInfo (p2:p2s) _) : eqs) - = if ( (unfailablePat p1 && unfailablePat p2) - || (isConPat p1 && isConPat p2) - || (isLitPat p1 && isLitPat p2) ) then + = if ( (irrefutablePat p1 && irrefutablePat p2) + || (isConPat p1 && isConPat p2) + || (isLitPat p1 && isLitPat p2) ) then eq1 `tack_onto` unmixed_rest else [ eq1 ] : unmixed_rest @@ -514,8 +514,8 @@ matchUnmixedEqns :: [Id] matchUnmixedEqns [] _ _ = panic "matchUnmixedEqns: no names" matchUnmixedEqns all_vars@(var:vars) eqns_info shadows - | unfailablePat first_pat - = ASSERT( unfailablePats column_1_pats ) -- Sanity check + | irrefutablePat first_pat + = ASSERT( irrefutablePats column_1_pats ) -- Sanity check -- Real true variables, just like in matchVar, SLPJ p 94 match vars remaining_eqns_info remaining_shadows diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs index 11dbd1d99a..c94ce52d45 100644 --- a/ghc/compiler/deSugar/MatchCon.lhs +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -8,8 +8,8 @@ module MatchCon ( matchConFamily ) where -import Ubiq -import DsLoop ( match ) -- break match-ish loop +IMP_Ubiq() +IMPORT_DELOOPER(DsLoop) ( match ) -- break match-ish loop import HsSyn ( OutPat(..), HsLit, HsExpr ) import DsHsSyn ( outPatType ) diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index da0392e5c2..010d471bbe 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -8,8 +8,8 @@ module MatchLit ( matchLiterals ) where -import Ubiq -import DsLoop -- break match-ish and dsExpr-ish loops +IMP_Ubiq() +IMPORT_DELOOPER(DsLoop) -- break match-ish and dsExpr-ish loops import HsSyn ( HsLit(..), OutPat(..), HsExpr(..), Match, HsBinds, Stmt, Qual, PolyType, ArithSeqInfo ) diff --git a/ghc/compiler/deforest/DefExpr.lhs b/ghc/compiler/deforest/DefExpr.lhs index cda10ffd63..bae88366ec 100644 --- a/ghc/compiler/deforest/DefExpr.lhs +++ b/ghc/compiler/deforest/DefExpr.lhs @@ -293,7 +293,7 @@ should an unfolding be required. > then no_unfold > > else case (getIdUnfolding id) of -> GenForm _ _ expr guidance -> +> GenForm _ expr guidance -> > panic "DefExpr:GenForm has changed a little; needs mod here" > -- SLPJ March 95 > diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index a725c1d6fd..5d6667ccae 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -10,10 +10,10 @@ Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@. module HsBinds where -import Ubiq +IMP_Ubiq() -- friends: -import HsLoop +IMPORT_DELOOPER(HsLoop) import HsMatches ( pprMatches, pprGRHSsAndBinds, Match, GRHSsAndBinds ) import HsPat ( collectPatBinders, InPat ) diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index aac5fd6136..6dd80c18f2 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -20,7 +20,7 @@ module HsCore ( UnfoldingPrimOp(..), UfCostCentre(..) ) where -import Ubiq +IMP_Ubiq() -- friends: import HsTypes ( MonoType, PolyType ) diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 3bc2b5f9db..b4356c7e81 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -11,10 +11,10 @@ Definitions for: @FixityDecl@, @TyDecl@ and @ConDecl@, @ClassDecl@, module HsDecls where -import Ubiq +IMP_Ubiq() -- friends: -import HsLoop ( nullMonoBinds, MonoBinds, Sig ) +IMPORT_DELOOPER(HsLoop) ( nullMonoBinds, MonoBinds, Sig ) import HsPragmas ( DataPragmas, ClassPragmas, InstancePragmas, ClassOpPragmas ) diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 55709cabdd..53bd6720c4 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -8,8 +8,8 @@ module HsExpr where -import Ubiq{-uitous-} -import HsLoop -- for paranoia checking +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(HsLoop) -- for paranoia checking -- friends: import HsBinds ( HsBinds ) @@ -84,8 +84,9 @@ data HsExpr tyvar uvar id pat | HsDo [Stmt tyvar uvar id pat] -- "do":one or more stmts SrcLoc - | HsDoOut [Stmt tyvar uvar id pat] -- "do":one or more stmts - id id -- Monad and MonadZero dicts + | HsDoOut [Stmt tyvar uvar id pat] -- "do":one or more stmts + id -- id for >>=, types applied + id -- id for zero, typed applied SrcLoc | ListComp (HsExpr tyvar uvar id pat) -- list comprehension @@ -278,9 +279,9 @@ pprExpr sty (HsLet binds expr) ppHang (ppPStr SLIT("in")) 2 (ppr sty expr)] pprExpr sty (HsDo stmts _) - = ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)] + = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts)) pprExpr sty (HsDoOut stmts _ _ _) - = ppCat [ppPStr SLIT("do"), ppAboves (map (ppr sty) stmts)] + = ppHang (ppPStr SLIT("do")) 2 (ppAboves (map (ppr sty) stmts)) pprExpr sty (ListComp expr quals) = ppHang (ppCat [ppLbrack, pprExpr sty expr, ppChar '|']) @@ -304,8 +305,8 @@ pprExpr sty (RecordUpdOut aexp _ rbinds) = pp_rbinds sty (pprParendExpr sty aexp) rbinds pprExpr sty (ExprWithTySig expr sig) - = ppHang (ppBesides [ppLparen, ppNest 2 (pprExpr sty expr), ppPStr SLIT(" ::")]) - 4 (ppBeside (ppr sty sig) ppRparen) + = ppHang (ppBeside (ppNest 2 (pprExpr sty expr)) (ppPStr SLIT(" ::"))) + 4 (ppr sty sig) pprExpr sty (ArithSeqIn info) = ppBracket (ppr sty info) @@ -421,6 +422,10 @@ data Stmt tyvar uvar id pat | ExprStmt (HsExpr tyvar uvar id pat) SrcLoc | LetStmt (HsBinds tyvar uvar id pat) + + -- Translations; the types are the "a" and "b" types of the monad. + | BindStmtOut pat (HsExpr tyvar uvar id pat) SrcLoc (GenType tyvar uvar) (GenType tyvar uvar) + | ExprStmtOut (HsExpr tyvar uvar id pat) SrcLoc (GenType tyvar uvar) (GenType tyvar uvar) \end{code} \begin{code} @@ -433,6 +438,10 @@ instance (NamedThing id, Outputable id, Outputable pat, = ppCat [ppPStr SLIT("let"), ppr sty binds] ppr sty (ExprStmt expr _) = ppr sty expr + ppr sty (BindStmtOut pat expr _ _ _) + = ppCat [ppr sty pat, ppStr "<-", ppr sty expr] + ppr sty (ExprStmtOut expr _ _ _) + = ppr sty expr \end{code} %************************************************************************ diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs index b1d462da86..7bdf830d74 100644 --- a/ghc/compiler/hsSyn/HsImpExp.lhs +++ b/ghc/compiler/hsSyn/HsImpExp.lhs @@ -8,8 +8,9 @@ module HsImpExp where -import Ubiq +IMP_Ubiq() +import Name ( pprNonSym ) import Outputable import PprStyle ( PprStyle(..) ) import Pretty @@ -33,23 +34,22 @@ data ImportDecl name \end{code} \begin{code} -instance (Outputable name) => Outputable (ImportDecl name) where +instance (NamedThing name, Outputable name) => Outputable (ImportDecl name) where ppr sty (ImportDecl mod qual as spec _) - = ppHang (ppCat [ppStr "import", pp_qual qual, ppPStr mod, pp_as as]) + = ppHang (ppCat [ppPStr SLIT("import"), pp_qual qual, ppPStr mod, pp_as as]) 4 (pp_spec spec) where pp_qual False = ppNil - pp_qual True = ppStr "qualified" + pp_qual True = ppPStr SLIT("qualified") pp_as Nothing = ppNil - pp_as (Just a) = ppCat [ppStr "as", ppPStr a] + pp_as (Just a) = ppBeside (ppPStr SLIT("as ")) (ppPStr a) pp_spec Nothing = ppNil pp_spec (Just (False, spec)) - = ppBesides [ppStr "(", interpp'SP sty spec, ppStr ")"] + = ppParens (interpp'SP sty spec) pp_spec (Just (True, spec)) - = ppBesides [ppStr "hiding (", interpp'SP sty spec, ppStr ")"] - + = ppBeside (ppPStr SLIT("hiding ")) (ppParens (interpp'SP sty spec)) \end{code} %************************************************************************ @@ -67,13 +67,14 @@ data IE name \end{code} \begin{code} -instance (Outputable name) => Outputable (IE name) where - ppr sty (IEVar var) = ppr sty var +instance (NamedThing name, Outputable name) => Outputable (IE name) where + ppr sty (IEVar var) = pprNonSym sty var ppr sty (IEThingAbs thing) = ppr sty thing ppr sty (IEThingAll thing) = ppBesides [ppr sty thing, ppStr "(..)"] ppr sty (IEThingWith thing withs) - = ppBesides [ppr sty thing, ppLparen, ppInterleave ppComma (map (ppr sty) withs), ppRparen] + = ppBeside (ppr sty thing) + (ppParens (ppInterleave ppComma (map (pprNonSym sty) withs))) ppr sty (IEModuleContents mod) = ppBeside (ppPStr SLIT("module ")) (ppPStr mod) \end{code} diff --git a/ghc/compiler/hsSyn/HsLit.lhs b/ghc/compiler/hsSyn/HsLit.lhs index f18cde5a67..e0f736433a 100644 --- a/ghc/compiler/hsSyn/HsLit.lhs +++ b/ghc/compiler/hsSyn/HsLit.lhs @@ -8,7 +8,8 @@ module HsLit where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} +IMPORT_1_3(Ratio(Rational)) import Pretty \end{code} diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs index 7c7db36de9..5800e5e62f 100644 --- a/ghc/compiler/hsSyn/HsMatches.lhs +++ b/ghc/compiler/hsSyn/HsMatches.lhs @@ -10,9 +10,9 @@ The @Match@, @GRHSsAndBinds@ and @GRHS@ datatypes. module HsMatches where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} -import HsLoop ( HsExpr, nullBinds, HsBinds ) +IMPORT_DELOOPER(HsLoop) ( HsExpr, nullBinds, HsBinds ) import Outputable ( ifPprShowAll ) import PprType ( GenType{-instance Outputable-} ) import Pretty diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 96d308229d..5cb26fac2b 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -10,21 +10,21 @@ module HsPat ( InPat(..), OutPat(..), - unfailablePats, unfailablePat, + irrefutablePat, irrefutablePats, + failureFreePat, patsAreAllCons, isConPat, patsAreAllLits, isLitPat, - irrefutablePat, collectPatBinders ) where -import Ubiq +IMP_Ubiq() -- friends: import HsLit ( HsLit ) -import HsLoop ( HsExpr ) +IMPORT_DELOOPER(HsLoop) ( HsExpr ) -- others: -import Id ( GenId, dataConSig ) +import Id ( dataConTyCon, GenId ) import Maybes ( maybeToBool ) import Name ( pprSym, pprNonSym ) import Outputable ( interppSP, interpp'SP, ifPprShowAll ) @@ -234,17 +234,36 @@ At least the numeric ones may be overloaded. A pattern is in {\em exactly one} of the above three categories; `as' patterns are treated specially, of course. +The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are. \begin{code} -unfailablePats :: [OutPat a b c] -> Bool -unfailablePats pat_list = all unfailablePat pat_list - -unfailablePat (AsPat _ pat) = unfailablePat pat -unfailablePat (WildPat _) = True -unfailablePat (VarPat _) = True -unfailablePat (LazyPat _) = True -unfailablePat (DictPat ds ms) = (length ds + length ms) <= 1 -unfailablePat other = False +irrefutablePats :: [OutPat a b c] -> 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 a b c -> Bool + +failureFreePat (WildPat _) = True +failureFreePat (VarPat _) = True +failureFreePat (LazyPat _) = True +failureFreePat (AsPat _ pat) = failureFreePat pat +failureFreePat (ConPat con tys pats) = only_con con && all failureFreePat pats +failureFreePat (ConOpPat pat1 con pat2 _) = only_con con && failureFreePat pat1 && failureFreePat pat1 +failureFreePat (RecPat con _ fields) = only_con con && and [ failureFreePat pat | (_,pat,_) <- fields ] +failureFreePat (ListPat _ _) = False +failureFreePat (TuplePat pats) = all failureFreePat pats +failureFreePat (DictPat _ _) = True +failureFreePat other_pat = False -- Literals, NPat + +only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con)) +\end{code} +\begin{code} patsAreAllCons :: [OutPat a b c] -> Bool patsAreAllCons pat_list = all isConPat pat_list @@ -266,28 +285,6 @@ isLitPat (NPat _ _ _) = True isLitPat other = False \end{code} -A pattern is irrefutable if a match on it cannot fail -(at any depth). -\begin{code} -irrefutablePat :: OutPat a b c -> Bool - -irrefutablePat (WildPat _) = True -irrefutablePat (VarPat _) = True -irrefutablePat (LazyPat _) = True -irrefutablePat (AsPat _ pat) = irrefutablePat pat -irrefutablePat (ConPat con tys pats) = only_con con && all irrefutablePat pats -irrefutablePat (ConOpPat pat1 con pat2 _) = only_con con && irrefutablePat pat1 && irrefutablePat pat1 -irrefutablePat (RecPat con _ fields) = only_con con && and [ irrefutablePat pat | (_,pat,_) <- fields ] -irrefutablePat (ListPat _ _) = False -irrefutablePat (TuplePat pats) = all irrefutablePat pats -irrefutablePat (DictPat _ _) = True -irrefutablePat other_pat = False -- Literals, NPat - -only_con con = maybeToBool (maybeTyConSingleCon tycon) - where - (_,_,_,tycon) = dataConSig con -\end{code} - This function @collectPatBinders@ works with the ``collectBinders'' functions for @HsBinds@, etc. The order in which the binders are collected is important; see @HsBinds.lhs@. diff --git a/ghc/compiler/hsSyn/HsPragmas.lhs b/ghc/compiler/hsSyn/HsPragmas.lhs index 59a29b3757..876ba1d234 100644 --- a/ghc/compiler/hsSyn/HsPragmas.lhs +++ b/ghc/compiler/hsSyn/HsPragmas.lhs @@ -16,7 +16,7 @@ for values show up; ditto @SpecInstSig@ (for instances) and module HsPragmas where -import Ubiq +IMP_Ubiq() -- friends: import HsCore ( UnfoldingCoreExpr ) diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index aa4a6bdc9b..5e46ea2642 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -27,7 +27,7 @@ module HsSyn ( ) where -import Ubiq +IMP_Ubiq() -- friends: import HsBinds diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 945ae656b8..41e552747b 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -23,7 +23,7 @@ module HsTypes ( ) where #ifdef COMPILING_GHC -import Ubiq +IMP_Ubiq() import Outputable ( interppSP, ifnotPprForUser ) import Pretty diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index edf7a30c82..04ae96f182 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -15,7 +15,7 @@ module ErrUtils ( ghcExit ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Bag ( bagToList ) import PprStyle ( PprStyle(..) ) diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 49c9b69992..c0d47913cd 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -8,9 +8,7 @@ module Main ( main ) where -import Ubiq{-uitous-} - -import PreludeGlaST ( thenPrimIO, fopen, fclose, _FILE{-instance CCallable-} ) +IMP_Ubiq(){-uitous-} import HsSyn @@ -37,6 +35,7 @@ import RdrHsSyn ( getRawExportees ) import Specialise ( SpecialiseData(..) ) import StgSyn ( pprPlainStgBinding, GenStgBinding ) import TcInstUtil ( InstInfo ) +import TyCon ( isDataTyCon ) import UniqSupply ( mkSplitUniqSupply ) import PprAbsC ( dumpRealC, writeRealC ) @@ -65,7 +64,7 @@ main doIt :: ([CoreToDo], [StgToDo]) -> String -> IO () doIt (core_cmds, stg_cmds) input_pgm - = doDump opt_Verbose "Glasgow Haskell Compiler, version 1.01, for Haskell 1.3" "" >> + = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.01, for Haskell 1.3" "" >> -- ******* READER show_pass "Reader" >> @@ -159,8 +158,8 @@ doIt (core_cmds, stg_cmds) input_pgm case tc_results of { (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds), - interface_stuff, - (local_tycons,local_classes), pragma_tycon_specs, ddump_deriv) -> + interface_stuff@(_,local_tycons,_,_), + pragma_tycon_specs, ddump_deriv) -> doDump opt_D_dump_tc "Typechecked:" (pp_show (ppAboves [ @@ -198,8 +197,11 @@ doIt (core_cmds, stg_cmds) input_pgm -- ******* CORE-TO-CORE SIMPLIFICATION (NB: I/O op) show_pass "Core2Core" >> _scc_ "Core2Core" + let + local_data_tycons = filter isDataTyCon local_tycons + in core2core core_cmds mod_name pprStyle - sm_uniqs local_tycons pragma_tycon_specs desugared + sm_uniqs local_data_tycons pragma_tycon_specs desugared >>= \ (simplified, inlinings_env, @@ -312,15 +314,9 @@ doIt (core_cmds, stg_cmds) input_pgm = case switch of Nothing -> return () Just fname -> - fopen fname "a+" `thenPrimIO` \ file -> - if (file == ``NULL'') then - error ("doOutput: failed to open:"++fname) - else - io_action file >>= \ () -> - fclose file `thenPrimIO` \ status -> - if status == 0 - then return () - else error ("doOutput: closed failed: "{-++show status++" "-}++fname) + openFile fname WriteMode >>= \ handle -> + io_action handle >> + hClose handle doDump switch hdr string = if switch diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index ce876cb1b2..8083b8d891 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -18,7 +18,7 @@ module MkIface ( ifacePragmas ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Bag ( emptyBag, snocBag, bagToList ) import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) ) @@ -26,7 +26,7 @@ import CmdLineOpts ( opt_ProduceHi ) import FieldLabel ( FieldLabel{-instance NamedThing-} ) import FiniteMap ( fmToList ) import HsSyn -import Id ( idType, dataConSig, dataConFieldLabels, +import Id ( idType, dataConRawArgTys, dataConFieldLabels, dataConStrictMarks, StrictnessMark(..), GenId{-instance NamedThing/Outputable-} ) @@ -60,6 +60,7 @@ ppr_name n pp = prettyToUn (ppr PprInterface on) in (if isLexSym s then uppParens else id) pp +{-OLD: ppr_unq_name n = let on = origName n @@ -67,6 +68,7 @@ ppr_unq_name n pp = uppPStr s in (if isLexSym s then uppParens else id) pp +-} \end{code} We have a function @startIface@ to open the output file and put @@ -144,7 +146,7 @@ ifaceUsages (Just if_hdl) usages upp_versions (fmToList versions), uppSemi] upp_versions nvs - = uppIntersperse upp'SP{-'-} [ uppCat [(if isLexSym n then uppParens else id) (uppPStr n), uppInt v] | (n,v) <- nvs ] + = uppIntersperse uppSP [ uppCat [(if isLexSym n then uppParens else id) (uppPStr n), uppInt v] | (n,v) <- nvs ] \end{code} \begin{code} @@ -256,14 +258,13 @@ ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _) ifaceDecls Nothing{-no iface handle-} _ = return () ifaceDecls (Just if_hdl) (vals, tycons, classes, _) - = let - togo_classes = [ c | c <- classes, isLocallyDefined c ] - togo_tycons = [ t | t <- tycons, isLocallyDefined t ] - togo_vals = [ v | v <- vals, isLocallyDefined v ] - - sorted_classes = sortLt ltLexical togo_classes - sorted_tycons = sortLt ltLexical togo_tycons - sorted_vals = sortLt ltLexical togo_vals + = ASSERT(all isLocallyDefined vals) + ASSERT(all isLocallyDefined tycons) + ASSERT(all isLocallyDefined classes) + let + sorted_classes = sortLt ltLexical classes + sorted_tycons = sortLt ltLexical tycons + sorted_vals = sortLt ltLexical vals in if (null sorted_classes && null sorted_tycons && null sorted_vals) then -- You could have a module with just instances in it @@ -365,7 +366,7 @@ ppr_tycon tycon ppr_tc (initNmbr (nmbrTyCon tycon)) ------------------------ -ppr_tc (PrimTyCon _ n _) +ppr_tc (PrimTyCon _ n _ _) = uppCat [ uppStr "{- data", ppr_name n, uppStr " *built-in* -}" ] ppr_tc FunTyCon @@ -386,7 +387,7 @@ ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new) ppr_context ctxt, ppr_name n, uppIntersperse uppSP (map ppr_tyvar tvs), - pp_unabstract_condecls, + uppEquals, pp_condecls, uppSemi] -- NB: we do not print deriving info in interfaces where @@ -401,16 +402,6 @@ ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new) uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs], uppRparen, uppPStr SLIT(" =>")] - yes_we_print_condecls - = case (getExportFlag n) of - ExportAbs -> False - other -> True - - pp_unabstract_condecls - = if yes_we_print_condecls - then uppCat [uppEquals, pp_condecls] - else uppNil - pp_condecls = let (c:cs) = cons @@ -421,11 +412,11 @@ ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new) ppr_con con = let - (_, _, con_arg_tys, _) = dataConSig con + con_arg_tys = dataConRawArgTys con labels = dataConFieldLabels con -- none if not a record strict_marks = dataConStrictMarks con in - uppCat [ppr_unq_name con, ppr_fields labels strict_marks con_arg_tys] + uppCat [ppr_name con, ppr_fields labels strict_marks con_arg_tys] ppr_fields labels strict_marks con_arg_tys = if null labels then -- not a record thingy @@ -440,7 +431,7 @@ ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new) (prettyToUn (pprParendType PprInterface t)) ppr_field l b t - = uppBesides [ppr_unq_name l, uppPStr SLIT(" :: "), + = uppBesides [ppr_name l, uppPStr SLIT(" :: "), case b of { MarkedStrict -> uppChar '!'; _ -> uppNil }, ppr_ty t] \end{code} diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 90863433d3..830e450dfc 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -7,7 +7,7 @@ module AbsCStixGen ( genCodeAbstractC ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import AbsCSyn import Stix @@ -33,6 +33,10 @@ import StixMacro ( macroCode ) import StixPrim ( primCode, amodeToStix, amodeToStix' ) import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) ) import Util ( naturalMergeSortLe, panic ) + +#ifdef REALLY_HASKELL_1_3 +ord = fromEnum :: Char -> Int +#endif \end{code} For each independent chunk of AbstractC code, we generate a list of diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index ac259c4fea..090e13fc68 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -7,7 +7,7 @@ module AsmCodeGen ( writeRealAsm, dumpRealAsm ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import MachMisc import MachRegs @@ -23,7 +23,7 @@ import PrimRep ( PrimRep{-instance Eq-} ) import RegAllocInfo ( mkMRegsState, MRegsState ) import Stix ( StixTree(..), StixReg(..), CodeSegment ) import UniqSupply ( returnUs, thenUs, mapUs, UniqSM(..) ) -import Unpretty ( uppAppendFile, uppShow, uppAboves, Unpretty(..) ) +import Unpretty ( uppPutStr, uppShow, uppAboves, Unpretty(..) ) \end{code} The 96/03 native-code generator has machine-independent and @@ -73,10 +73,10 @@ The machine-dependent bits break down as follows: So, here we go: \begin{code} -writeRealAsm :: _FILE -> AbstractC -> UniqSupply -> IO () +writeRealAsm :: Handle -> AbstractC -> UniqSupply -> IO () -writeRealAsm file absC us - = uppAppendFile file 80 (runNCG absC us) +writeRealAsm handle absC us + = uppPutStr handle 80 (runNCG absC us) dumpRealAsm :: AbstractC -> UniqSupply -> String diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs index 6f8df0b713..00d5d79e56 100644 --- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs +++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs @@ -8,13 +8,14 @@ module AsmRegAlloc ( runRegAllocate, runHairyRegAllocate ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import MachCode ( InstrList(..) ) import MachMisc ( Instr ) import MachRegs import RegAllocInfo +import AbsCSyn ( MagicId ) import BitSet ( BitSet ) import FiniteMap ( emptyFM, addListToFM, delListFromFM, lookupFM, keysFM ) import Maybes ( maybeToBool ) diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 25d9be3f15..c9b671ebd6 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -14,7 +14,7 @@ structure should not be too overwhelming. module MachCode ( stmt2Instrs, asmVoid, InstrList(..) ) where -import Ubiq{-uitious-} +IMP_Ubiq(){-uitious-} import MachMisc -- may differ per-platform import MachRegs diff --git a/ghc/compiler/nativeGen/MachMisc.lhs b/ghc/compiler/nativeGen/MachMisc.lhs index 237b3343f1..54f761601d 100644 --- a/ghc/compiler/nativeGen/MachMisc.lhs +++ b/ghc/compiler/nativeGen/MachMisc.lhs @@ -41,9 +41,9 @@ module MachMisc ( #endif ) where -import Ubiq{-uitous-} -import AbsCLoop ( fixedHdrSizeInWords, varHdrSizeInWords ) -- paranoia -import NcgLoop ( underscorePrefix, fmtAsmLbl ) -- paranoia +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(AbsCLoop) ( fixedHdrSizeInWords, varHdrSizeInWords ) -- paranoia +IMPORT_DELOOPER(NcgLoop) ( underscorePrefix, fmtAsmLbl ) -- paranoia import AbsCSyn ( MagicId(..) ) import AbsCUtils ( magicIdPrimRep ) diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs index 32159f1dc9..7493de4e9f 100644 --- a/ghc/compiler/nativeGen/MachRegs.lhs +++ b/ghc/compiler/nativeGen/MachRegs.lhs @@ -59,7 +59,7 @@ module MachRegs ( #endif ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import AbsCSyn ( MagicId(..) ) import AbsCUtils ( magicIdPrimRep ) @@ -331,16 +331,19 @@ cmp_i a1 a2 = if a1 == a2 then EQ_ else if a1 < a2 then LT_ else GT_ cmp_ihash :: FAST_INT -> FAST_INT -> TAG_ cmp_ihash a1 a2 = if a1 _EQ_ a2 then EQ_ else if a1 _LT_ a2 then LT_ else GT_ +instance Ord3 Reg where + cmp = cmpReg + instance Eq Reg where - a == b = case cmpReg a b of { EQ_ -> True; _ -> False } - a /= b = case cmpReg a b of { EQ_ -> False; _ -> True } + a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } + a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } instance Ord Reg where - a <= b = case cmpReg a b of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case cmpReg a b of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case cmpReg a b of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case cmpReg a b of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp a b = case cmpReg a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } + a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } + a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } + a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } + a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } + _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } instance Uniquable Reg where uniqueOf (UnmappedReg u _) = u diff --git a/ghc/compiler/nativeGen/PprMach.lhs b/ghc/compiler/nativeGen/PprMach.lhs index 65a5edc092..3d4d67954d 100644 --- a/ghc/compiler/nativeGen/PprMach.lhs +++ b/ghc/compiler/nativeGen/PprMach.lhs @@ -13,11 +13,12 @@ We start with the @pprXXX@s with some cross-platform commonality module PprMach ( pprInstr ) where -import Ubiq{-uitious-} +IMP_Ubiq(){-uitious-} import MachRegs -- may differ per-platform import MachMisc +import AbsCSyn ( MagicId ) import CLabel ( pprCLabel_asm, externallyVisibleCLabel ) import CStrings ( charToC ) import Maybes ( maybeToBool ) @@ -214,8 +215,8 @@ pprSize x = uppPStr (case x of #endif #if sparc_TARGET_ARCH B -> SLIT("sb") + BU -> SLIT("ub") -- HW -> SLIT("hw") UNUSED --- BU -> SLIT("ub") UNUSED -- HWU -> SLIT("uhw") UNUSED W -> SLIT("") F -> SLIT("") diff --git a/ghc/compiler/nativeGen/RegAllocInfo.lhs b/ghc/compiler/nativeGen/RegAllocInfo.lhs index 93cda5c3a1..e650837176 100644 --- a/ghc/compiler/nativeGen/RegAllocInfo.lhs +++ b/ghc/compiler/nativeGen/RegAllocInfo.lhs @@ -51,12 +51,13 @@ module RegAllocInfo ( freeRegSet ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import MachMisc import MachRegs import MachCode ( InstrList(..) ) +import AbsCSyn ( MagicId ) import BitSet ( unitBS, mkBS, minusBS, unionBS, listBS, BitSet ) import CLabel ( pprCLabel_asm, CLabel{-instance Ord-} ) import FiniteMap ( addToFM, lookupFM ) diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index f187e9fe1d..2dd8169c55 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -15,7 +15,7 @@ module Stix ( getUniqLabelNCG ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import AbsCSyn ( node, infoptr, MagicId(..) ) import AbsCUtils ( magicIdPrimRep ) diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs index 82b88c6760..9afcec5480 100644 --- a/ghc/compiler/nativeGen/StixInfo.lhs +++ b/ghc/compiler/nativeGen/StixInfo.lhs @@ -7,7 +7,7 @@ module StixInfo ( genCodeInfoTable ) where -import Ubiq{-uitious-} +IMP_Ubiq(){-uitious-} import AbsCSyn ( AbstractC(..), CAddrMode, ReturnInfo, RegRelative, MagicId, CStmtMacro diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index fe9ec744e8..5c90139f2c 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -11,8 +11,8 @@ module StixInteger ( encodeFloatingKind, decodeFloatingKind ) where -import Ubiq{-uitous-} -import NcgLoop ( amodeToStix ) +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(NcgLoop) ( amodeToStix ) import MachMisc import MachRegs diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index 4e7b47f8a0..62c5f9762a 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -7,8 +7,8 @@ module StixMacro ( macroCode, heapCheck ) where -import Ubiq{-uitious-} -import NcgLoop ( amodeToStix ) +IMP_Ubiq(){-uitious-} +IMPORT_DELOOPER(NcgLoop) ( amodeToStix ) import MachMisc import MachRegs diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 01b0404176..c986b3117b 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -7,8 +7,8 @@ module StixPrim ( primCode, amodeToStix, amodeToStix' ) where -import Ubiq{-uitous-} -import NcgLoop -- paranoia checking only +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(NcgLoop) -- paranoia checking only import MachMisc import MachRegs @@ -32,6 +32,10 @@ import StixInteger {- everything -} import UniqSupply ( returnUs, thenUs, UniqSM(..) ) import Unpretty ( uppBeside, uppPStr, uppInt ) import Util ( panic ) + +#ifdef REALLY_HASKELL_1_3 +ord = fromEnum :: Char -> Int +#endif \end{code} The main honcho here is primCode, which handles the guts of COpStmts. diff --git a/ghc/compiler/parser/UgenAll.lhs b/ghc/compiler/parser/UgenAll.lhs index 9bb3e80a75..d6ebf181e7 100644 --- a/ghc/compiler/parser/UgenAll.lhs +++ b/ghc/compiler/parser/UgenAll.lhs @@ -1,6 +1,8 @@ Stuff the Ugenny things show to the parser. \begin{code} +#include "HsVersions.h" + module UgenAll ( -- re-exported Prelude stuff returnUgn, thenUgn, @@ -25,7 +27,7 @@ module UgenAll ( import PreludeGlaST -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} -- friends: import U_binding diff --git a/ghc/compiler/parser/UgenUtil.lhs b/ghc/compiler/parser/UgenUtil.lhs index 860c33be3d..a432c3cf8f 100644 --- a/ghc/compiler/parser/UgenUtil.lhs +++ b/ghc/compiler/parser/UgenUtil.lhs @@ -14,7 +14,7 @@ module UgenUtil ( import PreludeGlaST -import Ubiq +IMP_Ubiq() import Name ( RdrName(..) ) import SrcLoc ( mkSrcLoc2, mkUnknownSrcLoc ) diff --git a/ghc/compiler/parser/binding.ugn b/ghc/compiler/parser/binding.ugn index 3b130aedae..b03ba07394 100644 --- a/ghc/compiler/parser/binding.ugn +++ b/ghc/compiler/parser/binding.ugn @@ -2,8 +2,10 @@ #include "hspincl.h" %} %{{ +#include "HsVersions.h" + module U_binding where -import Ubiq -- debugging consistency check +IMP_Ubiq() -- debugging consistency check import UgenUtil import U_constr diff --git a/ghc/compiler/parser/constr.ugn b/ghc/compiler/parser/constr.ugn index e2d37336cf..30cd438121 100644 --- a/ghc/compiler/parser/constr.ugn +++ b/ghc/compiler/parser/constr.ugn @@ -2,8 +2,10 @@ #include "hspincl.h" %} %{{ +#include "HsVersions.h" + module U_constr where -import Ubiq -- debugging consistency check +IMP_Ubiq() -- debugging consistency check import UgenUtil import U_maybe diff --git a/ghc/compiler/parser/either.ugn b/ghc/compiler/parser/either.ugn index a75acf94cb..f59778cdba 100644 --- a/ghc/compiler/parser/either.ugn +++ b/ghc/compiler/parser/either.ugn @@ -2,8 +2,10 @@ #include "hspincl.h" %} %{{ +#include "HsVersions.h" + module U_either where -import Ubiq -- debugging consistency check +IMP_Ubiq() -- debugging consistency check import UgenUtil %}} type either; diff --git a/ghc/compiler/parser/entidt.ugn b/ghc/compiler/parser/entidt.ugn index eb661c0c73..6ae01e2dc4 100644 --- a/ghc/compiler/parser/entidt.ugn +++ b/ghc/compiler/parser/entidt.ugn @@ -2,8 +2,10 @@ #include "hspincl.h" %} %{{ +#include "HsVersions.h" + module U_entidt where -import Ubiq -- debugging consistency check +IMP_Ubiq() -- debugging consistency check import UgenUtil import U_list diff --git a/ghc/compiler/parser/hslexer.flex b/ghc/compiler/parser/hslexer.flex index f66949f0a2..d5c187e05f 100644 --- a/ghc/compiler/parser/hslexer.flex +++ b/ghc/compiler/parser/hslexer.flex @@ -240,7 +240,7 @@ O [0-7] H [0-9A-Fa-f] N {D}+ F {N}"."{N}(("e"|"E")("+"|"-")?{N})? -S [!#$%&*+./<=>?@\\^|-~:\xa1-\xbf\xd7\xf7] +S [!#$%&*+./<=>?@\\^|\-~:\xa1-\xbf\xd7\xf7] SId {S}{S}* L [A-Z\xc0-\xd6\xd8-\xde] l [a-z\xdf-\xf6\xf8-\xff] @@ -304,8 +304,13 @@ NL [\n\r] PUSH_STATE(UserPragma); RETURN(DEFOREST_UPRAGMA); } +<Code,GlaExt>"{-#"{WS}*"GENERATE_SPECS" { + /* these are handled by hscpp */ + nested_comments =1; + PUSH_STATE(Comment); + } <Code,GlaExt>"{-#"{WS}*[A-Z_]+ { - fprintf(stderr, "Warning: \"%s\", line %d: Unrecognised pragma '", + fprintf(stderr, "\"%s\", line %d: Warning: Unrecognised pragma '", input_filename, hsplineno); format_string(stderr, (unsigned char *) yytext, yyleng); fputs("'\n", stderr); @@ -888,8 +893,6 @@ NL [\n\r] This allows unnamed sources to be piped into the parser. */ -extern BOOLEAN acceptPrim; - void yyinit(void) { @@ -899,7 +902,7 @@ yyinit(void) setyyin _before_ calling yylex for the first time! */ yy_switch_to_buffer(yy_create_buffer(stdin, YY_BUF_SIZE)); - if (acceptPrim) + if (nonstandardFlag) PUSH_STATE(GlaExt); else PUSH_STATE(Code); diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y index 50ba88fd23..930f6d50d0 100644 --- a/ghc/compiler/parser/hsparser.y +++ b/ghc/compiler/parser/hsparser.y @@ -258,7 +258,7 @@ BOOLEAN inpat; qvarid qconid qvarsym qconsym qvar qcon qvarop qconop qop qvark qconk qtycon qtycls - gcon gconk gtycon qop1 qvarop1 + gcon gconk gtycon itycon qop1 qvarop1 ename iname %type <ubinding> topdecl topdecls letdecls @@ -400,10 +400,16 @@ import_list: ; import : var { $$ = mkentid(mknoqual($1)); } - | tycon { $$ = mkenttype(mknoqual($1)); } - | tycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall(mknoqual($1)); } - | tycon OPAREN CPAREN { $$ = mkenttypenamed(mknoqual($1),Lnil); } - | tycon OPAREN inames CPAREN { $$ = mkenttypenamed(mknoqual($1),$3); } + | itycon { $$ = mkenttype($1); } + | itycon OPAREN DOTDOT CPAREN { $$ = mkenttypeall($1); } + | itycon OPAREN CPAREN { $$ = mkenttypenamed($1,Lnil);} + | itycon OPAREN inames CPAREN { $$ = mkenttypenamed($1,$3); } + ; + +itycon : tycon { $$ = mknoqual($1); } + | OBRACK CBRACK { $$ = creategid(-1); } + | OPAREN CPAREN { $$ = creategid(0); } + | OPAREN commas CPAREN { $$ = creategid($2); } ; inames : iname { $$ = lsing($1); } diff --git a/ghc/compiler/parser/list.ugn b/ghc/compiler/parser/list.ugn index 6ffd8920c6..b6c5908e15 100644 --- a/ghc/compiler/parser/list.ugn +++ b/ghc/compiler/parser/list.ugn @@ -2,8 +2,10 @@ #include "hspincl.h" %} %{{ +#include "HsVersions.h" + module U_list where -import Ubiq -- debugging consistency check +IMP_Ubiq() -- debugging consistency check import UgenUtil %}} type list; diff --git a/ghc/compiler/parser/literal.ugn b/ghc/compiler/parser/literal.ugn index fea4048ac3..49c68b0803 100644 --- a/ghc/compiler/parser/literal.ugn +++ b/ghc/compiler/parser/literal.ugn @@ -2,8 +2,10 @@ #include "hspincl.h" %} %{{ +#include "HsVersions.h" + module U_literal where -import Ubiq -- debugging consistency check +IMP_Ubiq() -- debugging consistency check import UgenUtil %}} type literal; diff --git a/ghc/compiler/parser/maybe.ugn b/ghc/compiler/parser/maybe.ugn index a9120832c1..cfcf959131 100644 --- a/ghc/compiler/parser/maybe.ugn +++ b/ghc/compiler/parser/maybe.ugn @@ -2,8 +2,10 @@ #include "hspincl.h" %} %{{ +#include "HsVersions.h" + module U_maybe where -import Ubiq -- debugging consistency check +IMP_Ubiq() -- debugging consistency check import UgenUtil %}} type maybe; diff --git a/ghc/compiler/parser/pbinding.ugn b/ghc/compiler/parser/pbinding.ugn index 2700417e5a..f695eac811 100644 --- a/ghc/compiler/parser/pbinding.ugn +++ b/ghc/compiler/parser/pbinding.ugn @@ -2,8 +2,10 @@ #include "hspincl.h" %} %{{ +#include "HsVersions.h" + module U_pbinding where -import Ubiq -- debugging consistency check +IMP_Ubiq() -- debugging consistency check import UgenUtil import U_constr ( U_constr ) -- interface only diff --git a/ghc/compiler/parser/qid.ugn b/ghc/compiler/parser/qid.ugn index f42d5072a6..4ecd7cf370 100644 --- a/ghc/compiler/parser/qid.ugn +++ b/ghc/compiler/parser/qid.ugn @@ -2,8 +2,10 @@ #include "hspincl.h" %} %{{ +#include "HsVersions.h" + module U_qid where -import Ubiq -- debugging consistency check +IMP_Ubiq() -- debugging consistency check import UgenUtil %}} type qid; diff --git a/ghc/compiler/parser/tree.ugn b/ghc/compiler/parser/tree.ugn index fb69ec100c..86c5174c78 100644 --- a/ghc/compiler/parser/tree.ugn +++ b/ghc/compiler/parser/tree.ugn @@ -2,8 +2,10 @@ #include "hspincl.h" %} %{{ +#include "HsVersions.h" + module U_tree where -import Ubiq -- debugging consistency check +IMP_Ubiq() -- debugging consistency check import UgenUtil import U_constr ( U_constr ) -- interface only diff --git a/ghc/compiler/parser/ttype.ugn b/ghc/compiler/parser/ttype.ugn index f548b3201e..25d451393f 100644 --- a/ghc/compiler/parser/ttype.ugn +++ b/ghc/compiler/parser/ttype.ugn @@ -2,8 +2,10 @@ #include "hspincl.h" %} %{{ +#include "HsVersions.h" + module U_ttype where -import Ubiq -- debugging consistency check +IMP_Ubiq() -- debugging consistency check import UgenUtil import U_list diff --git a/ghc/compiler/parser/util.c b/ghc/compiler/parser/util.c index f8ebc57c09..e07cf7dc3c 100644 --- a/ghc/compiler/parser/util.c +++ b/ghc/compiler/parser/util.c @@ -10,24 +10,18 @@ #include "constants.h" #include "utils.h" -#define PARSER_VERSION "1.3-???" +#define PARSER_VERSION "2.01 (Haskell 1.3)" tree root; /* The root of the built syntax tree. */ list Lnil; BOOLEAN nonstandardFlag = FALSE; /* Set if non-std Haskell extensions to be used. */ -BOOLEAN acceptPrim = FALSE; /* Set if Int#, etc., may be used */ BOOLEAN haskell1_2Flag = FALSE; /* Set if we are compiling for 1.2 */ BOOLEAN etags = FALSE; /* Set if we're parsing only to produce tags. */ BOOLEAN hashIds = FALSE; /* Set if Identifiers should be hashed. */ BOOLEAN ignoreSCC = TRUE; /* Set if we ignore/filter scc expressions. */ -static BOOLEAN verbose = FALSE; /* Set for verbose messages. */ - -/* Forward decls */ -static void who_am_i PROTO((void)); - /********************************************************************** * * * * @@ -48,8 +42,6 @@ process_args(argc,argv) { BOOLEAN keep_munging_option = FALSE; - argc--, argv++; - while (argc > 0 && argv[0][0] == '-') { keep_munging_option = TRUE; @@ -57,14 +49,8 @@ process_args(argc,argv) while (keep_munging_option && *++*argv != '\0') { switch(**argv) { - case 'v': - who_am_i(); /* identify myself */ - verbose = TRUE; - break; - case 'N': nonstandardFlag = TRUE; - acceptPrim = TRUE; break; case '2': @@ -106,12 +92,6 @@ process_args(argc,argv) fprintf(stderr, "Cannot open %s.\n", argv[1]); exit(1); } - - if (verbose) { - fprintf(stderr,"Hash Table Contains %d entries\n",hash_table_size); - if(acceptPrim) - fprintf(stderr,"Allowing special syntax for Unboxed Values\n"); - } } void @@ -122,12 +102,6 @@ error(s) exit(1); } -static void -who_am_i(void) -{ - fprintf(stderr,"Glasgow Haskell parser, version %s\n", PARSER_VERSION); -} - list lconc(l1, l2) list l1; diff --git a/ghc/compiler/parser/utils.h b/ghc/compiler/parser/utils.h index 816304c913..c4f60a9e75 100644 --- a/ghc/compiler/parser/utils.h +++ b/ghc/compiler/parser/utils.h @@ -12,7 +12,6 @@ extern list all; extern BOOLEAN nonstandardFlag; extern BOOLEAN hashIds; -extern BOOLEAN acceptPrim; extern BOOLEAN etags; extern BOOLEAN ignoreSCC; diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 95af63e27c..ccefcf3638 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -15,8 +15,8 @@ module PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon ) where -import Ubiq -import PrelLoop ( primOpNameInfo ) +IMP_Ubiq() +IMPORT_DELOOPER(PrelLoop) ( primOpNameInfo ) -- friends: import PrelMods -- Prelude module names @@ -119,8 +119,7 @@ builtinNameInfo -- tycons map pcTyConWiredInInfo prim_tycons, map pcTyConWiredInInfo g_tycons, - map pcTyConWiredInInfo data_tycons, - map pcTyConWiredInInfo synonym_tycons + map pcTyConWiredInInfo data_tycons ] assoc_keys @@ -174,13 +173,11 @@ g_con_tycons min_nonprim_tycon_list -- used w/ HideMostBuiltinNames = [ boolTyCon - , orderingTyCon , charTyCon , intTyCon , floatTyCon , doubleTyCon , integerTyCon - , ratioTyCon , liftTyCon , return2GMPsTyCon -- ADR asked for these last two (WDP 94/11) , returnIntAndGMPTyCon @@ -191,16 +188,16 @@ data_tycons = [ addrTyCon , boolTyCon , charTyCon - , orderingTyCon , doubleTyCon , floatTyCon + , foreignObjTyCon , intTyCon , integerTyCon , liftTyCon - , foreignObjTyCon - , ratioTyCon + , primIoTyCon , return2GMPsTyCon , returnIntAndGMPTyCon + , stTyCon , stablePtrTyCon , stateAndAddrPrimTyCon , stateAndArrayPrimTyCon @@ -208,24 +205,17 @@ data_tycons , stateAndCharPrimTyCon , stateAndDoublePrimTyCon , stateAndFloatPrimTyCon - , stateAndIntPrimTyCon , stateAndForeignObjPrimTyCon + , stateAndIntPrimTyCon , stateAndMutableArrayPrimTyCon , stateAndMutableByteArrayPrimTyCon - , stateAndSynchVarPrimTyCon , stateAndPtrPrimTyCon , stateAndStablePtrPrimTyCon + , stateAndSynchVarPrimTyCon , stateAndWordPrimTyCon , stateTyCon , wordTyCon ] - -synonym_tycons - = [ primIoTyCon - , rationalTyCon - , stTyCon - , stringTyCon - ] \end{code} The WiredIn Ids ... @@ -318,12 +308,28 @@ For the Ids we may also have some builtin IdInfo. \begin{code} id_keys_infos :: [((FAST_STRING,Module), Unique, Maybe IdInfo)] id_keys_infos - = [ ((SLIT("main"),SLIT("Main")), mainIdKey, Nothing) + = [ -- here so we can check the type of main/mainPrimIO + ((SLIT("main"),SLIT("Main")), mainIdKey, Nothing) , ((SLIT("mainPrimIO"),SLIT("Main")), mainPrimIOIdKey, Nothing) + + -- here because we use them in derived instances + , ((SLIT("&&"), pRELUDE), andandIdKey, Nothing) + , ((SLIT("."), pRELUDE), composeIdKey, Nothing) + , ((SLIT("lex"), pRELUDE), lexIdKey, Nothing) + , ((SLIT("not"), pRELUDE), notIdKey, Nothing) + , ((SLIT("readParen"), pRELUDE), readParenIdKey, Nothing) + , ((SLIT("showParen"), pRELUDE), showParenIdKey, Nothing) + , ((SLIT("showString"), pRELUDE), showStringIdKey,Nothing) + , ((SLIT("__readList"), pRELUDE), ureadListIdKey, Nothing) + , ((SLIT("__showList"), pRELUDE), ushowListIdKey, Nothing) + , ((SLIT("__showSpace"), pRELUDE), showSpaceIdKey, Nothing) ] tysyn_keys - = [ ((SLIT("IO"),pRELUDE), (iOTyConKey, RnImplicitTyCon)) + = [ ((SLIT("IO"),pRELUDE), (iOTyConKey, RnImplicitTyCon)) + , ((SLIT("Rational"),rATIO), (rationalTyConKey, RnImplicitTyCon)) + , ((SLIT("Ratio"),rATIO), (ratioTyConKey, RnImplicitTyCon)) + , ((SLIT("Ordering"),pRELUDE), (orderingTyConKey, RnImplicitTyCon)) ] -- this "class_keys" list *must* include: @@ -351,8 +357,8 @@ class_keys , ((SLIT("MonadZero"),pRELUDE), monadZeroClassKey) , ((SLIT("MonadPlus"),pRELUDE), monadPlusClassKey) , ((SLIT("Functor"),pRELUDE), functorClassKey) - , ((SLIT("CCallable"),pRELUDE), cCallableClassKey) -- mentioned, ccallish - , ((SLIT("CReturnable"),pRELUDE), cReturnableClassKey) -- mentioned, ccallish + , ((SLIT("_CCallable"),pRELUDE), cCallableClassKey) -- mentioned, ccallish + , ((SLIT("_CReturnable"),pRELUDE), cReturnableClassKey) -- mentioned, ccallish ]] class_op_keys @@ -365,6 +371,8 @@ class_op_keys , ((SLIT("enumFromTo"),pRELUDE), enumFromToClassOpKey) , ((SLIT("enumFromThenTo"),pRELUDE),enumFromThenToClassOpKey) , ((SLIT("=="),pRELUDE), eqClassOpKey) + , ((SLIT(">>="),pRELUDE), thenMClassOpKey) + , ((SLIT("zero"),pRELUDE), zeroClassOpKey) ]] \end{code} diff --git a/ghc/compiler/prelude/PrelMods.lhs b/ghc/compiler/prelude/PrelMods.lhs index 17bef6a65b..da5b7118ce 100644 --- a/ghc/compiler/prelude/PrelMods.lhs +++ b/ghc/compiler/prelude/PrelMods.lhs @@ -40,4 +40,7 @@ iX = SLIT("Ix") fromPrelude :: FAST_STRING -> Bool fromPrelude s = (_SUBSTR_ s 0 6 == SLIT("Prelude")) + where + substr str beg end + = take (end - beg + 1) (drop beg str) \end{code} diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 0ce975e5ef..9ae53002c9 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -8,10 +8,10 @@ module PrelVals where -import Ubiq -import IdLoop ( UnfoldingGuidance(..) ) +IMP_Ubiq() +IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..) ) import Id ( Id(..), GenId, mkPreludeId, mkTemplateLocals ) -import PrelLoop +IMPORT_DELOOPER(PrelLoop) -- friends: import PrelMods @@ -24,7 +24,7 @@ import IdInfo -- quite a bit import Literal ( mkMachInt ) import PrimOp ( PrimOp(..) ) import SpecEnv ( SpecEnv(..), nullSpecEnv ) -import TyVar ( alphaTyVar, betaTyVar, gammaTyVar ) +import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar ) import Unique -- lots of *Keys import Util ( panic ) \end{code} @@ -97,7 +97,7 @@ pAR_ERROR_ID (mkSigmaTy [alphaTyVar] [] alphaTy) noIdInfo errorTy :: Type -errorTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy] alphaTy) +errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] alphaTy) \end{code} We want \tr{_trace} (NB: name not in user namespace) to be wired in @@ -481,16 +481,12 @@ lex :: ReadS String %************************************************************************ %* * -\subsection[PrelVals-void]{@void#@: Magic value of type @Void#@} +\subsection[PrelVals-void]{@void@: Magic value of type @Void@} %* * %************************************************************************ -I don't think this is available to the user; it's used in the -simplifier (WDP 94/06). \begin{code} -voidPrimId - = pcMiscPrelId voidPrimIdKey pRELUDE_BUILTIN SLIT("void#") - voidPrimTy noIdInfo +voidId = pcMiscPrelId voidIdKey pRELUDE_BUILTIN SLIT("_void") voidTy noIdInfo \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index d02f5e19a7..6527a7e62b 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -29,7 +29,7 @@ module PrimOp ( pprPrimOp, showPrimOp ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import PrimRep -- most of it import TysPrim @@ -38,7 +38,7 @@ import TysWiredIn import CStrings ( identToC ) import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE ) import HeapOffs ( addOff, intOff, totHdrSize ) -import PprStyle ( codeStyle ) +import PprStyle ( codeStyle, PprStyle(..){-ToDo:rm-} ) import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} ) import Pretty import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) ) @@ -1310,6 +1310,12 @@ primOpInfo ParAtRelOp -- parAtRel# :: Int# -> Int# -> Int# -> Int# -> Int# -> a primOpInfo ParAtForNowOp -- parAtForNow# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c = AlgResult SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [alphaTy,betaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] liftTyCon [gammaTy] + +primOpInfo CopyableOp -- copyable# :: a -> a + = AlgResult SLIT("copyable#") [alphaTyVar] [alphaTy] liftTyCon [alphaTy] + +primOpInfo NoFollowOp -- noFollow# :: a -> a + = AlgResult SLIT("noFollow#") [alphaTyVar] [alphaTy] liftTyCon [alphaTy] \end{code} %************************************************************************ @@ -1335,8 +1341,12 @@ primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld# primOpInfo (CCallOp _ _ _ arg_tys result_ty) = AlgResult SLIT("ccall#") [] arg_tys result_tycon tys_applied where - (result_tycon, tys_applied, _) = _trace "PrimOp.getAppDataTyConExpandingDicts" $ + (result_tycon, tys_applied, _) = -- _trace "PrimOp.getAppDataTyConExpandingDicts" $ getAppDataTyConExpandingDicts result_ty + +#ifdef DEBUG +primOpInfo op = panic ("primOpInfo:"++ show (I# (tagOf_PrimOp op))) +#endif \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/PrimRep.lhs b/ghc/compiler/prelude/PrimRep.lhs index 1a6d45e5e1..94ab0c50f2 100644 --- a/ghc/compiler/prelude/PrimRep.lhs +++ b/ghc/compiler/prelude/PrimRep.lhs @@ -19,7 +19,7 @@ module PrimRep ( guessPrimRep ) where -import Ubiq +IMP_Ubiq() import Pretty -- pretty-printing code import Util @@ -65,7 +65,6 @@ data PrimRep -- (Primitive states are mapped onto this) deriving (Eq, Ord) -- Kinds are used in PrimTyCons, which need both Eq and Ord - -- Text is needed for derived-Text on PrimitiveOps \end{code} %************************************************************************ diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 28b4571219..876048f4d9 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -11,9 +11,9 @@ types and operations.'' module TysPrim where -import Ubiq +IMP_Ubiq(){-uitous-} -import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind ) +import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind ) import Name ( mkBuiltinName ) import PrelMods ( pRELUDE_BUILTIN ) import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn @@ -38,31 +38,34 @@ alphaTys = mkTyVarTys alphaTyVars \begin{code} -- only used herein -pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING - -> Int -> ([PrimRep] -> PrimRep) -> TyCon -pcPrimTyCon key str arity{-UNUSED-} kind_fn{-UNUSED-} - = mkPrimTyCon name mkUnboxedTypeKind +pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> PrimRep -> TyCon + +pcPrimTyCon key str arity primrep + = mkPrimTyCon name (mk_kind arity) primrep where name = mkBuiltinName key pRELUDE_BUILTIN str + mk_kind 0 = mkUnboxedTypeKind + mk_kind n = mkTypeKind `mkArrowKind` mk_kind (n-1) + charPrimTy = applyTyCon charPrimTyCon [] -charPrimTyCon = pcPrimTyCon charPrimTyConKey SLIT("Char#") 0 (\ [] -> CharRep) +charPrimTyCon = pcPrimTyCon charPrimTyConKey SLIT("Char#") 0 CharRep intPrimTy = applyTyCon intPrimTyCon [] -intPrimTyCon = pcPrimTyCon intPrimTyConKey SLIT("Int#") 0 (\ [] -> IntRep) +intPrimTyCon = pcPrimTyCon intPrimTyConKey SLIT("Int#") 0 IntRep wordPrimTy = applyTyCon wordPrimTyCon [] -wordPrimTyCon = pcPrimTyCon wordPrimTyConKey SLIT("Word#") 0 (\ [] -> WordRep) +wordPrimTyCon = pcPrimTyCon wordPrimTyConKey SLIT("Word#") 0 WordRep addrPrimTy = applyTyCon addrPrimTyCon [] -addrPrimTyCon = pcPrimTyCon addrPrimTyConKey SLIT("Addr#") 0 (\ [] -> AddrRep) +addrPrimTyCon = pcPrimTyCon addrPrimTyConKey SLIT("Addr#") 0 AddrRep floatPrimTy = applyTyCon floatPrimTyCon [] -floatPrimTyCon = pcPrimTyCon floatPrimTyConKey SLIT("Float#") 0 (\ [] -> FloatRep) +floatPrimTyCon = pcPrimTyCon floatPrimTyConKey SLIT("Float#") 0 FloatRep doublePrimTy = applyTyCon doublePrimTyCon [] -doublePrimTyCon = pcPrimTyCon doublePrimTyConKey SLIT("Double#") 0 (\ [] -> DoubleRep) +doublePrimTyCon = pcPrimTyCon doublePrimTyConKey SLIT("Double#") 0 DoubleRep \end{code} @PrimitiveKinds@ are used in @PrimitiveOps@, for which we often need @@ -85,32 +88,29 @@ getPrimRepInfo DoubleRep = ("Double", doublePrimTy, doublePrimTyCon) %************************************************************************ %* * -\subsection[TysPrim-void]{The @Void#@ type} +\subsection[TysPrim-state]{The @State#@ type (and @_RealWorld@ types)} %* * %************************************************************************ -Very similar to the @State#@ type. -\begin{code} -voidPrimTy = applyTyCon voidPrimTyCon [] - where - voidPrimTyCon = pcPrimTyCon voidPrimTyConKey SLIT("Void#") 0 - (\ [] -> VoidRep) -\end{code} +State# is the primitive, unboxed type of states. It has one type parameter, +thus + State# RealWorld +or + State# s -%************************************************************************ -%* * -\subsection[TysPrim-state]{The @State#@ type (and @_RealWorld@ types)} -%* * -%************************************************************************ +where s is a type variable. The only purpose of the type parameter is to +keep different state threads separate. It is represented by nothing at all. \begin{code} mkStatePrimTy ty = applyTyCon statePrimTyCon [ty] -statePrimTyCon = pcPrimTyCon statePrimTyConKey SLIT("State#") 1 - (\ [s_kind] -> VoidRep) +statePrimTyCon = pcPrimTyCon statePrimTyConKey SLIT("State#") 1 VoidRep \end{code} @_RealWorld@ is deeply magical. It {\em is primitive}, but it {\em is not unboxed}. +We never manipulate values of type RealWorld; it's only used in the type +system, to parameterise State#. + \begin{code} realWorldTy = applyTyCon realWorldTyCon [] realWorldTyCon @@ -136,17 +136,13 @@ defined in \tr{TysWiredIn.lhs}, not here. %************************************************************************ \begin{code} -arrayPrimTyCon = pcPrimTyCon arrayPrimTyConKey SLIT("Array#") 1 - (\ [elt_kind] -> ArrayRep) +arrayPrimTyCon = pcPrimTyCon arrayPrimTyConKey SLIT("Array#") 1 ArrayRep -byteArrayPrimTyCon = pcPrimTyCon byteArrayPrimTyConKey SLIT("ByteArray#") 0 - (\ [] -> ByteArrayRep) +byteArrayPrimTyCon = pcPrimTyCon byteArrayPrimTyConKey SLIT("ByteArray#") 0 ByteArrayRep -mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConKey SLIT("MutableArray#") 2 - (\ [s_kind, elt_kind] -> ArrayRep) +mutableArrayPrimTyCon = pcPrimTyCon mutableArrayPrimTyConKey SLIT("MutableArray#") 2 ArrayRep -mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConKey SLIT("MutableByteArray#") 1 - (\ [s_kind] -> ByteArrayRep) +mutableByteArrayPrimTyCon = pcPrimTyCon mutableByteArrayPrimTyConKey SLIT("MutableByteArray#") 1 ByteArrayRep mkArrayPrimTy elt = applyTyCon arrayPrimTyCon [elt] byteArrayPrimTy = applyTyCon byteArrayPrimTyCon [] @@ -161,8 +157,7 @@ mkMutableByteArrayPrimTy s = applyTyCon mutableByteArrayPrimTyCon [s] %************************************************************************ \begin{code} -synchVarPrimTyCon = pcPrimTyCon synchVarPrimTyConKey SLIT("SynchVar#") 2 - (\ [s_kind, elt_kind] -> PtrRep) +synchVarPrimTyCon = pcPrimTyCon synchVarPrimTyConKey SLIT("SynchVar#") 2 PtrRep mkSynchVarPrimTy s elt = applyTyCon synchVarPrimTyCon [s, elt] \end{code} @@ -174,8 +169,7 @@ mkSynchVarPrimTy s elt = applyTyCon synchVarPrimTyCon [s, elt] %************************************************************************ \begin{code} -stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConKey SLIT("StablePtr#") 1 - (\ [elt_kind] -> StablePtrRep) +stablePtrPrimTyCon = pcPrimTyCon stablePtrPrimTyConKey SLIT("StablePtr#") 1 StablePtrRep mkStablePtrPrimTy ty = applyTyCon stablePtrPrimTyCon [ty] \end{code} @@ -202,6 +196,5 @@ could possibly be added?) \begin{code} foreignObjPrimTy = applyTyCon foreignObjPrimTyCon [] -foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConKey SLIT("ForeignObj#") 0 - (\ [] -> ForeignObjRep) +foreignObjPrimTyCon = pcPrimTyCon foreignObjPrimTyConKey SLIT("ForeignObj#") 0 ForeignObjRep \end{code} diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index a4623c2fd2..04b3e4996e 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -25,13 +25,11 @@ module TysWiredIn ( doubleDataCon, doubleTy, doubleTyCon, - eqDataCon, falseDataCon, floatDataCon, floatTy, floatTyCon, getStatePairingConInfo, - gtDataCon, intDataCon, intTy, intTyCon, @@ -41,7 +39,6 @@ module TysWiredIn ( liftDataCon, liftTyCon, listTyCon, - ltDataCon, foreignObjTyCon, mkLiftTy, mkListTy, @@ -49,13 +46,7 @@ module TysWiredIn ( mkStateTransformerTy, mkTupleTy, nilDataCon, - orderingTy, - orderingTyCon, primIoTyCon, - ratioDataCon, - ratioTyCon, - rationalTy, - rationalTyCon, realWorldStateTy, return2GMPsTyCon, returnIntAndGMPTyCon, @@ -78,7 +69,6 @@ module TysWiredIn ( stateDataCon, stateTyCon, stringTy, - stringTyCon, trueDataCon, unitTy, voidTy, voidTyCon, @@ -95,8 +85,8 @@ module TysWiredIn ( --import PprStyle --import Kind -import Ubiq -import TyLoop ( mkDataCon, StrictnessMark(..) ) +IMP_Ubiq() +IMPORT_DELOOPER(TyLoop) ( mkDataCon, StrictnessMark(..) ) -- friends: import PrelMods @@ -110,8 +100,8 @@ import SrcLoc ( mkBuiltinSrcLoc ) import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon, NewOrData(..), TyCon ) -import Type ( mkTyConTy, applyTyCon, mkSynTy, mkSigmaTy, - mkFunTys, maybeAppDataTyConExpandingDicts, +import Type ( mkTyConTy, applyTyCon, mkSigmaTy, + mkFunTys, maybeAppTyCon, GenType(..), ThetaType(..), TauType(..) ) import TyVar ( tyVarKind, alphaTyVar, betaTyVar ) import Unique @@ -122,12 +112,21 @@ addOneToSpecEnv = error "TysWiredIn:addOneToSpecEnv = " pc_gen_specs = error "TysWiredIn:pc_gen_specs " mkSpecInfo = error "TysWiredIn:SpecInfo" -pcDataTyCon :: Unique{-TyConKey-} -> Module -> FAST_STRING - -> [TyVar] -> [Id] -> TyCon -pcDataTyCon key mod str tyvars cons +alpha_tyvar = [alphaTyVar] +alpha_ty = [alphaTy] +alpha_beta_tyvars = [alphaTyVar, betaTyVar] + +pcDataTyCon, pcNewTyCon + :: Unique{-TyConKey-} -> Module -> FAST_STRING + -> [TyVar] -> [Id] -> TyCon + +pcDataTyCon = pc_tycon DataType +pcNewTyCon = pc_tycon NewType + +pc_tycon new_or_data key mod str tyvars cons = mkDataTyCon (mkBuiltinName key mod str) tycon_kind tyvars [{-no context-}] cons [{-no derivings-}] - DataType + new_or_data where tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind tyvars @@ -155,6 +154,13 @@ pcGenerateDataSpecs ty \begin{code} -- The Void type is represented as a data type with no constructors +-- It's a built in type (i.e. there's no way to define it in Haskell +-- the nearest would be +-- +-- data Void = -- No constructors! +-- +-- It's boxed; there is only one value of this +-- type, namely "void", whose semantics is just bottom. voidTy = mkTyConTy voidTyCon voidTyCon = pcDataTyCon voidTyConKey pRELUDE_BUILTIN SLIT("Void") [] [] @@ -206,20 +212,20 @@ doubleDataCon = pcDataCon doubleDataConKey pRELUDE_BUILTIN SLIT("D#") [] [] [dou mkStateTy ty = applyTyCon stateTyCon [ty] realWorldStateTy = mkStateTy realWorldTy -- a common use -stateTyCon = pcDataTyCon stateTyConKey pRELUDE_BUILTIN SLIT("_State") [alphaTyVar] [stateDataCon] +stateTyCon = pcDataTyCon stateTyConKey pRELUDE_BUILTIN SLIT("_State") alpha_tyvar [stateDataCon] stateDataCon = pcDataCon stateDataConKey pRELUDE_BUILTIN SLIT("S#") - [alphaTyVar] [] [mkStatePrimTy alphaTy] stateTyCon nullSpecEnv + alpha_tyvar [] [mkStatePrimTy alphaTy] stateTyCon nullSpecEnv \end{code} \begin{code} stablePtrTyCon = pcDataTyCon stablePtrTyConKey gLASGOW_MISC SLIT("_StablePtr") - [alphaTyVar] [stablePtrDataCon] + alpha_tyvar [stablePtrDataCon] where stablePtrDataCon = pcDataCon stablePtrDataConKey gLASGOW_MISC SLIT("_StablePtr") - [alphaTyVar] [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon nullSpecEnv + alpha_tyvar [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon nullSpecEnv \end{code} \begin{code} @@ -283,118 +289,118 @@ We fish one of these \tr{StateAnd<blah>#} things with \begin{code} stateAndPtrPrimTyCon = pcDataTyCon stateAndPtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndPtr#") - [alphaTyVar, betaTyVar] [stateAndPtrPrimDataCon] + alpha_beta_tyvars [stateAndPtrPrimDataCon] stateAndPtrPrimDataCon = pcDataCon stateAndPtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndPtr#") - [alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, betaTy] + alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy] stateAndPtrPrimTyCon nullSpecEnv stateAndCharPrimTyCon = pcDataTyCon stateAndCharPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndChar#") - [alphaTyVar] [stateAndCharPrimDataCon] + alpha_tyvar [stateAndCharPrimDataCon] stateAndCharPrimDataCon = pcDataCon stateAndCharPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndChar#") - [alphaTyVar] [] [mkStatePrimTy alphaTy, charPrimTy] + alpha_tyvar [] [mkStatePrimTy alphaTy, charPrimTy] stateAndCharPrimTyCon nullSpecEnv stateAndIntPrimTyCon = pcDataTyCon stateAndIntPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndInt#") - [alphaTyVar] [stateAndIntPrimDataCon] + alpha_tyvar [stateAndIntPrimDataCon] stateAndIntPrimDataCon = pcDataCon stateAndIntPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndInt#") - [alphaTyVar] [] [mkStatePrimTy alphaTy, intPrimTy] + alpha_tyvar [] [mkStatePrimTy alphaTy, intPrimTy] stateAndIntPrimTyCon nullSpecEnv stateAndWordPrimTyCon = pcDataTyCon stateAndWordPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndWord#") - [alphaTyVar] [stateAndWordPrimDataCon] + alpha_tyvar [stateAndWordPrimDataCon] stateAndWordPrimDataCon = pcDataCon stateAndWordPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndWord#") - [alphaTyVar] [] [mkStatePrimTy alphaTy, wordPrimTy] + alpha_tyvar [] [mkStatePrimTy alphaTy, wordPrimTy] stateAndWordPrimTyCon nullSpecEnv stateAndAddrPrimTyCon = pcDataTyCon stateAndAddrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndAddr#") - [alphaTyVar] [stateAndAddrPrimDataCon] + alpha_tyvar [stateAndAddrPrimDataCon] stateAndAddrPrimDataCon = pcDataCon stateAndAddrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndAddr#") - [alphaTyVar] [] [mkStatePrimTy alphaTy, addrPrimTy] + alpha_tyvar [] [mkStatePrimTy alphaTy, addrPrimTy] stateAndAddrPrimTyCon nullSpecEnv stateAndStablePtrPrimTyCon = pcDataTyCon stateAndStablePtrPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndStablePtr#") - [alphaTyVar, betaTyVar] [stateAndStablePtrPrimDataCon] + alpha_beta_tyvars [stateAndStablePtrPrimDataCon] stateAndStablePtrPrimDataCon = pcDataCon stateAndStablePtrPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndStablePtr#") - [alphaTyVar, betaTyVar] [] + alpha_beta_tyvars [] [mkStatePrimTy alphaTy, applyTyCon stablePtrPrimTyCon [betaTy]] stateAndStablePtrPrimTyCon nullSpecEnv stateAndForeignObjPrimTyCon = pcDataTyCon stateAndForeignObjPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndForeignObj#") - [alphaTyVar] [stateAndForeignObjPrimDataCon] + alpha_tyvar [stateAndForeignObjPrimDataCon] stateAndForeignObjPrimDataCon = pcDataCon stateAndForeignObjPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndForeignObj#") - [alphaTyVar] [] + alpha_tyvar [] [mkStatePrimTy alphaTy, applyTyCon foreignObjPrimTyCon []] stateAndForeignObjPrimTyCon nullSpecEnv stateAndFloatPrimTyCon = pcDataTyCon stateAndFloatPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndFloat#") - [alphaTyVar] [stateAndFloatPrimDataCon] + alpha_tyvar [stateAndFloatPrimDataCon] stateAndFloatPrimDataCon = pcDataCon stateAndFloatPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndFloat#") - [alphaTyVar] [] [mkStatePrimTy alphaTy, floatPrimTy] + alpha_tyvar [] [mkStatePrimTy alphaTy, floatPrimTy] stateAndFloatPrimTyCon nullSpecEnv stateAndDoublePrimTyCon = pcDataTyCon stateAndDoublePrimTyConKey pRELUDE_BUILTIN SLIT("StateAndDouble#") - [alphaTyVar] [stateAndDoublePrimDataCon] + alpha_tyvar [stateAndDoublePrimDataCon] stateAndDoublePrimDataCon = pcDataCon stateAndDoublePrimDataConKey pRELUDE_BUILTIN SLIT("StateAndDouble#") - [alphaTyVar] [] [mkStatePrimTy alphaTy, doublePrimTy] + alpha_tyvar [] [mkStatePrimTy alphaTy, doublePrimTy] stateAndDoublePrimTyCon nullSpecEnv \end{code} \begin{code} stateAndArrayPrimTyCon = pcDataTyCon stateAndArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndArray#") - [alphaTyVar, betaTyVar] [stateAndArrayPrimDataCon] + alpha_beta_tyvars [stateAndArrayPrimDataCon] stateAndArrayPrimDataCon = pcDataCon stateAndArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndArray#") - [alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, mkArrayPrimTy betaTy] + alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkArrayPrimTy betaTy] stateAndArrayPrimTyCon nullSpecEnv stateAndMutableArrayPrimTyCon = pcDataTyCon stateAndMutableArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMutableArray#") - [alphaTyVar, betaTyVar] [stateAndMutableArrayPrimDataCon] + alpha_beta_tyvars [stateAndMutableArrayPrimDataCon] stateAndMutableArrayPrimDataCon = pcDataCon stateAndMutableArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMutableArray#") - [alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, mkMutableArrayPrimTy alphaTy betaTy] + alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkMutableArrayPrimTy alphaTy betaTy] stateAndMutableArrayPrimTyCon nullSpecEnv stateAndByteArrayPrimTyCon = pcDataTyCon stateAndByteArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndByteArray#") - [alphaTyVar] [stateAndByteArrayPrimDataCon] + alpha_tyvar [stateAndByteArrayPrimDataCon] stateAndByteArrayPrimDataCon = pcDataCon stateAndByteArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndByteArray#") - [alphaTyVar] [] [mkStatePrimTy alphaTy, byteArrayPrimTy] + alpha_tyvar [] [mkStatePrimTy alphaTy, byteArrayPrimTy] stateAndByteArrayPrimTyCon nullSpecEnv stateAndMutableByteArrayPrimTyCon = pcDataTyCon stateAndMutableByteArrayPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndMutableByteArray#") - [alphaTyVar] [stateAndMutableByteArrayPrimDataCon] + alpha_tyvar [stateAndMutableByteArrayPrimDataCon] stateAndMutableByteArrayPrimDataCon = pcDataCon stateAndMutableByteArrayPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndMutableByteArray#") - [alphaTyVar] [] [mkStatePrimTy alphaTy, applyTyCon mutableByteArrayPrimTyCon [alphaTy]] + alpha_tyvar [] [mkStatePrimTy alphaTy, applyTyCon mutableByteArrayPrimTyCon alpha_ty] stateAndMutableByteArrayPrimTyCon nullSpecEnv stateAndSynchVarPrimTyCon = pcDataTyCon stateAndSynchVarPrimTyConKey pRELUDE_BUILTIN SLIT("StateAndSynchVar#") - [alphaTyVar, betaTyVar] [stateAndSynchVarPrimDataCon] + alpha_beta_tyvars [stateAndSynchVarPrimDataCon] stateAndSynchVarPrimDataCon = pcDataCon stateAndSynchVarPrimDataConKey pRELUDE_BUILTIN SLIT("StateAndSynchVar#") - [alphaTyVar, betaTyVar] [] [mkStatePrimTy alphaTy, mkSynchVarPrimTy alphaTy betaTy] + alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkSynchVarPrimTy alphaTy betaTy] stateAndSynchVarPrimTyCon nullSpecEnv \end{code} @@ -409,9 +415,9 @@ getStatePairingConInfo Type) -- type of state pair getStatePairingConInfo prim_ty - = case (maybeAppDataTyConExpandingDicts prim_ty) of + = case (maybeAppTyCon prim_ty) of Nothing -> panic "getStatePairingConInfo:1" - Just (prim_tycon, tys_applied, _) -> + Just (prim_tycon, tys_applied) -> let (pair_con, pair_tycon, num_tys) = assoc "getStatePairingConInfo" tbl prim_tycon pair_ty = applyTyCon pair_tycon (realWorldTy : drop num_tys tys_applied) @@ -445,17 +451,14 @@ getStatePairingConInfo prim_ty This is really just an ordinary synonym, except it is ABSTRACT. \begin{code} -mkStateTransformerTy s a = mkSynTy stTyCon [s, a] - -stTyCon - = let - ty = mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy]) - in - mkSynTyCon - (mkBuiltinName stTyConKey gLASGOW_ST SLIT("_ST")) - (mkBoxedTypeKind `mkArrowKind` (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind)) - 2 [alphaTyVar, betaTyVar] - ty +mkStateTransformerTy s a = applyTyCon stTyCon [s, a] + +stTyCon = pcNewTyCon stTyConKey pRELUDE SLIT("_ST") alpha_beta_tyvars [stDataCon] + where + ty = mkFunTys [mkStateTy alphaTy] (mkTupleTy 2 [betaTy, mkStateTy alphaTy]) + + stDataCon = pcDataCon stDataConKey pRELUDE SLIT("_ST") + alpha_beta_tyvars [] [ty] stTyCon nullSpecEnv \end{code} %************************************************************************ @@ -467,17 +470,14 @@ stTyCon @PrimIO@ and @IO@ really are just plain synonyms. \begin{code} -mkPrimIoTy a = mkSynTy primIoTyCon [a] - -primIoTyCon - = let - ty = mkStateTransformerTy realWorldTy alphaTy - in --- pprTrace "primIOTyCon:" (ppCat [pprType PprDebug ty, ppr PprDebug (typeKind ty)]) $ - mkSynTyCon - (mkBuiltinName primIoTyConKey pRELUDE_PRIMIO SLIT("PrimIO")) - (mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind) - 1 [alphaTyVar] ty +mkPrimIoTy a = applyTyCon primIoTyCon [a] + +primIoTyCon = pcNewTyCon primIoTyConKey pRELUDE SLIT("_PrimIO") alpha_tyvar [primIoDataCon] + where + ty = mkFunTys [mkStateTy realWorldTy] (mkTupleTy 2 [alphaTy, mkStateTy realWorldTy]) + + primIoDataCon = pcDataCon primIoDataConKey pRELUDE SLIT("_PrimIO") + alpha_tyvar [] [ty] primIoTyCon nullSpecEnv \end{code} %************************************************************************ @@ -539,27 +539,6 @@ trueDataCon = pcDataCon trueDataConKey pRELUDE SLIT("True") [] [] [] boolTyCo %************************************************************************ %* * -\subsection[TysWiredIn-Ordering]{The @Ordering@ type} -%* * -%************************************************************************ - -\begin{code} ---------------------------------------------- --- data Ordering = LT | EQ | GT deriving () ---------------------------------------------- - -orderingTy = mkTyConTy orderingTyCon - -orderingTyCon = pcDataTyCon orderingTyConKey pRELUDE_BUILTIN SLIT("Ordering") [] - [ltDataCon, eqDataCon, gtDataCon] - -ltDataCon = pcDataCon ltDataConKey pRELUDE_BUILTIN SLIT("LT") [] [] [] orderingTyCon nullSpecEnv -eqDataCon = pcDataCon eqDataConKey pRELUDE_BUILTIN SLIT("EQ") [] [] [] orderingTyCon nullSpecEnv -gtDataCon = pcDataCon gtDataConKey pRELUDE_BUILTIN SLIT("GT") [] [] [] orderingTyCon nullSpecEnv -\end{code} - -%************************************************************************ -%* * \subsection[TysWiredIn-List]{The @List@ type (incl ``build'' magic)} %* * %************************************************************************ @@ -577,15 +556,15 @@ ToDo: data () = () mkListTy :: GenType t u -> GenType t u mkListTy ty = applyTyCon listTyCon [ty] -alphaListTy = mkSigmaTy [alphaTyVar] [] (applyTyCon listTyCon [alphaTy]) +alphaListTy = mkSigmaTy alpha_tyvar [] (applyTyCon listTyCon alpha_ty) listTyCon = pcDataTyCon listTyConKey pRELUDE_BUILTIN SLIT("[]") - [alphaTyVar] [nilDataCon, consDataCon] + alpha_tyvar [nilDataCon, consDataCon] -nilDataCon = pcDataCon nilDataConKey pRELUDE_BUILTIN SLIT("[]") [alphaTyVar] [] [] listTyCon +nilDataCon = pcDataCon nilDataConKey pRELUDE_BUILTIN SLIT("[]") alpha_tyvar [] [] listTyCon (pcGenerateDataSpecs alphaListTy) consDataCon = pcDataCon consDataConKey pRELUDE_BUILTIN SLIT(":") - [alphaTyVar] [] [alphaTy, applyTyCon listTyCon [alphaTy]] listTyCon + alpha_tyvar [] [alphaTy, applyTyCon listTyCon alpha_ty] listTyCon (pcGenerateDataSpecs alphaListTy) -- Interesting: polymorphic recursion would help here. -- We can't use (mkListTy alphaTy) in the defn of consDataCon, else mkListTy @@ -648,33 +627,6 @@ unitTy = mkTupleTy 0 [] %************************************************************************ %* * -\subsection[TysWiredIn-Ratios]{@Ratio@ and @Rational@} -%* * -%************************************************************************ - -ToDo: make this (mostly) go away. - -\begin{code} -rationalTy :: GenType t u - -mkRatioTy ty = applyTyCon ratioTyCon [ty] -rationalTy = mkRatioTy integerTy - -ratioTyCon = pcDataTyCon ratioTyConKey rATIO SLIT("Ratio") [alphaTyVar] [ratioDataCon] - -ratioDataCon = pcDataCon ratioDataConKey rATIO SLIT(":%") - [alphaTyVar] [{-(integralClass,alphaTy)-}] [alphaTy, alphaTy] ratioTyCon nullSpecEnv - -- context omitted to match lib/prelude/ defn of "data Ratio ..." - -rationalTyCon - = mkSynTyCon - (mkBuiltinName rationalTyConKey rATIO SLIT("Rational")) - mkBoxedTypeKind - 0 [] rationalTy -- == mkRatioTy integerTy -\end{code} - -%************************************************************************ -%* * \subsection[TysWiredIn-_Lift]{@_Lift@ type: to support array indexing} %* * %************************************************************************ @@ -699,14 +651,14 @@ isLiftTy ty -} -alphaLiftTy = mkSigmaTy [alphaTyVar] [] (applyTyCon liftTyCon [alphaTy]) +alphaLiftTy = mkSigmaTy alpha_tyvar [] (applyTyCon liftTyCon alpha_ty) liftTyCon - = pcDataTyCon liftTyConKey pRELUDE_BUILTIN SLIT("_Lift") [alphaTyVar] [liftDataCon] + = pcDataTyCon liftTyConKey pRELUDE_BUILTIN SLIT("_Lift") alpha_tyvar [liftDataCon] liftDataCon = pcDataCon liftDataConKey pRELUDE_BUILTIN SLIT("_Lift") - [alphaTyVar] [] [alphaTy] liftTyCon + alpha_tyvar [] alpha_ty liftTyCon ((pcGenerateDataSpecs alphaLiftTy) `addOneToSpecEnv` (mkSpecInfo [Just realWorldStatePrimTy] 0 bottom)) where @@ -722,10 +674,4 @@ liftDataCon \begin{code} stringTy = mkListTy charTy - -stringTyCon - = mkSynTyCon - (mkBuiltinName stringTyConKey pRELUDE SLIT("String")) - mkBoxedTypeKind - 0 [] stringTy \end{code} diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index 2740a5b6b8..ad36f041f3 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -27,7 +27,7 @@ module CostCentre ( cmpCostCentre -- used for removing dups in a list ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Id ( externallyVisibleId, GenId, Id(..) ) import CStrings ( identToC, stringToC ) diff --git a/ghc/compiler/profiling/SCCauto.lhs b/ghc/compiler/profiling/SCCauto.lhs index caa46c28d5..331c37189b 100644 --- a/ghc/compiler/profiling/SCCauto.lhs +++ b/ghc/compiler/profiling/SCCauto.lhs @@ -16,7 +16,7 @@ This is a Core-to-Core pass (usually run {\em last}). module SCCauto ( addAutoCostCentres ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CmdLineOpts ( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs, diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 970264567c..7a61c5520d 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -27,7 +27,7 @@ This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg. module SCCfinal ( stgMassageForProfiling ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import StgSyn diff --git a/ghc/compiler/reader/PrefixSyn.lhs b/ghc/compiler/reader/PrefixSyn.lhs index e6c65c48a3..8cd388bd06 100644 --- a/ghc/compiler/reader/PrefixSyn.lhs +++ b/ghc/compiler/reader/PrefixSyn.lhs @@ -22,12 +22,16 @@ module PrefixSyn ( readInteger ) where -import Ubiq +IMP_Ubiq() import HsSyn import RdrHsSyn import Util ( panic ) +#ifdef REALLY_HASKELL_1_3 +ord = fromEnum :: Char -> Int +#endif + type RdrId = RdrName type SrcLine = Int type SrcFile = FAST_STRING diff --git a/ghc/compiler/reader/PrefixToHs.lhs b/ghc/compiler/reader/PrefixToHs.lhs index c638ca2f52..2f229553f8 100644 --- a/ghc/compiler/reader/PrefixToHs.lhs +++ b/ghc/compiler/reader/PrefixToHs.lhs @@ -20,7 +20,7 @@ module PrefixToHs ( sepDeclsIntoSigsAndBinds ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import PrefixSyn -- and various syntaxen. import HsSyn diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index e884ce0de9..cd0ae20ef9 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -50,7 +50,7 @@ module RdrHsSyn ( getRawExportees ) where -import Ubiq +IMP_Ubiq() import HsSyn import Name ( ExportFlag(..) ) diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index b35b926185..88ddda049d 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -6,11 +6,9 @@ \begin{code} #include "HsVersions.h" -module ReadPrefix ( - rdModule - ) where +module ReadPrefix ( rdModule ) where -import Ubiq +IMP_Ubiq() import UgenAll -- all Yacc parser gumpff... import PrefixSyn -- and various syntaxen. @@ -24,7 +22,7 @@ import ErrUtils ( addErrLoc, ghcExit ) import FiniteMap ( elemFM, FiniteMap ) import Name ( RdrName(..), isRdrLexConOrSpecial ) import PprStyle ( PprStyle(..) ) -import PrelMods ( fromPrelude ) +import PrelMods ( fromPrelude, pRELUDE ) import Pretty import SrcLoc ( SrcLoc ) import Util ( nOfThem, pprError, panic ) @@ -307,7 +305,14 @@ wlkExpr expr U_negate nexp -> -- prefix negation wlkExpr nexp `thenUgn` \ expr -> - returnUgn (NegApp expr (HsVar (Qual SLIT("Prelude") SLIT("negate")))) + -- this is a hack + let + neg = SLIT("negate") + rdr = if opt_CompilingPrelude + then Unqual neg + else Qual pRELUDE neg + in + returnUgn (NegApp expr (HsVar rdr)) U_llist llist -> -- explicit list wlkList rdExpr llist `thenUgn` \ exprs -> @@ -359,7 +364,13 @@ wlkPat pat = case pat of U_par ppat -> -- parenthesised pattern wlkPat ppat `thenUgn` \ pat -> - returnUgn (ParPatIn pat) + -- tidy things up a little: + returnUgn ( + case pat of + VarPatIn _ -> pat + WildPatIn -> pat + other -> ParPatIn pat + ) U_as avar as_pat -> -- "as" pattern wlkQid avar `thenUgn` \ var -> @@ -453,7 +464,7 @@ wlkLiteral :: U_literal -> UgnM HsLit wlkLiteral ulit = returnUgn ( case ulit of - U_integer s -> HsInt (as_integer s) + U_integer s -> HsInt (as_integer s) U_floatr s -> HsFrac (as_rational s) U_intprim s -> HsIntPrim (as_integer s) U_doubleprim s -> HsDoublePrim (as_rational s) diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index bd7dc9d3a7..86c467545a 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -3,7 +3,7 @@ module ParseIface ( parseIface ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import ParseUtils @@ -362,6 +362,7 @@ iname :: { FAST_STRING } iname : VARID { $1 } | CONID { $1 } | OPAREN VARSYM CPAREN { $2 } + | OPAREN BANG CPAREN { SLIT("!"){-sigh, double-sigh-} } | OPAREN CONSYM CPAREN { $2 } qiname :: { RdrName } diff --git a/ghc/compiler/rename/ParseUtils.lhs b/ghc/compiler/rename/ParseUtils.lhs index d095ce9d43..e3fde6b2ac 100644 --- a/ghc/compiler/rename/ParseUtils.lhs +++ b/ghc/compiler/rename/ParseUtils.lhs @@ -8,7 +8,7 @@ module ParseUtils where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import HsSyn -- quite a bit of stuff import RdrHsSyn -- oodles of synonyms @@ -278,8 +278,14 @@ lexIface str ITinteger (read num) : lexIface rest } ----------- - is_var_sym '_' = True - is_var_sym c = isAlphanum c + is_var_sym '_' = True + is_var_sym '\'' = True + is_var_sym '#' = True -- for Glasgow-extended names + is_var_sym c = isAlphanum c + + is_var_sym1 '\'' = False + is_var_sym1 '#' = False + is_var_sym1 c = is_var_sym c is_sym_sym c = c `elem` ":!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic @@ -287,16 +293,17 @@ lexIface str lex_word str@(c:cs) -- we know we have a capital letter to start = -- we first try for "<module>." on the front... case (module_dot str) of - Nothing -> lex_name Nothing is_var_sym str + Nothing -> lex_name Nothing (in_the_club str) str Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest - where - in_the_club [] = panic "lex_word:in_the_club" - in_the_club (c:_) | isAlpha c = is_var_sym - | is_sym_sym c = is_sym_sym - | otherwise = panic ("lex_word:in_the_club="++[c]) + where + in_the_club [] = panic "lex_word:in_the_club" + in_the_club (c:_) | isAlpha c = is_var_sym + | c == '_' = is_var_sym + | is_sym_sym c = is_sym_sym + | otherwise = panic ("lex_word:in_the_club="++[c]) module_dot (c:cs) - = if not (isUpper c) then + = if not (isUpper c) || c == '\'' then Nothing else case (span is_var_sym cs) of { (word, rest) -> @@ -309,8 +316,15 @@ lexIface str lex_name module_dot in_the_club str = case (span in_the_club str) of { (word, rest) -> case (lookupFM keywordsFM word) of - Just xx -> ASSERT( not (maybeToBool module_dot) ) - xx : lexIface rest + Just xx -> let + cont = xx : lexIface rest + in + case xx of + ITbang -> case module_dot of + Nothing -> cont + Just m -> ITqvarsym (Qual m SLIT("!")) + : lexIface rest + _ -> cont Nothing -> (let f = head word -- first char @@ -382,5 +396,5 @@ happyError ln toks = Failed (ifaceParseErr ln toks) ----------------------------------------------------------------- ifaceParseErr ln toks sty - = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show toks)] + = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show (take 10 toks))] \end{code} diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 409abef3c9..ac41996d2a 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -10,7 +10,7 @@ module Rename ( renameModule ) where import PreludeGlaST ( thenPrimIO, newVar, MutableVar(..) ) -import Ubiq +IMP_Ubiq() import HsSyn import RdrHsSyn ( RdrNameHsModule(..), RdrNameImportDecl(..) ) @@ -33,10 +33,10 @@ import RnMonad import RnNames ( getGlobalNames, GlobalNameInfo(..) ) import RnSource ( rnSource ) import RnIfaces ( rnIfaces ) -import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv, multipleOccWarn ) +import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv ) import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag ) -import CmdLineOpts ( opt_HiMap ) +import CmdLineOpts ( opt_HiMap, opt_NoImplicitPrelude ) import ErrUtils ( Error(..), Warning(..) ) import FiniteMap ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} ) import Maybes ( catMaybes ) @@ -73,13 +73,15 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) = let (b_names, b_keys, _) = builtinNameInfo + pp_pair (n,m) = ppBesides [ppPStr m,ppChar '.',ppPStr n] in - --pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) -> - -- ppAboves [ ppCat (map ppPStr (keysFM builtin_ids)) - -- , ppCat (map ppPStr (keysFM builtin_tcs)) - -- , ppCat (map ppPStr (keysFM b_keys)) - -- ]}) $ - + {- + pprTrace "builtins:\n" (case b_names of { (builtin_ids, builtin_tcs) -> + ppAboves [ ppCat (map pp_pair (keysFM builtin_ids)) + , ppCat (map pp_pair (keysFM builtin_tcs)) + , ppCat (map pp_pair (keysFM b_keys)) + ]}) $ + -} makeHiMap opt_HiMap >>= \ hi_files -> -- pprTrace "HiMap:\n" (ppAboves [ ppCat [ppPStr m, ppStr p] | (m,p) <- fmToList hi_files]) newVar (emptyFM,emptyFM,hi_files){-init iface cache-} `thenPrimIO` \ iface_cache -> @@ -165,6 +167,9 @@ renameModule us input@(HsModule mod _ _ imports _ _ _ _ _ _ _ _ _ _) pair_orig rn = (origName rn, rn) must_haves + | opt_NoImplicitPrelude + = [{-no Prelude.hi, no point looking-}] + | otherwise = [ name_fn (mkBuiltinName u mod str) | ((str, mod), (u, name_fn)) <- fmToList b_keys, str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ] @@ -215,6 +220,13 @@ makeHiMap (Just f) snag_path map mod (c:cs) rpath = snag_path map mod cs (c:rpath) \end{code} +Warning message used herein: +\begin{code} +multipleOccWarn (name, occs) sty + = ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ", + ppInterleave ppComma (map (ppr sty) occs)] +\end{code} + \begin{code} {- TESTING: pprPIface (ParsedIface m ms v mv usgs lcm exm ims lfx ltdm lvdm lids ldp) diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 3c27d75f93..a96d3ee5ad 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -19,8 +19,8 @@ module RnBinds ( DefinedVars(..) ) where -import Ubiq -import RnLoop -- break the RnPass/RnExpr/RnBinds loops +IMP_Ubiq() +IMPORT_DELOOPER(RnLoop) -- break the RnPass/RnExpr/RnBinds loops import HsSyn import HsPragmas ( isNoGenPragmas, noGenPragmas ) diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 9b4a61ba98..10aef2e765 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -17,8 +17,8 @@ module RnExpr ( checkPrecMatch ) where -import Ubiq -import RnLoop -- break the RnPass/RnExpr/RnBinds loops +IMP_Ubiq() +IMPORT_DELOOPER(RnLoop) -- break the RnPass/RnExpr/RnBinds loops import HsSyn import RdrHsSyn diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index c80f351cc2..d8cfa12473 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -8,7 +8,7 @@ module RnHsSyn where -import Ubiq +IMP_Ubiq() import HsSyn @@ -82,7 +82,7 @@ isRnField (RnField _ _) = True isRnField _ = False isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls -isRnClassOp cls _ = False +isRnClassOp cls n = pprTrace "isRnClassOp:" (ppr PprShowAll n) $ True -- let it past anyway isRnImplicit (RnImplicit _) = True isRnImplicit (RnImplicitTyCon _) = True diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 72fb264f35..6b0b75c4d6 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -15,7 +15,7 @@ module RnIfaces ( IfaceCache(..) ) where -import Ubiq +IMP_Ubiq() import LibDirectory import PreludeGlaST ( thenPrimIO, seqPrimIO, readVar, writeVar, MutableVar(..) ) @@ -38,10 +38,10 @@ import Bag ( emptyBag, unitBag, consBag, snocBag, import ErrUtils ( Error(..), Warning(..) ) import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM, fmToList, delListFromFM, sizeFM, foldFM, unitFM, - plusFM_C, keysFM{-ToDo:rm-} + plusFM_C, addListToFM, keysFM{-ToDo:rm-} ) import Maybes ( maybeToBool ) -import Name ( moduleNamePair, origName, RdrName(..) ) +import Name ( moduleNamePair, origName, isRdrLexCon, RdrName(..), Name{-instance NamedThing-} ) import PprStyle -- ToDo:rm import Outputable -- ToDo:rm import PrelInfo ( builtinNameInfo ) @@ -244,9 +244,11 @@ cachedDecl :: IfaceCache -> IO (MaybeErr RdrIfaceDecl Error) cachedDecl iface_cache class_or_tycon orig - = cachedIface True iface_cache mod >>= \ maybe_iface -> + = -- pprTrace "cachedDecl:" (ppr PprDebug orig) $ + cachedIface True iface_cache mod >>= \ maybe_iface -> case maybe_iface of - Failed err -> return (Failed err) + Failed err -> --pprTrace "cachedDecl:fail:" (ppr PprDebug orig) $ + return (Failed err) Succeeded (ParsedIface _ _ _ _ _ _ exps _ _ tdefs vdefs _ _) -> case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of Just decl -> return (Succeeded decl) @@ -269,7 +271,7 @@ cachedDeclByType iface_cache rn return_failed msg = return (Failed msg) in case maybe_decl of - Failed _ -> return_maybe_decl + Failed io_msg -> return_failed (ifaceIoErr io_msg rn) Succeeded if_decl -> case rn of WiredInId _ -> return_failed (ifaceLookupWiredErr "value" rn) @@ -315,13 +317,13 @@ readIface :: FilePath -> Module -> IO (MaybeErr ParsedIface Error) readIface file mod - = --hPutStr stderr (" reading "++file) >> + = hPutStr stderr (" reading "++file) >> readFile file `thenPrimIO` \ read_result -> case read_result of Left err -> return (Failed (cannaeReadErr file err)) - Right contents -> --hPutStr stderr " parsing" >> + Right contents -> hPutStr stderr ".." >> let parsed = parseIface contents in - --hPutStr stderr " done\n" >> + hPutStr stderr "..\n" >> return ( case parsed of Failed _ -> parsed @@ -359,7 +361,6 @@ rnIfaces iface_cache imp_mods us todo = {- pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $ - pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $ pprTrace "rnIfaces:unqual:" (ppCat (map ppPStr (keysFM unqual))) $ pprTrace "rnIfaces:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $ @@ -461,8 +462,8 @@ rnIfaces iface_cache imp_mods us Nothing | fst (moduleNamePair n) == modname -> -- avoid looking in interface for the module being compiled - -- pprTrace "do_decls:this module error:" (ppr PprDebug n) $ - do_decls ns down (add_err (thisModImplicitErr modname n) to_return) + --pprTrace "do_decls:this module error:" (ppr PprDebug n) $ + do_decls ns down (add_warn (thisModImplicitWarn modname n) to_return) | otherwise -> -- OK, see what the cache has for us... @@ -470,7 +471,7 @@ rnIfaces iface_cache imp_mods us cachedDeclByType iface_cache n >>= \ maybe_ans -> case maybe_ans of Failed err -> -- add the error, but keep going: - -- pprTrace "do_decls:cache error:" (ppr PprDebug n) $ + --pprTrace "do_decls:cache error:" (ppr PprDebug n) $ do_decls ns down (add_err err to_return) Succeeded iface_decl -> -- something needing renaming! @@ -528,7 +529,8 @@ new_uniqsupply us (def_env, occ_env, _) = (def_env, occ_env, us) add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us) = case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) -> - ASSERT(isEmptyBag def_dups) + (if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $ +-- ASSERT(isEmptyBag def_dups) let val_occs = val_defds ++ fmToList val_imps tc_occs = tc_defds ++ fmToList tc_imps @@ -563,6 +565,7 @@ add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs) add_err err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag` err,warns)) add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns)) +add_warn wrn (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `snocBag` wrn)) add_warns ws (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `unionBags` ws)) \end{code} @@ -659,6 +662,7 @@ cacheInstModules iface_cache imp_mods (imp_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims imp_ifaces))) get_ims (ParsedIface _ _ _ _ _ _ _ ims _ _ _ _ _) = ims in + --pprTrace "cacheInstModules:" (ppCat (map ppPStr imp_imods)) $ accumulate (map (cachedIface False iface_cache) imp_imods) >>= \ err_or_ifaces -> -- Sanity Check: @@ -753,7 +757,7 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return want_inst i@(InstSig clas tycon _ _) = -- it's a "good instance" (one to hang onto) if we have a -- chance of referring to *both* the class and tycon later on ... - + --pprTrace "want_inst:" (ppCat [ppr PprDebug clas, ppr PprDebug tycon, ppr PprDebug (mentionable tycon), ppr PprDebug (mentionable clas), ppr PprDebug(is_done_inst i)]) $ mentionable tycon && mentionable clas && not (is_done_inst i) where mentionable nm @@ -782,6 +786,9 @@ rnIfaceInst (InstSig _ _ _ inst_decl) = rnInstDecl inst_decl \end{code} \begin{code} +type BigMaps = (FiniteMap Module Version, -- module-version map + FiniteMap (FAST_STRING,Module) Version) -- ordinary version map + finalIfaceInfo :: IfaceCache -- iface cache -> Module -- this module's name @@ -799,47 +806,76 @@ finalIfaceInfo iface_cache modname if_final_env@((qual, unqual, tc_qual, tc_unqu -- pprTrace "usageIf:unqual:" (ppCat (map ppPStr (keysFM unqual))) $ -- pprTrace "usageIf:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $ -- pprTrace "usageIf:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $ + readVar iface_cache `thenPrimIO` \ (_, orig_iface_fm, _) -> let + all_ifaces = eltsFM orig_iface_fm + -- all the interfaces we have looked at + + big_maps + -- combine all the version maps we have seen into maps to + -- (a) lookup a module-version number, lookup an entity's + -- individual version number + = foldr mk_map (emptyFM,emptyFM) all_ifaces + val_stuff@(val_usages, val_versions) - = foldFM process_item (emptyFM, emptyFM){-init-} qual + = foldFM (process_item big_maps) (emptyFM, emptyFM){-init-} qual (all_usages, all_versions) - = foldFM process_item val_stuff{-keep going-} tc_qual + = foldFM (process_item big_maps) val_stuff{-keep going-} tc_qual in return (all_usages, all_versions, []) where - process_item :: (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components + mk_map (ParsedIface m _ mv _ _ vers _ _ _ _ _ _ _) (mv_map, ver_map) + = (addToFM mv_map m mv, -- add this module + addListToFM ver_map [ ((n,m), v) | (n,v) <- fmToList vers ]) + + ----------------------- + process_item :: BigMaps + -> (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components -> (UsagesMap, VersionsMap) -- input -> (UsagesMap, VersionsMap) -- output - process_item (n,m) rn as_before@(usages, versions) + process_item (big_mv_map, big_version_map) key@(n,m) rn as_before@(usages, versions) | irrelevant rn = as_before | m == modname -- this module => add to "versions" = (usages, addToFM versions n 1{-stub-}) | otherwise -- from another module => add to "usages" - = (add_to_usages usages m n 1{-stub-}, versions) + = (add_to_usages usages key, versions) + where + add_to_usages usages key@(n,m) + = let + mod_v = case (lookupFM big_mv_map m) of + Nothing -> pprTrace "big_mv_map:miss? " (ppPStr m) $ + 1 + Just nv -> nv + key_v = case (lookupFM big_version_map key) of + Nothing -> pprTrace "big_version_map:miss? " (ppCat [ppPStr n, ppPStr m]) $ + 1 + Just nv -> nv + in + addToFM usages m ( + case (lookupFM usages m) of + Nothing -> -- nothing for this module yet... + (mod_v, unitFM n key_v) + + Just (mversion, mstuff) -> -- the "new" stuff will shadow the old + ASSERT(mversion == mod_v) + (mversion, addToFM mstuff n key_v) + ) irrelevant (RnConstr _ _) = True -- We don't report these in their irrelevant (RnField _ _) = True -- own right in usages/etc. irrelevant (RnClassOp _ _) = True + irrelevant (RnImplicit n) = isRdrLexCon (origName n) -- really a RnConstr irrelevant _ = False - add_to_usages usages m n version - = addToFM usages m ( - case (lookupFM usages m) of - Nothing -> -- nothing for this module yet... - (1{-stub-}, unitFM n version) - - Just (mversion, mstuff) -> -- the "new" stuff will shadow the old - (mversion, addToFM mstuff n version) - ) \end{code} \begin{code} -thisModImplicitErr mod n sty - = ppCat [ppPStr SLIT("Implicit import of"), ppr sty n, ppPStr SLIT("when compiling"), ppPStr mod] +thisModImplicitWarn mod n sty + = ppBesides [ppPStr SLIT("An interface has an implicit need of "), ppPStr mod, ppChar '.', ppr sty n, ppPStr SLIT("; assuming this module will provide it.")] noIfaceErr mod sty = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod] @@ -859,4 +895,7 @@ ifaceLookupWiredErr msg n sty badIfaceLookupErr msg name decl sty = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppPStr SLIT(" declaration, but got this: ???")] + +ifaceIoErr io_msg rn sty + = ppBesides [io_msg sty, ppStr "; looking for: ", ppr sty rn] \end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 78f89184f7..3b36cf7c8b 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -30,7 +30,7 @@ module RnMonad ( fixIO ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import SST @@ -42,22 +42,25 @@ import RnHsSyn ( RnName, mkRnName, mkRnUnbound, mkRnImplicit, isRnClassOp, RenamedFixityDecl(..) ) import RnUtils ( RnEnv(..), extendLocalRnEnv, lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv, - unknownNameErr, badClassOpErr, qualNameErr, - dupNamesErr, shadowedNameWarn + qualNameErr, dupNamesErr ) import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) import CmdLineOpts ( opt_WarnNameShadowing ) -import ErrUtils ( Error(..), Warning(..) ) -import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM ) +import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine, + Error(..), Warning(..) + ) +import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, fmToList{-ToDo:rm-} ) import Maybes ( assocMaybe ) import Name ( Module(..), RdrName(..), isQual, Name, mkLocalName, mkImplicitName, - getOccName + getOccName, pprNonSym ) import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) ) import PrelMods ( pRELUDE ) -import Pretty ( Pretty(..), PrettyRep ) +import PprStyle{-ToDo:rm-} +import Outputable{-ToDo:rm-} +import Pretty--ToDo:rm ( Pretty(..), PrettyRep ) import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) import UniqFM ( UniqFM, emptyUFM ) import UniqSet ( UniqSet(..), mkUniqSet, minusUniqSet ) @@ -426,10 +429,13 @@ lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var rdr - = let str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } - in case (lookupFM b_names str_mod) of - Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr - Just xx -> returnSST xx + = let + str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n, pRELUDE) } + in + --pprTrace "lookup:" (ppAboves [case str_mod of {(n,m)->ppCat [ppPStr n, ppPStr m]}, ppAboves [ ppCat [ppPStr n, ppPStr m] | ((n,m), _) <- fmToList b_names]]) $ + case (lookupFM b_names str_mod) of + Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr + Just xx -> returnSST xx lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var rdr = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) -> @@ -545,3 +551,24 @@ fixIO k s = let in result \end{code} + +********************************************************* +* * +\subsection{Errors used in RnMonad} +* * +********************************************************* + +\begin{code} +unknownNameErr descriptor name locn + = addShortErrLocLine locn $ \ sty -> + ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name] + +badClassOpErr clas op locn + = addErrLoc locn "" $ \ sty -> + ppBesides [ppChar '`', pprNonSym sty op, ppStr "' is not an operation of class `", + ppr sty clas, ppStr "'"] + +shadowedNameWarn locn shadow + = addShortWarnLocLine locn $ \ sty -> + ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow] +\end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 921cf614f4..59594f20df 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -13,7 +13,7 @@ module RnNames ( import PreludeGlaST ( MutableVar(..) ) -import Ubiq +IMP_Ubiq() import HsSyn import RdrHsSyn @@ -29,9 +29,9 @@ import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst ) import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags, unionManyBags, mapBag, filterBag, listToBag, bagToList ) -import CmdLineOpts ( opt_NoImplicitPrelude ) +import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingPrelude ) import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine, addShortWarnLocLine ) -import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM ) +import FiniteMap ( emptyFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-} ) import Id ( GenId ) import Maybes ( maybeToBool, catMaybes, MaybeErr(..) ) import Name ( RdrName(..), Name, isQual, mkTopLevName, origName, @@ -40,14 +40,15 @@ import Name ( RdrName(..), Name, isQual, mkTopLevName, origName, pprNonSym, isLexCon, isRdrLexCon, ExportFlag(..) ) import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) ) -import PrelMods ( fromPrelude, pRELUDE, rATIO, iX ) +import PrelMods ( fromPrelude, pRELUDE_BUILTIN, pRELUDE, rATIO, iX ) import Pretty import SrcLoc ( SrcLoc, mkBuiltinSrcLoc ) import TyCon ( tyConDataCons ) import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM ) import UniqSupply ( splitUniqSupply ) import Util ( isIn, assoc, cmpPString, sortLt, removeDups, - equivClasses, panic, assertPanic ) + equivClasses, panic, assertPanic, pprTrace{-ToDo:rm-} + ) \end{code} @@ -134,7 +135,7 @@ getTyDeclNames :: RdrNameTyDecl -> RnM_Info s (RnName, Bag RnName, Bag RnName) -- tycon, constrs and fields getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc) - = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name -> + = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name -> getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM condecls `thenRn` \ (con_names, field_names) -> let @@ -145,15 +146,15 @@ getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc) returnRn (rn_tycon, listToBag rn_constrs, listToBag rn_fields) getTyDeclNames (TyNew _ tycon _ [NewConDecl con _ con_loc] _ _ src_loc) - = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name -> - newGlobalName con_loc (Just (nameExportFlag tycon_name)) con + = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name -> + newGlobalName con_loc (Just (nameExportFlag tycon_name)) True{-val-} con `thenRn` \ con_name -> returnRn (RnData tycon_name [con_name] [], unitBag (RnConstr con_name tycon_name), emptyBag) getTyDeclNames (TySynonym tycon _ _ src_loc) - = newGlobalName src_loc Nothing tycon `thenRn` \ tycon_name -> + = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name -> returnRn (RnSyn tycon_name, emptyBag, emptyBag) @@ -161,17 +162,17 @@ getConFieldNames exp constrs fields have [] = returnRn (bagToList constrs, bagToList fields) getConFieldNames exp constrs fields have (ConDecl con _ src_loc : rest) - = newGlobalName src_loc exp con `thenRn` \ con_name -> + = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name -> getConFieldNames exp (constrs `snocBag` con_name) fields have rest getConFieldNames exp constrs fields have (ConOpDecl _ con _ src_loc : rest) - = newGlobalName src_loc exp con `thenRn` \ con_name -> + = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name -> getConFieldNames exp (constrs `snocBag` con_name) fields have rest getConFieldNames exp constrs fields have (RecConDecl con fielddecls src_loc : rest) = mapRn (addErrRn . dupFieldErr con src_loc) dups `thenRn_` - newGlobalName src_loc exp con `thenRn` \ con_name -> - mapRn (newGlobalName src_loc exp) new_fields `thenRn` \ field_names -> + newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name -> + mapRn (newGlobalName src_loc exp True{-val-}) new_fields `thenRn` \ field_names -> let all_constrs = constrs `snocBag` con_name all_fields = fields `unionBags` listToBag field_names @@ -186,7 +187,7 @@ getClassNames :: RdrNameClassDecl -> RnM_Info s (RnName, Bag RnName) -- class and class ops getClassNames (ClassDecl _ cname _ sigs _ _ src_loc) - = newGlobalName src_loc Nothing cname `thenRn` \ class_name -> + = newGlobalName src_loc Nothing False{-notval-} cname `thenRn` \ class_name -> getClassOpNames (Just (nameExportFlag class_name)) sigs `thenRn` \ op_names -> returnRn (RnClass class_name op_names, @@ -195,7 +196,7 @@ getClassNames (ClassDecl _ cname _ sigs _ _ src_loc) getClassOpNames exp [] = returnRn [] getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs) - = newGlobalName src_loc exp op `thenRn` \ op_name -> + = newGlobalName src_loc exp True{-val-} op `thenRn` \ op_name -> getClassOpNames exp sigs `thenRn` \ op_names -> returnRn (op_name : op_names) getClassOpNames exp (_ : sigs) @@ -254,7 +255,7 @@ doPat locn (RecPatIn name fields) doField locn (_, pat, _) = doPat locn pat doName locn rdr - = newGlobalName locn Nothing rdr `thenRn` \ name -> + = newGlobalName locn Nothing True{-val-} rdr `thenRn` \ name -> returnRn (unitBag (RnName name)) \end{code} @@ -265,27 +266,37 @@ doName locn rdr ********************************************************* \begin{code} -newGlobalName :: SrcLoc -> Maybe ExportFlag +newGlobalName :: SrcLoc -> Maybe ExportFlag -> Bool{-True<=>value name,False<=>tycon/class-} -> RdrName -> RnM_Info s Name -- ToDo: b_names and b_keys being defined in this module !!! -newGlobalName locn maybe_exp rdr - = getExtraRn `thenRn` \ (_,b_keys,exp_fn,occ_fn) -> +newGlobalName locn maybe_exp is_val_name rdr + = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,exp_fn,occ_fn) -> getModuleRn `thenRn` \ mod -> rnGetUnique `thenRn` \ u -> let - (uniq, unqual) - = case rdr of - Qual m n -> (u, n) - Unqual n -> case (lookupFM b_keys n) of - Nothing -> (u, n) - Just (key,_) -> (key, n) + unqual = case rdr of { Qual m n -> n; Unqual n -> n } orig = if fromPrelude mod then (Unqual unqual) else (Qual mod unqual) + uniq + = let + str_mod = case orig of { Qual m n -> (n, m); Unqual n -> (n, pRELUDE) } + n = fst str_mod + m = snd str_mod + in + --pprTrace "newGlobalName:" (ppAboves ((ppCat [ppPStr n, ppPStr m]) : [ ppCat [ppPStr x, ppPStr y] | (x,y) <- keysFM b_keys])) $ + case (lookupFM b_keys str_mod) of + Just (key,_) -> key + Nothing -> if not opt_CompilingPrelude then u else + case (lookupFM (if is_val_name then b_val_names else b_tc_names) str_mod) of + Nothing -> u + Just xx -> --pprTrace "Using Unique for:" (ppCat [ppPStr n, ppPStr m]) $ + uniqueOf xx + exp = case maybe_exp of Just exp -> exp Nothing -> exp_fn n @@ -339,6 +350,7 @@ doImportDecls iface_cache g_info us src_imps -- cache the imported modules -- this ensures that all directly imported modules -- will have their original name iface in scope + -- pprTrace "doImportDecls:" (ppCat (map ppPStr imp_mods)) $ accumulate (map (cachedIface False iface_cache) imp_mods) >> -- process the imports @@ -354,14 +366,18 @@ doImportDecls iface_cache g_info us src_imps all_imps = implicit_qprel ++ the_imps implicit_qprel = if opt_NoImplicitPrelude - then [{- no "import qualified Prelude" -}] + then [{- no "import qualified Prelude" -} + ImportDecl pRELUDE_BUILTIN True Nothing Nothing prel_loc + ] else [ImportDecl pRELUDE True Nothing Nothing prel_loc] explicit_prelude_imp = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps, mod == pRELUDE ]) implicit_prel = if explicit_prelude_imp || opt_NoImplicitPrelude - then [{- no "import Prelude" -}] + then [{- no "import Prelude" -} + ImportDecl pRELUDE_BUILTIN False Nothing Nothing prel_loc + ] else [ImportDecl pRELUDE False Nothing Nothing prel_loc] prel_loc = mkBuiltinSrcLoc @@ -386,7 +402,7 @@ doImportDecls iface_cache g_info us src_imps has_same_mod (q,ImportDecl mod2 _ _ _ _) = mod == mod2 - imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ] + imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps, mod /= pRELUDE_BUILTIN ] imp_warns = listToBag (map dupImportWarn imp_dups) `unionBags` @@ -435,15 +451,25 @@ doImport :: IfaceCache Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) - = cachedIface False iface_cache mod >>= \ maybe_iface -> + = let + (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec + in + (if mod == pRELUDE_BUILTIN then + return (Succeeded (panic "doImport:PreludeBuiltin"), + \ iface -> ([], [], emptyBag)) + else + --pprTrace "doImport:" (ppPStr mod) $ + cachedIface False iface_cache mod >>= \ maybe_iface -> + return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec') + ) >>= \ (maybe_iface, do_ies) -> + case maybe_iface of Failed err -> return (emptyBag, emptyBag, emptyBag, emptyBag, unitBag err, emptyBag, emptyBag) Succeeded iface -> let - (b_vals, b_tcs, maybe_spec') = getBuiltins info mod maybe_spec - (ies, chk_ies, get_errs) = getOrigIEs iface maybe_spec' + (ies, chk_ies, get_errs) = do_ies iface in doOrigIEs iface_cache info mod src_loc us ies >>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) -> @@ -452,9 +478,13 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) let final_vals = mapBag fst_occ b_vals `unionBags` mapBag pair_occ ie_vals final_tcs = mapBag fst_occ b_tcs `unionBags` mapBag pair_occ ie_tcs + final_vals_list = bagToList final_vals in - accumulate (map (getFixityDecl iface_cache) (bagToList final_vals)) - >>= \ fix_maybes_errs -> + (if mod == pRELUDE_BUILTIN then + return [ (Nothing, emptyBag) | _ <- final_vals_list ] + else + accumulate (map (getFixityDecl iface_cache) final_vals_list) + ) >>= \ fix_maybes_errs -> let (chk_errs, chk_warns) = unzip chk_errs_warns (fix_maybes, fix_errs) = unzip fix_maybes_errs @@ -482,7 +512,7 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) getBuiltins _ mod maybe_spec - | not ((fromPrelude mod) || mod == iX || mod == rATIO ) + | not (fromPrelude mod || mod == iX || mod == rATIO) = (emptyBag, emptyBag, maybe_spec) getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) mod maybe_spec @@ -626,8 +656,8 @@ checkOrigIE iface_cache (IEThingWith n ns, ExportAll) = with_decl iface_cache n (\ err -> (unitBag (\ mod locn -> err), emptyBag)) (\ decl -> case decl of - NewTypeSig _ con _ _ -> (check_with "constructrs" [con] ns, emptyBag) - DataSig _ cons fields _ _ -> (check_with "constructrs (and fields)" (cons++fields) ns, emptyBag) + NewTypeSig _ con _ _ -> (check_with "constructors" [con] ns, emptyBag) + DataSig _ cons fields _ _ -> (check_with "constructors (and fields)" (cons++fields) ns, emptyBag) ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag)) where check_with str has rdrs @@ -650,6 +680,8 @@ with_decl iface_cache n do_err do_decl getFixityDecl iface_cache (_,rn) = let (mod, str) = moduleNamePair rn + + succeeded infx i = return (Just (infx rn i), emptyBag) in cachedIface True iface_cache mod >>= \ maybe_iface -> case maybe_iface of @@ -658,9 +690,9 @@ getFixityDecl iface_cache (_,rn) Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) -> case lookupFM fixes str of Nothing -> return (Nothing, emptyBag) - Just (InfixL _ i) -> return (Just (InfixL rn i), emptyBag) - Just (InfixR _ i) -> return (Just (InfixR rn i), emptyBag) - Just (InfixN _ i) -> return (Just (InfixN rn i), emptyBag) + Just (InfixL _ i) -> succeeded InfixL i + Just (InfixR _ i) -> succeeded InfixR i + Just (InfixN _ i) -> succeeded InfixN i ie_name (IEVar n) = n ie_name (IEThingAbs n) = n @@ -712,12 +744,13 @@ getIfaceDeclNames ie (NewTypeSig tycon con src_loc _) getIfaceDeclNames ie (DataSig tycon cons fields src_loc _) = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name -> - mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name)) - (Just (nameImportFlag tycon_name))) - cons `thenRn` \ con_names -> - mapRn (newImportedName False src_loc (Just (nameExportFlag tycon_name)) - (Just (nameImportFlag tycon_name))) - fields `thenRn` \ field_names -> + let + map_me = mapRn (newImportedName False src_loc + (Just (nameExportFlag tycon_name)) + (Just (nameImportFlag tycon_name))) + in + map_me cons `thenRn` \ con_names -> + map_me fields `thenRn` \ field_names -> let rn_tycon = RnData tycon_name con_names field_names rn_constrs = [ RnConstr name tycon_name | name <- con_names ] @@ -775,11 +808,11 @@ newImportedName tycon_or_class locn maybe_exp maybe_imp rdr Nothing -> rnGetUnique `thenRn` \ u -> let - uniq = case rdr of - Qual m n -> u - Unqual n -> case lookupFM b_keys n of - Nothing -> u - Just (key,_) -> key + str_mod = case rdr of { Qual m n -> (n,m); Unqual n -> (n,pRELUDE) } + + uniq = case lookupFM b_keys str_mod of + Nothing -> u + Just (key,_) -> key exp = case maybe_exp of Just exp -> exp diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 043d0ebe42..64f64c5f48 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -8,8 +8,8 @@ module RnSource ( rnSource, rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) where -import Ubiq -import RnLoop -- *check* the RnPass/RnExpr/RnBinds loop-breaking +IMP_Ubiq() +IMPORT_DELOOPER(RnLoop) -- *check* the RnPass/RnExpr/RnBinds loop-breaking import HsSyn import HsPragmas @@ -34,7 +34,7 @@ import SrcLoc ( SrcLoc ) import Unique ( Unique ) import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, plusUFM, lookupUFM, eltsUFM ) import UniqSet ( UniqSet(..) ) -import Util ( isIn, isn'tIn, sortLt, removeDups, mapAndUnzip3, cmpPString, +import Util ( isIn, isn'tIn, thenCmp, sortLt, removeDups, mapAndUnzip3, cmpPString, assertPanic, pprTrace{-ToDo:rm-} ) \end{code} @@ -236,7 +236,7 @@ rnIE mods (IEThingWith name names) `unionBags` listToBag (map exp_all fields)) | otherwise - = rnWithErr "constructrs (and fields)" rn (cons++fields) rns + = rnWithErr "constructors (and fields)" rn (cons++fields) rns checkIEWith rn@(RnClass n ops) rns | same_names ops rns = returnRn (unitBag (exp_all n), listToBag (map exp_all ops)) @@ -298,7 +298,7 @@ rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc) = pushSrcLocRn src_loc $ lookupTyCon tycon `thenRn` \ tycon' -> mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') -> - rnContext tv_env context `thenRn` \ context' -> + rnContext tv_env src_loc context `thenRn` \ context' -> rnConDecls tv_env condecls `thenRn` \ condecls' -> rn_derivs tycon' src_loc derivings `thenRn` \ derivings' -> ASSERT(isNoDataPragmas pragmas) @@ -308,7 +308,7 @@ rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc) = pushSrcLocRn src_loc $ lookupTyCon tycon `thenRn` \ tycon' -> mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') -> - rnContext tv_env context `thenRn` \ context' -> + rnContext tv_env src_loc context `thenRn` \ context' -> rnConDecls tv_env condecl `thenRn` \ condecl' -> rn_derivs tycon' src_loc derivings `thenRn` \ derivings' -> ASSERT(isNoDataPragmas pragmas) @@ -429,27 +429,34 @@ rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc) = pushSrcLocRn src_loc $ - mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) -> - rnContext tv_env context `thenRn` \ context' -> - lookupClass cname `thenRn` \ cname' -> - mapRn (rn_op cname' tv_env) sigs `thenRn` \ sigs' -> - rnMethodBinds cname' mbinds `thenRn` \ mbinds' -> + mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) -> + rnContext tv_env src_loc context `thenRn` \ context' -> + lookupClass cname `thenRn` \ cname' -> + mapRn (rn_op cname' tyvar' tv_env) sigs `thenRn` \ sigs' -> + rnMethodBinds cname' mbinds `thenRn` \ mbinds' -> ASSERT(isNoClassPragmas pragmas) returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc) where - rn_op clas tv_env (ClassOpSig op ty pragmas locn) + rn_op clas clas_tyvar tv_env sig@(ClassOpSig op ty pragmas locn) = pushSrcLocRn locn $ lookupClassOp clas op `thenRn` \ op_name -> rnPolyType tv_env ty `thenRn` \ new_ty -> - -{- -*** Please check here that tyvar' appears in new_ty *** -*** (used to be in tcClassSig, but it's better here) -*** not_elem = isn'tIn "tcClassSigs" -*** -- Check that the class type variable is mentioned -*** checkTc (clas_tyvar `not_elem` extractTyVarTemplatesFromTy local_ty) -*** (methodTypeLacksTyVarErr clas_tyvar (_UNPK_ op_name) src_loc) `thenTc_` --} + let + (HsForAllTy tvs ctxt op_ty) = new_ty + ctxt_tvs = extractCtxtTyNames ctxt + op_tvs = extractMonoTyNames is_tyvar_name op_ty + in + -- check that class tyvar appears in op_ty + ( if isIn "rn_op" clas_tyvar op_tvs + then returnRn () + else addErrRn (classTyVarNotInOpTyErr clas_tyvar sig locn) + ) `thenRn_` + + -- check that class tyvar *doesn't* appear in the sig's context + ( if isIn "rn_op(2)" clas_tyvar ctxt_tvs + then addErrRn (classTyVarInOpCtxtErr clas_tyvar sig locn) + else returnRn () + ) `thenRn_` ASSERT(isNoClassOpPragmas pragmas) returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn) @@ -630,13 +637,13 @@ rn_poly_help tv_env tyvars ctxt ty ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt), ppStr ";ty=", ppr PprShowAll ty]) $ -} - getSrcLocRn `thenRn` \ src_loc -> - mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) -> + getSrcLocRn `thenRn` \ src_loc -> + mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) -> let tv_env2 = catTyVarNamesEnvs tv_env1 tv_env in - rnContext tv_env2 ctxt `thenRn` \ new_ctxt -> - rnMonoType tv_env2 ty `thenRn` \ new_ty -> + rnContext tv_env2 src_loc ctxt `thenRn` \ new_ctxt -> + rnMonoType tv_env2 ty `thenRn` \ new_ty -> returnRn (HsForAllTy new_tyvars new_ctxt new_ty) \end{code} @@ -673,75 +680,101 @@ rnMonoType tv_env (MonoTyApp name tys) \end{code} \begin{code} -rnContext :: TyVarNamesEnv -> RdrNameContext -> RnM_Fixes s RenamedContext +rnContext :: TyVarNamesEnv -> SrcLoc -> RdrNameContext -> RnM_Fixes s RenamedContext -rnContext tv_env ctxt - = mapRn rn_ctxt ctxt +rnContext tv_env locn ctxt + = mapRn rn_ctxt ctxt `thenRn` \ result -> + let + (_, dup_asserts) = removeDups cmp_assert result + in + -- If this isn't an error, then it ought to be: + mapRn (addWarnRn . dupClassAssertWarn result locn) dup_asserts `thenRn_` + returnRn result where rn_ctxt (clas, tyvar) - = lookupClass clas `thenRn` \ clas_name -> - lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name -> - returnRn (clas_name, tyvar_name) + = lookupClass clas `thenRn` \ clas_name -> + lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name -> + returnRn (clas_name, tyvar_name) + + cmp_assert (c1,tv1) (c2,tv2) + = (c1 `cmp` c2) `thenCmp` (tv1 `cmp` tv2) \end{code} \begin{code} dupNameExportWarn locn names@((n,_):_) - = addShortWarnLocLine locn (\ sty -> - ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"]) + = addShortWarnLocLine locn $ \ sty -> + ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"] dupLocalsExportErr locn locals@((str,_):_) - = addErrLoc locn "exported names have same local name" (\ sty -> - ppInterleave ppSP (map (pprNonSym sty . snd) locals)) + = addErrLoc locn "exported names have same local name" $ \ sty -> + ppInterleave ppSP (map (pprNonSym sty . snd) locals) classOpExportErr op locn - = addShortErrLocLine locn (\ sty -> - ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"]) + = addShortErrLocLine locn $ \ sty -> + ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"] synAllExportErr is_error syn locn - = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn (\ sty -> - ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"]) + = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn $ \ sty -> + ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"] withExportErr str rn has rns locn - = addErrLoc locn "" (\ sty -> + = addErrLoc locn "" $ \ sty -> ppAboves [ ppBesides [ppStr "inconsistent list of ", ppStr str, ppStr " in export list for `", ppr sty rn, ppStr "'"], ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)], - ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ]) + ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ] importAllErr rn locn - = addShortErrLocLine locn (\ sty -> - ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"]) + = addShortErrLocLine locn $ \ sty -> + ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"] badModExportErr mod locn - = addShortErrLocLine locn (\ sty -> - ppCat [ ppStr "unknown module in export list: module", ppPStr mod]) + = addShortErrLocLine locn $ \ sty -> + ppCat [ ppStr "unknown module in export list: module", ppPStr mod] emptyModExportWarn locn mod - = addShortWarnLocLine locn (\ sty -> - ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"]) + = addShortWarnLocLine locn $ \ sty -> + ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"] dupModExportWarn locn mods@(mod:_) - = addShortWarnLocLine locn (\ sty -> - ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"]) + = addShortWarnLocLine locn $ \ sty -> + ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"] derivingNonStdClassErr clas locn - = addShortErrLocLine locn (\ sty -> - ppCat [ppStr "non-standard class in deriving:", ppr sty clas]) + = addShortErrLocLine locn $ \ sty -> + ppCat [ppStr "non-standard class in deriving:", ppr sty clas] dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty = ppAboves (item1 : map dup_item dup_things) where item1 - = addShortErrLocLine locn1 (\ sty -> ppStr "multiple default declarations") sty + = addShortErrLocLine locn1 (\ sty -> + ppStr "multiple default declarations") sty dup_item (DefaultDecl _ locn) - = addShortErrLocLine locn (\ sty -> ppStr "here was another default declaration") sty + = addShortErrLocLine locn (\ sty -> + ppStr "here was another default declaration") sty undefinedFixityDeclErr locn decl - = addErrLoc locn "fixity declaration for unknown operator" (\ sty -> - ppr sty decl) + = addErrLoc locn "fixity declaration for unknown operator" $ \ sty -> + ppr sty decl dupFixityDeclErr locn dups - = addErrLoc locn "multiple fixity declarations for same operator" (\ sty -> - ppAboves (map (ppr sty) dups)) + = addErrLoc locn "multiple fixity declarations for same operator" $ \ sty -> + ppAboves (map (ppr sty) dups) + +classTyVarNotInOpTyErr clas_tyvar sig locn + = addShortErrLocLine locn $ \ sty -> + ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"]) + 4 (ppr sty sig) + +classTyVarInOpCtxtErr clas_tyvar sig locn + = addShortErrLocLine locn $ \ sty -> + ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' present in method's local overloading context:"]) + 4 (ppr sty sig) + +dupClassAssertWarn ctxt locn dups + = addShortWarnLocLine locn $ \ sty -> + ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"]) + 4 (ppr sty ctxt) \end{code} diff --git a/ghc/compiler/rename/RnUtils.lhs b/ghc/compiler/rename/RnUtils.lhs index 1825928e20..7205e915d3 100644 --- a/ghc/compiler/rename/RnUtils.lhs +++ b/ghc/compiler/rename/RnUtils.lhs @@ -14,18 +14,14 @@ module RnUtils ( lubExportFlag, - unknownNameErr, - badClassOpErr, qualNameErr, - dupNamesErr, - shadowedNameWarn, - multipleOccWarn + dupNamesErr ) where -import Ubiq +IMP_Ubiq(){-uitous-} import Bag ( Bag, emptyBag, snocBag, unionBags ) -import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, addErrLoc ) +import ErrUtils ( addShortErrLocLine ) import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addListToFM, addToFM ) import Maybes ( maybeToBool ) @@ -164,20 +160,11 @@ lubExportFlag ExportAbs ExportAbs = ExportAbs ********************************************************* * * -\subsection{Errors used in RnMonad} +\subsection{Errors used *more than once* in the renamer} * * ********************************************************* \begin{code} -unknownNameErr descriptor name locn - = addShortErrLocLine locn ( \ sty -> - ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name] ) - -badClassOpErr clas op locn - = addErrLoc locn "" ( \ sty -> - ppBesides [ppChar '`', pprNonSym sty op, ppStr "' is not an operation of class `", - ppr sty clas, ppStr "'"] ) - qualNameErr descriptor (name,locn) = addShortErrLocLine locn ( \ sty -> ppBesides [ppStr "invalid use of qualified ", ppStr descriptor, ppStr ": ", pprNonSym sty name ] ) @@ -194,13 +181,5 @@ dupNamesErr descriptor ((name1,locn1) : dup_things) sty = addShortErrLocLine locn (\ sty -> ppBesides [ppStr "here was another declaration of `", pprNonSym sty name, ppStr "'" ]) sty - -shadowedNameWarn locn shadow - = addShortWarnLocLine locn ( \ sty -> - ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow] ) - -multipleOccWarn (name, occs) sty - = ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ", - ppInterleave ppComma (map (ppr sty) occs)] \end{code} diff --git a/ghc/compiler/simplCore/AnalFBWW.lhs b/ghc/compiler/simplCore/AnalFBWW.lhs index 136c4bfeb1..6c83afa0ce 100644 --- a/ghc/compiler/simplCore/AnalFBWW.lhs +++ b/ghc/compiler/simplCore/AnalFBWW.lhs @@ -8,7 +8,7 @@ module AnalFBWW ( analFBWW ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CoreSyn ( CoreBinding(..) ) import Util ( panic{-ToDo:rm-} ) diff --git a/ghc/compiler/simplCore/BinderInfo.lhs b/ghc/compiler/simplCore/BinderInfo.lhs index ebf64d75e7..82e024d93b 100644 --- a/ghc/compiler/simplCore/BinderInfo.lhs +++ b/ghc/compiler/simplCore/BinderInfo.lhs @@ -16,7 +16,7 @@ module BinderInfo ( inlineUnconditionally, oneTextualOcc, oneSafeOcc, - combineBinderInfo, combineAltsBinderInfo, + addBinderInfo, orBinderInfo, argOccurrence, funOccurrence, markMany, markDangerousToDup, markInsideSCC, @@ -26,7 +26,7 @@ module BinderInfo ( isFun, isDupDanger -- for Simon Marlow deforestation ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Pretty import Util ( panic ) @@ -46,7 +46,7 @@ data BinderInfo | ManyOcc -- Everything else besides DeadCode and OneOccs - Int -- number of arguments on stack when called + Int -- number of arguments on stack when called; this is a minimum guarantee | OneOcc -- Just one occurrence (or one each in @@ -66,7 +66,7 @@ data BinderInfo -- time we *use* the info; we could be more clever for -- other cases if we really had to. (WDP/PS) - Int -- number of arguments on stack when called + Int -- number of arguments on stack when called; minimum guarantee -- In general, we are feel free to substitute unless -- (a) is in an argument position (ArgOcc) @@ -170,17 +170,25 @@ markInsideSCC (OneOcc posn dup_danger _ n_alts ar) = OneOcc posn dup_danger InsideSCC n_alts ar markInsideSCC other = other -combineBinderInfo, combineAltsBinderInfo +addBinderInfo, orBinderInfo :: BinderInfo -> BinderInfo -> BinderInfo -combineBinderInfo DeadCode info2 = info2 -combineBinderInfo info1 DeadCode = info1 -combineBinderInfo info1 info2 +addBinderInfo DeadCode info2 = info2 +addBinderInfo info1 DeadCode = info1 +addBinderInfo info1 info2 = ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2)) -combineAltsBinderInfo DeadCode info2 = info2 -combineAltsBinderInfo info1 DeadCode = info1 -combineAltsBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1) +-- (orBinderInfo orig new) is used in two situations: +-- First, it combines occurrence info from branches of a case +-- +-- Second, when a variable whose occurrence +-- info is currently "orig" is bound to a variable whose occurrence info is "new" +-- eg (\new -> e) orig +-- What we want to do is to *worsen* orig's info to take account of new's + +orBinderInfo DeadCode info2 = info2 +orBinderInfo info1 DeadCode = info1 +orBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1) (OneOcc posn2 dup2 scc2 n_alts2 ar_2) = OneOcc (combine_posns posn1 posn2) (combine_dups dup1 dup2) @@ -188,9 +196,6 @@ combineAltsBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1) (n_alts1 + n_alts2) (min ar_1 ar_2) where - combine_posns FunOcc FunOcc = FunOcc -- see comment at FunOrArg defn - combine_posns _ _ = ArgOcc - combine_dups DupDanger _ = DupDanger -- Too paranoid?? ToDo combine_dups _ DupDanger = DupDanger combine_dups _ _ = NoDupDanger @@ -199,9 +204,24 @@ combineAltsBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1) combine_sccs _ InsideSCC = InsideSCC combine_sccs _ _ = NotInsideSCC -combineAltsBinderInfo info1 info2 +orBinderInfo info1 info2 = ManyOcc (min (getBinderInfoArity info1) (getBinderInfoArity info2)) +combine_posns FunOcc FunOcc = FunOcc -- see comment at FunOrArg defn +combine_posns _ _ = ArgOcc + +{- +multiplyBinderInfo orig@(ManyOcc _) new + = ManyOcc (min (getBinderInfoArity orig) (getBinderInfoArity new)) + +multiplyBinderInfo orig new@(ManyOcc _) + = ManyOcc (min (getBinderInfoArity orig) (getBinderInfoArity new)) + +multiplyBinderInfo (OneOcc posn1 dup1 scc1 n_alts1 ar_1) + (OneOcc posn2 dup2 scc2 n_alts2 ar_2) + = OneOcc (combine_posns posn1 posn2) ??? +-} + setBinderInfoArityToZero :: BinderInfo -> BinderInfo setBinderInfoArityToZero DeadCode = DeadCode setBinderInfoArityToZero (ManyOcc _) = ManyOcc 0 diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs index ef787b2d23..1b4c5ffeaa 100644 --- a/ghc/compiler/simplCore/ConFold.lhs +++ b/ghc/compiler/simplCore/ConFold.lhs @@ -12,10 +12,10 @@ ToDo: module ConFold ( completePrim ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CoreSyn -import CoreUnfold ( UnfoldingDetails(..), FormSummary(..) ) +import CoreUnfold ( whnfDetails, UnfoldingDetails(..), FormSummary(..) ) import Id ( idType ) import Literal ( mkMachInt, mkMachWord, Literal(..) ) import MagicUFs ( MagicUnfoldingFun ) @@ -23,6 +23,11 @@ import PrimOp ( PrimOp(..) ) import SimplEnv import SimplMonad import TysWiredIn ( trueDataCon, falseDataCon ) + +#ifdef REALLY_HASKELL_1_3 +ord = fromEnum :: Char -> Int +chr = toEnum :: Int -> Char +#endif \end{code} \begin{code} @@ -90,17 +95,10 @@ completePrim env SeqOp [TyArg ty, LitArg lit] = returnSmpl (Lit (mkMachInt 1)) completePrim env op@SeqOp args@[TyArg ty, VarArg var] - = case (lookupUnfolding env var) of - NoUnfoldingDetails -> give_up - LitForm _ -> hooray - OtherLitForm _ -> hooray - ConForm _ _ -> hooray - OtherConForm _ -> hooray - GenForm _ WhnfForm _ _ -> hooray - _ -> give_up - where - give_up = returnSmpl (Prim op args) - hooray = returnSmpl (Lit (mkMachInt 1)) + | whnfDetails (lookupUnfolding env var) + = returnSmpl (Lit (mkMachInt 1)) + | otherwise + = returnSmpl (Prim op args) \end{code} \begin{code} diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index b09986e370..b52523bf33 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -16,7 +16,7 @@ then discover that they aren't needed in the chosen branch. module FloatIn ( floatInwards ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import AnnCoreSyn import CoreSyn diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs index 401300459f..361b3cf866 100644 --- a/ghc/compiler/simplCore/FloatOut.lhs +++ b/ghc/compiler/simplCore/FloatOut.lhs @@ -10,7 +10,7 @@ module FloatOut ( floatOutwards ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CoreSyn diff --git a/ghc/compiler/simplCore/FoldrBuildWW.lhs b/ghc/compiler/simplCore/FoldrBuildWW.lhs index 55a0e31814..e5903cb1d7 100644 --- a/ghc/compiler/simplCore/FoldrBuildWW.lhs +++ b/ghc/compiler/simplCore/FoldrBuildWW.lhs @@ -8,7 +8,7 @@ module FoldrBuildWW ( mkFoldrBuildWW ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CoreSyn ( CoreBinding(..) ) import Util ( panic{-ToDo:rm?-} ) diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs index a75cd48b19..04aaa58ed4 100644 --- a/ghc/compiler/simplCore/LiberateCase.lhs +++ b/ghc/compiler/simplCore/LiberateCase.lhs @@ -10,7 +10,7 @@ module LiberateCase ( liberateCase ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Util ( panic ) liberateCase = panic "LiberateCase.liberateCase: ToDo" diff --git a/ghc/compiler/simplCore/MagicUFs.lhs b/ghc/compiler/simplCore/MagicUFs.lhs index 32318fe299..1df7968fc8 100644 --- a/ghc/compiler/simplCore/MagicUFs.lhs +++ b/ghc/compiler/simplCore/MagicUFs.lhs @@ -13,8 +13,8 @@ module MagicUFs ( applyMagicUnfoldingFun ) where -import Ubiq{-uitous-} -import IdLoop -- paranoia checking +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(IdLoop) -- paranoia checking import CoreSyn import SimplEnv ( SimplEnv ) @@ -320,9 +320,8 @@ foldr_fun _ _ = returnSmpl Nothing isConsFun :: SimplEnv -> CoreArg -> Bool isConsFun env (VarArg v) = case lookupUnfolding env v of - GenForm _ _ (Lam (x,_) (Lam (y,_) - (Con con tys [VarArg x',VarArg y']))) _ - | con == consDataCon && x==x' && y==y' + GenForm _ (Lam (x,_) (Lam (y,_) (Con con tys [VarArg x',VarArg y']))) _ + | con == consDataCon && x==x' && y==y' -> ASSERT ( length tys == 1 ) True _ -> False isConsFun env _ = False @@ -330,12 +329,9 @@ isConsFun env _ = False isNilForm :: SimplEnv -> CoreArg -> Bool isNilForm env (VarArg v) = case lookupUnfolding env v of - GenForm _ _ (CoTyApp (Var id) _) _ - | id == nilDataCon -> True - ConForm id _ _ - | id == nilDataCon -> True - LitForm (NoRepStr s) | _NULL_ s -> True - _ -> False + GenForm _ (CoTyApp (Var id) _) _ | id == nilDataCon -> True + GenForm _ (Lit (NoRepStr s)) _ | _NULL_ s -> True + _ -> False isNilForm env _ = False getBuildForm :: SimplEnv -> CoreArg -> Maybe Id @@ -343,9 +339,9 @@ getBuildForm env (VarArg v) = case lookupUnfolding env v of GenForm False _ _ _ -> Nothing -- not allowed to inline :-( - GenForm _ _ (App (CoTyApp (Var bld) _) (VarArg g)) _ + GenForm _ (App (CoTyApp (Var bld) _) (VarArg g)) _ | bld == buildId -> Just g - GenForm _ _ (App (App (CoTyApp (Var bld) _) + GenForm _ (App (App (CoTyApp (Var bld) _) (VarArg g)) h) _ | bld == augmentId && isNilForm env h -> Just g _ -> Nothing @@ -358,7 +354,7 @@ getAugmentForm env (VarArg v) = case lookupUnfolding env v of GenForm False _ _ _ -> Nothing -- not allowed to inline :-( - GenForm _ _ (App (App (CoTyApp (Var bld) _) + GenForm _ (App (App (CoTyApp (Var bld) _) (VarArg g)) h) _ | bld == augmentId -> Just (g,h) _ -> Nothing @@ -373,7 +369,7 @@ getAppendForm :: SimplEnv -> CoreArg -> Maybe (GenCoreAtom Id,GenCoreAtom Id) getAppendForm env (VarArg v) = case lookupUnfolding env v of GenForm False _ _ _ -> Nothing -- not allowed to inline :-( - GenForm _ _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _ + GenForm _ (App (App (App (CoTyApp (CoTyApp (Var fld) _) _) con) ys) xs) _ | fld == foldrId && isConsFun env con -> Just (xs,ys) _ -> Nothing getAppendForm env _ = Nothing @@ -390,7 +386,7 @@ getListForm -> Maybe ([CoreArg],CoreArg) getListForm env (VarArg v) = case lookupUnfolding env v of - ConForm id _ [head,tail] + GenForm _ (Con id [ty_arg,head,tail]) _ | id == consDataCon -> case getListForm env tail of Nothing -> Just ([head],tail) @@ -402,7 +398,7 @@ isInterestingArg :: SimplEnv -> CoreArg -> Bool isInterestingArg env (VarArg v) = case lookupUnfolding env v of GenForm False _ _ UnfoldNever -> False - GenForm _ _ exp guide -> True + GenForm _ exp guide -> True _ -> False isInterestingArg env _ = False diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index cc7d4fbdb8..cdb26cb131 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -17,7 +17,7 @@ module OccurAnal ( occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import BinderInfo import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) ) @@ -102,14 +102,14 @@ combineUsageDetails, combineAltsUsageDetails :: UsageDetails -> UsageDetails -> UsageDetails combineUsageDetails usage1 usage2 - = combineIdEnvs combineBinderInfo usage1 usage2 + = combineIdEnvs addBinderInfo usage1 usage2 combineAltsUsageDetails usage1 usage2 - = combineIdEnvs combineAltsBinderInfo usage1 usage2 + = combineIdEnvs orBinderInfo usage1 usage2 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails addOneOcc usage id info - = combineIdEnvs combineBinderInfo usage (unitIdEnv id info) + = combineIdEnvs addBinderInfo usage (unitIdEnv id info) -- ToDo: make this more efficient emptyDetails = (nullIdEnv :: UsageDetails) @@ -206,7 +206,7 @@ occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr occurAnalyseGlobalExpr expr = -- Top level expr, so no interesting free vars, and -- discard occurence info returned - expr' where (_, expr') = occurAnalyseExpr emptyIdSet expr + snd (occurAnalyseExpr emptyIdSet expr) \end{code} %************************************************************************ diff --git a/ghc/compiler/simplCore/SAT.lhs b/ghc/compiler/simplCore/SAT.lhs index 72c67099fc..cac46f1c73 100644 --- a/ghc/compiler/simplCore/SAT.lhs +++ b/ghc/compiler/simplCore/SAT.lhs @@ -42,7 +42,7 @@ Experimental Evidence: Heap: +/- 7% module SAT ( doStaticArgs ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Util ( panic ) doStaticArgs = panic "SAT.doStaticArgs (ToDo)" diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs index 627ade9461..029d856a0a 100644 --- a/ghc/compiler/simplCore/SATMonad.lhs +++ b/ghc/compiler/simplCore/SATMonad.lhs @@ -14,7 +14,7 @@ module SATMonad where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Util ( panic ) junk_from_SATMonad = panic "SATMonad.junk" diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index d1b50a5f83..f4bdc82638 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -21,7 +21,7 @@ module SetLevels ( -- not exported: , incMajorLvl, isTopMajLvl, unTopify ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import AnnCoreSyn import CoreSyn diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs index 4054a14463..58574cd6f9 100644 --- a/ghc/compiler/simplCore/SimplCase.lhs +++ b/ghc/compiler/simplCore/SimplCase.lhs @@ -10,13 +10,14 @@ Support code for @Simplify@. module SimplCase ( simplCase, bindLargeRhs ) where -import Ubiq{-uitous-} -import SmplLoop ( simplBind, simplExpr, MagicUnfoldingFun ) +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(SmplLoop) ( simplBind, simplExpr, MagicUnfoldingFun ) import BinderInfo -- too boring to try to select things... import CmdLineOpts ( SimplifierSwitch(..) ) import CoreSyn -import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..), +import CoreUnfold ( whnfDetails, mkConForm, mkLitForm, + UnfoldingDetails(..), UnfoldingGuidance(..), FormSummary(..) ) import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp, @@ -28,13 +29,13 @@ import Id ( idType, isDataCon, getIdDemandInfo, import IdInfo ( willBeDemanded, DemandInfo ) import Literal ( isNoRepLit, Literal{-instance Eq-} ) import Maybes ( maybeToBool ) -import PrelVals ( voidPrimId ) +import PrelVals ( voidId ) import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} ) import SimplEnv import SimplMonad import SimplUtils ( mkValLamTryingEta ) import Type ( isPrimType, maybeAppDataTyConExpandingDicts, mkFunTys, eqTy ) -import TysPrim ( voidPrimTy ) +import TysWiredIn ( voidTy ) import Unique ( Unique{-instance Eq-} ) import Usage ( GenUsage{-instance Eq-} ) import Util ( isIn, isSingleton, zipEqual, panic, assertPanic ) @@ -312,11 +313,6 @@ completeCase env scrut alts rhs_c [alt | alt@(alt_con,_,_) <- alts, not (alt_con `is_elem` not_these)] -#ifdef DEBUG --- ConForm c v -> pprPanic "completeCase!" (ppAbove (ppCat [ppr PprDebug c, ppStr "<args>"]) (ppr PprDebug alts)) - -- ConForm can't happen, since we'd have - -- inlined it, and be in completeCaseWithKnownCon by now -#endif other -> alts alt_binders_unused (con, args, rhs) = all is_dead args @@ -330,12 +326,7 @@ completeCase env scrut alts rhs_c -- If the scrut is already eval'd then there's no worry about -- eliminating the case - scrut_is_evald = case scrut_form of - OtherLitForm _ -> True - ConForm _ _ -> True - OtherConForm _ -> True - other -> False - + scrut_is_evald = whnfDetails scrut_form scrut_is_eliminable_primitive = case scrut of @@ -441,17 +432,17 @@ bindLargeRhs env args rhs_ty rhs_c -- for let-binding-purposes, we will *caseify* it (!), -- with potentially-disastrous strictness results. So -- instead we turn it into a function: \v -> e - -- where v::VoidPrim. Since arguments of type + -- where v::Void. Since arguments of type -- VoidPrim don't generate any code, this gives the -- desired effect. -- -- The general structure is just the same as for the common "otherwise~ case = newId prim_rhs_fun_ty `thenSmpl` \ prim_rhs_fun_id -> - newId voidPrimTy `thenSmpl` \ void_arg_id -> + newId voidTy `thenSmpl` \ void_arg_id -> rhs_c env `thenSmpl` \ prim_new_body -> returnSmpl (NonRec prim_rhs_fun_id (mkValLam [void_arg_id] prim_new_body), - App (Var prim_rhs_fun_id) (VarArg voidPrimId)) + App (Var prim_rhs_fun_id) (VarArg voidId)) | otherwise = -- Make the new binding Id. NB: it's an OutId @@ -484,7 +475,7 @@ bindLargeRhs env args rhs_ty rhs_c dead DeadCode = True dead other = False - prim_rhs_fun_ty = mkFunTys [voidPrimTy] rhs_ty + prim_rhs_fun_ty = mkFunTys [voidTy] rhs_ty \end{code} Case alternatives when we don't know the scrutinee @@ -535,7 +526,7 @@ simplAlts env scrut (PrimAlts alts deflt) rhs_c do_alt (lit, rhs) = let new_env = case scrut of - Var v -> extendUnfoldEnvGivenFormDetails env v (LitForm lit) + Var v -> extendUnfoldEnvGivenFormDetails env v (mkLitForm lit) other -> env in rhs_c new_env rhs `thenSmpl` \ rhs' -> @@ -592,16 +583,14 @@ simplDefault env (Var scrut_var) (BindDefault binder rhs) form_from_this_case rh = case (form_from_this_case, scrut_form) of (OtherConForm cs, OtherConForm ds) -> OtherConForm (cs++ds) (OtherLitForm cs, OtherLitForm ds) -> OtherLitForm (cs++ds) - -- ConForm, LitForm impossible - -- (ASSERT? ASSERT? Hello? WDP 95/05) other -> form_from_this_case env2 = extendUnfoldEnvGivenFormDetails env1 binder' final_form -- Change unfold details for scrut var. We now want to unfold it -- to binder' - new_scrut_var_form = GenForm True {- OK to dup -} WhnfForm - (Var binder') UnfoldAlways + new_scrut_var_form = GenForm WhnfForm (Var binder') UnfoldAlways + new_env = extendUnfoldEnvGivenFormDetails env2 scrut_var new_scrut_var_form in @@ -702,7 +691,7 @@ completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c let env1 = extendIdEnvWithClone env binder id' new_env = extendUnfoldEnvGivenFormDetails env1 id' - (ConForm con con_args) + (mkConForm con con_args) in rhs_c new_env rhs `thenSmpl` \ rhs' -> returnSmpl (Let (NonRec id' (Con con con_args)) rhs') diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index a58f126ae8..c8235b2268 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -8,7 +8,7 @@ module SimplCore ( core2core ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import AnalFBWW ( analFBWW ) import Bag ( isEmptyBag, foldBag ) @@ -327,7 +327,7 @@ calcInlinings scc_s_OK inline_env_so_far top_binds where pp_det NoUnfoldingDetails = ppStr "_N_" --LATER: pp_det (IWantToBeINLINEd _) = ppStr "INLINE" - pp_det (GenForm _ _ expr guide) + pp_det (GenForm _ expr guide) = ppAbove (ppr PprDebug guide) (ppr PprDebug expr) pp_det other = ppStr "???" diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 5406e3da09..7cd952426b 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -43,27 +43,30 @@ module SimplEnv ( OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..) ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} -import SmplLoop -- breaks the MagicUFs / SimplEnv loop +IMPORT_DELOOPER(SmplLoop) -- breaks the MagicUFs / SimplEnv loop -import BinderInfo ( BinderInfo{-instances-} ) +import BinderInfo ( orBinderInfo, oneSafeOcc, + BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC + ) import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD ) import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult ) import CoreSyn -import CoreUnfold ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails, +import CoreUnfold ( UnfoldingDetails(..), mkGenForm, mkConForm, calcUnfoldingGuidance, UnfoldingGuidance(..), - mkFormSummary, FormSummary + mkFormSummary, FormSummary(..) ) import CoreUtils ( manifestlyWHNF, exprSmallEnoughToDup ) import FiniteMap -- lots of things import Id ( idType, getIdUnfolding, getIdStrictness, applyTypeEnvToId, nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv, - addOneToIdEnv, modifyIdEnv, + addOneToIdEnv, modifyIdEnv, mkIdSet, IdEnv(..), IdSet(..), GenId ) import IdInfo ( bottomIsGuaranteed, StrictnessInfo ) import Literal ( isNoRepLit, Literal{-instances-} ) +import Maybes ( maybeToBool ) import Name ( isLocallyDefined ) import OccurAnal ( occurAnalyseExpr ) import Outputable ( Outputable(..){-instances-} ) @@ -77,16 +80,15 @@ import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv, TyVarEnv(..), GenTyVar{-instance Eq-} ) import Unique ( Unique{-instance Outputable-} ) -import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList ) -import UniqSet -- lots of things +import UniqFM ( addToUFM_Directly, lookupUFM_Directly, delFromUFM_Directly, + delFromUFM, ufmToList + ) +--import UniqSet -- lots of things import Usage ( UVar(..), GenUsage{-instances-} ) import Util ( zipEqual, thenCmp, cmpList, panic, panic#, assertPanic ) type TypeEnv = TyVarEnv Type cmpType = panic "cmpType (SimplEnv)" -oneSafeOcc = panic "oneSafeOcc (SimplEnv)" -oneTextualOcc = panic "oneTextualOcc (SimplEnv)" -simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)" \end{code} %************************************************************************ @@ -171,13 +173,11 @@ pprSimplEnv (SimplEnv _ _ ty_env id_env (UFE unfold_env _ _)) = ppCat [ppr PprDebug v, ppStr "=>", case form of NoUnfoldingDetails -> ppStr "NoUnfoldingDetails" - LitForm l -> ppCat [ppStr "Lit:", ppr PprDebug l] OtherLitForm ls -> ppCat [ppStr "Other lit:", ppInterleave (ppStr ", ") [ppr PprDebug l | l <- ls]] - ConForm c a -> ppCat [ppStr "Con:", ppr PprDebug c, ppr PprDebug a] OtherConForm cs -> ppCat [ppStr "OtherCon:", ppInterleave (ppStr ", ") [ppr PprDebug c | c <- cs]] - GenForm t w e g -> ppCat [ppStr "UF:", ppr PprDebug t, ppr PprDebug w, + GenForm w e g -> ppCat [ppStr "UF:", ppr PprDebug w, ppr PprDebug g, ppr PprDebug e] MagicForm s _ -> ppCat [ppStr "Magic:", ppr PprDebug s] ] @@ -258,12 +258,21 @@ data UnfoldConApp -- yet another glorified pair data UnfoldEnv -- yup, a glorified triple... = UFE (IdEnv UnfoldItem) -- Maps an OutId => its UnfoldItem - IdSet -- The Ids in the domain of the env - -- which have details (GenForm True ...) - -- i.e., they claim they are duplicatable. - -- These are the ones we have to worry - -- about when adding new items to the - -- unfold env. + + (IdEnv (Id,BinderInfo)) -- Occurrence info for some (but not necessarily all) + -- in-scope ids. The "Id" part is just so that + -- we can recover the domain of the mapping, which + -- IdEnvs don't allow directly. + -- + -- Anything that isn't in here + -- should be assumed to occur many times. + -- The things in here all occur once, and the + -- binder-info tells about whether that "once" + -- is inside a lambda, or perhaps once in each branch + -- of a case etc. + -- We keep this info so we can modify it when + -- something changes. + (FiniteMap UnfoldConApp [([Type], OutId)]) -- Maps applications of constructors (to -- value atoms) back to an association list @@ -274,7 +283,7 @@ data UnfoldEnv -- yup, a glorified triple... -- mapping for (part of) the main IdEnv -- (1st part of UFE) -null_unfold_env = UFE nullIdEnv emptyUniqSet emptyFM +null_unfold_env = UFE nullIdEnv nullIdEnv emptyFM \end{code} The @UnfoldEnv@ type. We expect on the whole that an @UnfoldEnv@ will @@ -289,45 +298,40 @@ things silently grow quite big.... Here are some local functions used elsewhere in the module: \begin{code} -grow_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv +grow_unfold_env :: UnfoldEnv -> OutId -> BinderInfo -> UnfoldingDetails -> EnclosingCcDetails -> UnfoldEnv lookup_unfold_env :: UnfoldEnv -> OutId -> UnfoldingDetails lookup_unfold_env_encl_cc :: UnfoldEnv -> OutId -> EnclosingCcDetails -grow_unfold_env full_u_env id NoUnfoldingDetails _ = full_u_env +grow_unfold_env full_u_env _ _ NoUnfoldingDetails _ = full_u_env -grow_unfold_env (UFE u_env interesting_ids con_apps) id - uf_details@(GenForm True _ _ _) encl_cc - -- Only interested in Ids which have a "dangerous" unfolding; that is - -- one that claims to have a single occurrence. +grow_unfold_env (UFE u_env occ_env con_apps) id occ_info uf_details encl_cc = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc)) - (addOneToUniqSet interesting_ids id) - con_apps - -grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc - = UFE (addOneToIdEnv u_env id (UnfoldItem id uf_details encl_cc)) - interesting_ids + new_occ_env new_con_apps where + new_occ_env = modify_occ_info occ_env id occ_info + new_con_apps = case uf_details of - ConForm con args -> snd (lookup_conapp_help con_apps con args id) + GenForm WhnfForm (Con con args) UnfoldAlways -> snd (lookup_conapp_help con_apps con args id) not_a_constructor -> con_apps -- unchanged -addto_unfold_env (UFE u_env interesting_ids con_apps) extra_items +addto_unfold_env (UFE u_env occ_env con_apps) extra_items = ASSERT(not (any constructor_form_in_those extra_items)) -- otherwise, we'd need to change con_apps - UFE (growIdEnvList u_env extra_items) interesting_ids con_apps + UFE (growIdEnvList u_env extra_items) occ_env con_apps where - constructor_form_in_those (_, UnfoldItem _ (ConForm _ _) _) = True + constructor_form_in_those (_, UnfoldItem _ (GenForm WhnfForm (Con _ _) UnfoldAlways) _) = True constructor_form_in_those _ = False rng_unfold_env (UFE u_env _ _) = rngIdEnv u_env -get_interesting_ids (UFE _ interesting_ids _) = interesting_ids +get_interesting_ids (UFE _ occ_env _) + = mkIdSet [ i | (_,(i,_)) <- ufmToList occ_env ] -foldr_unfold_env fun (UFE u_env interesting_ids con_apps) stuff - = UFE (foldr fun u_env stuff) interesting_ids con_apps +foldr_occ_env fun (UFE u_env occ_env con_apps) stuff + = UFE u_env (foldr fun occ_env stuff) con_apps lookup_unfold_env (UFE u_env _ _) id = case (lookupIdEnv u_env id) of @@ -368,30 +372,27 @@ lookup_conapp_help con_apps con args outid cmp_ty ty1 ty2 -- NB: we really only know how to do *equality* on types = if (ty1 `eqTy` ty2) then EQ_ else LT_{-random choice-} -modify_unfold_env (UFE u_env interesting_ids con_apps) zapper id - = UFE (modifyIdEnv u_env zapper id) interesting_ids con_apps +modify_occ_info occ_env id new_occ@(OneOcc _ _ _ _ _) + = modifyIdEnv occ_env (\ (i,o) -> (i, orBinderInfo o new_occ)) id --- If the current binding claims to be a "unique" one, then --- we modify it. -modifyItem :: Bool -> BinderInfo -> UnfoldItem -> UnfoldItem - -modifyItem ok_to_dup occ_info (UnfoldItem id details enc_cc) - = UnfoldItem id (modifyUnfoldingDetails ok_to_dup occ_info details) enc_cc +modify_occ_info occ_env id other_new_occ + = -- Many or Dead occurrence, just delete from occ_env + delFromUFM occ_env id \end{code} The main thing about @UnfoldConApp@ is that it has @Ord@ defined on it, so we can use it for a @FiniteMap@ key. \begin{code} instance Eq UnfoldConApp where - a == b = case cmp_app a b of { EQ_ -> True; _ -> False } - a /= b = case cmp_app a b of { EQ_ -> False; _ -> True } + a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } + a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } instance Ord UnfoldConApp where - a <= b = case cmp_app a b of { LT_ -> True; EQ_ -> True; GT__ -> False } - a < b = case cmp_app a b of { LT_ -> True; EQ_ -> False; GT__ -> False } - a >= b = case cmp_app a b of { LT_ -> False; EQ_ -> True; GT__ -> True } - a > b = case cmp_app a b of { LT_ -> False; EQ_ -> False; GT__ -> True } - _tagCmp a b = case cmp_app a b of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } + a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False } + a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False } + a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True } + a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True } + _tagCmp a b = case (a `cmp` b) of { LT_ -> _LT; EQ_ -> _EQ; GT__ -> _GT } instance Ord3 UnfoldConApp where cmp = cmp_app @@ -402,7 +403,7 @@ cmp_app (UCA c1 as1) (UCA c2 as2) -- ToDo: make an "instance Ord3 CoreArg"??? cmp_arg (VarArg x) (VarArg y) = x `cmp` y - cmp_arg (LitArg x) (LitArg y) = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ } + cmp_arg (LitArg x) (LitArg y) = x `cmp` y cmp_arg (TyArg x) (TyArg y) = panic# "SimplEnv.cmp_app:TyArgs" cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs" cmp_arg x y @@ -543,26 +544,19 @@ extendIdEnvWithAtom -> InBinder -> OutArg{-Val args only, please-} -> SimplEnv -extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit) +extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) + (in_id,occ_info) atom@(LitArg lit) = SimplEnv chkr encl_cc ty_env new_id_env unfold_env where new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom) -extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) - (in_id, occ_info) atom@(VarArg out_id) +extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env (UFE u_env occ_env con_apps)) + (in_id, occ_info) atom@(VarArg out_id) = SimplEnv chkr encl_cc ty_env new_id_env new_unfold_env where - new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom) - - new_unfold_env = modify_unfold_env - unfold_env - (modifyItem ok_to_dup occ_info) - out_id - -- Modify binding for in_id - -- NO! modify out_id, because its the info on the - -- atom that interest's us. - - ok_to_dup = switchIsOn chkr SimplOkToDupCode + new_id_env = addOneToIdEnv id_env in_id (ItsAnAtom atom) + new_unfold_env = UFE u_env (modify_occ_info occ_env out_id occ_info) con_apps + -- Modify occ info for out_id #ifdef DEBUG extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!" @@ -648,7 +642,8 @@ extendUnfoldEnvGivenFormDetails NoUnfoldingDetails -> env good_details -> SimplEnv chkr encl_cc ty_env id_env new_unfold_env where - new_unfold_env = grow_unfold_env unfold_env id good_details encl_cc + new_unfold_env = grow_unfold_env unfold_env id fake_occ_info good_details encl_cc + fake_occ_info = {-ToDo!-} ManyOcc 0 -- generally paranoid extendUnfoldEnvGivenConstructor -- specialised variant :: SimplEnv @@ -663,7 +658,7 @@ extendUnfoldEnvGivenConstructor env var con args (_, ty_args, _) = getAppDataTyConExpandingDicts scrut_ty in extendUnfoldEnvGivenFormDetails - env var (ConForm con (map TyArg ty_args ++ map VarArg args)) + env var (mkConForm con (map TyArg ty_args ++ map VarArg args)) \end{code} @@ -720,40 +715,40 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) = SimplEnv chkr encl_cc ty_env id_env new_unfold_env where -- Occurrence-analyse the RHS - (fv_occ_info, template) = occurAnalyseExpr {-test:nullIdEnv-} interesting_fvs rhs + (fv_occ_info, template) = occurAnalyseExpr interesting_fvs rhs - interesting_fvs = get_interesting_ids unfold_env + interesting_fvs = get_interesting_ids unfold_env -- Ids in dom of OccEnv -- Compute unfolding details - details = case rhs of - Var v -> panic "Vars already dealt with" - Lit lit | isNoRepLit lit -> LitForm lit - | otherwise -> panic "non-noRep Lits already dealt with" - - Con con args -> ConForm con args - - other -> mkGenForm ok_to_dup occ_info - (mkFormSummary (getIdStrictness out_id) rhs) - template guidance + details = mkGenForm (mkFormSummary (getIdStrictness out_id) rhs) + template guidance -- Compute resulting unfold env new_unfold_env = case details of - NoUnfoldingDetails -> unfold_env - GenForm _ _ _ _ -> unfold_env2{-test: unfold_env1 -} - other -> unfold_env1 + NoUnfoldingDetails -> unfold_env + other -> unfold_env1 -- Add unfolding to unfold env - unfold_env1 = grow_unfold_env unfold_env out_id details encl_cc + unfold_env1 = grow_unfold_env unfold_env out_id occ_info details encl_cc +{- OLD: done in grow_unfold_env -- Modify unfoldings of free vars of rhs, based on their -- occurrence info in the rhs [see notes above] - unfold_env2 = foldr_unfold_env modify unfold_env1 (ufmToList fv_occ_info) - - modify :: (Unique, BinderInfo) -> IdEnv UnfoldItem -> IdEnv UnfoldItem - modify (u, occ_info) env - = case (lookupUFM_Directly env u) of - Nothing -> env -- ToDo: can this happen? - Just xx -> addToUFM_Directly env u (modifyItem ok_to_dup occ_info xx) + unfold_env2 + = foldr_occ_env modify unfold_env1 (ufmToList fv_occ_info) + where + modify :: (Unique, (Id,BinderInfo)) -> IdEnv (Id,BinderInfo) -> IdEnv (Id,BinderInfo) + modify (u, item@(i,occ_info)) env + = if maybeToBool (lookupUFM_Directly env u) then + -- it occurred before, so now it occurs multiple times; + -- therefore, *delete* it from the occ(urs once) env. + delFromUFM_Directly env u + + else if not (oneSafeOcc ok_to_dup occ_info) then + env -- leave it alone + else + addToUFM_Directly env u item +-} -- Compute unfolding guidance guidance = if simplIdWantsToBeINLINEd out_id env @@ -765,8 +760,8 @@ extendUnfoldEnvGivenRhs env@(SimplEnv chkr encl_cc ty_env id_env unfold_env) Just xx -> xx ok_to_dup = switchIsOn chkr SimplOkToDupCode - || exprSmallEnoughToDup rhs - -- [Andy] added, Jun 95 +--NO: || exprSmallEnoughToDup rhs +-- -- [Andy] added, Jun 95 {- Reinstated AJG Jun 95; This is needed --example that does not (currently) work diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 4855ede668..f1a1257634 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -18,13 +18,11 @@ module SimplMonad ( -- Cloning cloneId, cloneIds, cloneTyVarSmpl, newIds, newId - - -- and to make the interface self-sufficient... ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} -import SmplLoop -- well, cheating sort of +IMPORT_DELOOPER(SmplLoop) -- well, cheating sort of import Id ( mkSysLocal, mkIdWithNewUniq ) import SimplEnv diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs index 3db8a5f5c8..692f720e7f 100644 --- a/ghc/compiler/simplCore/SimplPgm.lhs +++ b/ghc/compiler/simplCore/SimplPgm.lhs @@ -8,7 +8,7 @@ module SimplPgm ( simplifyPgm ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CmdLineOpts ( opt_D_verbose_core2core, switchIsOn, intSwitchSet, SimplifierSwitch(..) diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index ac24d65fc4..70ed4b8079 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -21,7 +21,8 @@ module SimplUtils ( type_ok_for_let_to_case ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(SmplLoop) -- paranoia checking import BinderInfo import CmdLineOpts ( SimplifierSwitch(..) ) diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index f6eecf2b31..043cd3d5e3 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -1,5 +1,5 @@ % -% (c) The AQUA Project, Glasgow University, 1993-1995 +% (c) The AQUA Project, Glasgow University, 1993-1996 % \section[SimplVar]{Simplifier stuff related to variables} @@ -11,15 +11,15 @@ module SimplVar ( leastItCouldCost ) where -import Ubiq{-uitous-} -import SmplLoop ( simplExpr ) +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(SmplLoop) ( simplExpr ) import CgCompInfo ( uNFOLDING_USE_THRESHOLD, uNFOLDING_CON_DISCOUNT_WEIGHT ) import CmdLineOpts ( intSwitchSet, switchIsOn, SimplifierSwitch(..) ) import CoreSyn -import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..), +import CoreUnfold ( whnfDetails, UnfoldingDetails(..), UnfoldingGuidance(..), FormSummary(..) ) import Id ( idType, getIdInfo, @@ -55,21 +55,9 @@ completeVar env var args in case (lookupUnfolding env var) of - LitForm lit - | not (isNoRepLit lit) - -- Inline literals, if they aren't no-repish things - -> ASSERT( null args ) - returnSmpl (Lit lit) - - ConForm con con_args - -- Always inline constructors. - -- See comments before completeLetBinding - -> ASSERT( null args ) - returnSmpl (Con con con_args) - - GenForm txt_occ form_summary template guidance + GenForm form_summary template guidance -> considerUnfolding env var args - txt_occ form_summary template guidance + (panic "completeVar"{-txt_occ-}) form_summary template guidance MagicForm str magic_fun -> applyMagicUnfoldingFun magic_fun env args `thenSmpl` \ result -> @@ -268,10 +256,9 @@ discountedCost env con_discount_weight size no_args is_con_vec args full_price else case arg of - LitArg _ -> full_price - VarArg v -> case lookupUnfolding env v of - ConForm _ _ -> take_something_off v - other_form -> full_price + LitArg _ -> full_price + VarArg v | whnfDetails (lookupUnfolding env v) -> take_something_off v + | otherwise -> full_price ) want_cons rest_args \end{code} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 27424dd023..240f4b3026 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -8,8 +8,8 @@ module Simplify ( simplTopBinds, simplExpr, simplBind ) where -import Ubiq{-uitous-} -import SmplLoop -- paranoia checking +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(SmplLoop) -- paranoia checking import BinderInfo import CmdLineOpts ( SimplifierSwitch(..) ) diff --git a/ghc/compiler/simplCore/SmplLoop.lhi b/ghc/compiler/simplCore/SmplLoop.lhi index ddffa3bbbd..a6275b949b 100644 --- a/ghc/compiler/simplCore/SmplLoop.lhi +++ b/ghc/compiler/simplCore/SmplLoop.lhi @@ -5,6 +5,8 @@ Also break the loop between SimplVar/SimplCase (which use Simplify.simplExpr) and SimplExpr (which uses whatever SimplVar/SimplCase cough up). +Tell SimplEnv about SimplUtils.simplIdWantsToBeINLINEd. + \begin{code} interface SmplLoop where @@ -13,6 +15,7 @@ import SimplEnv ( SimplEnv, InBinding(..), InExpr(..), OutArg(..), OutExpr(..), OutType(..) ) import Simplify ( simplExpr, simplBind ) +import SimplUtils ( simplIdWantsToBeINLINEd ) import BinderInfo(BinderInfo) import CoreSyn(GenCoreArg, GenCoreBinding, GenCoreExpr) @@ -27,6 +30,8 @@ import Usage(GenUsage) data MagicUnfoldingFun data SimplCount +simplIdWantsToBeINLINEd :: GenId (GenType (GenTyVar (GenUsage Unique)) Unique) -> SimplEnv -> Bool + simplBind :: SimplEnv -> GenCoreBinding (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> (SimplEnv -> UniqSupply -> SimplCount -> (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique, SimplCount)) -> GenType (GenTyVar (GenUsage Unique)) Unique -> UniqSupply -> SimplCount -> (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique, SimplCount) simplExpr :: SimplEnv -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> [GenCoreArg (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique] -> UniqSupply -> SimplCount -> (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique, SimplCount) \end{code} diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs index 0562a29846..1d88e2f54f 100644 --- a/ghc/compiler/simplStg/LambdaLift.lhs +++ b/ghc/compiler/simplStg/LambdaLift.lhs @@ -8,7 +8,7 @@ module LambdaLift ( liftProgram ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import StgSyn diff --git a/ghc/compiler/simplStg/SatStgRhs.lhs b/ghc/compiler/simplStg/SatStgRhs.lhs index eab32d0016..9feec285b5 100644 --- a/ghc/compiler/simplStg/SatStgRhs.lhs +++ b/ghc/compiler/simplStg/SatStgRhs.lhs @@ -60,7 +60,7 @@ This is done for local definitions as well. module SatStgRhs ( satStgRhs ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import StgSyn diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index f0aa84fa34..f57744c94d 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -8,7 +8,7 @@ module SimplStg ( stg2stg ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import StgSyn import StgUtils diff --git a/ghc/compiler/simplStg/StgSAT.lhs b/ghc/compiler/simplStg/StgSAT.lhs index a70205e11b..3d82b27dc6 100644 --- a/ghc/compiler/simplStg/StgSAT.lhs +++ b/ghc/compiler/simplStg/StgSAT.lhs @@ -33,7 +33,7 @@ useless as map' will be transformed back to what map was. module StgSAT ( doStaticArgs ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import StgSyn import UniqSupply ( UniqSM(..) ) diff --git a/ghc/compiler/simplStg/StgSATMonad.lhs b/ghc/compiler/simplStg/StgSATMonad.lhs index dd6379c2be..66e138ee60 100644 --- a/ghc/compiler/simplStg/StgSATMonad.lhs +++ b/ghc/compiler/simplStg/StgSATMonad.lhs @@ -12,7 +12,7 @@ module StgSATMonad ( getArgLists, saTransform ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Util ( panic ) diff --git a/ghc/compiler/simplStg/StgStats.lhs b/ghc/compiler/simplStg/StgStats.lhs index 8fba50ebc2..d1dd34c70d 100644 --- a/ghc/compiler/simplStg/StgStats.lhs +++ b/ghc/compiler/simplStg/StgStats.lhs @@ -25,7 +25,7 @@ The program gather statistics about module StgStats ( showStgStats ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import StgSyn diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs index ed675f705c..1947e9593a 100644 --- a/ghc/compiler/simplStg/StgVarInfo.lhs +++ b/ghc/compiler/simplStg/StgVarInfo.lhs @@ -11,7 +11,7 @@ let-no-escapes. module StgVarInfo ( setStgVarInfo ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import StgSyn diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs index e0f4adf6b3..103b633e20 100644 --- a/ghc/compiler/simplStg/UpdAnal.lhs +++ b/ghc/compiler/simplStg/UpdAnal.lhs @@ -12,7 +12,7 @@ > module UpdAnal ( updateAnalyse ) where > -> import Ubiq{-uitous-} +> IMP_Ubiq(){-uitous-} > > import StgSyn > import Util ( panic ) diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs index 64319b860e..28b306de65 100644 --- a/ghc/compiler/specialise/SpecEnv.lhs +++ b/ghc/compiler/specialise/SpecEnv.lhs @@ -13,7 +13,7 @@ module SpecEnv ( specEnvToList ) where -import Ubiq +IMP_Ubiq() import MatchEnv import Type ( matchTys, isTyVarTy ) diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index 7af0cc7eb7..68d6816bf2 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -21,7 +21,7 @@ module SpecUtils ( pprSpecErrs ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Bag ( isEmptyBag, bagToList ) import Class ( classOpString, GenClass{-instance NamedThing-} ) diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 2b69f39cce..dcbf88c181 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -13,7 +13,7 @@ module Specialise ( SpecialiseData(..) ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Bag ( emptyBag, unitBag, isEmptyBag, unionBags, partitionBag, listToBag, bagToList diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index edd2d815f3..a70706862b 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -15,7 +15,7 @@ Convert a @CoreSyntax@ program to a @StgSyntax@ program. module CoreToStg ( topCoreBindsToStg ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CoreSyn -- input import StgSyn -- output @@ -36,10 +36,17 @@ import PrelVals ( unpackCStringId, unpackCString2Id, import PrimOp ( PrimOp(..) ) import SpecUtils ( mkSpecialisedCon ) import SrcLoc ( mkUnknownSrcLoc ) -import Type ( getAppDataTyConExpandingDicts ) -import TysWiredIn ( stringTy, integerTy, rationalTy, ratioDataCon ) +import TyCon ( TyCon{-instance Uniquable-} ) +import Type ( maybeAppDataTyCon, getAppDataTyConExpandingDicts ) +import TysWiredIn ( stringTy ) +import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} ) import UniqSupply -- all of it, really -import Util ( panic ) +import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} ) +import Pretty--ToDo:rm +import PprStyle--ToDo:rm +import PprType --ToDo:rm +import Outputable--ToDo:rm +import PprEnv--ToDo:rm isLeakFreeType x y = False -- safe option; ToDo \end{code} @@ -303,7 +310,7 @@ litToStgArg (NoRepStr s) where is_NUL c = c == '\0' -litToStgArg (NoRepInteger i) +litToStgArg (NoRepInteger i integer_ty) -- extremely convenient to look out for a few very common -- Integer literals! | i == 0 = returnUs (StgVarArg integerZeroId, emptyBag) @@ -312,7 +319,7 @@ litToStgArg (NoRepInteger i) | i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag) | otherwise - = newStgVar integerTy `thenUs` \ var -> + = newStgVar integer_ty `thenUs` \ var -> let rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?) stgArgOcc -- safe @@ -332,18 +339,33 @@ litToStgArg (NoRepInteger i) in returnUs (StgVarArg var, unitBag (StgNonRec var rhs)) -litToStgArg (NoRepRational r) - = litToStgArg (NoRepInteger (numerator r)) `thenUs` \ (num_atom, binds1) -> - litToStgArg (NoRepInteger (denominator r)) `thenUs` \ (denom_atom, binds2) -> - newStgVar rationalTy `thenUs` \ var -> - let - rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?) - ratioDataCon -- Constructor - [num_atom, denom_atom] - in - returnUs (StgVarArg var, binds1 `unionBags` - binds2 `unionBags` - unitBag (StgNonRec var rhs)) +litToStgArg (NoRepRational r rational_ty) + = --ASSERT(is_rational_ty) + (if is_rational_ty then \x->x else pprTrace "litToStgArg:not rational?" (pprType PprDebug rational_ty)) $ + litToStgArg (NoRepInteger (numerator r) integer_ty) `thenUs` \ (num_atom, binds1) -> + litToStgArg (NoRepInteger (denominator r) integer_ty) `thenUs` \ (denom_atom, binds2) -> + newStgVar rational_ty `thenUs` \ var -> + let + rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?) + ratio_data_con -- Constructor + [num_atom, denom_atom] + in + returnUs (StgVarArg var, binds1 `unionBags` + binds2 `unionBags` + unitBag (StgNonRec var rhs)) + where + (is_rational_ty, ratio_data_con, integer_ty) + = case (maybeAppDataTyCon rational_ty) of + Just (tycon, [i_ty], [con]) + -> ASSERT(is_integer_ty i_ty) + (uniqueOf tycon == ratioTyConKey, con, i_ty) + + _ -> (False, panic "ratio_data_con", panic "integer_ty") + + is_integer_ty ty + = case (maybeAppDataTyCon ty) of + Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey + _ -> False litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag) \end{code} diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 48263f5142..d549f56a25 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -8,7 +8,7 @@ module StgLint ( lintStgBindings ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import StgSyn diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index ca50b0cc3a..c4fca6dc56 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -35,11 +35,9 @@ module StgSyn ( isLitLitArg, stgArity, collectExportedStgBinders - - -- and to make the interface self-sufficient... ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CostCentre ( showCostCentre ) import Id ( idPrimRep, GenId{-instance NamedThing-} ) diff --git a/ghc/compiler/stgSyn/StgUtils.lhs b/ghc/compiler/stgSyn/StgUtils.lhs index 7c89ac3761..d586d8e458 100644 --- a/ghc/compiler/stgSyn/StgUtils.lhs +++ b/ghc/compiler/stgSyn/StgUtils.lhs @@ -8,7 +8,7 @@ x% module StgUtils ( mapStgBindeesRhs ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Id ( GenId{-instanced NamedThing-} ) import StgSyn diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index 04ba2f0b6d..10f5e4221a 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -15,13 +15,13 @@ module SaAbsInt ( isBot ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CoreSyn import CoreUnfold ( UnfoldingDetails(..), FormSummary ) import CoreUtils ( unTagBinders ) import Id ( idType, getIdStrictness, getIdUnfolding, - dataConSig, dataConArgTys + dataConTyCon, dataConArgTys ) import IdInfo ( StrictnessInfo(..), Demand(..), wwPrim, wwStrict, wwEnum, wwUnpack @@ -393,14 +393,7 @@ absId anal var env (Just abs_val, _, _) -> abs_val -- Bound in the environment - (Nothing, NoStrictnessInfo, LitForm _) -> - AbsTop -- Literals all terminate, and have no poison - - (Nothing, NoStrictnessInfo, ConForm _ _) -> - AbsTop -- An imported constructor won't have - -- bottom components, nor poison! - - (Nothing, NoStrictnessInfo, GenForm _ _ unfolding _) -> + (Nothing, NoStrictnessInfo, GenForm _ unfolding _) -> -- We have an unfolding for the expr -- Assume the unfolding has no free variables since it -- came from inside the Id @@ -429,14 +422,9 @@ absId anal var env -- Includes MagicForm, IWantToBeINLINEd, NoUnfoldingDetails -- Try the strictness info absValFromStrictness anal strictness_info - - - -- Done via strictness now - -- GenForm _ BottomForm _ _ -> AbsBot in - -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppStr "=:", pp_anal anal, ppStr ":=",ppr PprDebug result]) ( + -- pprTrace "absId:" (ppBesides [ppr PprDebug var, ppStr "=:", pp_anal anal, ppStr ":=",ppr PprDebug result]) $ result - -- ) where pp_anal StrAnal = ppStr "STR" pp_anal AbsAnal = ppStr "ABS" @@ -518,8 +506,7 @@ absEval anal (Con con as) env then AbsBot else AbsTop where - (_,_,_, tycon) = dataConSig con - has_single_con = maybeToBool (maybeTyConSingleCon tycon) + has_single_con = maybeToBool (maybeTyConSingleCon (dataConTyCon con)) \end{code} \begin{code} diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs index ef42acde13..f09e9c9a61 100644 --- a/ghc/compiler/stranal/SaLib.lhs +++ b/ghc/compiler/stranal/SaLib.lhs @@ -18,7 +18,7 @@ module SaLib ( absValFromStrictness ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CoreSyn ( CoreExpr(..) ) import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList, diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 71c6e90388..fd4445b651 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -11,7 +11,7 @@ Semantique analyser) was written by Andy Gill. module StrictAnal ( saWwTopBinds, saTopBinds ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict, opt_D_dump_stranal, opt_D_simplifier_stats diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index d9ef03af1b..873c25f628 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -8,7 +8,7 @@ module WorkWrap ( workersAndWrappers ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CoreSyn import CoreUnfold ( UnfoldingGuidance(..) ) diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index eeaafc9c03..4f68efbcce 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -12,7 +12,7 @@ module WwLib ( mkWwBodies, mAX_WORKER_ARGS ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import CoreSyn import Id ( idType, mkSysLocal, dataConArgTys ) diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs index 079c2920b8..e86accf40b 100644 --- a/ghc/compiler/typecheck/GenSpecEtc.lhs +++ b/ghc/compiler/typecheck/GenSpecEtc.lhs @@ -12,7 +12,7 @@ module GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals ) where -import Ubiq +IMP_Ubiq() import TcMonad hiding ( rnMtoTcM ) import Inst ( Inst, InstOrigin(..), LIE(..), plusLIE, @@ -20,8 +20,8 @@ import Inst ( Inst, InstOrigin(..), LIE(..), plusLIE, import TcEnv ( tcGetGlobalTyVars ) import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals ) import TcType ( TcType(..), TcThetaType(..), TcTauType(..), - TcTyVarSet(..), TcTyVar(..), tcInstType, - newTyVarTy, zonkTcType + TcTyVarSet(..), TcTyVar(..), + newTyVarTy, zonkTcType, zonkTcTyVar, zonkTcTyVars ) import Unify ( unifyTauTy ) @@ -41,7 +41,7 @@ import Outputable ( interppSP, interpp'SP ) import Pretty import PprType ( GenClass, GenType, GenTyVar ) import Type ( mkTyVarTy, splitSigmaTy, mkForAllTys, mkFunTys, - getTyVar_maybe, tyVarsOfTypes, eqSimpleTheta ) + getTyVar, getTyVar_maybe, tyVarsOfTypes, eqSimpleTheta ) import TyVar ( GenTyVar, TyVar(..), tyVarKind, minusTyVarSet, emptyTyVarSet, elementOfTyVarSet, unionTyVarSets, tyVarSetToList ) import Usage ( UVar(..) ) @@ -378,24 +378,39 @@ checkSigTyVars :: [TcTyVar s] -- The original signature type variables -> TcM s () checkSigTyVars sig_tyvars sig_tau - = tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars -> - checkSigTyVarsGivenGlobals env_tyvars sig_tyvars sig_tau + = checkSigTyVarsGivenGlobals emptyTyVarSet sig_tyvars sig_tau checkSigTyVarsGivenGlobals - :: TcTyVarSet s -- Consider these fully-zonked tyvars as global + :: TcTyVarSet s -- Consider these tyvars as global in addition to envt ones -> [TcTyVar s] -- The original signature type variables -> TcType s -- signature type (for err msg) -> TcM s () -checkSigTyVarsGivenGlobals globals sig_tyvars sig_tau - = -- Check point (c) +checkSigTyVarsGivenGlobals extra_globals sig_tyvars sig_tau + = zonkTcTyVars extra_globals `thenNF_Tc` \ extra_tyvars' -> + tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars -> + let + globals = env_tyvars `unionTyVarSets` extra_tyvars' + mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars + in + -- TEMPORARY FIX + -- Until the final Bind-handling stuff is in, several type signatures in the same + -- bindings group can cause the signature type variable from the different + -- signatures to be unified. So we still need to zonk and check point (b). + -- Remove when activating the new binding code + mapNF_Tc zonkTcTyVar sig_tyvars `thenNF_Tc` \ sig_tys -> + checkTcM (hasNoDups (map (getTyVar "checkSigTyVars") sig_tys)) + (zonkTcType sig_tau `thenNF_Tc` \ sig_tau' -> + failTc (badMatchErr sig_tau sig_tau') + ) `thenTc_` + + + -- Check point (c) -- We want to report errors in terms of the original signature tyvars, -- ie sig_tyvars, NOT sig_tyvars'. sig_tys and sig_tyvars' correspond -- 1-1 with sig_tyvars, so we can just map back. checkTc (null mono_tyvars) (notAsPolyAsSigErr sig_tau mono_tyvars) - where - mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars \end{code} @@ -406,9 +421,8 @@ Contexts and errors \begin{code} notAsPolyAsSigErr sig_tau mono_tyvars sty = ppHang (ppStr "A type signature is more polymorphic than the inferred type") - 4 (ppAboves [ppStr "(That is, one or more type variables in the inferred type can't be forall'd.)", - ppHang (ppStr "Monomorphic type variable(s):") - 4 (interpp'SP sty mono_tyvars), + 4 (ppAboves [ppStr "Some type variables in the inferred type can't be forall'd, namely:", + interpp'SP sty mono_tyvars, ppStr "Possible cause: the RHS mentions something subject to the monomorphism restriction" ]) \end{code} diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 052d796319..2aacbfe3a0 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -23,26 +23,30 @@ module Inst ( zonkInst, instToId, matchesInst, - instBindingRequired, instCanBeGeneralised - + instBindingRequired, instCanBeGeneralised, + + pprInst ) where -import Ubiq +IMP_Ubiq() import HsSyn ( HsLit(..), HsExpr(..), HsBinds, InPat, OutPat, Stmt, Qual, Match, ArithSeqInfo, PolyType, Fake ) import RnHsSyn ( RenamedArithSeqInfo(..), RenamedHsExpr(..) ) import TcHsSyn ( TcIdOcc(..), TcExpr(..), TcIdBndr(..), - mkHsTyApp, mkHsDictApp ) + mkHsTyApp, mkHsDictApp, tcIdTyVars ) import TcMonad hiding ( rnMtoTcM ) -import TcEnv ( tcLookupGlobalValueByKey ) +import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey ) import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..), tcInstType, zonkTcType ) import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag ) -import Class ( Class(..), GenClass, ClassInstEnv(..), classInstEnv ) +import Class ( isCcallishClass, isNoDictClass, classInstEnv, + Class(..), GenClass, ClassInstEnv(..) + ) +import ErrUtils ( addErrLoc, Error(..) ) import Id ( GenId, idType, mkInstId ) import MatchEnv ( lookupMEnv, insertMEnv ) import Name ( mkLocalName, getLocalName, Name ) @@ -55,13 +59,16 @@ import SpecEnv ( SpecEnv(..) ) import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) import Type ( GenType, eqSimpleTy, instantiateTy, isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy, - splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes ) -import TyVar ( GenTyVar ) + splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes, + mkSynTy + ) +import TyVar ( unionTyVarSets, GenTyVar ) import TysPrim ( intPrimTy ) -import TysWiredIn ( intDataCon ) -import Unique ( Unique, showUnique, - fromRationalClassOpKey, fromIntClassOpKey, fromIntegerClassOpKey ) -import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic ) +import TysWiredIn ( intDataCon, integerTy ) +import Unique ( showUnique, fromRationalClassOpKey, rationalTyConKey, + fromIntClassOpKey, fromIntegerClassOpKey, Unique + ) +import Util ( panic, zipEqual, zipWithEqual, assoc, assertPanic, pprTrace{-ToDo:rm-} ) \end{code} %************************************************************************ @@ -178,7 +185,9 @@ newMethod orig id tys = -- Get the Id type and instantiate it at the specified types (case id of RealId id -> let (tyvars, rho) = splitForAllTy (idType id) - in tcInstType (zipEqual "newMethod" tyvars tys) rho + in + (if length tyvars /= length tys then pprTrace "newMethod" (ppr PprDebug (idType id)) else \x->x) $ + tcInstType (zip{-Equal "newMethod"-} tyvars tys) rho TcId id -> let (tyvars, rho) = splitForAllTy (idType id) in returnNF_Tc (instantiateTy (zipEqual "newMethod(2)" tyvars tys) rho) ) `thenNF_Tc` \ rho_ty -> @@ -272,7 +281,9 @@ zonkInst (LitInst u lit ty orig loc) \begin{code} tyVarsOfInst :: Inst s -> TcTyVarSet s tyVarsOfInst (Dict _ _ ty _ _) = tyVarsOfType ty -tyVarsOfInst (Method _ _ tys rho _ _) = tyVarsOfTypes tys +tyVarsOfInst (Method _ id tys rho _ _) = tyVarsOfTypes tys `unionTyVarSets` tcIdTyVars id + -- The id might not be a RealId; in the case of + -- locally-overloaded class methods, for example tyVarsOfInst (LitInst _ _ ty _ _) = tyVarsOfType ty \end{code} @@ -320,19 +331,12 @@ must be witnessed by an actual binding; the second tells whether an \begin{code} instBindingRequired :: Inst s -> Bool -instBindingRequired inst - = case getInstOrigin inst of - CCallOrigin _ _ -> False -- No binding required - LitLitOrigin _ -> False - OccurrenceOfCon _ -> False - other -> True +instBindingRequired (Dict _ clas _ _ _) = not (isNoDictClass clas) +instBindingRequired other = True instCanBeGeneralised :: Inst s -> Bool -instCanBeGeneralised inst - = case getInstOrigin inst of - CCallOrigin _ _ -> False -- Can't be generalised - LitLitOrigin _ -> False -- Can't be generalised - other -> True +instCanBeGeneralised (Dict _ clas _ _ _) = not (isCcallishClass clas) +instCanBeGeneralised other = True \end{code} @@ -343,32 +347,29 @@ relevant in error messages. \begin{code} instance Outputable (Inst s) where - ppr sty (LitInst uniq lit ty orig loc) - = ppSep [case lit of - OverloadedIntegral i -> ppInteger i - OverloadedFractional f -> ppRational f, - ppStr "at", - ppr sty ty, - show_uniq sty uniq - ] - - ppr sty (Dict uniq clas ty orig loc) - = ppSep [ppr sty clas, - ppStr "at", - ppr sty ty, - show_uniq sty uniq - ] - - ppr sty (Method uniq id tys rho orig loc) - = ppSep [ppr sty id, - ppStr "at", - ppr sty tys, - show_uniq sty uniq - ] - -show_uniq PprDebug uniq = ppr PprDebug uniq -show_uniq sty uniq = ppNil + ppr sty inst = ppr_inst sty ppNil (\ o l -> ppNil) inst + +pprInst sty hdr inst = ppr_inst sty hdr (\ o l -> pprOrigin hdr o l sty) inst + +ppr_inst sty hdr ppr_orig (LitInst u lit ty orig loc) + = ppHang (ppr_orig orig loc) + 4 (ppCat [case lit of + OverloadedIntegral i -> ppInteger i + OverloadedFractional f -> ppRational f, + ppStr "at", + ppr sty ty, + show_uniq sty u]) +ppr_inst sty hdr ppr_orig (Dict u clas ty orig loc) + = ppHang (ppr_orig orig loc) + 4 (ppCat [ppr sty clas, ppr sty ty, show_uniq sty u]) + +ppr_inst sty hdr ppr_orig (Method u id tys rho orig loc) + = ppHang (ppr_orig orig loc) + 4 (ppCat [ppr sty id, ppStr "at", interppSP sty tys, show_uniq sty u]) + +show_uniq PprDebug u = ppr PprDebug u +show_uniq sty u = ppNil \end{code} Printing in error messages @@ -412,7 +413,7 @@ lookupInst :: Inst s lookupInst dict@(Dict _ clas ty orig loc) = case lookupMEnv matchTy (get_inst_env clas orig) ty of Nothing -> tcAddSrcLoc loc $ - tcAddErrCtxt (pprOrigin orig) $ + tcAddErrCtxt (pprOrigin ""{-hdr-} orig loc) $ failTc (noInstanceErr dict) Just (dfun_id, tenv) @@ -453,15 +454,22 @@ lookupInst inst@(LitInst u (OverloadedIntegral i) ty orig loc) = -- Alas, it is overloaded and a big literal! tcLookupGlobalValueByKey fromIntegerClassOpKey `thenNF_Tc` \ from_integer -> newMethodAtLoc orig loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) -> - returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsInt i) ty))) + returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsInt i) integerTy))) where intprim_lit = HsLitOut (HsIntPrim i) intPrimTy int_lit = HsApp (HsVar (RealId intDataCon)) intprim_lit lookupInst inst@(LitInst u (OverloadedFractional f) ty orig loc) = tcLookupGlobalValueByKey fromRationalClassOpKey `thenNF_Tc` \ from_rational -> + + -- The type Rational isn't wired in so we have to conjure it up + tcLookupTyConByKey rationalTyConKey `thenNF_Tc` \ rational_tycon -> + let + rational_ty = mkSynTy rational_tycon [] + rational_lit = HsLitOut (HsFrac f) rational_ty + in newMethodAtLoc orig loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) -> - returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) (HsLitOut (HsFrac f) ty))) + returnTc ([method_inst], (instToId inst, HsApp (HsVar method_id) rational_lit)) \end{code} There is a second, simpler interface, when you want an instance of a @@ -611,51 +619,43 @@ get_inst_env clas (InstanceSpecOrigin inst_mapper _ _) get_inst_env clas other_orig = classInstEnv clas -pprOrigin :: InstOrigin s -> PprStyle -> Pretty +pprOrigin :: String -> InstOrigin s -> SrcLoc -> Error -pprOrigin (OccurrenceOf id) sty - = ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"), +pprOrigin hdr orig locn + = addErrLoc locn hdr $ \ sty -> + case orig of + OccurrenceOf id -> + ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"), ppr sty id, ppChar '\''] -pprOrigin (OccurrenceOfCon id) sty - = ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"), + OccurrenceOfCon id -> + ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"), ppr sty id, ppChar '\''] -pprOrigin (InstanceDeclOrigin) sty - = ppStr "in an instance declaration" -pprOrigin (LiteralOrigin lit) sty - = ppCat [ppStr "at an overloaded literal:", ppr sty lit] -pprOrigin (ArithSeqOrigin seq) sty - = ppCat [ppStr "at an arithmetic sequence:", ppr sty seq] -pprOrigin (SignatureOrigin) sty - = ppStr "in a type signature" -pprOrigin (DoOrigin) sty - = ppStr "in a do statement" -pprOrigin (ClassDeclOrigin) sty - = ppStr "in a class declaration" --- pprOrigin (DerivingOrigin _ clas tycon) sty --- = ppBesides [ppStr "in a `deriving' clause; class `", --- ppr sty clas, --- ppStr "'; offending type `", --- ppr sty tycon, --- ppStr "'"] -pprOrigin (InstanceSpecOrigin _ clas ty) sty - = ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"", + InstanceDeclOrigin -> + ppStr "in an instance declaration" + LiteralOrigin lit -> + ppCat [ppStr "at an overloaded literal:", ppr sty lit] + ArithSeqOrigin seq -> + ppCat [ppStr "at an arithmetic sequence:", ppr sty seq] + SignatureOrigin -> + ppStr "in a type signature" + DoOrigin -> + ppStr "in a do statement" + ClassDeclOrigin -> + ppStr "in a class declaration" + InstanceSpecOrigin _ clas ty -> + ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"", ppr sty clas, ppStr "\" type: ", ppr sty ty] --- pprOrigin (DefaultDeclOrigin) sty --- = ppStr "in a `default' declaration" -pprOrigin (ValSpecOrigin name) sty - = ppBesides [ppStr "in a SPECIALIZE user-pragma for `", + ValSpecOrigin name -> + ppBesides [ppStr "in a SPECIALIZE user-pragma for `", ppr sty name, ppStr "'"] -pprOrigin (CCallOrigin clabel Nothing{-ccall result-}) sty - = ppBesides [ppStr "in the result of the _ccall_ to `", + CCallOrigin clabel Nothing{-ccall result-} -> + ppBesides [ppStr "in the result of the _ccall_ to `", ppStr clabel, ppStr "'"] -pprOrigin (CCallOrigin clabel (Just arg_expr)) sty - = ppBesides [ppStr "in an argument in the _ccall_ to `", + CCallOrigin clabel (Just arg_expr) -> + ppBesides [ppStr "in an argument in the _ccall_ to `", ppStr clabel, ppStr "', namely: ", ppr sty arg_expr] -pprOrigin (LitLitOrigin s) sty - = ppBesides [ppStr "in this ``literal-literal'': ", ppStr s] -pprOrigin UnknownOrigin sty - = ppStr "in... oops -- I don't know where the overloading came from!" + LitLitOrigin s -> + ppBesides [ppStr "in this ``literal-literal'': ", ppStr s] + UnknownOrigin -> + ppStr "in... oops -- I don't know where the overloading came from!" \end{code} - - - diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index b4d87a7b90..e6f78b3eed 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -8,7 +8,7 @@ module TcBinds ( tcBindsAndThen, tcPragmaSigs ) where -import Ubiq +IMP_Ubiq() import HsSyn ( HsBinds(..), Bind(..), Sig(..), MonoBinds(..), HsExpr, Match, PolyType, InPat, OutPat(..), @@ -24,12 +24,12 @@ import TcMonad hiding ( rnMtoTcM ) import GenSpecEtc ( checkSigTyVars, genBinds, TcSigInfo(..) ) import Inst ( Inst, LIE(..), emptyLIE, plusLIE, InstOrigin(..) ) import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds ) -import TcLoop ( tcGRHSsAndBinds ) +IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds ) import TcMatches ( tcMatchesFun ) import TcMonoType ( tcPolyType ) import TcPat ( tcPat ) import TcSimplify ( bindInstsOfLocalFuns ) -import TcType ( newTcTyVar, tcInstType ) +import TcType ( newTcTyVar, tcInstSigType ) import Unify ( unifyTauTy ) import Kind ( mkBoxedTypeKind, mkTypeKind ) @@ -209,8 +209,8 @@ tcBindAndSigs binder_rn_names bind sigs prag_info_fn genBinds binder_names mono_ids bind' lie sig_info prag_info_fn where kind = case bind of - NonRecBind _ -> mkBoxedTypeKind -- Recursive, so no unboxed types - RecBind _ -> mkTypeKind -- Non-recursive, so we permit unboxed types + NonRecBind _ -> mkTypeKind -- Recursive, so no unboxed types + RecBind _ -> mkBoxedTypeKind -- Non-recursive, so we permit unboxed types \end{code} @@ -451,7 +451,7 @@ tcTySigs :: [RenamedSig] -> TcM s [TcSigInfo s] tcTySigs (Sig v ty _ src_loc : other_sigs) = tcAddSrcLoc src_loc ( tcPolyType ty `thenTc` \ sigma_ty -> - tcInstType [] sigma_ty `thenNF_Tc` \ sigma_ty' -> + tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' -> let (tyvars', theta', tau') = splitSigmaTy sigma_ty' in @@ -568,7 +568,7 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) -- Get and instantiate its alleged specialised type tcPolyType poly_ty `thenTc` \ sig_sigma -> - tcInstType [] sig_sigma `thenNF_Tc` \ sig_ty -> + tcInstSigType sig_sigma `thenNF_Tc` \ sig_ty -> let (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty origin = ValSpecOrigin name @@ -580,7 +580,7 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) -- Get and instantiate the type of the id mentioned tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id -> - tcInstType [] (idType main_id) `thenNF_Tc` \ main_ty -> + tcInstSigType [] (idType main_id) `thenNF_Tc` \ main_ty -> let (main_tyvars, main_rho) = splitForAllTy main_ty (main_theta,main_tau) = splitRhoTy main_rho diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index d2a63baf2f..039361851b 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -10,7 +10,7 @@ module TcClassDcl ( tcClassDecl1, tcClassDecls2 ) where -import Ubiq +IMP_Ubiq() import HsSyn ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), @@ -23,18 +23,19 @@ import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..), RnName{-instance Uniquable-} ) import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..), - mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam ) + mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType ) -import TcMonad hiding ( rnMtoTcM ) import Inst ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts ) import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds) -import TcInstDcls ( processInstBinds ) -import TcKind ( unifyKind ) -import TcMonoType ( tcMonoType, tcContext ) -import TcType ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars ) +import TcInstDcls ( processInstBinds, newMethodId ) import TcKind ( TcKind ) +import TcKind ( unifyKind ) +import TcMonad hiding ( rnMtoTcM ) +import TcMonoType ( tcPolyType, tcMonoType, tcContext ) +import TcSimplify ( tcSimplifyAndCheck ) +import TcType ( TcType(..), TcTyVar(..), tcInstType, tcInstSigTyVars, tcInstSigType ) -import Bag ( foldBag ) +import Bag ( foldBag, unionManyBags ) import Class ( GenClass, mkClass, mkClassOp, classBigSig, classOps, classOpString, classOpLocalType, classOpTagByString @@ -52,16 +53,51 @@ import SrcLoc ( mkGeneratedSrcLoc ) import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, mkForAllTy, mkSigmaTy, splitSigmaTy) import TysWiredIn ( stringTy ) -import TyVar ( GenTyVar ) +import TyVar ( mkTyVarSet, GenTyVar ) import Unique ( Unique ) import Util + -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas ) tcGenPragmas ty id ps = returnNF_Tc noIdInfo tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo, noIdInfo) - \end{code} + + +Dictionary handling +~~~~~~~~~~~~~~~~~~~ +Every class implicitly declares a new data type, corresponding to dictionaries +of that class. So, for example: + + class (D a) => C a where + op1 :: a -> a + op2 :: forall b. Ord b => a -> b -> b + +would implicitly declare + + data CDict a = CDict (D a) + (a -> a) + (forall b. Ord b => a -> b -> b) + +(We could use a record decl, but that means changing more of the existing apparatus. +One step at at time!) + +For classes with just one superclass+method, we use a newtype decl instead: + + class C a where + op :: forallb. a -> b -> b + +generates + + newtype CDict a = CDict (forall b. a -> b -> b) + +Now DictTy in Type is just a form of type synomym: + DictTy c t = TyConTy CDict `AppTy` t + +Death to "ExpandingDicts". + + \begin{code} tcClassDecl1 rec_inst_mapper (ClassDecl context class_name @@ -88,8 +124,6 @@ tcClassDecl1 rec_inst_mapper `thenTc` \ sig_stuff -> -- MAKE THE CLASS OBJECT ITSELF --- BOGUS: --- tcGetUnique `thenNF_Tc` \ uniq -> let (ops, op_sel_ids, defm_ids) = unzip3 sig_stuff clas = mkClass (uniqueOf class_name) (getName class_name) rec_tyvar @@ -100,6 +134,32 @@ tcClassDecl1 rec_inst_mapper \end{code} + let + clas_ty = mkTyVarTy clas_tyvar + dict_component_tys = [mkDictTy sc clas_ty | sc <- scs] ++ + [classOpLocalType op | op <- ops]) + new_or_data = case dict_component_tys of + [_] -> NewType + other -> DataType + + dict_con_id = mkDataCon class_name + [NotMarkedStrict] + [{- No labelled fields -}] + [clas_tyvar] + [{-No context-}] + dict_component_tys + tycon + + tycon = mkDataTyCon class_name + (tyVarKind rec_tyvar `mkArrowKind` mkBoxedTypeKind) + [rec_tyvar] + [{- Empty context -}] + [dict_con_id] + [{- No derived classes -}] + new_or_data + in + + \begin{code} tcClassContext :: Class -> TyVar -> RenamedContext -- class context @@ -135,10 +195,10 @@ tcClassContext rec_class rec_tyvar context pragmas Just prag -> tcGenPragmas Nothing{-ty unknown-} rec_super_id prag ) `thenNF_Tc` \ id_info -> let - ty = mkForAllTy rec_tyvar ( - mkFunTy (mkDictTy rec_class (mkTyVarTy rec_tyvar)) - (mkDictTy super_class (mkTyVarTy rec_tyvar)) - ) + rec_tyvar_ty = mkTyVarTy rec_tyvar + ty = mkForAllTy rec_tyvar $ + mkFunTy (mkDictTy rec_class rec_tyvar_ty) + (mkDictTy super_class rec_tyvar_ty) in -- BUILD THE SUPERCLASS ID returnTc (mkSuperDictSelId uniq rec_class super_class ty id_info) @@ -164,21 +224,21 @@ tcClassSig :: Class -- Knot tying only! tcClassSig rec_clas rec_clas_tyvar rec_classop_spec_fn (ClassOpSig op_name - (HsForAllTy tyvar_names context monotype) + op_ty pragmas src_loc) = tcAddSrcLoc src_loc $ fixTc ( \ ~(_, rec_sel_id, rec_defm_id) -> -- Knot for pragmas -- Check the type signature. NB that the envt *already has* -- bindings for the type variables; see comments in TcTyAndClassDcls. - tcContext context `thenTc` \ theta -> - tcMonoType monotype `thenTc` \ tau -> - mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (_,tyvars) -> + + -- NB: Renamer checks that the class type variable is mentioned in local_ty, + -- and that it is not constrained by theta + tcPolyType op_ty `thenTc` \ local_ty -> let - full_tyvars = rec_clas_tyvar : tyvars - full_theta = (rec_clas, mkTyVarTy rec_clas_tyvar) : theta - global_ty = mkSigmaTy full_tyvars full_theta tau - local_ty = mkSigmaTy tyvars theta tau + global_ty = mkSigmaTy [rec_clas_tyvar] + [(rec_clas, mkTyVarTy rec_clas_tyvar)] + local_ty class_op_nm = getLocalName op_name class_op = mkClassOp class_op_nm (classOpTagByString rec_clas{-yeeps!-} class_op_nm) @@ -333,6 +393,7 @@ buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids Make a selector expression for @sel_id@ from a dictionary @clas_dict@ consisting of @dicts@ and @methods@. +====================== OLD ============================ We have to do a bit of jiggery pokery to get the type variables right. Suppose we have the class decl: \begin{verbatim} @@ -360,6 +421,12 @@ whereas \tr{op1_sel} (the one we use) has the decent type \begin{verbatim} op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a \end{verbatim} +========================= END OF OLD =========================== + +NEW COMMENT: instead we now go for op1_sel' above. Seems tidier and +the rest of the compiler darn well ought to cope. + + NOTE that we return a TcMonoBinds (which is later zonked) even though there's no real back-substitution to do. It's just simpler this way! @@ -376,28 +443,23 @@ mkSelBind :: Id -- the selector id -> NF_TcM s (TcMonoBinds s) mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op) - = let - (op_tyvars,op_theta,op_tau) = splitSigmaTy (idType op) - op_tys = mkTyVarTys op_tyvars - in - newDicts ClassDeclOrigin op_theta `thenNF_Tc` \ (_, op_dicts) -> - - -- sel_id = /\ clas_tyvar op_tyvars -> \ clas_dict op_dicts -> + = + -- sel_id = /\ clas_tyvar -> \ clas_dict -> -- case clas_dict of - -- <dicts..methods> -> method_or_dict op_tyvars op_dicts + -- <dicts..methods> -> method_or_dict returnNF_Tc (VarMonoBind (RealId sel_id) ( - TyLam (clas_tyvar:op_tyvars) ( - DictLam (clas_dict:op_dicts) ( + TyLam [clas_tyvar] ( + DictLam [clas_dict] ( HsCase (HsVar clas_dict) ([PatMatch (DictPat dicts methods) ( GRHSMatch (GRHSsAndBindsOut [OtherwiseGRHS - (mkHsDictApp (mkHsTyApp (HsVar method_or_dict) op_tys) op_dicts) + (HsVar method_or_dict) mkGeneratedSrcLoc] EmptyBinds - op_tau))]) + (idType op)))]) mkGeneratedSrcLoc )))) \end{code} @@ -425,11 +487,22 @@ we get the default methods: defm.Foo.op1 :: forall a. Foo a => a -> Bool defm.Foo.op1 = /\a -> \dfoo -> \x -> True +====================== OLD ================== +\begin{verbatim} defm.Foo.op2 :: forall a, b. (Foo a, Ord b) => a -> b -> b -> b defm.Foo.op2 = /\ a b -> \ dfoo dord -> \x y z -> if (op1 a dfoo x) && (< b dord y z) then y else z \end{verbatim} Notice that, like all ids, the foralls of defm.Foo.op2 are at the top. +====================== END OF OLD =================== + +NEW: +\begin{verbatim} +defm.Foo.op2 :: forall a. Foo a => forall b. Ord b => a -> b -> b -> b +defm.Foo.op2 = /\ a -> \ dfoo -> /\ b -> \ dord -> \x y z -> + if (op1 a dfoo x) && (< b dord y z) then y else z +\end{verbatim} + When we come across an instance decl, we may need to use the default methods: @@ -442,14 +515,15 @@ const.Foo.Int.op1 :: Int -> Bool const.Foo.Int.op1 = defm.Foo.op1 Int dfun.Foo.Int const.Foo.Int.op2 :: forall b. Ord b => Int -> b -> b -> b -const.Foo.Int.op2 = /\b -> defm.Foo.op2 Int b dfun.Foo.Int +const.Foo.Int.op2 = defm.Foo.op2 Int dfun.Foo.Int dfun.Foo.Int :: Foo Int dfun.Foo.Int = (const.Foo.Int.op1, const.Foo.Int.op2) \end{verbatim} Notice that, as with method selectors above, we assume that dictionary application is curried, so there's no need to mention the Ord dictionary -in const.Foo.Int.op2 +in const.Foo.Int.op2 (or the type variable). + \begin{verbatim} instance Foo a => Foo [a] where {} @@ -458,7 +532,7 @@ dfun.Foo.List = /\ a -> \ dfoo_a -> let rec op1 = defm.Foo.op1 [a] dfoo_list - op2 = /\b -> \dord -> defm.Foo.op2 [a] b dfoo_list dord + op2 = defm.Foo.op2 [a] dfoo_list dfoo_list = (op1, op2) in dfoo_list @@ -474,16 +548,38 @@ buildDefaultMethodBinds buildDefaultMethodBinds clas clas_tyvar default_method_ids default_binds - = -- Deal with the method declarations themselves + = newDicts origin [(clas,inst_ty)] `thenNF_Tc` \ (this_dict, [this_dict_id]) -> + mapAndUnzipNF_Tc mk_method default_method_ids `thenNF_Tc` \ (insts_s, local_defm_ids) -> + let + avail_insts = this_dict `plusLIE` unionManyBags insts_s -- Insts available + in processInstBinds clas - (makeClassDeclDefaultMethodRhs clas default_method_ids) - [] -- No tyvars in scope for "this inst decl" - emptyLIE -- No insts available - (map RealId default_method_ids) - default_binds `thenTc` \ (dicts_needed, default_binds') -> + (makeClassDeclDefaultMethodRhs clas local_defm_ids) + [clas_tyvar] -- Tyvars in scope + avail_insts + local_defm_ids + default_binds `thenTc` \ (insts_needed, default_binds') -> + + tcSimplifyAndCheck + (mkTyVarSet [clas_tyvar]) + avail_insts + insts_needed `thenTc` \ (const_lie, dict_binds) -> + - returnTc (dicts_needed, SingleBind (NonRecBind default_binds')) + let + defm_binds = AbsBinds + [clas_tyvar] + [this_dict_id] + (local_defm_ids `zip` map RealId default_method_ids) + dict_binds + (RecBind default_binds') + in + returnTc (const_lie, defm_binds) + where + inst_ty = mkTyVarTy clas_tyvar + mk_method defm_id = newMethodId defm_id inst_ty origin + origin = ClassDeclOrigin \end{code} @makeClassDeclDefaultMethodRhs@ builds the default method for a @@ -492,12 +588,21 @@ class declaration when no explicit default method is given. \begin{code} makeClassDeclDefaultMethodRhs :: Class - -> [Id] + -> [TcIdOcc s] -> Int -> NF_TcM s (TcExpr s) makeClassDeclDefaultMethodRhs clas method_ids tag - = tcInstType [] (idType method_id) `thenNF_Tc` \ method_ty -> + = -- Return the expression + -- error ty "No default method for ..." + -- The interesting thing is that method_ty is a for-all type; + -- this is fun, although unusual in a type application! + + returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tcIdType method_id]) + (HsLitOut (HsString (_PK_ error_msg)) stringTy)) + +{- OLD AND COMPLICATED + tcInstSigType () `thenNF_Tc` \ method_ty -> let (tyvars, theta, tau) = splitSigmaTy method_ty in @@ -507,11 +612,13 @@ makeClassDeclDefaultMethodRhs clas method_ids tag mkHsDictLam dict_ids ( HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tau]) (HsLitOut (HsString (_PK_ error_msg)) stringTy)))) +-} + where (clas_mod, clas_name) = moduleNamePair clas method_id = method_ids !! (tag-1) - class_op = (classOps clas) !! (tag-1) + class_op = (classOps clas) !! (tag-1) error_msg = _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "." ++ (ppShow 80 (ppr PprForUser class_op)) diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index 964847d8d8..3d40162240 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -8,7 +8,7 @@ module TcDefaults ( tcDefaults ) where -import Ubiq +IMP_Ubiq() import HsSyn ( DefaultDecl(..), MonoType, HsExpr, HsLit, ArithSeqInfo, Fake, InPat) diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 5e7d91e4ca..7304d60fd2 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[TcDeriv]{Deriving} @@ -10,49 +10,59 @@ Handles @deriving@ clauses on @data@ declarations. module TcDeriv ( tcDeriving ) where -import Ubiq +IMP_Ubiq() import HsSyn ( FixityDecl, Sig, HsBinds(..), Bind(..), MonoBinds(..), GRHSsAndBinds, Match, HsExpr, HsLit, InPat, ArithSeqInfo, Fake, MonoType ) import HsPragmas ( InstancePragmas(..) ) -import RnHsSyn ( RenamedHsBinds(..), RenamedFixityDecl(..) ) +import RnHsSyn ( mkRnName, RnName(..), RenamedHsBinds(..), RenamedFixityDecl(..) ) import TcHsSyn ( TcIdOcc ) -import TcMonad hiding ( rnMtoTcM ) -import Inst ( InstOrigin(..), InstanceMapper(..) ) -import TcEnv ( getEnv_TyCons ) +import TcMonad +import Inst ( InstanceMapper(..) ) +import TcEnv ( getEnv_TyCons, tcLookupClassByKey ) import TcKind ( TcKind ) ---import TcGenDeriv -- Deriv stuff +import TcGenDeriv -- Deriv stuff import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs ) import TcSimplify ( tcSimplifyThetas ) import RnMonad -import RnUtils ( RnEnv(..) ) +import RnUtils ( RnEnv(..), extendGlobalRnEnv ) import RnBinds ( rnMethodBinds, rnTopBinds ) import Bag ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag ) -import Class ( GenClass, classKey ) +import Class ( classKey, needsDataDeclCtxtClassKeys, GenClass ) import CmdLineOpts ( opt_CompilingPrelude ) import ErrUtils ( pprBagOfErrors, addErrLoc, Error(..) ) -import Id ( dataConSig, dataConArity ) -import Maybes ( assocMaybe, maybeToBool, Maybe(..) ) -import Outputable +import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId ) +import Maybes ( maybeToBool, Maybe(..) ) +import Name ( moduleNamePair, isLocallyDefined, getSrcLoc, + mkTopLevName, origName, mkImplicitName, ExportFlag(..), + RdrName{-instance Outputable-}, Name{--O only-} + ) +import Outputable ( Outputable(..){-instances e.g., (,)-} ) import PprType ( GenType, GenTyVar, GenClass, TyCon ) -import PprStyle -import Pretty -import SrcLoc ( mkGeneratedSrcLoc, mkUnknownSrcLoc, SrcLoc ) +import PprStyle ( PprStyle(..) ) +import Pretty ( ppAbove, ppAboves, ppCat, ppBesides, ppStr, ppHang, Pretty(..) ) +import Pretty--ToDo:rm +import FiniteMap--ToDo:rm +import SrcLoc ( mkGeneratedSrcLoc, SrcLoc ) import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, - maybeTyConSingleCon, isEnumerationTyCon, TyCon ) + tyConTheta, maybeTyConSingleCon, + isEnumerationTyCon, isDataTyCon, TyCon + ) import Type ( GenType(..), TauType(..), mkTyVarTys, applyTyCon, mkSigmaTy, mkDictTy, isPrimType, instantiateTy, - getAppTyCon, getAppDataTyCon + getAppDataTyCon, getAppTyCon ) +import TysWiredIn ( voidTy ) import TyVar ( GenTyVar ) import UniqFM ( emptyUFM ) import Unique -- Keys stuff -import Util ( zipWithEqual, zipEqual, sortLt, removeDups, - thenCmp, cmpList, panic, pprPanic, pprPanic# +import Util ( zipWithEqual, zipEqual, sortLt, removeDups, assoc, + thenCmp, cmpList, panic, pprPanic, pprPanic#, + assertPanic, pprTrace{-ToDo:rm-} ) \end{code} @@ -69,6 +79,10 @@ Consider | C3 (T a a) deriving (Eq) +[NOTE: See end of these comments for what to do with + data (C a, D b) => T a b = ... +] + We want to come up with an instance declaration of the form instance (Ping a, Pong b, ...) => Eq (T a b) where @@ -147,6 +161,31 @@ type DerivRhs = [(Class, TauType)] -- Same as a ThetaType! type DerivSoln = DerivRhs \end{code} + +A note about contexts on data decls +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + + data (RealFloat a) => Complex a = !a :+ !a deriving( Read ) + +We will need an instance decl like: + + instance (Read a, RealFloat a) => Read (Complex a) where + ... + +The RealFloat in the context is because the read method for Complex is bound +to construct a Complex, and doing that requires that the argument type is +in RealFloat. + +But this ain't true for Show, Eq, Ord, etc, since they don't construct +a Complex; they only take them apart. + +Our approach: identify the offending classes, and add the data type +context to the instance decl. The "offending classes" are + + Read, Enum? + + %************************************************************************ %* * \subsection[TcDeriv-driver]{Top-level function for \tr{derivings}} @@ -164,10 +203,6 @@ tcDeriving :: Module -- name of module under scrutiny -- for debugging via -ddump-derivings. tcDeriving modname rn_env inst_decl_infos_in fixities - = returnTc (trace "tcDeriving:ToDo" (emptyBag, EmptyBinds, \ x -> ppNil)) -{- LATER: - -tcDeriving modname rn_env inst_decl_infos_in fixities = -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". makeDerivEqns `thenTc` \ eqns -> @@ -184,37 +219,22 @@ tcDeriving modname rn_env inst_decl_infos_in fixities -- "con2tag" and/or "tag2con" functions. We do these -- separately. - gen_taggery_Names eqns `thenTc` \ nm_alist_etc -> - let - nm_alist = [ (pn, n) | (pn,n,_,_) <- nm_alist_etc ] - - -- We have the renamer's final "name funs" in our hands - -- (they were passed in). So we can handle ProtoNames - -- that refer to anything "out there". But our generated - -- code may also mention "con2tag" (etc.). So we need - -- to augment to "name funs" to include those. - (rn_val_gnf, rn_tc_gnf) = renamer_name_funs - - deriv_val_gnf pname = case (assoc_maybe nm_alist pname) of - Just xx -> Just xx - Nothing -> rn_val_gnf pname - - deriver_name_funs = (deriv_val_gnf, rn_tc_gnf) - - assoc_maybe [] _ = Nothing - assoc_maybe ((k,v) : vs) key - = if k `eqProtoName` key then Just v else assoc_maybe vs key - in - gen_tag_n_con_binds deriver_rn_env nm_alist_etc `thenTc` \ extra_binds -> + gen_taggery_Names new_inst_infos `thenTc` \ nm_alist_etc -> + gen_tag_n_con_binds rn_env nm_alist_etc + `thenTc` \ (extra_binds, deriver_rn_env) -> mapTc (gen_inst_info maybe_mod fixities deriver_rn_env) new_inst_infos - `thenTc` \ really_new_inst_infos -> + `thenTc` \ really_new_inst_infos -> + let + ddump_deriv = ddump_deriving really_new_inst_infos extra_binds + in + --pprTrace "derived:\n" (ddump_deriv PprDebug) $ returnTc (listToBag really_new_inst_infos, extra_binds, - ddump_deriving really_new_inst_infos extra_binds) + ddump_deriv) where - maybe_mod = if opt_CompilingPrelude then Nothing else Just mod_name + maybe_mod = if opt_CompilingPrelude then Nothing else Just modname ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty) @@ -252,12 +272,14 @@ all those. makeDerivEqns :: TcM s [DerivEqn] makeDerivEqns - = tcGetEnv `thenNF_Tc` \ env -> + = tcGetEnv `thenNF_Tc` \ env -> + tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas -> let - tycons = getEnv_TyCons env - think_about_deriving = need_deriving tycons + tycons = filter isDataTyCon (getEnv_TyCons env) + -- ToDo: what about newtypes??? + think_about_deriving = need_deriving eval_clas tycons in - mapTc (chk_out think_about_deriving) think_about_deriving `thenTc_` + mapTc chk_out think_about_deriving `thenTc_` let (derive_these, _) = removeDups cmp_deriv think_about_deriving eqns = map mk_eqn derive_these @@ -265,34 +287,48 @@ makeDerivEqns returnTc eqns where ------------------------------------------------------------------ - need_deriving :: [TyCon] -> [(Class, TyCon)] - -- find the tycons that have `deriving' clauses + need_deriving :: Class -> [TyCon] -> [(Class, TyCon)] + -- find the tycons that have `deriving' clauses; + -- we handle the "every datatype in Eval" by + -- doing a dummy "deriving" for it. - need_deriving tycons_to_consider + need_deriving eval_clas tycons_to_consider = foldr ( \ tycon acc -> + let + acc_plus = if isLocallyDefined tycon + then (eval_clas, tycon) : acc + else acc + in case (tyConDerivings tycon) of - [] -> acc - cs -> [ (clas,tycon) | clas <- cs ] ++ acc + [] -> acc_plus + cs -> [ (clas,tycon) | clas <- cs ] ++ acc_plus ) [] tycons_to_consider ------------------------------------------------------------------ - chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM s () - chk_out whole_deriving_list this_one@(clas, tycon) + chk_out :: (Class, TyCon) -> TcM s () + chk_out this_one@(clas, tycon) = let clas_key = classKey clas - in + is_enumeration = isEnumerationTyCon tycon + is_single_con = maybeToBool (maybeTyConSingleCon tycon) + + chk_clas clas_uniq clas_str cond + = if (clas_uniq == clas_key) + then checkTc cond (derivingThingErr clas_str tycon) + else returnTc () + in -- Are things OK for deriving Enum (if appropriate)? - checkTc (clas_key == enumClassKey && not (isEnumerationTyCon tycon)) - (derivingEnumErr tycon) `thenTc_` + chk_clas enumClassKey "Enum" is_enumeration `thenTc_` + + -- Are things OK for deriving Bounded (if appropriate)? + chk_clas boundedClassKey "Bounded" + (is_enumeration || is_single_con) `thenTc_` -- Are things OK for deriving Ix (if appropriate)? - checkTc (clas_key == ixClassKey - && not (isEnumerationTyCon tycon - || maybeToBool (maybeTyConSingleCon tycon))) - (derivingIxErr tycon) + chk_clas ixClassKey "Ix.Ix" (is_enumeration || is_single_con) ------------------------------------------------------------------ cmp_deriv :: (Class, TyCon) -> (Class, TyCon) -> TAG_ @@ -305,22 +341,31 @@ makeDerivEqns -- to make the rest of the equation mk_eqn (clas, tycon) - = (clas, tycon, tyvars, constraints) + = (clas, tycon, tyvars, if_not_Eval constraints) where + clas_key = classKey clas tyvars = tyConTyVars tycon -- ToDo: Do we need new tyvars ??? tyvar_tys = mkTyVarTys tyvars data_cons = tyConDataCons tycon - constraints = concat (map mk_constraints data_cons) + + if_not_Eval cs = if clas_key == evalClassKey then [] else cs + + constraints = extra_constraints ++ concat (map mk_constraints data_cons) + + -- "extra_constraints": see notes above about contexts on data decls + extra_constraints + | offensive_class = tyConTheta tycon + | otherwise = [] + where + offensive_class = clas_key `elem` needsDataDeclCtxtClassKeys mk_constraints data_con - = [ (clas, instantiateTy inst_env arg_ty) - | arg_ty <- arg_tys, + = [ (clas, arg_ty) + | arg_ty <- instd_arg_tys, not (isPrimType arg_ty) -- No constraints for primitive types ] where - (con_tyvars, _, arg_tys, _) = dataConSig data_con - inst_env = zipEqual "mk_eqn" con_tyvars tyvar_tys - -- same number of tyvars in data constr and type constr! + instd_arg_tys = dataConArgTys data_con tyvar_tys \end{code} %************************************************************************ @@ -334,11 +379,11 @@ terms, which is the final correct RHS for the corresponding original equation. \begin{itemize} \item -Each (k,UniTyVarTemplate tv) in a solution constrains only a type +Each (k,TyVarTy tv) in a solution constrains only a type variable, tv. \item -The (k,UniTyVarTemplate tv) pairs in a solution are canonically +The (k,TyVarTy tv) pairs in a solution are canonically ordered by sorting on type varible, tv, (major key) and then class, k, (minor key) \end{itemize} @@ -370,24 +415,19 @@ solveDerivEqns inst_decl_infos_in orig_eqns add_solns inst_decl_infos_in orig_eqns current_solns `thenTc` \ (new_inst_infos, inst_mapper) -> - - -- Simplify each RHS, using a DerivingOrigin containing an - -- inst_mapper reflecting the previous solution let - mk_deriv_origin clas ty - = DerivingOrigin inst_mapper clas tycon - where - (tycon,_) = getAppTyCon ty + class_to_inst_env cls = fst (inst_mapper cls) in - listTc [ tcSimplifyThetas mk_deriv_origin rhs - | (_, _, _, rhs) <- orig_eqns - ] `thenTc` \ next_solns -> + -- Simplify each RHS + + listTc [ tcSimplifyThetas class_to_inst_env [{-Nothing "given"-}] deriv_rhs + | (_,_,_,deriv_rhs) <- orig_eqns ] `thenTc` \ next_solns -> -- Canonicalise the solutions, so they compare nicely let canonicalised_next_solns = [ sortLt lt_rhs next_soln | next_soln <- next_solns ] in - if current_solns `eq_solns` canonicalised_next_solns then + if (current_solns `eq_solns` canonicalised_next_solns) then returnTc new_inst_infos else iterateDeriv canonicalised_next_solns @@ -407,8 +447,7 @@ solveDerivEqns inst_decl_infos_in orig_eqns \end{code} \begin{code} -add_solns :: FAST_STRING - -> Bag InstInfo -- The global, non-derived ones +add_solns :: Bag InstInfo -- The global, non-derived ones -> [DerivEqn] -> [DerivSoln] -> TcM s ([InstInfo], -- The new, derived ones InstanceMapper) @@ -426,22 +465,34 @@ add_solns inst_infos_in eqns solns mk_deriv_inst_info (clas, tycon, tyvars, _) theta = InstInfo clas tyvars (applyTyCon tycon (mkTyVarTys tyvars)) theta - theta -- Blarg. This is the dfun_theta slot, - -- which is needed by buildInstanceEnv; - -- This works ok for solving the eqns, and - -- gen_eqns sets it to its final value - -- (incl super class dicts) before we - -- finally return it. -#ifdef DEBUG - (panic "add_soln:dfun_id") (panic "add_soln:const_meth_ids") - (panic "add_soln:binds") (panic "add_soln:from_here") - (panic "add_soln:modname") mkGeneratedSrcLoc - (panic "add_soln:upragmas") -#else - bottom bottom bottom bottom bottom mkGeneratedSrcLoc bottom + (my_panic "dfun_theta") + + dummy_dfun_id + + (my_panic "const_meth_ids") + (my_panic "binds") (my_panic "from_here") + (my_panic "modname") mkGeneratedSrcLoc + (my_panic "upragmas") where - bottom = panic "add_soln" -#endif + dummy_dfun_id + = mkDictFunId bottom bottom bottom dummy_dfun_ty + bottom bottom bottom bottom + where + bottom = panic "dummy_dfun_id" + + dummy_dfun_ty = mkSigmaTy tyvars theta voidTy + -- All we need from the dfun is its "theta" part, used during + -- equation simplification (tcSimplifyThetas). The final + -- dfun_id will have the superclass dictionaries as arguments too, + -- but that'll be added after the equations are solved. For now, + -- it's enough just to make a dummy dfun with the simple theta part. + -- + -- The part after the theta is dummied here as voidTy; actually it's + -- (C (T a b)), but it doesn't seem worth constructing it. + -- We can't leave it as a panic because to get the theta part we + -- have to run down the type! + + my_panic str = pprPanic ("add_soln:"++str) (ppCat [ppChar ':', ppr PprDebug clas, ppr PprDebug tycon]) \end{code} %************************************************************************ @@ -465,8 +516,7 @@ We want derived instances of @Eq@ and @Ord@ (both v common) to be ``you-couldn't-do-better-by-hand'' efficient. \item -Deriving @Text@---also pretty common, usually just for -@show@---should also be reasonable good code. +Deriving @Show@---also pretty common--- should also be reasonable good code. \item Deriving for the other classes isn't that common or that big a deal. @@ -476,13 +526,13 @@ PRAGMATICS: \begin{itemize} \item -Deriving @Ord@ is done mostly with our non-standard @tagCmp@ method. +Deriving @Ord@ is done mostly with the 1.3 @compare@ method. \item -Deriving @Eq@ also uses @tagCmp@, if we're deriving @Ord@, too. +Deriving @Eq@ also uses @compare@, if we're deriving @Ord@, too. \item -We {\em normally} generated code only for the non-defaulted methods; +We {\em normally} generate code only for the non-defaulted methods; there are some exceptions for @Eq@ and (especially) @Ord@... \item @@ -491,7 +541,6 @@ constructor's numeric (@Int#@) tag. These are generated by @gen_tag_n_con_binds@, and the heuristic for deciding if one of these is around is given by @hasCon2TagFun@. - The examples under the different sections below will make this clearer. @@ -500,11 +549,11 @@ Much less often (really just for deriving @Ix@), we use a @_tag2con_<tycon>@ function. See the examples. \item -We use Pass~4 of the renamer!!! Reason: we're supposed to be +We use the renamer!!! Reason: we're supposed to be producing @RenamedMonoBinds@ for the methods, but that means producing correctly-uniquified code on the fly. This is entirely possible (the @TcM@ monad has a @UniqueSupply@), but it is painful. -So, instead, we produce @ProtoNameMonoBinds@ then heave 'em through +So, instead, we produce @RdrNameMonoBinds@ then heave 'em through the renamer. What a great hack! \end{itemize} @@ -517,7 +566,7 @@ gen_inst_info :: Maybe Module -- Module name; Nothing => Prelude -> TcM s InstInfo -- the gen'd (filled-in) "instance decl" gen_inst_info modname fixities deriver_rn_env - info@(InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _) + (InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _) = -- Generate the various instance-related Ids mkInstanceRelatedIds @@ -531,18 +580,33 @@ gen_inst_info modname fixities deriver_rn_env -- Generate the bindings for the new instance declaration, -- rename it, and check for errors let - (tycon,_,_) = getAppDataTyCon ty + (tycon,_,_) = --pprTrace "gen_inst_info:ty" (ppCat[ppr PprDebug clas, ppr PprDebug ty]) $ + getAppDataTyCon ty proto_mbinds - | clas_key == eqClassKey = gen_Eq_binds tycon - | clas_key == showClassKey = gen_Show_binds fixities tycon - | clas_key == ordClassKey = gen_Ord_binds tycon - | clas_key == enumClassKey = gen_Enum_binds tycon - | clas_key == ixClassKey = gen_Ix_binds tycon - | clas_key == readClassKey = gen_Read_binds fixities tycon - | clas_key == binaryClassKey = gen_Binary_binds tycon - | otherwise = panic "gen_inst_info:bad derived class" + = assoc "gen_inst_info:bad derived class" + [(eqClassKey, gen_Eq_binds) + ,(ordClassKey, gen_Ord_binds) + ,(enumClassKey, gen_Enum_binds) + ,(evalClassKey, gen_Eval_binds) + ,(boundedClassKey, gen_Bounded_binds) + ,(showClassKey, gen_Show_binds fixities) + ,(readClassKey, gen_Read_binds fixities) + ,(ixClassKey, gen_Ix_binds) + ] + clas_key $ tycon + in +{- + let + ((qual, unqual, tc_qual, tc_unqual), stack) = deriver_rn_env in + pprTrace "gen_inst:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $ + pprTrace "gen_inst:unqual:" (ppCat (map ppPStr (keysFM unqual))) $ + pprTrace "gen_inst:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $ + pprTrace "gen_inst:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $ +-} + -- pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $ + rnMtoTcM deriver_rn_env ( setExtraRn emptyUFM{-no fixities-} $ rnMethodBinds clas_Name proto_mbinds @@ -552,8 +616,6 @@ gen_inst_info modname fixities deriver_rn_env pprPanic "gen_inst_info:renamer errs!\n" (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds)) else - --pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $ - -- All done let from_here = isLocallyDefined tycon -- If so, then from here @@ -563,10 +625,8 @@ gen_inst_info modname fixities deriver_rn_env (if from_here then mbinds else EmptyMonoBinds) from_here modname locn []) where - clas_key = classKey clas - clas_Name - = let (mod, nm) = moduleNamePair clas in - ClassName clas_key (mkPreludeCoreName mod nm) [] + clas_key = classKey clas + clas_Name = RnImplicitClass (mkImplicitName clas_key (origName clas)) \end{code} %************************************************************************ @@ -583,14 +643,38 @@ maxtag_Foo :: Int -- ditto (NB: not unboxed) \begin{code} gen_tag_n_con_binds :: RnEnv - -> [(RdrName, RnName, TyCon, TagThingWanted)] - -> TcM s RenamedHsBinds + -> [(RdrName, TyCon, TagThingWanted)] + -> TcM s (RenamedHsBinds, + RnEnv) -- input one with any new names added -gen_tag_n_con_binds deriver_rn_env nm_alist_etc - = let - proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc - proto_mbinds = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list +gen_tag_n_con_binds rn_env nm_alist_etc + = + let + -- We have the renamer's final "name funs" in our hands + -- (they were passed in). So we can handle ProtoNames + -- that refer to anything "out there". But our generated + -- code may also mention "con2tag" (etc.). So we need + -- to augment to "name funs" to include those. + + names_to_add = [ pn | (pn,_,_) <- nm_alist_etc ] + in + tcGetUniques (length names_to_add) `thenNF_Tc` \ uniqs -> + let + pairs_to_add = [ (pn, mkRnName (mkTopLevName u pn mkGeneratedSrcLoc ExportAll [])) + | (pn,u) <- zipEqual "gen_tag..." names_to_add uniqs ] + + deriver_rn_env + = if null names_to_add + then rn_env else added_rn_env + + (added_rn_env, errs_bag) + = extendGlobalRnEnv rn_env pairs_to_add [{-no tycons-}] + + ---------------- + proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc + proto_mbinds = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list in + ASSERT(isEmptyBag errs_bag) rnMtoTcM deriver_rn_env ( setExtraRn emptyUFM{-no fixities-} $ @@ -598,9 +682,10 @@ gen_tag_n_con_binds deriver_rn_env nm_alist_etc ) `thenNF_Tc` \ (binds, errs) -> if not (isEmptyBag errs) then - panic "gen_inst_info:renamer errs (2)!" + pprPanic "gen_tag_n_con_binds:renamer errs!\n" + (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug binds)) else - returnTc binds + returnTc (binds, deriver_rn_env) \end{code} %************************************************************************ @@ -628,30 +713,33 @@ We're deriving @Enum@, or @Ix@ (enum type only???) If we have a @tag2con@ function, we also generate a @maxtag@ constant. \begin{code} -gen_taggery_Names :: [DerivEqn] - -> TcM s [(RdrName, RnName, -- for an assoc list - TyCon, -- related tycon +gen_taggery_Names :: [InstInfo] + -> TcM s [(RdrName, -- for an assoc list + TyCon, -- related tycon TagThingWanted)] -gen_taggery_Names eqns - = let - all_tycons = [ tc | (_, tc, _, _) <- eqns ] - (tycons_of_interest, _) = removeDups cmp all_tycons - in - foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far -> - foldlTc do_tag2con names_so_far tycons_of_interest +gen_taggery_Names inst_infos + = --pprTrace "gen_taggery:\n" (ppAboves [ppCat [ppr PprDebug c, ppr PprDebug t] | (c,t) <- all_CTs]) $ + foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far -> + foldlTc do_tag2con names_so_far tycons_of_interest where + all_CTs = [ mk_CT c ty | (InstInfo c _ ty _ _ _ _ _ _ _ _ _) <- inst_infos ] + + mk_CT c ty = (c, fst (getAppTyCon ty)) + + all_tycons = map snd all_CTs + (tycons_of_interest, _) = removeDups cmp all_tycons + do_con2tag acc_Names tycon = if (we_are_deriving eqClassKey tycon - && any ( (== 0).dataConArity ) (tyConDataCons tycon)) + && any isNullaryDataCon (tyConDataCons tycon)) || (we_are_deriving ordClassKey tycon && not (maybeToBool (maybeTyConSingleCon tycon))) || (we_are_deriving enumClassKey tycon) || (we_are_deriving ixClassKey tycon) then - tcGetUnique `thenNF_Tc` ( \ u -> - returnTc ((con2tag_PN tycon, ValName u (con2tag_FN tycon), tycon, GenCon2Tag) - : acc_Names) ) + returnTc ((con2tag_PN tycon, tycon, GenCon2Tag) + : acc_Names) else returnTc acc_Names @@ -659,33 +747,26 @@ gen_taggery_Names eqns = if (we_are_deriving enumClassKey tycon) || (we_are_deriving ixClassKey tycon) then - tcGetUnique `thenNF_Tc` \ u1 -> - tcGetUnique `thenNF_Tc` \ u2 -> - returnTc ( (tag2con_PN tycon, ValName u1 (tag2con_FN tycon), tycon, GenTag2Con) - : (maxtag_PN tycon, ValName u2 (maxtag_FN tycon), tycon, GenMaxTag) + returnTc ( (tag2con_PN tycon, tycon, GenTag2Con) + : (maxtag_PN tycon, tycon, GenMaxTag) : acc_Names) else returnTc acc_Names we_are_deriving clas_key tycon - = is_in_eqns clas_key tycon eqns + = is_in_eqns clas_key tycon all_CTs where is_in_eqns clas_key tycon [] = False - is_in_eqns clas_key tycon ((c,t,_,_):eqns) + is_in_eqns clas_key tycon ((c,t):cts) = (clas_key == classKey c && tycon == t) - || is_in_eqns clas_key tycon eqns + || is_in_eqns clas_key tycon cts \end{code} \begin{code} -derivingEnumErr :: TyCon -> Error -derivingEnumErr tycon - = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Enum'" ( \ sty -> - ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] ) - -derivingIxErr :: TyCon -> Error -derivingIxErr tycon - = addErrLoc (getSrcLoc tycon) "Can't derive an instance of `Ix'" ( \ sty -> - ppBesides [ppStr "type `", ppr sty tycon, ppStr "'"] ) --} +derivingThingErr :: String -> TyCon -> Error + +derivingThingErr thing tycon sty + = ppHang (ppCat [ppStr "Can't make a derived instance of", ppStr thing]) + 4 (ppBesides [ppStr "for the type `", ppr sty tycon, ppStr "'"]) \end{code} diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 7702e31d65..0c299a5669 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -21,18 +21,18 @@ module TcEnv( ) where -import Ubiq -import TcMLoop -- for paranoia checking +IMP_Ubiq() +IMPORT_DELOOPER(TcMLoop) -- for paranoia checking import Id ( Id(..), GenId, idType, mkUserLocal ) import TcHsSyn ( TcIdBndr(..), TcIdOcc(..) ) import TcKind ( TcKind, newKindVars, tcDefaultKind, kindToTcKind ) import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..), - newTyVarTys, tcInstTyVars, tcInstType, zonkTcTyVars + newTyVarTys, tcInstTyVars, zonkTcTyVars ) import TyVar ( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet ) import Type ( tyVarsOfTypes ) -import TyCon ( TyCon, Arity(..), tyConKind, synTyConArity ) +import TyCon ( TyCon, tyConKind, synTyConArity ) import Class ( Class(..), GenClass, classSig ) import TcMonad hiding ( rnMtoTcM ) @@ -294,7 +294,7 @@ newMonoIds names kind m mk_id name uniq ty = let - name_str = case (getOccName name) of { Unqual n -> n } + name_str = case (getOccName name) of { Unqual n -> n; Qual m n -> n } in mkUserLocal name_str uniq ty (getSrcLoc name) in diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 21e864e3e0..a45dc275e6 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -8,13 +8,13 @@ module TcExpr ( tcExpr ) where -import Ubiq +IMP_Ubiq() import HsSyn ( HsExpr(..), Qual(..), Stmt(..), HsBinds(..), Bind(..), MonoBinds(..), ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds, Match, Fake, InPat, OutPat, PolyType, - irrefutablePat, collectPatBinders ) + failureFreePat, collectPatBinders ) import RnHsSyn ( RenamedHsExpr(..), RenamedQual(..), RenamedStmt(..), RenamedRecordBinds(..), RnName{-instance Outputable-} @@ -37,17 +37,18 @@ import TcMonoType ( tcPolyType ) import TcPat ( tcPat ) import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 ) import TcType ( TcType(..), TcMaybe(..), - tcInstId, tcInstType, tcInstTheta, tcInstTyVars, + tcInstId, tcInstType, tcInstSigTyVars, + tcInstSigType, tcInstTcType, tcInstTheta, newTyVarTy, zonkTcTyVars, zonkTcType ) import TcKind ( TcKind ) import Class ( Class(..), classSig ) import FieldLabel ( fieldLabelName ) -import Id ( Id(..), GenId, idType, dataConFieldLabels, dataConSig ) +import Id ( idType, dataConFieldLabels, dataConSig, Id(..), GenId ) import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind ) import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals ) import Name ( Name{-instance Eq-} ) -import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, +import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy, getTyVar_maybe, getFunTy_maybe, instantiateTy, splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy, isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe, @@ -65,7 +66,7 @@ import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) import Unique ( Unique, cCallableClassKey, cReturnableClassKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromThenToClassOpKey, - monadClassKey, monadZeroClassKey + thenMClassOpKey, zeroClassOpKey ) --import Name ( Name ) -- Instance import Outputable ( interpp'SP ) @@ -318,32 +319,8 @@ tcExpr (ListComp expr quals) \end{code} \begin{code} -tcExpr (HsDo stmts src_loc) - = -- get the Monad and MonadZero classes - -- create type consisting of a fresh monad tyvar - tcAddSrcLoc src_loc $ - newTyVarTy monadKind `thenNF_Tc` \ m -> - tcDoStmts False m stmts `thenTc` \ ((stmts',monad,mzero), lie, do_ty) -> - - -- create dictionaries for monad and possibly monadzero - (if monad then - tcLookupClassByKey monadClassKey `thenNF_Tc` \ monadClass -> - newDicts DoOrigin [(monadClass, m)] - else - returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"]) - ) `thenNF_Tc` \ (m_lie, [m_id]) -> - (if mzero then - tcLookupClassByKey monadZeroClassKey `thenNF_Tc` \ monadZeroClass -> - newDicts DoOrigin [(monadZeroClass, m)] - else - returnNF_Tc (emptyLIE, [panic "TcExpr: MonadZero dictionary"]) - ) `thenNF_Tc` \ (mz_lie, [mz_id]) -> - - returnTc (HsDoOut stmts' m_id mz_id src_loc, - lie `plusLIE` m_lie `plusLIE` mz_lie, - do_ty) - where - monadKind = mkArrowKind mkBoxedTypeKind mkBoxedTypeKind +tcExpr expr@(HsDo stmts src_loc) + = tcDoStmts stmts src_loc \end{code} \begin{code} @@ -487,7 +464,7 @@ tcExpr in_expr@(ExprWithTySig expr poly_ty) -- Check the tau-type part tcSetErrCtxt (exprSigCtxt in_expr) $ - tcInstType [] sigma_sig `thenNF_Tc` \ sigma_sig' -> + tcInstSigType sigma_sig `thenNF_Tc` \ sigma_sig' -> let (sig_tyvars', sig_theta', sig_tau') = splitSigmaTy sigma_sig' in @@ -590,11 +567,17 @@ tcArg expected_arg_ty arg -- of instantiating a function involving rank-2 polymorphism, so there -- isn't any danger of using the same tyvars twice -- The argument type shouldn't be overloaded type (hence ASSERT) + + -- To ensure that the forall'd type variables don't get unified with each + -- other or any other types, we make fresh *signature* type variables + -- and unify them with the tyvars. let (expected_tyvars, expected_theta, expected_tau) = splitSigmaTy expected_arg_ty in ASSERT( null expected_theta ) -- And expected_tyvars are all DontBind things - + tcInstSigTyVars expected_tyvars `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) -> + unifyTauTyLists (mkTyVarTys expected_tyvars) sig_tyvar_tys `thenTc_` + -- Type-check the arg and unify with expected type tcExpr arg `thenTc` \ (arg', lie_arg, actual_arg_ty) -> unifyTauTy expected_tau actual_arg_ty `thenTc_` ( @@ -609,11 +592,10 @@ tcArg expected_arg_ty arg -- So now s' isn't unconstrained because it's linked to a. -- Conclusion: include the free vars of the expected arg type in the -- list of "free vars" for the signature check. + tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $ - tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars -> - zonkTcTyVars (tyVarsOfType expected_arg_ty) `thenNF_Tc` \ free_tyvars -> checkSigTyVarsGivenGlobals - (env_tyvars `unionTyVarSets` free_tyvars) + (tyVarsOfType expected_arg_ty) expected_tyvars expected_tau `thenTc_` -- Check that there's no overloading involved @@ -649,42 +631,45 @@ tcId name = -- Look up the Id and instantiate its type tcLookupLocalValue name `thenNF_Tc` \ maybe_local -> - (case maybe_local of - Just tc_id -> let - (tyvars, rho) = splitForAllTy (idType tc_id) - in - tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys', tenv) -> - let - rho' = instantiateTy tenv rho - in - returnNF_Tc (TcId tc_id, arg_tys', rho') - - Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id -> - let - (tyvars, rho) = splitForAllTy (idType id) - in - tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) -> - tcInstType tenv rho `thenNF_Tc` \ rho' -> - returnNF_Tc (RealId id, arg_tys, rho') - - ) `thenNF_Tc` \ (tc_id_occ, arg_tys, rho) -> - - -- Is it overloaded? - case splitRhoTy rho of - ([], tau) -> -- Not overloaded, so just make a type application - returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau) - - (theta, tau) -> -- Overloaded, so make a Method inst - newMethodWithGivenTy (OccurrenceOf tc_id_occ) - tc_id_occ arg_tys rho `thenNF_Tc` \ (lie, meth_id) -> - returnNF_Tc (HsVar meth_id, lie, tau) -\end{code} + case maybe_local of + Just tc_id -> instantiate_it (TcId tc_id) (idType tc_id) + Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id -> + tcInstType [] (idType id) `thenNF_Tc` \ inst_ty -> + let + (tyvars, rho) = splitForAllTy inst_ty + in + instantiate_it2 (RealId id) tyvars rho + where + -- The instantiate_it loop runs round instantiating the Id. + -- It has to be a loop because we are now prepared to entertain + -- types like + -- f:: forall a. Eq a => forall b. Baz b => tau + -- We want to instantiate this to + -- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)} + instantiate_it tc_id_occ ty + = tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) -> + instantiate_it2 tc_id_occ tyvars rho + + instantiate_it2 tc_id_occ tyvars rho + | null theta -- Is it overloaded? + = returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau) + + | otherwise -- Yes, it's overloaded + = newMethodWithGivenTy (OccurrenceOf tc_id_occ) + tc_id_occ arg_tys rho `thenNF_Tc` \ (lie1, meth_id) -> + instantiate_it meth_id tau `thenNF_Tc` \ (expr, lie2, final_tau) -> + returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau) + + where + (theta, tau) = splitRhoTy rho + arg_tys = mkTyVarTys tyvars +\end{code} %************************************************************************ %* * -\subsection{@tcQuals@ typchecks list comprehension qualifiers} +\subsection{@tcQuals@ typechecks list-comprehension qualifiers} %* * %************************************************************************ @@ -749,67 +734,78 @@ tcListComp expr (LetQual binds : quals) %************************************************************************ \begin{code} -tcDoStmts :: Bool -- True => require a monad - -> TcType s -- m - -> [RenamedStmt] - -> TcM s (([TcStmt s], - Bool, -- True => Monad - Bool), -- True => MonadZero - LIE s, - TcType s) - -tcDoStmts monad m [stmt@(ExprStmt exp src_loc)] - = tcAddSrcLoc src_loc $ - tcSetErrCtxt (stmtCtxt stmt) $ - tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) -> - (if monad then - newTyVarTy mkTypeKind `thenNF_Tc` \ a -> - unifyTauTy (mkAppTy m a) exp_ty - else - returnTc () - ) `thenTc_` - returnTc (([ExprStmt exp' src_loc], monad, False), exp_lie, exp_ty) - -tcDoStmts _ m (stmt@(ExprStmt exp src_loc) : stmts) - = tcAddSrcLoc src_loc ( - tcSetErrCtxt (stmtCtxt stmt) ( - tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) -> - newTyVarTy mkTypeKind `thenNF_Tc` \ a -> - unifyTauTy (mkAppTy m a) exp_ty `thenTc_` - returnTc (ExprStmt exp' src_loc, exp_lie) - )) `thenTc` \ (stmt', stmt_lie) -> - tcDoStmts True m stmts `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) -> - returnTc ((stmt':stmts', True, mzero), - stmt_lie `plusLIE` stmts_lie, - stmts_ty) - -tcDoStmts _ m (stmt@(BindStmt pat exp src_loc) : stmts) - = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ -> - tcAddSrcLoc src_loc ( - tcSetErrCtxt (stmtCtxt stmt) ( - tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) -> - - tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) -> +tcDoStmts stmts src_loc + = -- get the Monad and MonadZero classes + -- create type consisting of a fresh monad tyvar + tcAddSrcLoc src_loc $ + newTyVarTy (mkArrowKind mkBoxedTypeKind mkBoxedTypeKind) `thenNF_Tc` \ m -> + + + -- Build the then and zero methods in case we need them + tcLookupGlobalValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id -> + tcLookupGlobalValueByKey zeroClassOpKey `thenNF_Tc` \ zero_sel_id -> + newMethod DoOrigin + (RealId then_sel_id) [m] `thenNF_Tc` \ (m_lie, then_id) -> + newMethod DoOrigin + (RealId zero_sel_id) [m] `thenNF_Tc` \ (mz_lie, zero_id) -> + + let + get_m_arg ty + = newTyVarTy mkTypeKind `thenNF_Tc` \ arg_ty -> + unifyTauTy (mkAppTy m arg_ty) ty `thenTc_` + returnTc arg_ty + + go [stmt@(ExprStmt exp src_loc)] + = tcAddSrcLoc src_loc $ + tcSetErrCtxt (stmtCtxt stmt) $ + tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) -> + returnTc ([ExprStmt exp' src_loc], exp_lie, exp_ty) + + go (stmt@(ExprStmt exp src_loc) : stmts) + = tcAddSrcLoc src_loc ( + tcSetErrCtxt (stmtCtxt stmt) ( + tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) -> + get_m_arg exp_ty `thenTc` \ a -> + returnTc (a, exp', exp_lie) + )) `thenTc` \ (a, exp', exp_lie) -> + go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) -> + get_m_arg stmts_ty `thenTc` \ b -> + returnTc (ExprStmtOut exp' src_loc a b : stmts', + exp_lie `plusLIE` stmts_lie `plusLIE` m_lie, + stmts_ty) + + go (stmt@(BindStmt pat exp src_loc) : stmts) + = newMonoIds (collectPatBinders pat) mkBoxedTypeKind $ \ _ -> + tcAddSrcLoc src_loc ( + tcSetErrCtxt (stmtCtxt stmt) ( + tcPat pat `thenTc` \ (pat', pat_lie, pat_ty) -> + tcExpr exp `thenTc` \ (exp', exp_lie, exp_ty) -> -- See comments with tcListComp on GeneratorQual - newTyVarTy mkTypeKind `thenNF_Tc` \ a -> - unifyTauTy a pat_ty `thenTc_` - unifyTauTy (mkAppTy m a) exp_ty `thenTc_` - returnTc (BindStmt pat' exp' src_loc, pat_lie `plusLIE` exp_lie, irrefutablePat pat') - )) `thenTc` \ (stmt', stmt_lie, failure_free) -> - tcDoStmts True m stmts `thenTc` \ ((stmts', _, mzero), stmts_lie, stmts_ty) -> - returnTc ((stmt':stmts', True, mzero || not failure_free), - stmt_lie `plusLIE` stmts_lie, - stmts_ty) - -tcDoStmts monad m (LetStmt binds : stmts) - = tcBindsAndThen -- No error context, but a binding group is - combine -- rather a large thing for an error context anyway - binds - (tcDoStmts monad m stmts) - where - combine binds' (stmts', monad, mzero) = ((LetStmt binds' : stmts'), monad, mzero) + get_m_arg exp_ty `thenTc` \ a -> + unifyTauTy a pat_ty `thenTc_` + returnTc (a, pat', exp', pat_lie `plusLIE` exp_lie) + )) `thenTc` \ (a, pat', exp', stmt_lie) -> + go stmts `thenTc` \ (stmts', stmts_lie, stmts_ty) -> + get_m_arg stmts_ty `thenTc` \ b -> + returnTc (BindStmtOut pat' exp' src_loc a b : stmts', + stmt_lie `plusLIE` stmts_lie `plusLIE` m_lie `plusLIE` + (if failureFreePat pat' then emptyLIE else mz_lie), + stmts_ty) + + go (LetStmt binds : stmts) + = tcBindsAndThen -- No error context, but a binding group is + combine -- rather a large thing for an error context anyway + binds + (go stmts) + where + combine binds' stmts' = LetStmt binds' : stmts' + in + go stmts `thenTc` \ (stmts', final_lie, final_ty) -> + returnTc (HsDoOut stmts' then_id zero_id src_loc, + final_lie, + final_ty) \end{code} Game plan for record bindings diff --git a/ghc/compiler/typecheck/TcGRHSs.lhs b/ghc/compiler/typecheck/TcGRHSs.lhs index edc2869829..4a532ae009 100644 --- a/ghc/compiler/typecheck/TcGRHSs.lhs +++ b/ghc/compiler/typecheck/TcGRHSs.lhs @@ -4,10 +4,12 @@ \section[TcGRHSs]{Typecheck guarded right-hand-sides} \begin{code} +#include "HsVersions.h" + module TcGRHSs ( tcGRHSsAndBinds ) where -import Ubiq{-uitous-} -import TcLoop -- for paranoia checking +IMP_Ubiq(){-uitous-} +IMPORT_DELOOPER(TcLoop) -- for paranoia checking import HsSyn ( GRHSsAndBinds(..), GRHS(..), HsExpr, HsBinds(..), InPat, OutPat, Bind, Sig, Fake ) diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 8f19aef1c7..743851770d 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -11,7 +11,7 @@ This is where we do all the grimy bindings' generation. \begin{code} #include "HsVersions.h" -module TcGenDeriv {- ( +module TcGenDeriv ( a_Expr, a_PN, a_Pat, @@ -29,15 +29,16 @@ module TcGenDeriv {- ( d_PN, d_Pat, dh_PN, - eqH_PN, + eqH_Int_PN, eqTag_Expr, eq_PN, error_PN, false_Expr, false_PN, geH_PN, - gen_Binary_binds, + gen_Bounded_binds, gen_Enum_binds, + gen_Eval_binds, gen_Eq_binds, gen_Ix_binds, gen_Ord_binds, @@ -47,7 +48,7 @@ module TcGenDeriv {- ( gtTag_Expr, gt_PN, leH_PN, - ltH_PN, + ltH_Int_PN, ltTag_Expr, lt_PN, minusH_PN, @@ -56,49 +57,50 @@ module TcGenDeriv {- ( true_Expr, true_PN, - con2tag_FN, tag2con_FN, maxtag_FN, con2tag_PN, tag2con_PN, maxtag_PN, TagThingWanted(..) - ) -} where + ) where -import Ubiq +IMP_Ubiq() import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qual(..), Stmt, ArithSeqInfo, Sig, PolyType, FixityDecl, Fake ) import RdrHsSyn ( RdrNameMonoBinds(..), RdrNameHsExpr(..), RdrNamePat(..) ) -import RnHsSyn ( RnName(..), RenamedFixityDecl(..) ) +import RnHsSyn ( RenamedFixityDecl(..) ) +--import RnUtils ---import RnMonad4 -- initRn4, etc. -import RnUtils - -import Id ( GenId, dataConArity, dataConTag, - dataConSig, fIRST_TAG, +import Id ( GenId, dataConArity, isNullaryDataCon, dataConTag, + dataConRawArgTys, fIRST_TAG, isDataCon, DataCon(..), ConTag(..) ) import IdUtils ( primOpId ) import Maybes ( maybeToBool ) ---import Name ( Name(..) ) -import Outputable -import PrimOp ---import PrelInfo -import Pretty +import Name ( moduleNamePair, origName, RdrName(..) ) +import PrelMods ( fromPrelude, pRELUDE, pRELUDE_BUILTIN, pRELUDE_LIST, pRELUDE_TEXT ) +import PrelVals ( eRROR_ID ) + +import PrimOp ( PrimOp(..) ) import SrcLoc ( mkGeneratedSrcLoc ) import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon ) import Type ( eqTy, isPrimType ) -import Unique -import Util +import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, + floatPrimTy, doublePrimTy + ) +import TysWiredIn ( falseDataCon, trueDataCon, intDataCon ) +--import Unique +import Util ( mapAccumL, zipEqual, zipWith3Equal, nOfThem, panic, assertPanic ) \end{code} %************************************************************************ %* * -\subsection[TcGenDeriv-classes]{Generating code, by derivable class} +\subsection{Generating code, by derivable class} %* * %************************************************************************ %************************************************************************ %* * -\subsubsection[TcGenDeriv-Eq]{Generating @Eq@ instance declarations} +\subsubsection{Generating @Eq@ instance declarations} %* * %************************************************************************ @@ -170,18 +172,15 @@ instance ... Eq (Foo ...) where \end{itemize} \begin{code} -foo_TcGenDeriv = panic "Nothing in TcGenDeriv LATER ToDo" - -{- LATER: gen_Eq_binds :: TyCon -> RdrNameMonoBinds gen_Eq_binds tycon - = case (partition (\ con -> dataConArity con == 0) - (tyConDataCons tycon)) - of { (nullary_cons, nonnullary_cons) -> - let + = let + (nullary_cons, nonnullary_cons) + = partition isNullaryDataCon (tyConDataCons tycon) + rest - = if null nullary_cons then + = if (null nullary_cons) then case maybeTyConSingleCon tycon of Just _ -> [] Nothing -> -- if cons don't match, then False @@ -189,11 +188,10 @@ gen_Eq_binds tycon else -- calc. and compare the tags [([a_Pat, b_Pat], untag_Expr tycon [(a_PN,ah_PN), (b_PN,bh_PN)] - (cmp_tags_Expr eqH_PN ah_PN bh_PN true_Expr false_Expr))] + (cmp_tags_Expr eqH_Int_PN ah_PN bh_PN true_Expr false_Expr))] in mk_FunMonoBind eq_PN ((map pats_etc nonnullary_cons) ++ rest) `AndMonoBinds` boring_ne_method - } where ------------------------------------------------------------------ pats_etc data_con @@ -201,31 +199,37 @@ gen_Eq_binds tycon con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed) con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed) - data_con_PN = Prel (WiredInId data_con) - as_needed = take (dataConArity data_con) as_PNs - bs_needed = take (dataConArity data_con) bs_PNs - tys_needed = case (dataConSig data_con) of - (_,_, arg_tys, _) -> arg_tys + data_con_PN = origName data_con + con_arity = dataConArity data_con + as_needed = take con_arity as_PNs + bs_needed = take con_arity bs_PNs + tys_needed = dataConRawArgTys data_con in ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed) where + nested_eq_expr [] [] [] = true_Expr + nested_eq_expr tys as bs + = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) + where + nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b)) +{-OLD: nested_eq_expr [] [] [] = true_Expr - nested_eq_expr [ty] [a] [b] = eq_Expr ty (HsVar a) (HsVar b) + nested_eq_expr [ty] [a] [b] = nested_eq_expr (t:ts) (a:as) (b:bs) = let rest_expr = nested_eq_expr ts as bs in and_Expr (eq_Expr t (HsVar a) (HsVar b)) rest_expr +-} boring_ne_method - = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] ( - HsApp (HsVar not_PN) (HsApp (HsApp (HsVar eq_PN) a_Expr) b_Expr) - ) + = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] $ + HsApp (HsVar not_PN) (HsPar (mk_easy_App eq_PN [a_PN, b_PN])) \end{code} %************************************************************************ %* * -\subsubsection[TcGenDeriv-Ord]{Generating @Ord@ instance declarations} +\subsubsection{Generating @Ord@ instance declarations} %* * %************************************************************************ @@ -245,13 +249,13 @@ data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ... We do all the other @Ord@ methods with calls to @compare@: \begin{verbatim} instance ... (Ord <wurble> <wurble>) where - a < b = case compare a b of { LT -> True; EQ -> False; GT -> False } - a <= b = case compare a b of { LT -> True; EQ -> True; GT -> False } - a >= b = case compare a b of { LT -> False; EQ -> True; GT -> True } - a > b = case compare a b of { LT -> False; EQ -> False; GT -> True } + a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False } + a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False } + a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True } - max a b = case compare a b of { LT -> b; EQ -> a; GT -> a } - min a b = case compare a b of { LT -> a; EQ -> b; GT -> b } + max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a } + min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b } -- compare to come... \end{verbatim} @@ -263,7 +267,7 @@ instance ... (Ord <wurble> <wurble>) where \begin{verbatim} compare a b = case (con2tag_Foo a) of { a# -> case (con2tag_Foo b) of { b# -> - case (a# ==# b#) of { + case (a# ==# b#) of { True -> cmp_eq a b False -> case (a# <# b#) of True -> _LT @@ -329,7 +333,7 @@ gen_Ord_binds tycon cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr else untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] - (cmp_tags_Expr eqH_PN ah_PN bh_PN + (cmp_tags_Expr eqH_Int_PN ah_PN bh_PN -- True case; they are equal -- If an enumeration type we are done; else -- recursively compare their components @@ -340,7 +344,7 @@ gen_Ord_binds tycon ) -- False case; they aren't equal -- So we need to do a less-than comparison on the tags - (cmp_tags_Expr ltH_PN ah_PN bh_PN ltTag_Expr gtTag_Expr))) + (cmp_tags_Expr ltH_Int_PN ah_PN bh_PN ltTag_Expr gtTag_Expr))) (nullary_cons, nonnullary_cons) = partition (\ con -> dataConArity con == 0) (tyConDataCons tycon) @@ -355,11 +359,11 @@ gen_Ord_binds tycon con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed) con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed) - data_con_PN = Prel (WiredInId data_con) - as_needed = take (dataConArity data_con) as_PNs - bs_needed = take (dataConArity data_con) bs_PNs - tys_needed = case (dataConSig data_con) of - (_,_, arg_tys, _) -> arg_tys + data_con_PN = origName data_con + con_arity = dataConArity data_con + as_needed = take con_arity as_PNs + bs_needed = take con_arity bs_PNs + tys_needed = dataConRawArgTys data_con nested_compare_expr [ty] [a] [b] = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b) @@ -393,7 +397,7 @@ min_ = mk_easy_FunMonoBind min_PN [a_Pat, b_Pat] [] ( %************************************************************************ %* * -\subsubsection[TcGenDeriv-Enum]{Generating @Enum@ instance declarations} +\subsubsection{Generating @Enum@ instance declarations} %* * %************************************************************************ @@ -434,26 +438,70 @@ gen_Enum_binds tycon = enum_from `AndMonoBinds` enum_from_then where enum_from - = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] ( - untag_Expr tycon [(a_PN, ah_PN)] ( - HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) ( - enum_from_to_Expr - (HsApp (HsVar mkInt_PN) (HsVar ah_PN)) - (HsVar (maxtag_PN tycon))))) + = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] $ + untag_Expr tycon [(a_PN, ah_PN)] $ + HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $ + HsPar (enum_from_to_Expr + (mk_easy_App mkInt_PN [ah_PN]) + (HsVar (maxtag_PN tycon))) enum_from_then - = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] ( - untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] ( - HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) ( - enum_from_then_to_Expr - (HsApp (HsVar mkInt_PN) (HsVar ah_PN)) - (HsApp (HsVar mkInt_PN) (HsVar bh_PN)) - (HsVar (maxtag_PN tycon))))) + = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] $ + untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] $ + HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $ + HsPar (enum_from_then_to_Expr + (mk_easy_App mkInt_PN [ah_PN]) + (mk_easy_App mkInt_PN [bh_PN]) + (HsVar (maxtag_PN tycon))) +\end{code} + +%************************************************************************ +%* * +\subsubsection{Generating @Eval@ instance declarations} +%* * +%************************************************************************ + +\begin{code} +gen_Eval_binds tycon = EmptyMonoBinds \end{code} %************************************************************************ %* * -\subsubsection[TcGenDeriv-Ix]{Generating @Ix@ instance declarations} +\subsubsection{Generating @Bounded@ instance declarations} +%* * +%************************************************************************ + +\begin{code} +gen_Bounded_binds tycon + = if isEnumerationTyCon tycon then + min_bound_enum `AndMonoBinds` max_bound_enum + else + ASSERT(length data_cons == 1) + min_bound_1con `AndMonoBinds` max_bound_1con + where + data_cons = tyConDataCons tycon + + ----- enum-flavored: --------------------------- + min_bound_enum = mk_easy_FunMonoBind minBound_PN [] [] (HsVar data_con_1_PN) + max_bound_enum = mk_easy_FunMonoBind maxBound_PN [] [] (HsVar data_con_N_PN) + + data_con_1 = head data_cons + data_con_N = last data_cons + data_con_1_PN = origName data_con_1 + data_con_N_PN = origName data_con_N + + ----- single-constructor-flavored: ------------- + arity = dataConArity data_con_1 + + min_bound_1con = mk_easy_FunMonoBind minBound_PN [] [] $ + mk_easy_App data_con_1_PN (nOfThem arity minBound_PN) + max_bound_1con = mk_easy_FunMonoBind maxBound_PN [] [] $ + mk_easy_App data_con_1_PN (nOfThem arity maxBound_PN) +\end{code} + +%************************************************************************ +%* * +\subsubsection{Generating @Ix@ instance declarations} %* * %************************************************************************ @@ -524,25 +572,24 @@ gen_Ix_binds tycon enum_index `AndMonoBinds` enum_inRange enum_range - = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] ( - untag_Expr tycon [(a_PN, ah_PN)] ( - untag_Expr tycon [(b_PN, bh_PN)] ( - HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) ( - enum_from_to_Expr - (HsApp (HsVar mkInt_PN) (HsVar ah_PN)) - (HsApp (HsVar mkInt_PN) (HsVar bh_PN)) - )))) + = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] $ + untag_Expr tycon [(a_PN, ah_PN)] $ + untag_Expr tycon [(b_PN, bh_PN)] $ + HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $ + HsPar (enum_from_to_Expr + (mk_easy_App mkInt_PN [ah_PN]) + (mk_easy_App mkInt_PN [bh_PN])) enum_index = mk_easy_FunMonoBind index_PN [AsPatIn c_PN (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] ( - HsIf (HsApp (HsApp (HsVar inRange_PN) c_Expr) d_Expr) ( + HsIf (HsPar (mk_easy_App inRange_PN [c_PN, d_PN])) ( untag_Expr tycon [(a_PN, ah_PN)] ( untag_Expr tycon [(d_PN, dh_PN)] ( let - grhs = [OtherwiseGRHS (HsApp (HsVar mkInt_PN) (HsVar c_PN)) mkGeneratedSrcLoc] + grhs = [OtherwiseGRHS (mk_easy_App mkInt_PN [c_PN]) mkGeneratedSrcLoc] in HsCase - (OpApp (HsVar dh_PN) (HsVar minusH_PN) (HsVar ah_PN)) + (HsPar (OpApp (HsVar dh_PN) (HsVar minusH_PN) (HsVar ah_PN))) [PatMatch (VarPatIn c_PN) (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))] mkGeneratedSrcLoc @@ -557,7 +604,7 @@ gen_Ix_binds tycon untag_Expr tycon [(a_PN, ah_PN)] ( untag_Expr tycon [(b_PN, bh_PN)] ( untag_Expr tycon [(c_PN, ch_PN)] ( - HsIf (OpApp (HsVar ch_PN) (HsVar geH_PN) (HsVar ah_PN)) ( + HsIf (HsPar (OpApp (HsVar ch_PN) (HsVar geH_PN) (HsVar ah_PN))) ( (OpApp (HsVar ch_PN) (HsVar leH_PN) (HsVar bh_PN)) ) {-else-} ( false_Expr @@ -570,22 +617,19 @@ gen_Ix_binds tycon data_con = case maybeTyConSingleCon tycon of -- just checking... Nothing -> panic "get_Ix_binds" - Just dc -> let - (_, _, arg_tys, _) = dataConSig dc - in - if any isPrimType arg_tys then + Just dc -> if (any isPrimType (dataConRawArgTys dc)) then error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str) else dc con_arity = dataConArity data_con - data_con_PN = Prel (WiredInId data_con) + data_con_PN = origName data_con con_pat xs = ConPatIn data_con_PN (map VarPatIn xs) - con_expr xs = foldl HsApp (HsVar data_con_PN) (map HsVar xs) + con_expr xs = mk_easy_App data_con_PN xs - as_needed = take (dataConArity data_con) as_PNs - bs_needed = take (dataConArity data_con) bs_PNs - cs_needed = take (dataConArity data_con) cs_PNs + as_needed = take con_arity as_PNs + bs_needed = take con_arity bs_PNs + cs_needed = take con_arity cs_PNs -------------------------------------------------------------- single_con_range @@ -626,7 +670,7 @@ gen_Ix_binds tycon %************************************************************************ %* * -\subsubsection[TcGenDeriv-Text]{Generating @Show@ and @Read@ instance declarations} +\subsubsection{Generating @Read@ instance declarations} %* * %************************************************************************ @@ -634,14 +678,13 @@ Ignoring all the infix-ery mumbo jumbo (ToDo) \begin{code} gen_Read_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds -gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds gen_Read_binds fixities tycon = reads_prec `AndMonoBinds` read_list where ----------------------------------------------------------------------- read_list = mk_easy_FunMonoBind readList_PN [] [] - (HsApp (HsVar _readList_PN) (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0)))) + (HsApp (HsVar _readList_PN) (HsPar (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0))))) ----------------------------------------------------------------------- reads_prec = let @@ -654,12 +697,13 @@ gen_Read_binds fixities tycon where read_con data_con -- note: "b" is the string being "read" = let - data_con_PN = Prel (WiredInId data_con) + data_con_PN = origName data_con data_con_str= snd (moduleNamePair data_con) - as_needed = take (dataConArity data_con) as_PNs - bs_needed = take (dataConArity data_con) bs_PNs - con_expr = foldl HsApp (HsVar data_con_PN) (map HsVar as_needed) - nullary_con = dataConArity data_con == 0 + con_arity = dataConArity data_con + as_needed = take con_arity as_PNs + bs_needed = take con_arity bs_PNs + con_expr = mk_easy_App data_con_PN as_needed + nullary_con = isNullaryDataCon data_con con_qual = GeneratorQual @@ -672,39 +716,51 @@ gen_Read_binds fixities tycon = if nullary_con then -- must be False (parens are surely optional) false_Expr else -- parens depend on precedence... - OpApp a_Expr (HsVar gt_PN) (HsLit (HsInt 9)) + HsPar (OpApp a_Expr (HsVar gt_PN) (HsLit (HsInt 9))) in HsApp ( - readParen_Expr read_paren_arg ( + readParen_Expr read_paren_arg $ HsPar $ HsLam (mk_easy_Match [c_Pat] [] ( ListComp (ExplicitTuple [con_expr, if null bs_needed then d_Expr else HsVar (last bs_needed)]) (con_qual : field_quals))) - )) (HsVar b_PN) + ) (HsVar b_PN) where mk_qual draw_from (con_field, str_left) = (HsVar str_left, -- what to draw from down the line... GeneratorQual (TuplePatIn [VarPatIn con_field, VarPatIn str_left]) (HsApp (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 10))) draw_from)) +\end{code} +%************************************************************************ +%* * +\subsubsection{Generating @Show@ instance declarations} +%* * +%************************************************************************ + +Ignoring all the infix-ery mumbo jumbo (ToDo) + +\begin{code} +gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds gen_Show_binds fixities tycon = shows_prec `AndMonoBinds` show_list where ----------------------------------------------------------------------- show_list = mk_easy_FunMonoBind showList_PN [] [] - (HsApp (HsVar _showList_PN) (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0)))) + (HsApp (HsVar _showList_PN) (HsPar (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0))))) ----------------------------------------------------------------------- shows_prec = mk_FunMonoBind showsPrec_PN (map pats_etc (tyConDataCons tycon)) where pats_etc data_con = let - data_con_PN = Prel (WiredInId data_con) - bs_needed = take (dataConArity data_con) bs_PNs + data_con_PN = origName data_con + con_arity = dataConArity data_con + bs_needed = take con_arity bs_PNs con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed) - nullary_con = dataConArity data_con == 0 + nullary_con = isNullaryDataCon data_con show_con = let (mod, nm) = moduleNamePair data_con @@ -723,8 +779,8 @@ gen_Show_binds fixities tycon ([a_Pat, con_pat], show_con) else ([a_Pat, con_pat], - showParen_Expr (OpApp a_Expr (HsVar ge_PN) (HsLit (HsInt 10))) - (nested_compose_Expr show_thingies)) + showParen_Expr (HsPar (OpApp a_Expr (HsVar ge_PN) (HsLit (HsInt 10)))) + (HsPar (nested_compose_Expr show_thingies))) where spacified [] = [] spacified [x] = [x] @@ -733,22 +789,7 @@ gen_Show_binds fixities tycon %************************************************************************ %* * -\subsubsection[TcGenDeriv-Binary]{Generating @Binary@ instance declarations} -%* * -%************************************************************************ - -ToDo: NOT DONE YET. - -\begin{code} -gen_Binary_binds :: TyCon -> RdrNameMonoBinds - -gen_Binary_binds tycon - = panic "gen_Binary_binds" -\end{code} - -%************************************************************************ -%* * -\subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)} +\subsection{Generating extra binds (@con2tag@ and @tag2con@)} %* * %************************************************************************ @@ -768,12 +809,12 @@ data TagThingWanted = GenCon2Tag | GenTag2Con | GenMaxTag gen_tag_n_con_monobind - :: (RdrName, RnName, -- (proto)Name for the thing in question + :: (RdrName, -- (proto)Name for the thing in question TyCon, -- tycon in question TagThingWanted) -> RdrNameMonoBinds -gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag) +gen_tag_n_con_monobind (pn, tycon, GenCon2Tag) = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon)) where mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr) @@ -783,9 +824,9 @@ gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag) ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))) where pat = ConPatIn var_PN (nOfThem (dataConArity var) WildPatIn) - var_PN = Prel (WiredInId var) + var_PN = origName var -gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con) +gen_tag_n_con_monobind (pn, tycon, GenTag2Con) = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon)) where mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr) @@ -795,9 +836,9 @@ gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con) ([lit_pat], HsVar var_PN) where lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))] - var_PN = Prel (WiredInId var) + var_PN = origName var -gen_tag_n_con_monobind (pn, _, tycon, GenMaxTag) +gen_tag_n_con_monobind (pn, tycon, GenMaxTag) = mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag))) where max_tag = case (tyConDataCons tycon) of @@ -806,7 +847,7 @@ gen_tag_n_con_monobind (pn, _, tycon, GenMaxTag) %************************************************************************ %* * -\subsection[TcGenDeriv-bind-utils]{Utility bits for generating bindings} +\subsection{Utility bits for generating bindings} %* * %************************************************************************ @@ -833,9 +874,7 @@ mk_easy_FunMonoBind fun pats binds expr = FunMonoBind fun False{-not infix-} [mk_easy_Match pats binds expr] mkGeneratedSrcLoc mk_easy_Match pats binds expr - = foldr PatMatch - (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] (mkbind binds))) - pats + = mk_match pats expr (mkbind binds) where mkbind [] = EmptyBinds mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs)) @@ -849,12 +888,21 @@ mk_FunMonoBind :: RdrName mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind" mk_FunMonoBind fun pats_and_exprs - = FunMonoBind fun False{-not infix-} (map mk_match pats_and_exprs) mkGeneratedSrcLoc + = FunMonoBind fun False{-not infix-} + [ mk_match p e EmptyBinds | (p,e) <-pats_and_exprs ] + mkGeneratedSrcLoc + +mk_match pats expr binds + = foldr PatMatch + (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] binds)) + (map paren pats) where - mk_match (pats, expr) - = foldr PatMatch - (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] EmptyBinds)) - pats + paren p@(VarPatIn _) = p + paren other_p = ParPatIn other_p +\end{code} + +\begin{code} +mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs) \end{code} \begin{code} @@ -877,7 +925,7 @@ compare_Case = compare_gen_Case compare_PN cmp_eq_Expr = compare_gen_Case cmp_eq_PN compare_gen_Case fun lt eq gt a b - = HsCase (HsApp (HsApp (HsVar fun) a) b) {-of-} + = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-} [PatMatch (ConPatIn ltTag_PN []) (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)), @@ -893,9 +941,9 @@ careful_compare_Case ty lt eq gt a b compare_gen_Case compare_PN lt eq gt a b else -- we have to do something special for primitive things... - HsIf (OpApp a (HsVar relevant_eq_op) b) + HsIf (HsPar (OpApp a (HsVar relevant_eq_op) b)) eq - (HsIf (OpApp a (HsVar relevant_lt_op) b) lt gt mkGeneratedSrcLoc) + (HsIf (HsPar (OpApp a (HsVar relevant_lt_op) b)) lt gt mkGeneratedSrcLoc) mkGeneratedSrcLoc where relevant_eq_op = assoc_ty_id eq_op_tbl ty @@ -907,21 +955,23 @@ assoc_ty_id tyids ty where res = [id | (ty',id) <- tyids, eqTy ty ty'] -eq_op_tbl = [ - (charPrimTy, Prel (WiredInId (primOpId CharEqOp))), - (intPrimTy, Prel (WiredInId (primOpId IntEqOp))), - (wordPrimTy, Prel (WiredInId (primOpId WordEqOp))), - (addrPrimTy, Prel (WiredInId (primOpId AddrEqOp))), - (floatPrimTy, Prel (WiredInId (primOpId FloatEqOp))), - (doublePrimTy, Prel (WiredInId (primOpId DoubleEqOp))) ] - -lt_op_tbl = [ - (charPrimTy, Prel (WiredInId (primOpId CharLtOp))), - (intPrimTy, Prel (WiredInId (primOpId IntLtOp))), - (wordPrimTy, Prel (WiredInId (primOpId WordLtOp))), - (addrPrimTy, Prel (WiredInId (primOpId AddrLtOp))), - (floatPrimTy, Prel (WiredInId (primOpId FloatLtOp))), - (doublePrimTy, Prel (WiredInId (primOpId DoubleLtOp))) ] +eq_op_tbl = + [(charPrimTy, eqH_Char_PN) + ,(intPrimTy, eqH_Int_PN) + ,(wordPrimTy, eqH_Word_PN) + ,(addrPrimTy, eqH_Addr_PN) + ,(floatPrimTy, eqH_Float_PN) + ,(doublePrimTy, eqH_Double_PN) + ] + +lt_op_tbl = + [(charPrimTy, ltH_Char_PN) + ,(intPrimTy, ltH_Int_PN) + ,(wordPrimTy, ltH_Word_PN) + ,(addrPrimTy, ltH_Addr_PN) + ,(floatPrimTy, ltH_Float_PN) + ,(doublePrimTy, ltH_Double_PN) + ] ----------------------------------------------------------------------- @@ -932,7 +982,7 @@ append_Expr a b = OpApp a (HsVar append_PN) b ----------------------------------------------------------------------- -eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr +eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr eq_Expr ty a b = if not (isPrimType ty) then OpApp a (HsVar eq_PN) b @@ -946,21 +996,21 @@ eq_Expr ty a b untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr untag_Expr tycon [] expr = expr untag_Expr tycon ((untag_this, put_tag_here) : more) expr - = HsCase (HsApp (con2tag_Expr tycon) (HsVar untag_this)) {-of-} + = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-} [PatMatch (VarPatIn put_tag_here) (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))] mkGeneratedSrcLoc where grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc] -cmp_tags_Expr :: RdrName -- Comparison op - -> RdrName -> RdrName -- Things to compare +cmp_tags_Expr :: RdrName -- Comparison op + -> RdrName -> RdrName -- Things to compare -> RdrNameHsExpr -- What to return if true - -> RdrNameHsExpr -- What to return if false + -> RdrNameHsExpr -- What to return if false -> RdrNameHsExpr cmp_tags_Expr op a b true_case false_case - = HsIf (OpApp (HsVar a) (HsVar op) (HsVar b)) true_case false_case mkGeneratedSrcLoc + = HsIf (HsPar (OpApp (HsVar a) (HsVar op) (HsVar b))) true_case false_case mkGeneratedSrcLoc enum_from_to_Expr :: RdrNameHsExpr -> RdrNameHsExpr @@ -981,26 +1031,29 @@ readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_PN) e1) e2 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr -nested_compose_Expr [e] = e +nested_compose_Expr [e] = parenify e nested_compose_Expr (e:es) - = HsApp (HsApp (HsVar compose_PN) e) (nested_compose_Expr es) + = HsApp (HsApp (HsVar compose_PN) (parenify e)) (nested_compose_Expr es) + +parenify e@(HsVar _) = e +parenify e = HsPar e \end{code} \begin{code} -a_PN = Unk SLIT("a") -b_PN = Unk SLIT("b") -c_PN = Unk SLIT("c") -d_PN = Unk SLIT("d") -ah_PN = Unk SLIT("a#") -bh_PN = Unk SLIT("b#") -ch_PN = Unk SLIT("c#") -dh_PN = Unk SLIT("d#") -cmp_eq_PN = Unk SLIT("cmp_eq") -rangeSize_PN = Unk SLIT("rangeSize") - -as_PNs = [ Unk (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ] -bs_PNs = [ Unk (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ] -cs_PNs = [ Unk (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ] +a_PN = Unqual SLIT("a") +b_PN = Unqual SLIT("b") +c_PN = Unqual SLIT("c") +d_PN = Unqual SLIT("d") +ah_PN = Unqual SLIT("a#") +bh_PN = Unqual SLIT("b#") +ch_PN = Unqual SLIT("c#") +dh_PN = Unqual SLIT("d#") +cmp_eq_PN = Unqual SLIT("cmp_eq") +rangeSize_PN = Unqual SLIT("rangeSize") + +as_PNs = [ Unqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ] +bs_PNs = [ Unqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ] +cs_PNs = [ Unqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ] eq_PN = prelude_method SLIT("Eq") SLIT("==") ne_PN = prelude_method SLIT("Eq") SLIT("/=") @@ -1011,9 +1064,11 @@ gt_PN = prelude_method SLIT("Ord") SLIT(">") max_PN = prelude_method SLIT("Ord") SLIT("max") min_PN = prelude_method SLIT("Ord") SLIT("min") compare_PN = prelude_method SLIT("Ord") SLIT("compare") -ltTag_PN = Prel (WiredInId ltDataCon) -eqTag_PN = Prel (WiredInId eqDataCon) -gtTag_PN = Prel (WiredInId gtDataCon) +minBound_PN = prelude_method SLIT("Bounded") SLIT("minBound") +maxBound_PN = prelude_method SLIT("Bounded") SLIT("maxBound") +ltTag_PN = Unqual SLIT("LT") +eqTag_PN = Unqual SLIT("EQ") +gtTag_PN = Unqual SLIT("GT") enumFrom_PN = prelude_method SLIT("Enum") SLIT("enumFrom") enumFromTo_PN = prelude_method SLIT("Enum") SLIT("enumFromTo") enumFromThen_PN = prelude_method SLIT("Enum") SLIT("enumFromThen") @@ -1028,30 +1083,41 @@ showList_PN = prelude_method SLIT("Show") SLIT("showList") plus_PN = prelude_method SLIT("Num") SLIT("+") times_PN = prelude_method SLIT("Num") SLIT("*") -false_PN = Prel (WiredInId falseDataCon) -true_PN = Prel (WiredInId trueDataCon) -eqH_PN = Prel (WiredInId (primOpId IntEqOp)) -geH_PN = Prel (WiredInId (primOpId IntGeOp)) -leH_PN = Prel (WiredInId (primOpId IntLeOp)) -ltH_PN = Prel (WiredInId (primOpId IntLtOp)) -minusH_PN = Prel (WiredInId (primOpId IntSubOp)) +false_PN = prelude_val pRELUDE SLIT("False") +true_PN = prelude_val pRELUDE SLIT("True") +eqH_Char_PN = prelude_primop CharEqOp +ltH_Char_PN = prelude_primop CharLtOp +eqH_Word_PN = prelude_primop WordEqOp +ltH_Word_PN = prelude_primop WordLtOp +eqH_Addr_PN = prelude_primop AddrEqOp +ltH_Addr_PN = prelude_primop AddrLtOp +eqH_Float_PN = prelude_primop FloatEqOp +ltH_Float_PN = prelude_primop FloatLtOp +eqH_Double_PN = prelude_primop DoubleEqOp +ltH_Double_PN = prelude_primop DoubleLtOp +eqH_Int_PN = prelude_primop IntEqOp +ltH_Int_PN = prelude_primop IntLtOp +geH_PN = prelude_primop IntGeOp +leH_PN = prelude_primop IntLeOp +minusH_PN = prelude_primop IntSubOp and_PN = prelude_val pRELUDE SLIT("&&") not_PN = prelude_val pRELUDE SLIT("not") append_PN = prelude_val pRELUDE_LIST SLIT("++") map_PN = prelude_val pRELUDE_LIST SLIT("map") compose_PN = prelude_val pRELUDE SLIT(".") -mkInt_PN = Prel (WiredInId intDataCon) -error_PN = Prel (WiredInId eRROR_ID) -showSpace_PN = prelude_val pRELUDE_TEXT SLIT("showSpace__") -- not quite std +mkInt_PN = prelude_val pRELUDE_BUILTIN SLIT("I#") +error_PN = prelude_val pRELUDE SLIT("error") showString_PN = prelude_val pRELUDE_TEXT SLIT("showString") showParen_PN = prelude_val pRELUDE_TEXT SLIT("showParen") readParen_PN = prelude_val pRELUDE_TEXT SLIT("readParen") lex_PN = prelude_val pRELUDE_TEXT SLIT("lex") -_showList_PN = prelude_val pRELUDE SLIT("_showList") -_readList_PN = prelude_val pRELUDE SLIT("_readList") +showSpace_PN = prelude_val pRELUDE_TEXT SLIT("__showSpace") +_showList_PN = prelude_val pRELUDE SLIT("__showList") +_readList_PN = prelude_val pRELUDE SLIT("__readList") -prelude_val m s = Imp m s [m] s -prelude_method c o = Imp pRELUDE o [pRELUDE] o -- class not used... +prelude_val m s = Unqual s +prelude_method c o = Unqual o +prelude_primop o = origName (primOpId o) a_Expr = HsVar a_PN b_Expr = HsVar b_PN @@ -1070,47 +1136,23 @@ b_Pat = VarPatIn b_PN c_Pat = VarPatIn c_PN d_Pat = VarPatIn d_PN - con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> RdrName con2tag_PN tycon = let (mod, nm) = moduleNamePair tycon con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#") in - Imp mod con2tag [mod] con2tag + (if fromPrelude mod then Unqual else Qual mod) con2tag tag2con_PN tycon = let (mod, nm) = moduleNamePair tycon tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#") in - Imp mod tag2con [mod] tag2con + (if fromPrelude mod then Unqual else Qual mod) tag2con maxtag_PN tycon = let (mod, nm) = moduleNamePair tycon maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#") in - Imp mod maxtag [mod] maxtag - - -con2tag_FN, tag2con_FN, maxtag_FN :: TyCon -> RnName - -tag2con_FN tycon - = let (mod, nm) = moduleNamePair tycon - tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#") - in - mkFullName mod tag2con InventedInThisModule NotExported mkGeneratedSrcLoc - -maxtag_FN tycon - = let (mod, nm) = moduleNamePair tycon - maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#") - in - mkFullName mod maxtag InventedInThisModule NotExported mkGeneratedSrcLoc - -con2tag_FN tycon - = let (mod, nm) = moduleNamePair tycon - con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#") - in - mkFullName mod con2tag InventedInThisModule NotExported mkGeneratedSrcLoc --} + (if fromPrelude mod then Unqual else Qual mod) maxtag \end{code} - diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index ba69475148..54d2b7a262 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -7,6 +7,8 @@ This module is an extension of @HsSyn@ syntax, for use in the type checker. \begin{code} +#include "HsVersions.h" + module TcHsSyn ( TcIdBndr(..), TcIdOcc(..), @@ -25,13 +27,13 @@ module TcHsSyn ( mkHsTyApp, mkHsDictApp, mkHsTyLam, mkHsDictLam, - tcIdType, + tcIdType, tcIdTyVars, zonkBinds, zonkDictBinds ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} -- friends: import HsSyn -- oodles of it @@ -44,16 +46,15 @@ import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids import Name ( Name{--O only-} ) import TcMonad hiding ( rnMtoTcM ) import TcType ( TcType(..), TcMaybe, TcTyVar(..), - zonkTcTypeToType, zonkTcTyVarToTyVar, - tcInstType + zonkTcTypeToType, zonkTcTyVarToTyVar ) import Usage ( UVar(..) ) import Util ( zipEqual, panic, pprPanic, pprTrace ) import PprType ( GenType, GenTyVar ) -- instances -import Type ( mkTyVarTy ) +import Type ( mkTyVarTy, tyVarsOfType ) import TyVar ( GenTyVar {- instances -}, - TyVarEnv(..), growTyVarEnvList ) -- instances + TyVarEnv(..), growTyVarEnvList, emptyTyVarSet ) import TysWiredIn ( voidTy ) import Unique ( Unique ) -- instances import UniqFM @@ -122,9 +123,10 @@ mkHsDictLam dicts expr = DictLam dicts expr tcIdType :: TcIdOcc s -> TcType s tcIdType (TcId id) = idType id tcIdType (RealId id) = pprPanic "tcIdType:" (ppr PprDebug id) -\end{code} - +tcIdTyVars (TcId id) = tyVarsOfType (idType id) +tcIdTyVars (RealId _) = emptyTyVarSet -- Top level Ids have no free type variables +\end{code} \begin{code} instance Eq (TcIdOcc s) where @@ -396,17 +398,14 @@ zonkExpr te ve (HsIf e1 e2 e3 src_loc) zonkExpr te ve (HsLet binds expr) = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) -> - zonkExpr te new_ve expr `thenNF_Tc` \ new_expr -> + zonkExpr te new_ve expr `thenNF_Tc` \ new_expr -> returnNF_Tc (HsLet new_binds new_expr) zonkExpr te ve (HsDo _ _) = panic "zonkExpr te ve:HsDo" -zonkExpr te ve (HsDoOut stmts m_id mz_id src_loc) +zonkExpr te ve (HsDoOut stmts then_id zero_id src_loc) = zonkStmts te ve stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (HsDoOut new_stmts m_new mz_new src_loc) - where - m_new = zonkIdOcc ve m_id - mz_new = zonkIdOcc ve mz_id + returnNF_Tc (HsDoOut new_stmts (zonkIdOcc ve then_id) (zonkIdOcc ve zero_id) src_loc) zonkExpr te ve (ListComp expr quals) = zonkQuals te ve quals `thenNF_Tc` \ (new_quals, new_ve) -> @@ -558,27 +557,36 @@ zonkQuals te ve (LetQual binds : quals) zonkStmts :: TyVarEnv Type -> IdEnv Id -> [TcStmt s] -> NF_TcM s [TypecheckedStmt] -zonkStmts te ve [] - = returnNF_Tc [] +zonkStmts te ve [] = returnNF_Tc [] + +zonkStmts te ve [ExprStmt expr locn] + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + returnNF_Tc [ExprStmt new_expr locn] -zonkStmts te ve (BindStmt pat expr src_loc : stmts) - = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> - zonkExpr te ve expr `thenNF_Tc` \ new_expr -> +zonkStmts te ve (ExprStmtOut expr locn a b : stmts) + = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + zonkTcTypeToType te a `thenNF_Tc` \ new_a -> + zonkTcTypeToType te b `thenNF_Tc` \ new_b -> + zonkStmts te ve stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (ExprStmtOut new_expr locn new_a new_b : new_stmts) + +zonkStmts te ve (LetStmt binds : stmts) + = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) -> + zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts -> + returnNF_Tc (LetStmt new_binds : new_stmts) + +zonkStmts te ve (BindStmtOut pat expr locn a b : stmts) + = zonkPat te ve pat `thenNF_Tc` \ (new_pat, ids) -> + zonkExpr te ve expr `thenNF_Tc` \ new_expr -> + zonkTcTypeToType te a `thenNF_Tc` \ new_a -> + zonkTcTypeToType te b `thenNF_Tc` \ new_b -> let new_ve = extend_ve ve ids in zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (BindStmt new_pat new_expr src_loc : new_stmts) + returnNF_Tc (BindStmtOut new_pat new_expr locn new_a new_b : new_stmts) -zonkStmts te ve (ExprStmt expr src_loc : stmts) - = zonkExpr te ve expr `thenNF_Tc` \ new_expr -> - zonkStmts te ve stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (ExprStmt new_expr src_loc : new_stmts) -zonkStmts te ve (LetStmt binds : stmts) - = zonkBinds te ve binds `thenNF_Tc` \ (new_binds, new_ve) -> - zonkStmts te new_ve stmts `thenNF_Tc` \ new_stmts -> - returnNF_Tc (LetStmt new_binds : new_stmts) ------------------------------------------------------------------------- zonkRbinds :: TyVarEnv Type -> IdEnv Id diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 9e60168493..7326d93f3b 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -8,7 +8,7 @@ module TcIfaceSig ( tcInterfaceSigs ) where -import Ubiq +IMP_Ubiq() import TcMonad hiding ( rnMtoTcM ) import TcMonoType ( tcPolyType ) @@ -19,6 +19,7 @@ import RnHsSyn ( RenamedSig(..), RnName(..) ) import CmdLineOpts ( opt_CompilingPrelude ) import Id ( mkImported ) --import Name ( Name(..) ) +import Maybes ( maybeToBool ) import Pretty import Util ( panic ) @@ -41,7 +42,8 @@ tcInterfaceSigs :: [RenamedSig] -> TcM s [Id] tcInterfaceSigs [] = returnTc [] -tcInterfaceSigs (Sig name@(RnName full_name) ty pragmas src_loc : sigs) +tcInterfaceSigs (Sig name ty pragmas src_loc : sigs) + | has_full_name = tcAddSrcLoc src_loc ( tcPolyType ty `thenTc` \ sigma_ty -> fixTc ( \ rec_id -> @@ -52,13 +54,19 @@ tcInterfaceSigs (Sig name@(RnName full_name) ty pragmas src_loc : sigs) tcInterfaceSigs sigs `thenTc` \ sigs' -> returnTc (id:sigs') - -tcInterfaceSigs (Sig odd_name _ _ src_loc : sigs) - = case odd_name of + | otherwise -- odd name... + = case name of WiredInId _ | opt_CompilingPrelude -> tcInterfaceSigs sigs _ -> tcAddSrcLoc src_loc $ - failTc (ifaceSigNameErr odd_name) + failTc (ifaceSigNameErr name) + where + has_full_name = maybeToBool full_name_maybe + (Just full_name) = full_name_maybe + full_name_maybe = case name of + RnName fn -> Just fn + RnImplicit fn -> Just fn + _ -> Nothing ifaceSigNameErr name sty = ppHang (ppStr "Bad name in an interface type signature (a Prelude name?)") diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 0f1a61a8ed..80238ffce9 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -9,11 +9,12 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2, - processInstBinds + processInstBinds, + newMethodId ) where -import Ubiq +IMP_Ubiq() import HsSyn ( InstDecl(..), FixityDecl, Sig(..), SpecInstSig(..), HsBinds(..), Bind(..), @@ -33,7 +34,7 @@ import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), import TcMonad hiding ( rnMtoTcM ) -import GenSpecEtc ( checkSigTyVars ) +import GenSpecEtc ( checkSigTyVarsGivenGlobals ) import Inst ( Inst, InstOrigin(..), InstanceMapper(..), newDicts, newMethod, LIE(..), emptyLIE, plusLIE ) import TcBinds ( tcPragmaSigs ) @@ -44,11 +45,11 @@ import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs ) import TcKind ( TcKind, unifyKind ) import TcMatches ( tcMatchesFun ) import TcMonoType ( tcContext, tcMonoTypeKind ) -import TcSimplify ( tcSimplifyAndCheck, tcSimplifyThetas ) +import TcSimplify ( tcSimplifyAndCheck ) import TcType ( TcType(..), TcTyVar(..), - tcInstSigTyVars, tcInstType, tcInstTheta + tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType ) -import Unify ( unifyTauTy ) +import Unify ( unifyTauTy, unifyTauTyLists ) import Bag ( emptyBag, unitBag, unionBags, unionManyBags, @@ -76,9 +77,9 @@ import RnUtils ( RnEnv(..) ) import TyCon ( isSynTyCon, derivedFor ) import Type ( GenType(..), ThetaType(..), mkTyVarTys, splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy, - getTyCon_maybe, maybeBoxedPrimType + getTyCon_maybe, maybeBoxedPrimType, splitRhoTy ) -import TyVar ( GenTyVar, mkTyVarSet ) +import TyVar ( GenTyVar, mkTyVarSet, unionTyVarSets ) import TysWiredIn ( stringTy ) import Unique ( Unique ) import Util ( zipEqual, panic ) @@ -368,7 +369,7 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty let sc_theta' = super_classes `zip` repeat inst_ty' origin = InstanceDeclOrigin - mk_method sel_id = newMethodId sel_id inst_ty' origin locn + mk_method sel_id = newMethodId sel_id inst_ty' origin in -- Create dictionary Ids from the specified instance contexts. newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) -> @@ -447,6 +448,8 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty returnTc (const_lie `plusLIE` spec_lie, inst_binds) \end{code} +============= OLD ================ + @mkMethodId@ manufactures an id for a local method. It's rather turgid stuff, because there are two cases: @@ -473,10 +476,15 @@ It's rather turgid stuff, because there are two cases: So for these we just make a local (non-Inst) id with a suitable type. How disgusting. +=============== END OF OLD =================== \begin{code} -newMethodId sel_id inst_ty origin loc - = let (sel_tyvars,sel_theta,sel_tau) = splitSigmaTy (idType sel_id) +newMethodId sel_id inst_ty origin + = newMethod origin (RealId sel_id) [inst_ty] + + +{- REMOVE SOON: (this was pre-split-poly selector types) +let (sel_tyvars,sel_theta,sel_tau) = splitSigmaTy (idType sel_id) (_:meth_theta) = sel_theta -- The local theta is all except the -- first element of the context in @@ -493,6 +501,7 @@ newMethodId sel_id inst_ty origin loc `thenNF_Tc` \ method_ty -> newLocalId (getLocalName sel_id) method_ty `thenNF_Tc` \ meth_id -> returnNF_Tc (emptyLIE, meth_id) +-} \end{code} The next function makes a default method which calls the global default method, at @@ -511,22 +520,13 @@ makeInstanceDeclDefaultMethodExpr -> NF_TcM s (TcExpr s) makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag - = newDicts origin op_theta `thenNF_Tc` \ (op_lie,op_dicts) -> - - -- def_op_id = /\ op_tyvars -> \ op_dicts -> - -- defm_id inst_ty op_tyvars this_dict op_dicts - returnNF_Tc ( - mkHsTyLam op_tyvars ( - mkHsDictLam op_dicts ( - mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) - (inst_ty : mkTyVarTys op_tyvars)) - (this_dict : op_dicts) - ))) + = + -- def_op_id = defm_id inst_ty this_dict + returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) [inst_ty]) [this_dict]) where idx = tag - 1 meth_id = meth_ids !! idx defm_id = defm_ids !! idx - (op_tyvars, op_theta, op_tau) = splitSigmaTy (tcIdType meth_id) makeInstanceDeclNoDefaultExpr :: InstOrigin s @@ -539,23 +539,19 @@ makeInstanceDeclNoDefaultExpr -> NF_TcM s (TcExpr s) makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag - = newDicts origin op_theta `thenNF_Tc` \ (op_lie, op_dicts) -> - + = -- Produce a warning if the default instance method -- has been omitted when one exists in the class warnTc (not err_defm_ok) (omitDefaultMethodWarn clas_op clas_name inst_ty) `thenNF_Tc_` - returnNF_Tc (mkHsTyLam op_tyvars ( - mkHsDictLam op_dicts ( - HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [op_tau]) - (HsLitOut (HsString (_PK_ error_msg)) stringTy)))) + returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [tcIdType meth_id]) + (HsLitOut (HsString (_PK_ error_msg)) stringTy)) where idx = tag - 1 meth_id = meth_ids !! idx clas_op = (classOps clas) !! idx defm_id = defm_ids !! idx - (op_tyvars,op_theta,op_tau) = splitSigmaTy (tcIdType meth_id) Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id @@ -666,16 +662,12 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids mbind let tag = classOpTagByString clas occ method_id = method_ids !! (tag-1) + method_ty = tcIdType method_id in - -- The "method" might be a RealId, when processInstBinds is used by - -- TcClassDcls:buildDefaultMethodBinds to make default-method bindings - (case method_id of - TcId id -> returnNF_Tc (idType id) - RealId id -> tcInstType [] (idType id) - ) `thenNF_Tc` \ method_ty -> + tcInstTcType method_ty `thenNF_Tc` \ (method_tyvars, method_rho) -> let - (method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty + (method_theta, method_tau) = splitRhoTy method_rho in newDicts origin method_theta `thenNF_Tc` \ (method_dicts,method_dict_ids) -> @@ -694,10 +686,17 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids mbind -- The latter is needed just so we can return an AbsBinds wrapped -- up inside a MonoBinds. + + -- Make the method_tyvars into signature tyvars so they + -- won't get unified with anything. + tcInstSigTyVars method_tyvars `thenNF_Tc` \ (sig_tyvars, sig_tyvar_tys, _) -> + unifyTauTyLists (mkTyVarTys method_tyvars) sig_tyvar_tys `thenTc_` + newLocalId occ method_tau `thenNF_Tc` \ local_id -> newLocalId occ method_ty `thenNF_Tc` \ copy_id -> let - inst_method_tyvars = inst_tyvars ++ method_tyvars + inst_tyvar_set = mkTyVarSet inst_tyvars + inst_method_tyvar_set = inst_tyvar_set `unionTyVarSets` (mkTyVarSet sig_tyvars) in -- Typecheck the method tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) -> @@ -712,12 +711,17 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids mbind -- Here we must simplify constraints on "a" to catch all -- the Bar-ish things. tcAddErrCtxt (methodSigCtxt op method_ty) ( + checkSigTyVarsGivenGlobals + inst_tyvar_set + sig_tyvars method_tau `thenTc_` + tcSimplifyAndCheck - (mkTyVarSet inst_method_tyvars) + inst_method_tyvar_set (method_dicts `plusLIE` avail_insts) lieIop ) `thenTc` \ (f_dicts, dict_binds) -> + returnTc ([tag], f_dicts, VarMonoBind method_id @@ -926,8 +930,8 @@ scrutiniseInstanceType from_here clas inst_tau -- A user declaration of a CCallable/CReturnable instance -- must be for a "boxed primitive" type. isCcallishClass clas - && not opt_CompilingPrelude -- which allows anything - && maybeToBool (maybeBoxedPrimType inst_tau) +-- && not opt_CompilingPrelude -- which allows anything + && not (maybeToBool (maybeBoxedPrimType inst_tau)) = failTc (nonBoxedPrimCCallErr clas inst_tau) | otherwise diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index b41b4ea943..04717e3605 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -14,7 +14,7 @@ module TcInstUtil ( buildInstanceEnvs ) where -import Ubiq +IMP_Ubiq() import HsSyn ( MonoBinds, Fake, InPat, Sig ) import RnHsSyn ( RenamedMonoBinds(..), RenamedSig(..), @@ -219,7 +219,7 @@ addClassInstance addClassInstance (class_inst_env, op_spec_envs) - (InstInfo clas inst_tyvars inst_ty inst_decl_theta dfun_theta + (InstInfo clas inst_tyvars inst_ty _ _ dfun_id const_meth_ids _ _ _ src_loc _) = diff --git a/ghc/compiler/typecheck/TcKind.lhs b/ghc/compiler/typecheck/TcKind.lhs index 5e7becfa5c..5f669078ad 100644 --- a/ghc/compiler/typecheck/TcKind.lhs +++ b/ghc/compiler/typecheck/TcKind.lhs @@ -1,4 +1,6 @@ \begin{code} +#include "HsVersions.h" + module TcKind ( Kind, mkTypeKind, mkBoxedTypeKind, mkUnboxedTypeKind, mkArrowKind, @@ -14,7 +16,7 @@ module TcKind ( tcDefaultKind -- TcKind s -> NF_TcM s Kind ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Kind import TcMonad hiding ( rnMtoTcM ) diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 87628cf432..fed6045d7c 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -8,7 +8,7 @@ module TcMatches ( tcMatchesFun, tcMatchesCase, tcMatch ) where -import Ubiq +IMP_Ubiq() import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat, HsExpr, HsBinds, OutPat, Fake, @@ -19,7 +19,7 @@ import TcHsSyn ( TcIdOcc(..), TcMatch(..) ) import TcMonad hiding ( rnMtoTcM ) import Inst ( Inst, LIE(..), plusLIE ) import TcEnv ( newMonoIds ) -import TcLoop ( tcGRHSsAndBinds ) +IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds ) import TcPat ( tcPat ) import TcType ( TcType(..), TcMaybe, zonkTcType ) import Unify ( unifyTauTy, unifyTauTyList ) diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 006777ac1a..1dd4a4297d 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -11,12 +11,11 @@ module TcModule ( TcResults(..), TcResultBinds(..), TcIfaceInfo(..), - TcLocalTyConsAndClasses(..), TcSpecialiseRequests(..), TcDDumpDeriv(..) ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr, TyDecl, SpecDataSig, ClassDecl, InstDecl, @@ -45,13 +44,13 @@ import TcTyDecls ( mkDataBinds ) import Bag ( listToBag ) import Class ( GenClass, classSelIds ) import ErrUtils ( Warning(..), Error(..) ) -import Id ( GenId, isDataCon, isMethodSelId, idType, IdEnv(..), nullIdEnv ) +import Id ( idType, isMethodSelId, isTopLevId, GenId, IdEnv(..), nullIdEnv ) import Maybes ( catMaybes ) import Name ( isExported, isLocallyDefined ) import Pretty import RnUtils ( RnEnv(..) ) -import TyCon ( isDataTyCon, TyCon ) -import Type ( mkSynTy ) +import TyCon ( TyCon ) +import Type ( applyTyCon ) import TysWiredIn ( unitTy, mkPrimIoTy ) import TyVar ( TyVarEnv(..), nullTyVarEnv ) import Unify ( unifyTauTy ) @@ -70,7 +69,6 @@ Outside-world interface: type TcResults = (TcResultBinds, TcIfaceInfo, - TcLocalTyConsAndClasses, TcSpecialiseRequests, TcDDumpDeriv) @@ -87,10 +85,6 @@ type TcResultBinds type TcIfaceInfo -- things for the interface generator = ([Id], [TyCon], [Class], Bag InstInfo) -type TcLocalTyConsAndClasses -- things defined in this module - = ([TyCon], [Class]) - -- not sure the classes are used at all (ToDo) - type TcSpecialiseRequests = FiniteMap TyCon [(Bool, [Maybe Type])] -- source tycon specialisation requests @@ -242,22 +236,20 @@ tcModule rn_env let localids = getEnv_LocalIds final_env - tycons = getEnv_TyCons final_env - classes = getEnv_Classes final_env + tycons = getEnv_TyCons final_env + classes = getEnv_Classes final_env - local_tycons = [ tc | tc <- tycons, isLocallyDefined tc && isDataTyCon tc ] + local_tycons = filter isLocallyDefined tycons local_classes = filter isLocallyDefined classes - exported_ids' = filter isExported (eltsUFM ve2) - in - + local_vals = [ v | v <- eltsUFM ve2, isLocallyDefined v && isTopLevId v ] + -- the isTopLevId is doubtful... + in -- FINISHED AT LAST returnTc ( (data_binds', cls_binds', inst_binds', val_binds', const_insts'), -- the next collection is just for mkInterface - (exported_ids', tycons, classes, inst_info), - - (local_tycons, local_classes), + (local_vals, local_tycons, local_classes, inst_info), tycon_specs, @@ -267,7 +259,6 @@ tcModule rn_env ty_decls_bag = listToBag ty_decls cls_decls_bag = listToBag cls_decls inst_decls_bag = listToBag inst_decls - \end{code} @@ -294,7 +285,7 @@ checkTopLevelIds mod final_env case (maybe_main, maybe_prim) of (Just main, Nothing) -> tcAddErrCtxt mainCtxt $ - unifyTauTy (mkSynTy io_tc [unitTy]) + unifyTauTy (applyTyCon io_tc [unitTy]) (idType main) (Nothing, Just prim) -> tcAddErrCtxt primCtxt $ diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 876564daad..b5853aa544 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -1,4 +1,6 @@ \begin{code} +#include "HsVersions.h" + module TcMonad( TcM(..), NF_TcM(..), TcDown, TcEnv, SST_R, FSST_R, @@ -33,9 +35,9 @@ module TcMonad( MutableVar(..), _MutableArray ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} -import TcMLoop ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env +IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env import Type ( Type(..), GenType ) import TyVar ( TyVar(..), GenTyVar ) @@ -44,12 +46,14 @@ import ErrUtils ( Error(..), Message(..), ErrCtxt(..), Warning(..) ) import SST -import RnMonad ( RnM(..), RnDown, initRn, setExtraRn ) +import RnMonad ( RnM(..), RnDown, initRn, setExtraRn, + returnRn, thenRn, getImplicitUpRn + ) import RnUtils ( RnEnv(..) ) import Bag ( Bag, emptyBag, isEmptyBag, foldBag, unitBag, unionBags, snocBag ) -import FiniteMap ( FiniteMap, emptyFM ) +import FiniteMap ( FiniteMap, emptyFM, isEmptyFM ) --import Outputable ( Outputable(..), NamedThing(..), ExportFlag ) import ErrUtils ( Error(..) ) import Maybes ( MaybeErr(..) ) @@ -459,7 +463,18 @@ rnMtoTcM rn_env rn_action down env writeMutVarSST u_var new_uniq_supply `thenSST_` let (rn_result, rn_errs, rn_warns) - = initRn True (panic "rnMtoTcM:module") rn_env uniq_s rn_action + = initRn False{-*interface* mode! so we can see the builtins-} + (panic "rnMtoTcM:module") + rn_env uniq_s ( + rn_action `thenRn` \ result -> + + -- Though we are in "interface mode", we must + -- not have added anything to the ImplicitEnv! + getImplicitUpRn `thenRn` \ implicit_env@(v_env,tc_env) -> + if (isEmptyFM v_env && isEmptyFM tc_env) + then returnRn result + else panic "rnMtoTcM: non-empty ImplicitEnv!" + ) in returnSST (rn_result, rn_errs) where diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index eee6f125e1..dfa3e597eb 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -8,7 +8,7 @@ module TcMonoType ( tcPolyType, tcMonoType, tcMonoTypeKind, tcContext ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import HsSyn ( PolyType(..), MonoType(..), Fake ) import RnHsSyn ( RenamedPolyType(..), RenamedMonoType(..), @@ -31,7 +31,7 @@ import Type ( GenType, Type(..), ThetaType(..), import TyVar ( GenTyVar, TyVar(..), mkTyVar ) import Type ( mkDictTy ) import Class ( cCallishClassKeys ) -import TyCon ( TyCon, Arity(..) ) +import TyCon ( TyCon ) import TysWiredIn ( mkListTy, mkTupleTy ) import Unique ( Unique ) import PprStyle diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 0c8470cbd1..b857bb00f0 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -8,7 +8,7 @@ module TcPat ( tcPat ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..), Match, HsBinds, Qual, PolyType, @@ -23,7 +23,7 @@ import Inst ( Inst, OverloadedLit(..), InstOrigin(..), ) import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupLocalValueOK ) -import TcType ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys, tcInstId ) +import TcType ( TcType(..), TcMaybe, newTyVarTy, newTyVarTys, tcInstId ) import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) import Bag ( Bag ) diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index fcde43dc7f..21f45479df 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % \section[TcSimplify]{TcSimplify} @@ -12,7 +12,7 @@ module TcSimplify ( bindInstsOfLocalFuns ) where -import Ubiq +IMP_Ubiq() import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit, Match, HsBinds, Qual, PolyType, ArithSeqInfo, @@ -21,10 +21,13 @@ import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcExpr(..), TcMonoBinds(..) ) import TcMonad hiding ( rnMtoTcM ) import Inst ( lookupInst, lookupSimpleInst, - tyVarsOfInst, isTyVarDict, isDict, matchesInst, - instToId, instBindingRequired, instCanBeGeneralised, newDictsAtLoc, - Inst(..), LIE(..), zonkLIE, emptyLIE, plusLIE, unitLIE, consLIE, - InstOrigin(..), OverloadedLit ) + tyVarsOfInst, isTyVarDict, isDict, + matchesInst, instToId, instBindingRequired, + instCanBeGeneralised, newDictsAtLoc, + pprInst, + Inst(..), LIE(..), zonkLIE, emptyLIE, + plusLIE, unitLIE, consLIE, InstOrigin(..), + OverloadedLit ) import TcEnv ( tcGetGlobalTyVars ) import TcType ( TcType(..), TcTyVar(..), TcTyVarSet(..), TcMaybe, tcInstType ) import Unify ( unifyTauTy ) @@ -378,7 +381,7 @@ elimTyCons squash_consts is_free_tv givens wanteds %************************************************************************ %* * \subsection[elimSCs]{@elimSCs@} -%* 2 * +%* * %************************************************************************ \begin{code} @@ -554,7 +557,10 @@ elimSCsSimple givens (c_t@(clas,ty) : rest) where rest' = elimSCsSimple rest (c1,t1) `subsumes` (c2,t2) = t1 `eqSimpleTy` t2 && - maybeToBool (c2 `isSuperClassOf` c1) + (c1 == c2 || maybeToBool (c2 `isSuperClassOf` c1)) +-- We deal with duplicates here ^^^^^^^^ +-- It's a simple place to do it, although it's done in elimTyCons in the +-- full-blown version of the simpifier. \end{code} %************************************************************************ @@ -668,8 +674,6 @@ the most common use of defaulting is code like: \end{verbatim} Since we're not using the result of @foo@, the result if (presumably) @void@. -WDP Comment: no such thing as voidTy; so not quite in yet (94/07). -SLPJ comment: since \begin{code} disambigOne :: [SimpleDictInfo s] -> TcM s () @@ -740,8 +744,7 @@ genCantGenErr insts sty -- Can't generalise these Insts \begin{code} ambigErr insts sty - = ppHang (ppStr "Ambiguous overloading") - 4 (ppAboves (map (ppr sty) insts)) + = ppAboves (map (pprInst sty "Ambiguous overloading") insts) \end{code} @reduceErr@ complains if we can't express required dictionaries in @@ -749,10 +752,8 @@ terms of the signature. \begin{code} reduceErr insts sty - = ppHang (ppStr "Type signature lacks context required by inferred type") - 4 (ppHang (ppStr "Context reqd: ") - 4 (ppAboves (map (ppr sty) (bagToList insts))) - ) + = ppAboves (map (pprInst sty "Context required by inferred type, but missing on a type signature") + (bagToList insts)) \end{code} \begin{code} @@ -760,7 +761,7 @@ defaultErr dicts defaulting_tys sty = ppHang (ppStr "Ambiguously-overloaded types could not be resolved:") 4 (ppAboves [ ppHang (ppStr "Conflicting:") - 4 (ppInterleave ppSemi (map (ppr sty) dicts)), + 4 (ppInterleave ppSemi (map (pprInst sty ""{-???-}) dicts)), ppHang (ppStr "Defaulting types :") 4 (ppr sty defaulting_tys), ppStr "([Int, Double] is the default list of defaulting types.)" ]) diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 495c0a5fec..680753e2c6 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -10,7 +10,7 @@ module TcTyClsDecls ( tcTyAndClassDecls1 ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), ClassDecl(..), MonoType(..), PolyType(..), @@ -39,9 +39,9 @@ import UniqSet ( UniqSet(..), emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, uniqSetToList ) import SrcLoc ( SrcLoc ) -import TyCon ( TyCon, tyConDataCons, isDataTyCon, isSynTyCon ) +import TyCon ( TyCon ) import Unique ( Unique ) -import Util ( panic, pprTrace ) +import Util ( panic{-, pprTrace-} ) \end{code} diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index e248b90d0e..47649c76bb 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -12,7 +12,7 @@ module TcTyDecls ( mkDataBinds ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..), Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..), @@ -250,7 +250,6 @@ mkConstructor con_id checkTc (null eval_theta') (missingEvalErr con_id eval_theta') `thenTc_` - -- Build the data constructor let con_rhs = mkHsTyLam tc_tyvars $ diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 0a602c731c..b386d1ade2 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -1,4 +1,6 @@ \begin{code} +#include "HsVersions.h" + module TcType ( TcTyVar(..), @@ -18,13 +20,15 @@ module TcType ( tcReadTyVar, -- :: TcTyVar s -> NF_TcM (TcMaybe s) - tcInstTyVars, -- TyVar -> NF_TcM s (TcTyVar s) + tcInstTyVars, tcInstSigTyVars, - tcInstType, tcInstTheta, tcInstId, + tcInstType, tcInstSigType, tcInstTcType, + tcInstTheta, tcInstId, zonkTcTyVars, zonkTcType, zonkTcTypeToType, + zonkTcTyVar, zonkTcTyVarToTyVar ) where @@ -34,10 +38,12 @@ module TcType ( -- friends: import Type ( Type(..), ThetaType(..), GenType(..), tyVarsOfTypes, getTyVar_maybe, - splitForAllTy, splitRhoTy + splitForAllTy, splitRhoTy, + mkForAllTys, instantiateTy ) import TyVar ( TyVar(..), GenTyVar(..), TyVarSet(..), GenTyVarSet(..), - TyVarEnv(..), lookupTyVarEnv, addOneToTyVarEnv, mkTyVarEnv, + TyVarEnv(..), lookupTyVarEnv, addOneToTyVarEnv, + nullTyVarEnv, mkTyVarEnv, tyVarSetToList ) @@ -51,11 +57,11 @@ import Usage ( Usage(..), GenUsage, UVar(..), duffUsage ) import TysWiredIn ( voidTy ) -import Ubiq +IMP_Ubiq() import Unique ( Unique ) import UniqFM ( UniqFM ) import Maybes ( assocMaybe ) -import Util ( zipEqual, nOfThem, panic, pprPanic ) +import Util ( zipEqual, nOfThem, panic, pprPanic, pprTrace{-ToDo:rm-} ) import Outputable ( Outputable(..) ) -- Debugging messages import PprType ( GenTyVar, GenType ) @@ -121,15 +127,14 @@ newTyVarTys :: Int -> Kind -> NF_TcM s [TcType s] newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind) - -- For signature type variables, mark them as "DontBind" tcInstTyVars, tcInstSigTyVars :: [GenTyVar flexi] -> NF_TcM s ([TcTyVar s], [TcType s], [(GenTyVar flexi, TcType s)]) + tcInstTyVars tyvars = inst_tyvars UnBound tyvars tcInstSigTyVars tyvars = inst_tyvars DontBind tyvars - inst_tyvars initial_cts tyvars = mapNF_Tc (inst_tyvar initial_cts) tyvars `thenNF_Tc` \ tc_tyvars -> let @@ -143,24 +148,44 @@ inst_tyvar initial_cts (TyVar _ kind name _) returnNF_Tc (TyVar uniq kind name box) \end{code} -@tcInstType@ and @tcInstTcType@ both create a fresh instance of a +@tcInstType@ and @tcInstSigType@ both create a fresh instance of a type, returning a @TcType@. All inner for-alls are instantiated with fresh TcTyVars. -There are two versions, one for instantiating a @Type@, and one for a @TcType@. -The former must instantiate everything; all tyvars must be bound either -by a forall or by an environment passed in. The latter can do some sharing, -and is happy with free tyvars (which is vital when instantiating the type -of local functions). In the future @tcInstType@ may try to be clever about not -instantiating constant sub-parts. +The difference is that tcInstType instantiates all forall'd type +variables (and their bindees) with UnBound type variables, whereas +tcInstSigType instantiates them with DontBind types variables. +@tcInstSigType@ also doesn't take an environment. + +On the other hand, @tcInstTcType@ instantiates a TcType. It uses +instantiateTy which could take advantage of sharing some day. \begin{code} +tcInstTcType :: TcType s -> NF_TcM s ([TcTyVar s], TcType s) +tcInstTcType ty + = case tyvars of + [] -> returnNF_Tc ([], ty) -- Nothing to do + other -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) -> + returnNF_Tc (tyvars', instantiateTy tenv rho) + where + (tyvars, rho) = splitForAllTy ty + tcInstType :: [(GenTyVar flexi,TcType s)] -> GenType (GenTyVar flexi) UVar -> NF_TcM s (TcType s) tcInstType tenv ty_to_inst = tcConvert bind_fn occ_fn (mkTyVarEnv tenv) ty_to_inst where + bind_fn = inst_tyvar UnBound + occ_fn env tyvar = case lookupTyVarEnv env tyvar of + Just ty -> returnNF_Tc ty + Nothing -> pprPanic "tcInstType:" (ppAboves [ppr PprDebug ty_to_inst, + ppr PprDebug tyvar]) + +tcInstSigType :: GenType (GenTyVar flexi) UVar -> NF_TcM s (TcType s) +tcInstSigType ty_to_inst + = tcConvert bind_fn occ_fn nullTyVarEnv ty_to_inst + where bind_fn = inst_tyvar DontBind occ_fn env tyvar = case lookupTyVarEnv env tyvar of Just ty -> returnNF_Tc ty @@ -168,9 +193,15 @@ tcInstType tenv ty_to_inst ppr PprDebug tyvar]) zonkTcTyVarToTyVar :: TcTyVar s -> NF_TcM s TyVar -zonkTcTyVarToTyVar tyvar - = zonkTcTyVar tyvar `thenNF_Tc` \ (TyVarTy tyvar') -> - returnNF_Tc (tcTyVarToTyVar tyvar') +zonkTcTyVarToTyVar tv + = zonkTcTyVar tv `thenNF_Tc` \ tv_ty -> + case tv_ty of -- Should be a tyvar! + + TyVarTy tv' -> returnNF_Tc (tcTyVarToTyVar tv') + + _ -> pprTrace "zonkTcTyVarToTyVar:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $ + returnNF_Tc (tcTyVarToTyVar tv) + zonkTcTypeToType :: TyVarEnv Type -> TcType s -> NF_TcM s Type zonkTcTypeToType env ty @@ -331,9 +362,14 @@ zonkTcType (SynTy tc tys ty) returnNF_Tc (SynTy tc tys' ty') zonkTcType (ForAllTy tv ty) - = zonkTcTyVar tv `thenNF_Tc` \ (TyVarTy tv') -> -- Should be a tyvar! + = zonkTcTyVar tv `thenNF_Tc` \ tv_ty -> zonkTcType ty `thenNF_Tc` \ ty' -> - returnNF_Tc (ForAllTy tv' ty') + case tv_ty of -- Should be a tyvar! + TyVarTy tv' -> + returnNF_Tc (ForAllTy tv' ty') + _ -> pprTrace "zonkTcType:ForAllTy:" (ppCat [ppr PprDebug tv, ppr PprDebug tv_ty]) $ + + returnNF_Tc (ForAllTy tv{-(tcTyVarToTyVar tv)-} ty') zonkTcType (ForAllUsageTy uv uvs ty) = panic "zonk:ForAllUsageTy" diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs index 39c27f3239..77742f4db5 100644 --- a/ghc/compiler/typecheck/Unify.lhs +++ b/ghc/compiler/typecheck/Unify.lhs @@ -11,7 +11,7 @@ updatable substitution). module Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) where -import Ubiq +IMP_Ubiq() -- friends: import TcMonad hiding ( rnMtoTcM ) @@ -229,15 +229,24 @@ uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) case (maybe_ty1, maybe_ty2) of (_, BoundTo ty2') -> uUnboundVar tv1 maybe_ty1 ty2' ty2' - (DontBind,DontBind) - -> failTc (unifyDontBindErr tv1 ps_ty2) - (UnBound, _) | kind2 `hasMoreBoxityInfo` kind1 -> tcWriteTyVar tv1 ty2 `thenNF_Tc_` returnTc () (_, UnBound) | kind1 `hasMoreBoxityInfo` kind2 -> tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc () +-- TEMPORARY FIX +-- (DontBind,DontBind) +-- -> failTc (unifyDontBindErr tv1 ps_ty2) + +-- TEMPORARILY allow two type-sig variables to be bound together. +-- See notes in tcCheckSigVars + (DontBind,DontBind) | kind2 `hasMoreBoxityInfo` kind1 + -> tcWriteTyVar tv1 ty2 `thenNF_Tc_` returnTc () + + | kind1 `hasMoreBoxityInfo` kind2 + -> tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc () + other -> failTc (unifyKindErr tv1 ps_ty2) -- Second one isn't a type variable diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 0cf92a5ad8..2a38d47ca2 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -16,7 +16,8 @@ module Class ( isSuperClassOf, classOpTagByString, - derivableClassKeys, cCallishClassKeys, + derivableClassKeys, needsDataDeclCtxtClassKeys, + cCallishClassKeys, isNoDictClass, isNumericClass, isStandardClass, isCcallishClass, GenClassOp(..), ClassOp(..), @@ -29,7 +30,7 @@ module Class ( CHK_Ubiq() -- debugging consistency check -import TyLoop +IMPORT_DELOOPER(TyLoop) import TyCon ( TyCon ) import TyVar ( TyVar(..), GenTyVar ) @@ -191,25 +192,33 @@ isNumericClass (Class key _ _ _ _ _ _ _ _ _) = --pprTrace "isNum:" (ppCat (map key `is_elem` numericClassKeys isStandardClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys isCcallishClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` cCallishClassKeys +isNoDictClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` noDictClassKeys is_elem = isIn "is_X_Class" numericClassKeys - = [ numClassKey, - realClassKey, - integralClassKey, - fractionalClassKey, - floatingClassKey, - realFracClassKey, - realFloatClassKey ] + = [ numClassKey + , realClassKey + , integralClassKey + , fractionalClassKey + , floatingClassKey + , realFracClassKey + , realFloatClassKey + ] derivableClassKeys - = [ eqClassKey, - showClassKey, - ordClassKey, - boundedClassKey, - enumClassKey, - ixClassKey, - readClassKey ] + = [ eqClassKey + , ordClassKey + , enumClassKey + , evalClassKey + , boundedClassKey + , showClassKey + , readClassKey + , ixClassKey + ] + +needsDataDeclCtxtClassKeys -- see comments in TcDeriv + = [ readClassKey + ] cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ] @@ -222,6 +231,16 @@ standardClassKeys -- _ccall_ foo ... 93{-numeric literal-} ... -- -- ... it can do The Right Thing on the 93. + +noDictClassKeys -- These classes are used only for type annotations; + -- they are not implemented by dictionaries, ever. + = cCallishClassKeys + -- I used to think that class Eval belonged in here, but + -- we really want functions with type (Eval a => ...) and that + -- means that we really want to pass a placeholder for an Eval + -- dictionary. The unit tuple is what we'll get if we leave things + -- alone, and that'll do for now. Could arrange to drop that parameter + -- in the end. \end{code} %************************************************************************ diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs index 249ad6c76b..ab77d19805 100644 --- a/ghc/compiler/types/Kind.lhs +++ b/ghc/compiler/types/Kind.lhs @@ -17,10 +17,11 @@ module Kind ( hasMoreBoxityInfo, resultKind, argKind, - isUnboxedKind, isTypeKind + isUnboxedKind, isTypeKind, + notArrowKind ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Util ( panic, assertPanic ) --import Outputable ( Outputable(..) ) @@ -66,7 +67,6 @@ kind1@(ArrowKind _ _) `hasMoreBoxityInfo` kind2@(ArrowKind _ _) = ASSERT( kind1 kind1 `hasMoreBoxityInfo` kind2 = False --- Not exported notArrowKind (ArrowKind _ _) = False notArrowKind other_kind = True diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 472060547c..eb6ed43bdc 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -19,14 +19,14 @@ module PprType( GenClass, GenClassOp, pprGenClassOp, - addTyVar, nmbrTyVar, + addTyVar{-ToDo:don't export-}, nmbrTyVar, addUVar, nmbrUsage, nmbrType, nmbrTyCon, nmbrClass ) where -import Ubiq -import IdLoop -- for paranoia checking -import TyLoop -- for paranoia checking +IMP_Ubiq() +IMPORT_DELOOPER(IdLoop) -- for paranoia checking +IMPORT_DELOOPER(TyLoop) -- for paranoia checking -- friends: -- (PprType can see all the representations it's trying to print) @@ -289,9 +289,9 @@ showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon) pprTyCon :: PprStyle -> TyCon -> Pretty -pprTyCon sty FunTyCon = ppStr "(->)" -pprTyCon sty (TupleTyCon _ name _) = ppr sty name -pprTyCon sty (PrimTyCon uniq name kind) = ppr sty name +pprTyCon sty FunTyCon = ppStr "(->)" +pprTyCon sty (TupleTyCon _ name _) = ppr sty name +pprTyCon sty (PrimTyCon _ name _ _) = ppr sty name pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd) = ppr sty name @@ -455,7 +455,13 @@ addTyVar, nmbrTyVar :: TyVar -> NmbrM TyVar addTyVar tv@(TyVar u k maybe_name use) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) = --pprTrace "addTyVar:" (ppCat [pprUnique u, pprUnique ut]) $ case (lookupUFM_Directly tvenv u) of - Just xx -> pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $ + Just xx -> -- pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $ + -- (It gets triggered when we do a datatype: first we + -- "addTyVar" the tyvars for the datatype as a whole; + -- we will subsequently "addId" the data cons, including + -- the type for each of them -- each of which includes + -- _forall_ ...tvs..., which we will addTyVar. + -- Harmless, if that's all that happens.... (nenv, xx) Nothing -> let @@ -480,9 +486,9 @@ nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) nmbrTyCon : only called from ``top-level'', if you know what I mean. \begin{code} -nmbrTyCon tc@FunTyCon = returnNmbr tc -nmbrTyCon tc@(TupleTyCon _ _ _) = returnNmbr tc -nmbrTyCon tc@(PrimTyCon _ _ _) = returnNmbr tc +nmbrTyCon tc@FunTyCon = returnNmbr tc +nmbrTyCon tc@(TupleTyCon _ _ _) = returnNmbr tc +nmbrTyCon tc@(PrimTyCon _ _ _ _) = returnNmbr tc nmbrTyCon (DataTyCon u n k tvs theta cons clss nod) = --pprTrace "nmbrDataTyCon:" (ppCat (map (ppr PprDebug) tvs)) $ diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index b983664863..be4eccd029 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -28,7 +28,9 @@ module TyCon( tyConDataCons, tyConFamilySize, tyConDerivings, - tyConArity, synTyConArity, + tyConTheta, + tyConPrimRep, + synTyConArity, getSynTyConDefn, maybeTyConSingleCon, @@ -38,10 +40,10 @@ module TyCon( CHK_Ubiq() -- debugging consistency check -import TyLoop ( Type(..), GenType, +IMPORT_DELOOPER(TyLoop) ( Type(..), GenType, Class(..), GenClass, Id(..), GenId, - mkTupleCon, dataConSig, + mkTupleCon, isNullaryDataCon, specMaybeTysSuffix ) @@ -55,6 +57,7 @@ import Name ( Name, RdrName(..), appendRdr, nameUnique, ) import Unique ( Unique, funTyConKey, mkTupleTyConUnique ) import Pretty ( Pretty(..), PrettyRep ) +import PrimRep ( PrimRep(..) ) import SrcLoc ( SrcLoc, mkBuiltinSrcLoc ) import Util ( panic, panic#, pprPanic{-ToDo:rm-}, nOfThem, isIn, Ord3(..) ) import {-hide me-} @@ -91,6 +94,7 @@ data TyCon Unique -- Always unboxed; hence never represented by a closure Name -- Often represented by a bit-pattern for the thing Kind -- itself (eg Int#), but sometimes by a pointer to + PrimRep | SpecTyCon -- A specialised TyCon; eg (Arr# Int#), or (List Int#) TyCon @@ -138,7 +142,7 @@ mkSynTyCon name isFunTyCon FunTyCon = True isFunTyCon _ = False -isPrimTyCon (PrimTyCon _ _ _) = True +isPrimTyCon (PrimTyCon _ _ _ _) = True isPrimTyCon _ = False -- At present there are no unboxed non-primitive types, so @@ -166,7 +170,7 @@ kind2 = mkBoxedTypeKind `mkArrowKind` kind1 tyConKind :: TyCon -> Kind tyConKind FunTyCon = kind2 tyConKind (DataTyCon _ _ kind _ _ _ _ _) = kind -tyConKind (PrimTyCon _ _ kind) = kind +tyConKind (PrimTyCon _ _ kind _) = kind tyConKind (SynTyCon _ _ k _ _ _) = k tyConKind (TupleTyCon _ _ n) @@ -191,18 +195,10 @@ tyConUnique :: TyCon -> Unique tyConUnique FunTyCon = funTyConKey tyConUnique (DataTyCon uniq _ _ _ _ _ _ _) = uniq tyConUnique (TupleTyCon uniq _ _) = uniq -tyConUnique (PrimTyCon uniq _ _) = uniq +tyConUnique (PrimTyCon uniq _ _ _) = uniq tyConUnique (SynTyCon uniq _ _ _ _ _) = uniq tyConUnique (SpecTyCon _ _ ) = panic "tyConUnique:SpecTyCon" -tyConArity :: TyCon -> Arity -tyConArity FunTyCon = 2 -tyConArity (DataTyCon _ _ _ tvs _ _ _ _) = length tvs -tyConArity (TupleTyCon _ _ arity) = arity -tyConArity (PrimTyCon _ _ _) = 0 -- ?? -tyConArity (SpecTyCon _ _) = 0 -tyConArity (SynTyCon _ _ _ arity _ _) = arity - synTyConArity :: TyCon -> Maybe Arity -- Nothing <=> not a syn tycon synTyConArity (SynTyCon _ _ _ arity _ _) = Just arity synTyConArity _ = Nothing @@ -214,8 +210,10 @@ tyConTyVars FunTyCon = [alphaTyVar,betaTyVar] tyConTyVars (DataTyCon _ _ _ tvs _ _ _ _) = tvs tyConTyVars (TupleTyCon _ _ arity) = take arity alphaTyVars tyConTyVars (SynTyCon _ _ _ _ tvs _) = tvs -tyConTyVars (PrimTyCon _ _ _) = panic "tyConTyVars:PrimTyCon" +#ifdef DEBUG +tyConTyVars (PrimTyCon _ _ _ _) = panic "tyConTyVars:PrimTyCon" tyConTyVars (SpecTyCon _ _ ) = panic "tyConTyVars:SpecTyCon" +#endif \end{code} \begin{code} @@ -234,6 +232,10 @@ tyConFamilySize (TupleTyCon _ _ _) = 1 #ifdef DEBUG tyConFamilySize other = pprPanic "tyConFamilySize:" (pprTyCon PprDebug other) #endif + +tyConPrimRep :: TyCon -> PrimRep +tyConPrimRep (PrimTyCon _ _ _ rep) = rep +tyConPrimRep _ = PtrRep \end{code} \begin{code} @@ -243,6 +245,13 @@ tyConDerivings other = [] \end{code} \begin{code} +tyConTheta :: TyCon -> [(Class,Type)] +tyConTheta (DataTyCon _ _ _ _ theta _ _ _) = theta +tyConTheta (TupleTyCon _ _ _) = [] +-- should ask about anything else +\end{code} + +\begin{code} getSynTyConDefn :: TyCon -> ([TyVar], Type) getSynTyConDefn (SynTyCon _ _ _ _ tyvars ty) = (tyvars,ty) \end{code} @@ -253,17 +262,14 @@ maybeTyConSingleCon :: TyCon -> Maybe Id maybeTyConSingleCon (TupleTyCon _ _ arity) = Just (mkTupleCon arity) maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _) = Just c maybeTyConSingleCon (DataTyCon _ _ _ _ _ _ _ _) = Nothing -maybeTyConSingleCon (PrimTyCon _ _ _) = Nothing +maybeTyConSingleCon (PrimTyCon _ _ _ _) = Nothing maybeTyConSingleCon (SpecTyCon tc tys) = panic "maybeTyConSingleCon:SpecTyCon" -- requires DataCons of TyCon isEnumerationTyCon (TupleTyCon _ _ arity) = arity == 0 isEnumerationTyCon (DataTyCon _ _ _ _ _ data_cons _ _) - = not (null data_cons) && all is_nullary data_cons - where - is_nullary con = case (dataConSig con) of { (_,_, arg_tys, _) -> - null arg_tys } + = not (null data_cons) && all isNullaryDataCon data_cons \end{code} @derivedFor@ reports if we have an {\em obviously}-derived instance @@ -292,28 +298,7 @@ the property @(a<=b) || (b<=a)@. \begin{code} instance Ord3 TyCon where - cmp FunTyCon FunTyCon = EQ_ - cmp (DataTyCon a _ _ _ _ _ _ _) (DataTyCon b _ _ _ _ _ _ _) = a `cmp` b - cmp (SynTyCon a _ _ _ _ _) (SynTyCon b _ _ _ _ _) = a `cmp` b - cmp (TupleTyCon _ _ a) (TupleTyCon _ _ b) = a `cmp` b - cmp (PrimTyCon a _ _) (PrimTyCon b _ _) = a `cmp` b - cmp (SpecTyCon tc1 mtys1) (SpecTyCon tc2 mtys2) - = panic# "cmp on SpecTyCons" -- case (tc1 `cmp` tc2) of { EQ_ -> mtys1 `cmp` mtys2; xxx -> xxx } - - -- now we *know* the tags are different, so... - cmp other_1 other_2 - | tag1 _LT_ tag2 = LT_ - | otherwise = GT_ - where - tag1 = tag_TyCon other_1 - tag2 = tag_TyCon other_2 - - tag_TyCon FunTyCon = ILIT(1) - tag_TyCon (DataTyCon _ _ _ _ _ _ _ _) = ILIT(2) - tag_TyCon (TupleTyCon _ _ _) = ILIT(3) - tag_TyCon (PrimTyCon _ _ _) = ILIT(4) - tag_TyCon (SpecTyCon _ _) = ILIT(5) - tag_TyCon (SynTyCon _ _ _ _ _ _) = ILIT(6) + cmp tc1 tc2 = uniqueOf tc1 `cmp` uniqueOf tc2 instance Eq TyCon where a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } @@ -329,7 +314,7 @@ instance Ord TyCon where instance Uniquable TyCon where uniqueOf (DataTyCon u _ _ _ _ _ _ _) = u uniqueOf (TupleTyCon u _ _) = u - uniqueOf (PrimTyCon u _ _) = u + uniqueOf (PrimTyCon u _ _ _) = u uniqueOf (SynTyCon u _ _ _ _ _) = u uniqueOf tc@(SpecTyCon _ _) = panic "uniqueOf:SpecTyCon" uniqueOf tc = uniqueOf (getName tc) @@ -338,7 +323,7 @@ instance Uniquable TyCon where \begin{code} instance NamedThing TyCon where getName (DataTyCon _ n _ _ _ _ _ _) = n - getName (PrimTyCon _ n _) = n + getName (PrimTyCon _ n _ _) = n getName (SpecTyCon tc _) = getName tc getName (SynTyCon _ n _ _ _ _) = n getName FunTyCon = mkFunTyConName diff --git a/ghc/compiler/types/TyLoop.lhi b/ghc/compiler/types/TyLoop.lhi index d36e74e1cb..2491f4c638 100644 --- a/ghc/compiler/types/TyLoop.lhi +++ b/ghc/compiler/types/TyLoop.lhi @@ -9,7 +9,7 @@ import Unique ( Unique ) import FieldLabel ( FieldLabel ) import Id ( Id, GenId, StrictnessMark, mkTupleCon, mkDataCon, - dataConSig, dataConArgTys ) + isNullaryDataCon, dataConArgTys ) import PprType ( specMaybeTysSuffix ) import Name ( Name ) import TyCon ( TyCon ) @@ -17,6 +17,7 @@ import TyVar ( GenTyVar, TyVar ) import Type ( GenType, Type ) import Usage ( GenUsage ) import Class ( Class, GenClass ) +import TysWiredIn ( voidTy ) data GenId ty data GenType tyvar uvar @@ -31,12 +32,13 @@ type Id = GenId (GenType (GenTyVar (GenUsage Unique)) Unique) -- Needed in TyCon mkTupleCon :: Int -> Id -dataConSig :: Id -> ([TyVar], [(Class, Type)], [Type], TyCon) +isNullaryDataCon :: Id -> Bool specMaybeTysSuffix :: [Maybe Type] -> _PackedString instance Eq (GenClass a b) -- Needed in Type dataConArgTys :: Id -> [Type] -> [Type] +voidTy :: Type -- Needed in TysWiredIn data StrictnessMark = MarkedStrict | NotMarkedStrict diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs index 980f1dd1e2..7ba82cdab2 100644 --- a/ghc/compiler/types/TyVar.lhs +++ b/ghc/compiler/types/TyVar.lhs @@ -7,6 +7,7 @@ module TyVar ( tyVarKind, -- TyVar -> Kind cloneTyVar, + openAlphaTyVar, alphaTyVars, alphaTyVar, betaTyVar, gammaTyVar, deltaTyVar, -- We also export "environments" keyed off of @@ -23,11 +24,11 @@ module TyVar ( ) where CHK_Ubiq() -- debugging consistency check -import IdLoop -- for paranoia checking +IMPORT_DELOOPER(IdLoop) -- for paranoia checking -- friends import Usage ( GenUsage, Usage(..), usageOmega ) -import Kind ( Kind, mkBoxedTypeKind ) +import Kind ( Kind, mkBoxedTypeKind, mkTypeKind ) -- others import UniqSet -- nearly all of it @@ -77,10 +78,16 @@ cloneTyVar (TyVar _ k n x) u = TyVar u k n x Fixed collection of type variables ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} + -- openAlphaTyVar is prepared to be instantiated + -- to a boxed or unboxed type variable. It's used for the + -- result type for "error", so that we can have (error Int# "Help") +openAlphaTyVar = TyVar (mkAlphaTyVarUnique 1) mkTypeKind Nothing usageOmega + alphaTyVars = [ TyVar u mkBoxedTypeKind Nothing usageOmega - | u <- map mkAlphaTyVarUnique [1..] ] + | u <- map mkAlphaTyVarUnique [2..] ] (alphaTyVar:betaTyVar:gammaTyVar:deltaTyVar:_) = alphaTyVars + \end{code} diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index aff733f824..41f3cce9c2 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -10,7 +10,7 @@ module Type ( getFunTy_maybe, getFunTyExpandingDicts_maybe, mkTyConTy, getTyCon_maybe, applyTyCon, mkSynTy, - mkForAllTy, mkForAllTys, getForAllTy_maybe, splitForAllTy, + mkForAllTy, mkForAllTys, getForAllTy_maybe, getForAllTyExpandingDicts_maybe, splitForAllTy, mkForAllUsageTy, getForAllUsageTy, applyTy, #ifdef DEBUG @@ -39,15 +39,15 @@ module Type ( tyVarsOfType, tyVarsOfTypes, typeKind ) where -import Ubiq -import IdLoop -- for paranoia checking -import TyLoop -- for paranoia checking -import PrelLoop -- for paranoia checking +IMP_Ubiq() +IMPORT_DELOOPER(IdLoop) -- for paranoia checking +IMPORT_DELOOPER(TyLoop) -- for paranoia checking +IMPORT_DELOOPER(PrelLoop) -- for paranoia checking -- friends: import Class ( classSig, classOpLocalType, GenClass{-instances-} ) -import Kind ( mkBoxedTypeKind, resultKind ) -import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon, tyConArity, +import Kind ( mkBoxedTypeKind, resultKind, notArrowKind ) +import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon, tyConKind, tyConDataCons, getSynTyConDefn, TyCon ) import TyVar ( tyVarKind, GenTyVar{-instances-}, GenTyVarSet(..), emptyTyVarSet, unionTyVarSets, minusTyVarSet, @@ -58,9 +58,11 @@ import Usage ( usageOmega, GenUsage, Usage(..), UVar(..), UVarEnv(..), eqUsage ) -- others -import Maybes ( maybeToBool ) +import Maybes ( maybeToBool, assocMaybe ) import PrimRep ( PrimRep(..) ) -import Util ( thenCmp, zipEqual, panic, panic#, assertPanic, pprTrace{-ToDo:rm-}, pprPanic{-ToDo:rm-}, +import Unique -- quite a few *Keys +import Util ( thenCmp, zipEqual, assoc, + panic, panic#, assertPanic, pprTrace{-ToDo:rm-}, pprPanic{-ToDo:rm-}, Ord3(..){-instances-} ) -- ToDo:rm all these @@ -69,11 +71,11 @@ import {-mumble-} import {-mumble-} PprStyle import {-mumble-} - PprType (pprType ) + PprType --(pprType ) import {-mumble-} UniqFM (ufmToList ) -import {-mumble-} - Unique (pprUnique ) +import {-mumble-} + Outputable \end{code} Data types @@ -144,6 +146,8 @@ expandTy (SynTy _ _ t) = expandTy t expandTy (DictTy clas ty u) = case all_arg_tys of + [] -> voidTy -- Empty dictionary represented by Void + [arg_ty] -> expandTy arg_ty -- just the <whatever> itself -- The extra expandTy is to make sure that @@ -258,7 +262,8 @@ mkTyConTy tycon applyTyCon :: TyCon -> [GenType t u] -> GenType t u applyTyCon tycon tys - = ASSERT (not (isSynTyCon tycon)) + = --ASSERT (not (isSynTyCon tycon)) + (if (not (isSynTyCon tycon)) then \x->x else pprTrace "applyTyCon:" (pprTyCon PprDebug tycon)) $ foldl AppTy (TyConTy tycon usageOmega) tys getTyCon_maybe :: GenType t u -> Maybe TyCon @@ -341,6 +346,12 @@ getForAllTy_maybe (SynTy _ _ t) = getForAllTy_maybe t getForAllTy_maybe (ForAllTy tyvar t) = Just(tyvar,t) getForAllTy_maybe _ = Nothing +getForAllTyExpandingDicts_maybe :: Type -> Maybe (TyVar, Type) +getForAllTyExpandingDicts_maybe (SynTy _ _ t) = getForAllTyExpandingDicts_maybe t +getForAllTyExpandingDicts_maybe (ForAllTy tyvar t) = Just(tyvar,t) +getForAllTyExpandingDicts_maybe ty@(DictTy _ _ _) = getForAllTyExpandingDicts_maybe (expandTy ty) +getForAllTyExpandingDicts_maybe _ = Nothing + splitForAllTy :: GenType t u-> ([t], GenType t u) splitForAllTy t = go t [] where @@ -392,9 +403,9 @@ Applied data tycons (give back constrs) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} maybeAppDataTyCon - :: GenType tyvar uvar + :: GenType (GenTyVar any) uvar -> Maybe (TyCon, -- the type constructor - [GenType tyvar uvar], -- types to which it is applied + [GenType (GenTyVar any) uvar], -- types to which it is applied [Id]) -- its family of data-constructors maybeAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts :: Type -> Maybe (TyCon, [Type], [Id]) @@ -405,26 +416,30 @@ maybeAppSpecDataTyConExpandingDicts ty = maybe_app_data_tycon expandTy ty maybe_app_data_tycon expand ty - = case (getTyCon_maybe app_ty) of - Just tycon | isDataTyCon tycon && - tyConArity tycon == length arg_tys + = let + expanded_ty = expand ty + (app_ty, arg_tys) = splitAppTy expanded_ty + in + case (getTyCon_maybe app_ty) of + Just tycon | --pprTrace "maybe_app:" (ppCat [ppr PprDebug (isDataTyCon tycon), ppr PprDebug (notArrowKind (typeKind expanded_ty))]) $ + isDataTyCon tycon && + notArrowKind (typeKind expanded_ty) -- Must be saturated for ty to be a data type -> Just (tycon, arg_tys, tyConDataCons tycon) other -> Nothing - where - (app_ty, arg_tys) = splitAppTy (expand ty) getAppDataTyCon, getAppSpecDataTyCon - :: GenType tyvar uvar + :: GenType (GenTyVar any) uvar -> (TyCon, -- the type constructor - [GenType tyvar uvar], -- types to which it is applied + [GenType (GenTyVar any) uvar], -- types to which it is applied [Id]) -- its family of data-constructors getAppDataTyConExpandingDicts, getAppSpecDataTyConExpandingDicts :: Type -> (TyCon, [Type], [Id]) getAppDataTyCon ty = get_app_data_tycon maybeAppDataTyCon ty -getAppDataTyConExpandingDicts ty = get_app_data_tycon maybeAppDataTyConExpandingDicts ty +getAppDataTyConExpandingDicts ty = --pprTrace "getAppDataTyConEx...:" (pprType PprDebug ty) $ + get_app_data_tycon maybeAppDataTyConExpandingDicts ty -- these should work like the UniTyFuns.getUniDataSpecTyCon* things of old (ToDo) getAppSpecDataTyCon = getAppDataTyCon @@ -467,6 +482,7 @@ Finding the kind of a type ~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} typeKind :: GenType (GenTyVar any) u -> Kind + typeKind (TyVarTy tyvar) = tyVarKind tyvar typeKind (TyConTy tycon usage) = tyConKind tycon typeKind (SynTy _ _ ty) = typeKind ty @@ -619,9 +635,33 @@ This is *not* right: it is a placeholder (ToDo 96/03 WDP): typePrimRep :: GenType tyvar uvar -> PrimRep typePrimRep (SynTy _ _ ty) = typePrimRep ty -typePrimRep (TyConTy tc _) = if isPrimTyCon tc then panic "typePrimRep:PrimTyCon" else PtrRep typePrimRep (AppTy ty _) = typePrimRep ty +typePrimRep (TyConTy tc _) = if not (isPrimTyCon tc) then + PtrRep + else + case (assocMaybe tc_primrep_list (uniqueOf tc)) of + Just xx -> xx + Nothing -> pprPanic "typePrimRep:" (pprTyCon PprDebug tc) + typePrimRep _ = PtrRep -- the "default" + +tc_primrep_list + = [(addrPrimTyConKey, AddrRep) + ,(arrayPrimTyConKey, ArrayRep) + ,(byteArrayPrimTyConKey, ByteArrayRep) + ,(charPrimTyConKey, CharRep) + ,(doublePrimTyConKey, DoubleRep) + ,(floatPrimTyConKey, FloatRep) + ,(foreignObjPrimTyConKey, ForeignObjRep) + ,(intPrimTyConKey, IntRep) + ,(mutableArrayPrimTyConKey, ArrayRep) + ,(mutableByteArrayPrimTyConKey, ByteArrayRep) + ,(stablePtrPrimTyConKey, StablePtrRep) + ,(statePrimTyConKey, VoidRep) + ,(synchVarPrimTyConKey, PtrRep) + ,(voidTyConKey, VoidRep) + ,(wordPrimTyConKey, WordRep) + ] \end{code} %************************************************************************ diff --git a/ghc/compiler/types/Usage.lhs b/ghc/compiler/types/Usage.lhs index e5c4eb147f..c5e26d2cbc 100644 --- a/ghc/compiler/types/Usage.lhs +++ b/ghc/compiler/types/Usage.lhs @@ -14,7 +14,7 @@ module Usage ( eqUVar, eqUsage ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Pretty ( Pretty(..), PrettyRep, ppPStr, ppBeside ) import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM, diff --git a/ghc/compiler/utils/Bag.lhs b/ghc/compiler/utils/Bag.lhs index 857dda2c97..6085e37123 100644 --- a/ghc/compiler/utils/Bag.lhs +++ b/ghc/compiler/utils/Bag.lhs @@ -4,6 +4,8 @@ \section[Bags]{@Bag@: an unordered collection with duplicates} \begin{code} +#include "HsVersions.h" + module Bag ( Bag, -- abstract type @@ -15,7 +17,8 @@ module Bag ( ) where #ifdef COMPILING_GHC -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} +IMPORT_1_3(List(partition)) import Outputable ( interpp'SP ) import Pretty diff --git a/ghc/compiler/utils/CharSeq.lhs b/ghc/compiler/utils/CharSeq.lhs index 68948f4c66..43dfb7f478 100644 --- a/ghc/compiler/utils/CharSeq.lhs +++ b/ghc/compiler/utils/CharSeq.lhs @@ -31,12 +31,12 @@ module CharSeq ( #if ! defined(COMPILING_GHC) ) where #else - , cAppendFile + , cPutStr ) where CHK_Ubiq() -- debugging consistency check +IMPORT_1_3(IO) -import PreludeGlaST #endif \end{code} @@ -65,7 +65,7 @@ cCh :: Char -> CSeq cInt :: Int -> CSeq #if defined(COMPILING_GHC) -cAppendFile :: _FILE -> CSeq -> IO () +cPutStr :: Handle -> CSeq -> IO () #endif \end{code} @@ -86,7 +86,7 @@ data CSeq | CCh Char | CInt Int -- equiv to "CStr (show the_int)" #if defined(COMPILING_GHC) - | CPStr _PackedString + | CPStr FAST_STRING #endif \end{code} @@ -125,11 +125,6 @@ cShow seq = flatten ILIT(0) _TRUE_ seq [] cShows seq rest = cShow seq ++ rest cLength seq = length (cShow seq) -- *not* the best way to do this! #endif - -#if defined(COMPILING_GHC) -cAppendFile file_star seq - = flattenIO file_star seq `seqPrimIO` return () -#endif \end{code} This code is {\em hammered}. We are not above doing sleazy @@ -156,14 +151,14 @@ flatten n _FALSE_ (CStr s) seqs = s ++ flattenS _FALSE_ seqs flatten n _FALSE_ (CCh c) seqs = c : flattenS _FALSE_ seqs flatten n _FALSE_ (CInt i) seqs = show i ++ flattenS _FALSE_ seqs #if defined(COMPILING_GHC) -flatten n _FALSE_ (CPStr s) seqs = _unpackPS s ++ flattenS _FALSE_ seqs +flatten n _FALSE_ (CPStr s) seqs = _UNPK_ s ++ flattenS _FALSE_ seqs #endif flatten n _TRUE_ (CStr s) seqs = mkIndent n (s ++ flattenS _FALSE_ seqs) flatten n _TRUE_ (CCh c) seqs = mkIndent n (c : flattenS _FALSE_ seqs) flatten n _TRUE_ (CInt i) seqs = mkIndent n (show i ++ flattenS _FALSE_ seqs) #if defined(COMPILING_GHC) -flatten n _TRUE_ (CPStr s) seqs = mkIndent n (_unpackPS s ++ flattenS _FALSE_ seqs) +flatten n _TRUE_ (CPStr s) seqs = mkIndent n ( _UNPK_ s ++ flattenS _FALSE_ seqs) #endif \end{code} @@ -187,61 +182,21 @@ Now the I/O version. This code is massively {\em hammered}. It {\em ignores} indentation. +(NB: 1.3 compiler: efficiency hacks removed for now!) + \begin{code} #if defined(COMPILING_GHC) -flattenIO :: _FILE -- file we are writing to - -> CSeq -- Seq to print - -> PrimIO () - -flattenIO file sq - | file == ``NULL'' = error "panic:flattenIO" -- really just to force eval :-) - | otherwise - = flat sq +cPutStr handle sq = flat sq where - flat CNil = returnPrimIO () + flat CNil = return () flat (CIndent n2 seq) = flat seq - flat (CAppend s1 s2) = flat s1 `seqPrimIO` flat s2 - flat CNewline = _ccall_ stg_putc '\n' file - flat (CCh c) = _ccall_ stg_putc c file - flat (CInt i) = _ccall_ fprintf file percent_d i - flat (CStr s) = put_str s - flat (CPStr s) = put_pstr s - - ----- - put_str, put_str2 :: String -> PrimIO () - - put_str str - = --put_str2 ``stderr'' (str ++ "\n") `seqPrimIO` - put_str2 str - - put_str2 [] = returnPrimIO () - - put_str2 (c1@(C# _) : c2@(C# _) : c3@(C# _) : c4@(C# _) : cs) - = _ccall_ stg_putc c1 file `seqPrimIO` - _ccall_ stg_putc c2 file `seqPrimIO` - _ccall_ stg_putc c3 file `seqPrimIO` - _ccall_ stg_putc c4 file `seqPrimIO` - put_str2 cs -- efficiency hack? who knows... (WDP 94/10) - - put_str2 (c1@(C# _) : c2@(C# _) : c3@(C# _) : cs) - = _ccall_ stg_putc c1 file `seqPrimIO` - _ccall_ stg_putc c2 file `seqPrimIO` - _ccall_ stg_putc c3 file `seqPrimIO` - put_str2 cs -- efficiency hack? who knows... (WDP 94/10) - - put_str2 (c1@(C# _) : c2@(C# _) : cs) - = _ccall_ stg_putc c1 file `seqPrimIO` - _ccall_ stg_putc c2 file `seqPrimIO` - put_str2 cs -- efficiency hack? who knows... (WDP 94/10) - - put_str2 (c1@(C# _) : cs) - = _ccall_ stg_putc c1 file `seqPrimIO` - put_str2 cs -- efficiency hack? who knows... (WDP 94/10) - - put_pstr ps = _putPS file ps - -percent_d = _psToByteArray SLIT("%d") + flat (CAppend s1 s2) = flat s1 >> flat s2 + flat CNewline = hPutChar handle '\n' + flat (CCh c) = hPutChar handle c + flat (CInt i) = hPutStr handle (show i) + flat (CStr s) = hPutStr handle s + flat (CPStr s) = hPutStr handle (_UNPK_ s) #endif {- COMPILING_GHC -} \end{code} diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs index 384a7d122a..e2a9ec5960 100644 --- a/ghc/compiler/utils/FiniteMap.lhs +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -63,17 +63,12 @@ module FiniteMap ( , FiniteSet(..), emptySet, mkSet, isEmptySet , elementOf, setToList, union, minusSet #endif - - -- To make it self-sufficient -#if __HASKELL1__ < 3 - , Maybe -#endif ) where import Maybes #ifdef COMPILING_GHC -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} # ifdef DEBUG import Pretty # endif @@ -757,97 +752,65 @@ When the FiniteMap module is used in GHC, we specialise it for \tr{Uniques}, for dastardly efficiency reasons. \begin{code} -#if 0 -#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ +#if defined(COMPILING_GHC) && __GLASGOW_HASKELL__ && !defined(REALLY_HASKELL_1_3) -{-# SPECIALIZE listToFM - :: [(Int,elt)] -> FiniteMap Int elt, - [(CLabel,elt)] -> FiniteMap CLabel elt, - [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt, - [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt - IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt) - #-} -{-# SPECIALIZE addToFM - :: FiniteMap Int elt -> Int -> elt -> FiniteMap Int elt, - FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt, - FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt - IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt) - #-} {-# SPECIALIZE addListToFM - :: FiniteMap Int elt -> [(Int,elt)] -> FiniteMap Int elt, - FiniteMap CLabel elt -> [(CLabel,elt)] -> FiniteMap CLabel elt + :: FiniteMap (FAST_STRING, FAST_STRING) elt -> [((FAST_STRING, FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt IF_NCG(COMMA FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt) #-} -{-NOT EXPORTED!! # SPECIALIZE addToFM_C - :: (elt -> elt -> elt) -> FiniteMap Int elt -> Int -> elt -> FiniteMap Int elt, - (elt -> elt -> elt) -> FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt - IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt) - #-} {-# SPECIALIZE addListToFM_C - :: (elt -> elt -> elt) -> FiniteMap Int elt -> [(Int,elt)] -> FiniteMap Int elt, - (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt, - (elt -> elt -> elt) -> FiniteMap CLabel elt -> [(CLabel,elt)] -> FiniteMap CLabel elt + :: (elt -> elt -> elt) -> FiniteMap TyCon elt -> [(TyCon,elt)] -> FiniteMap TyCon elt, + (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> [(Reg COMMA elt)] -> FiniteMap Reg elt) #-} -{-NOT EXPORTED!!! # SPECIALIZE delFromFM - :: FiniteMap Int elt -> Int -> FiniteMap Int elt, - FiniteMap CLabel elt -> CLabel -> FiniteMap CLabel elt - IF_NCG(COMMA FiniteMap Reg elt -> Reg -> FiniteMap Reg elt) - #-} -{-# SPECIALIZE delListFromFM - :: FiniteMap Int elt -> [Int] -> FiniteMap Int elt, - FiniteMap CLabel elt -> [CLabel] -> FiniteMap CLabel elt - IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> FiniteMap Reg elt) +{-# SPECIALIZE addToFM + :: FiniteMap CLabel elt -> CLabel -> elt -> FiniteMap CLabel elt, + FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt, + FiniteMap (FAST_STRING, FAST_STRING) elt -> (FAST_STRING, FAST_STRING) -> elt -> FiniteMap (FAST_STRING, FAST_STRING) elt, + FiniteMap RdrName elt -> RdrName -> elt -> FiniteMap RdrName elt + IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt) #-} -{-# SPECIALIZE elemFM - :: FAST_STRING -> FiniteMap FAST_STRING elt -> Bool +{-# SPECIALIZE addToFM_C + :: (elt -> elt -> elt) -> FiniteMap (RdrName, RdrName) elt -> (RdrName, RdrName) -> elt -> FiniteMap (RdrName, RdrName) elt, + (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FAST_STRING -> elt -> FiniteMap FAST_STRING elt + IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt) #-} -{-not EXPORTED!!! # SPECIALIZE filterFM - :: (Int -> elt -> Bool) -> FiniteMap Int elt -> FiniteMap Int elt, - (CLabel -> elt -> Bool) -> FiniteMap CLabel elt -> FiniteMap CLabel elt - IF_NCG(COMMA (Reg -> elt -> Bool) -> FiniteMap Reg elt -> FiniteMap Reg elt) +{-# SPECIALIZE bagToFM + :: Bag (FAST_STRING,elt) -> FiniteMap FAST_STRING elt #-} -{-NOT EXPORTED!!! # SPECIALIZE intersectFM - :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt, - FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt - IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) +{-# SPECIALIZE delListFromFM + :: FiniteMap RdrName elt -> [RdrName] -> FiniteMap RdrName elt, + FiniteMap FAST_STRING elt -> [FAST_STRING] -> FiniteMap FAST_STRING elt + IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> FiniteMap Reg elt) #-} -{-not EXPORTED !!!# SPECIALIZE intersectFM_C - :: (elt -> elt -> elt) -> FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt, - (elt -> elt -> elt) -> FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt - IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) +{-# SPECIALIZE listToFM + :: [([Char],elt)] -> FiniteMap [Char] elt, + [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt, + [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt + IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt) #-} {-# SPECIALIZE lookupFM - :: FiniteMap Int elt -> Int -> Maybe elt, - FiniteMap CLabel elt -> CLabel -> Maybe elt, + :: FiniteMap CLabel elt -> CLabel -> Maybe elt, + FiniteMap [Char] elt -> [Char] -> Maybe elt, FiniteMap FAST_STRING elt -> FAST_STRING -> Maybe elt, - FiniteMap (FAST_STRING,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt + FiniteMap (FAST_STRING,FAST_STRING) elt -> (FAST_STRING,FAST_STRING) -> Maybe elt, + FiniteMap RdrName elt -> RdrName -> Maybe elt, + FiniteMap (RdrName,RdrName) elt -> (RdrName,RdrName) -> Maybe elt IF_NCG(COMMA FiniteMap Reg elt -> Reg -> Maybe elt) #-} {-# SPECIALIZE lookupWithDefaultFM - :: FiniteMap Int elt -> elt -> Int -> elt, - FiniteMap CLabel elt -> elt -> CLabel -> elt + :: FiniteMap FAST_STRING elt -> elt -> FAST_STRING -> elt IF_NCG(COMMA FiniteMap Reg elt -> elt -> Reg -> elt) #-} -{-# SPECIALIZE minusFM - :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt, - FiniteMap TyCon elt -> FiniteMap TyCon elt -> FiniteMap TyCon elt, - FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt, - FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt - IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) - #-} {-# SPECIALIZE plusFM - :: FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt, - FiniteMap TyCon elt -> FiniteMap TyCon elt -> FiniteMap TyCon elt, - FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt + :: FiniteMap RdrName elt -> FiniteMap RdrName elt -> FiniteMap RdrName elt, + FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt IF_NCG(COMMA FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) #-} {-# SPECIALIZE plusFM_C - :: (elt -> elt -> elt) -> FiniteMap Int elt -> FiniteMap Int elt -> FiniteMap Int elt, - (elt -> elt -> elt) -> FiniteMap CLabel elt -> FiniteMap CLabel elt -> FiniteMap CLabel elt + :: (elt -> elt -> elt) -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt IF_NCG(COMMA (elt -> elt -> elt) -> FiniteMap Reg elt -> FiniteMap Reg elt -> FiniteMap Reg elt) #-} #endif {- compiling for GHC -} -#endif {- 0 -} \end{code} diff --git a/ghc/compiler/utils/ListSetOps.lhs b/ghc/compiler/utils/ListSetOps.lhs index 3be4d89325..5a46b2391b 100644 --- a/ghc/compiler/utils/ListSetOps.lhs +++ b/ghc/compiler/utils/ListSetOps.lhs @@ -4,6 +4,8 @@ \section[ListSetOps]{Set-like operations on lists} \begin{code} +#include "HsVersions.h" + module ListSetOps ( unionLists, intersectLists, @@ -14,7 +16,7 @@ module ListSetOps ( ) where #if defined(COMPILING_GHC) -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Util ( isIn, isn'tIn ) #endif diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs index 1c6a863eaa..c40ffb2ae6 100644 --- a/ghc/compiler/utils/Maybes.lhs +++ b/ghc/compiler/utils/Maybes.lhs @@ -24,11 +24,9 @@ module Maybes ( failMaB, failMaybe, seqMaybe, - mapMaybe, returnMaB, returnMaybe, - thenMaB, - thenMaybe + thenMaB #if ! defined(COMPILING_GHC) , findJust @@ -113,12 +111,6 @@ returnMaybe = Just failMaybe :: Maybe a failMaybe = Nothing - -mapMaybe :: (a -> Maybe b) -> [a] -> Maybe [b] -mapMaybe f [] = returnMaybe [] -mapMaybe f (x:xs) = f x `thenMaybe` \ x' -> - mapMaybe f xs `thenMaybe` \ xs' -> - returnMaybe (x':xs') \end{code} Lookup functions diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 455cea2f27..0ed69ce60b 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -19,7 +19,7 @@ module Outputable ( ifPprInterface ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import PprStyle ( PprStyle(..) ) import Pretty diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs index e5c20cc175..8cb244056c 100644 --- a/ghc/compiler/utils/Pretty.lhs +++ b/ghc/compiler/utils/Pretty.lhs @@ -12,7 +12,7 @@ #endif module Pretty ( - Pretty(..), + SYN_IE(Pretty), #if defined(COMPILING_GHC) prettyToUn, @@ -32,21 +32,20 @@ module Pretty ( ppShow, speakNth, #if defined(COMPILING_GHC) - ppAppendFile, + ppPutStr, #endif -- abstract type, to complete the interface... - PrettyRep(..), CSeq, Delay -#if defined(COMPILING_GHC) - , Unpretty(..) -#endif + PrettyRep(..), Delay ) where #if defined(COMPILING_GHC) CHK_Ubiq() -- debugging consistency check +IMPORT_1_3(Ratio) +IMPORT_1_3(IO) -import Unpretty ( Unpretty(..) ) +import Unpretty ( SYN_IE(Unpretty) ) #endif import CharSeq @@ -94,7 +93,7 @@ ppNest :: Int -> Pretty -> Pretty ppShow :: Int -> Pretty -> [Char] #if defined(COMPILING_GHC) -ppAppendFile :: _FILE -> Int -> Pretty -> IO () +ppPutStr :: Handle -> Int -> Pretty -> IO () #endif \end{code} @@ -129,9 +128,9 @@ ppShow width p MkPrettyRep seq ll emp sl -> cShow seq #if defined(COMPILING_GHC) -ppAppendFile f width p +ppPutStr f width p = case (p width False) of - MkPrettyRep seq ll emp sl -> cAppendFile f seq + MkPrettyRep seq ll emp sl -> cPutStr f seq #endif ppNil width is_vert = MkPrettyRep cNil (MkDelay 0) True (width >= 0) diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi index b2f07e4d30..82e31b4b14 100644 --- a/ghc/compiler/utils/Ubiq.lhi +++ b/ghc/compiler/utils/Ubiq.lhi @@ -28,6 +28,7 @@ import Id ( StrictnessMark, GenId, Id(..) ) import IdInfo ( IdInfo, OptIdInfo(..), ArityInfo, DeforestInfo, Demand, StrictnessInfo, UpdateInfo ) import Kind ( Kind ) import Literal ( Literal ) +import MachRegs ( Reg ) import Maybes ( MaybeErr ) import MatchEnv ( MatchEnv ) import Name ( Module(..), RdrName, Name, ExportFlag, NamedThing(..) ) @@ -111,6 +112,7 @@ data MaybeErr a b data MatchEnv a b data Name data RdrName = Unqual _PackedString | Qual _PackedString _PackedString +data Reg data OutPat a b c data PprStyle data PragmaInfo @@ -144,4 +146,14 @@ type Id = GenId (GenType (GenTyVar (GenUsage Unique)) Unique) type Type = GenType (GenTyVar (GenUsage Unique)) Unique type TyVar = GenTyVar (GenUsage Unique) type Usage = GenUsage Unique + +-- These are here only for SPECIALIZing in FiniteMap (ToDo:move?) +instance Ord Reg +instance Ord RdrName +instance Ord CLabel +instance Ord TyCon +instance Eq Reg +instance Eq RdrName +instance Eq CLabel +instance Eq TyCon \end{code} diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs index 166688c07c..a2f48801a4 100644 --- a/ghc/compiler/utils/UniqFM.lhs +++ b/ghc/compiler/utils/UniqFM.lhs @@ -35,6 +35,7 @@ module UniqFM ( IF_NOT_GHC(addToUFM_C COMMA) addListToUFM_C, delFromUFM, + delFromUFM_Directly, delListFromUFM, plusUFM, plusUFM_C, @@ -53,7 +54,7 @@ module UniqFM ( ) where #if defined(COMPILING_GHC) -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} #endif import Unique ( Unique, u2i, mkUniqueGrimily ) @@ -101,6 +102,7 @@ addListToUFM_C :: Uniquable key => (elt -> elt -> elt) delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt +delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt plusUFM :: UniqFM elt -> UniqFM elt -> UniqFM elt @@ -329,7 +331,8 @@ Now ways of removing things from UniqFM. \begin{code} delListFromUFM fm lst = foldl delFromUFM fm lst -delFromUFM fm key = delete fm (u2i (uniqueOf key)) +delFromUFM fm key = delete fm (u2i (uniqueOf key)) +delFromUFM_Directly fm u = delete fm (u2i u) delete EmptyUFM _ = EmptyUFM delete fm key = del_ele fm diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs index 9df9fc852a..4e516acd41 100644 --- a/ghc/compiler/utils/UniqSet.lhs +++ b/ghc/compiler/utils/UniqSet.lhs @@ -20,7 +20,7 @@ module UniqSet ( isEmptyUniqSet ) where -import Ubiq{-uitous-} +IMP_Ubiq(){-uitous-} import Maybes ( maybeToBool, Maybe ) import UniqFM diff --git a/ghc/compiler/utils/Unpretty.lhs b/ghc/compiler/utils/Unpretty.lhs index cf90116dc8..8e35e3c195 100644 --- a/ghc/compiler/utils/Unpretty.lhs +++ b/ghc/compiler/utils/Unpretty.lhs @@ -7,7 +7,7 @@ #include "HsVersions.h" module Unpretty ( - Unpretty(..), + SYN_IE(Unpretty), uppNil, uppStr, uppPStr, uppChar, uppInt, uppInteger, uppSP, upp'SP, uppLbrack, uppRbrack, uppLparen, uppRparen, @@ -17,13 +17,14 @@ module Unpretty ( uppCat, uppBeside, uppBesides, uppAbove, uppAboves, uppNest, uppSep, uppInterleave, uppIntersperse, uppShow, - uppAppendFile, + uppPutStr, -- abstract type, to complete the interface... CSeq ) where CHK_Ubiq() -- debugging consistency check +IMPORT_1_3(IO) import CharSeq \end{code} @@ -69,7 +70,7 @@ uppNest :: Int -> Unpretty -> Unpretty uppShow :: Int -> Unpretty -> [Char] -uppAppendFile :: _FILE -> Int -> Unpretty -> IO () +uppPutStr :: Handle -> Int -> Unpretty -> IO () \end{code} %************************************************ @@ -81,7 +82,7 @@ uppAppendFile :: _FILE -> Int -> Unpretty -> IO () \begin{code} uppShow _ p = cShow p -uppAppendFile f _ p = cAppendFile f p +uppPutStr f _ p = cPutStr f p uppNil = cNil uppStr s = cStr s diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index c026524ecf..8ae4b4b727 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -582,11 +582,11 @@ transitiveClosure :: (a -> [a]) -- Successor function -> [a] -- The transitive closure transitiveClosure succ eq xs - = do [] xs + = go [] xs where - do done [] = done - do done (x:xs) | x `is_in` done = do done xs - | otherwise = do (x:done) (succ x ++ xs) + go done [] = done + go done (x:xs) | x `is_in` done = go done xs + | otherwise = go (x:done) (succ x ++ xs) x `is_in` [] = False x `is_in` (y:ys) | eq x y = True |