From: partain Date: Wed, 26 Jun 1996 10:30:32 +0000 (+0000) Subject: [project @ 1996-06-26 10:26:00 by partain] X-Git-Tag: Approximately_1000_patches_recorded~908 X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=26741ec416bae2c502ef00a2ba0e79050a32cb67 [project @ 1996-06-26 10:26:00 by partain] SLPJ 1.3 changes through 96/06/25 --- diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h index f61a2a4..d64c74b 100644 --- a/ghc/compiler/HsVersions.h +++ b/ghc/compiler/HsVersions.h @@ -10,14 +10,6 @@ you will screw up the layout where they are used in case expressions! #endif -#ifdef __GLASGOW_HASKELL__ -#define TAG_ Int# -#define LT_ -1# -#define EQ_ 0# -#define GT_ 1# -#endif -#define GT__ _ - #define COMMA , #ifdef DEBUG @@ -35,25 +27,38 @@ you will screw up the layout where they are used in case expressions! #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 200 # define REALLY_HASKELL_1_3 # define SYN_IE(a) a +# define EXP_MODULE(a) module 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 _Addr GHCbase.Addr # define Text Show +# define IMP_Ubiq() IMPORT_DELOOPER(Ubiq); import qualified GHCbase +# define CHK_Ubiq() IMPORT_DELOOPER(Ubiq); import qualified GHCbase +# define minInt (minBound::Int) +# define maxInt (maxBound::Int) #else # define SYN_IE(a) a(..) +# define EXP_MODULE(a) a.. # define IMPORT_DELOOPER(mod) import mod # define IMPORT_1_3(mod) {--} +# define IMP_Ubiq() IMPORT_DELOOPER(Ubiq) +# define CHK_Ubiq() IMPORT_DELOOPER(Ubiq) #endif -#define IMP_Ubiq() IMPORT_DELOOPER(Ubiq) -#define CHK_Ubiq() IMPORT_DELOOPER(Ubiq) -#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 26 +#if __GLASGOW_HASKELL__ >= 26 && __GLASGOW_HASKELL__ < 200 #define trace _trace #endif +#define TAG_ Int# +#define LT_ -1# +#define EQ_ 0# +#define GT_ 1# +#define GT__ _ + #if defined(__GLASGOW_HASKELL__) #define FAST_INT Int# #define ILIT(x) (x#) @@ -100,36 +105,53 @@ you will screw up the layout where they are used in case expressions! #endif {- ! __GLASGOW_HASKELL__ -} #if __GLASGOW_HASKELL__ >= 23 -#define USE_FAST_STRINGS 1 -#define FAST_STRING _PackedString -#define SLIT(x) (_packCString (A# x#)) -#define _CMP_STRING_ cmpPString -#define _NULL_ _nullPS -#define _NIL_ _nilPS -#define _CONS_ _consPS -#define _HEAD_ _headPS -#define _TAIL_ _tailPS -#define _LENGTH_ _lengthPS -#define _PK_ _packString -#define _UNPK_ _unpackPS -#define _SUBSTR_ _substrPS -#define _APPEND_ `_appendPS` -#define _CONCAT_ _concatPS +# define USE_FAST_STRINGS 1 +# if __GLASGOW_HASKELL__ < 200 +# define FAST_STRING _PackedString +# define SLIT(x) (_packCString (A# x#)) +# define _CMP_STRING_ cmpPString +# define _NULL_ _nullPS +# define _NIL_ _nilPS +# define _CONS_ _consPS +# define _HEAD_ _headPS +# define _TAIL_ _tailPS +# define _LENGTH_ _lengthPS +# define _PK_ _packString +# define _UNPK_ _unpackPS +# define _SUBSTR_ _substrPS +# define _APPEND_ `_appendPS` +# define _CONCAT_ _concatPS +# else +# define FAST_STRING GHCbase.PackedString +# define SLIT(x) (packCString (GHCbase.A# x#)) +# define _CMP_STRING_ cmpPString +# define _NULL_ nullPS +# define _NIL_ nilPS +# define _CONS_ consPS +# define _HEAD_ headPS +# define _TAIL_ tailPS +# define _LENGTH_ lengthPS +# define _PK_ packString +# define _UNPK_ unpackPS +# define _SUBSTR_ substrPS +# define _APPEND_ `appendPS` +# define _CONCAT_ concatPS +# endif #else -#define FAST_STRING String -#define SLIT(x) (x) -#define _CMP_STRING_ cmpString -#define _NULL_ null -#define _NIL_ "" -#define _CONS_ (:) -#define _HEAD_ head -#define _TAIL_ tail -#define _LENGTH_ length -#define _PK_ (\x->x) -#define _UNPK_ (\x->x) -#define _SUBSTR_ substr{-from Utils-} -#define _APPEND_ ++ -#define _CONCAT_ concat +# define FAST_STRING String +# define SLIT(x) (x) +# define _CMP_STRING_ cmpString +# define _NULL_ null +# define _NIL_ "" +# define _CONS_ (:) +# define _HEAD_ head +# define _TAIL_ tail +# define _LENGTH_ length +# define _PK_ (\x->x) +# define _UNPK_ (\x->x) +# define _SUBSTR_ substr{-from Utils-} +# define _APPEND_ ++ +# define _CONCAT_ concat #endif #endif diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile index a47b639..e3496ad 100644 --- a/ghc/compiler/Jmakefile +++ b/ghc/compiler/Jmakefile @@ -25,7 +25,6 @@ SUBDIRS = __ghc_compiler_tests_dir */ SuffixRules_flexish() SuffixRule_c_o() -LitSuffixRule(.lprl,.prl) /* for makeSymbolList.prl */ .SUFFIXES: .lhi .lhi.hi: @@ -231,9 +230,7 @@ stranal/StrictAnal.lhs \ stranal/SaLib.lhs \ stranal/SaAbsInt.lhs \ stranal/WwLib.lhs \ -stranal/WorkWrap.lhs \ -\ -profiling/SCCauto.lhs DEFORESTER_SRCS_LHS +stranal/WorkWrap.lhs DEFORESTER_SRCS_LHS #define STG_SRCS_LHS \ stgSyn/CoreToStg.lhs \ @@ -606,7 +603,6 @@ compile(prelude/PrimOp,lhs,-K3m -H10m) compile(prelude/TysPrim,lhs,) compile(prelude/TysWiredIn,lhs,) -compile(profiling/SCCauto,lhs,) compile(profiling/SCCfinal,lhs,) compile(profiling/CostCentre,lhs,) @@ -820,6 +816,11 @@ InstallBinaryTarget(hsp,$(INSTLIBDIR_GHC)) YaccRunWithExpectMsg(parser/hsparser,12,0) +parser/hslexer.o : parser/hslexer.c parser/hsparser.tab.h + $(RM) $@ + $(CC) $(CFLAGS) -c $< + @if [ \( $(@D) != '.' \) -a \( $(@D) != './' \) ] ; then echo mv $(@F) $@ ; mv $(@F) $@ ; else exit 0 ; fi + UgenTarget(parser,constr) UgenTarget(parser,binding) UgenTarget(parser,pbinding) diff --git a/ghc/compiler/absCSyn/AbsCLoop_1_3.lhi b/ghc/compiler/absCSyn/AbsCLoop_1_3.lhi new file mode 100644 index 0000000..63f3690 --- /dev/null +++ b/ghc/compiler/absCSyn/AbsCLoop_1_3.lhi @@ -0,0 +1,8 @@ +\begin{code} +interface AbsCLoop_1_3 1 +__exports__ +MachMisc fixedHdrSizeInWords (..) +MachMisc varHdrSizeInWords (..) +CgRetConv ctrlReturnConvAlg (..) +CgRetConv CtrlReturnConvention(..) +\end{code} diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index 53ce362..61d17ac 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -42,8 +42,8 @@ import CgCompInfo ( mAX_Vanilla_REG, mAX_Float_REG, lIVENESS_R3, lIVENESS_R4, lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8 ) -import HeapOffs ( VirtualSpAOffset(..), VirtualSpBOffset(..), - VirtualHeapOffset(..) +import HeapOffs ( SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset), + SYN_IE(VirtualHeapOffset) ) import Literal ( mkMachInt ) import PrimRep ( isFollowableRep, PrimRep(..) ) diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index af1f7af..65742ea 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -26,7 +26,7 @@ import AbsCSyn import CLabel ( mkReturnPtLabel ) import Digraph ( stronglyConnComp ) import HeapOffs ( possiblyEqualHeapOffset ) -import Id ( fIRST_TAG, ConTag(..) ) +import Id ( fIRST_TAG, SYN_IE(ConTag) ) import Literal ( literalPrimRep, Literal(..) ) import PrimRep ( getPrimRepSize, PrimRep(..) ) import Unique ( Unique{-instance Eq-} ) diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index c4f8ae6..284d6e7 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -61,16 +61,16 @@ import Id ( externallyVisibleId, cmpId_withSpecDataCon, isConstMethodId_maybe, isDefaultMethodId_maybe, isSuperDictSelId_maybe, fIRST_TAG, - ConTag(..), GenId{-instance Outputable-} + SYN_IE(ConTag), GenId{-instance Outputable-} ) import Maybes ( maybeToBool ) import PprStyle ( PprStyle(..) ) import PprType ( showTyCon, GenType{-instance Outputable-} ) -import Pretty ( prettyToUn ) +import Pretty ( prettyToUn, ppPStr{-ToDo:rm-} ) import TyCon ( TyCon{-instance Eq-} ) import Unique ( showUnique, pprUnique, Unique{-instance Eq-} ) import Unpretty -- NOTE!! ******************** -import Util ( assertPanic ) +import Util ( assertPanic, pprTrace{-ToDo:rm-} ) \end{code} things we want to find out: @@ -335,11 +335,11 @@ pprCLabel (PprForAsm prepend_cSEP _) lbl prLbl = pprCLabel PprForC lbl pprCLabel sty (TyConLabel tc UnvecConUpdCode) - = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), + = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP, uppPStr SLIT("upd")] pprCLabel sty (TyConLabel tc (VecConUpdCode tag)) - = uppBesides [uppPStr SLIT("ret"), pp_cSEP, uppStr (showTyCon sty tc), pp_cSEP, + = uppBesides [uppPStr SLIT("ret"), pp_cSEP, ppr_tycon sty tc, pp_cSEP, uppInt tag, pp_cSEP, uppPStr SLIT("upd")] pprCLabel sty (TyConLabel tc (StdUpdCode tag)) @@ -348,10 +348,10 @@ pprCLabel sty (TyConLabel tc (StdUpdCode tag)) VectoredReturn _ -> uppBeside (uppPStr SLIT("IndUpdRetV")) (uppInt (tag - fIRST_TAG)) pprCLabel sty (TyConLabel tc InfoTblVecTbl) - = uppBesides [uppStr (showTyCon sty tc), pp_cSEP, uppPStr SLIT("itblvtbl")] + = uppBesides [ppr_tycon sty tc, pp_cSEP, uppPStr SLIT("itblvtbl")] pprCLabel sty (TyConLabel tc StdUpdVecTbl) - = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, uppStr (showTyCon sty tc), + = uppBesides [uppPStr SLIT("vtbl"), pp_cSEP, ppr_tycon sty tc, pp_cSEP, uppPStr SLIT("upd")] pprCLabel sty (CaseLabel u CaseReturnPt) @@ -382,6 +382,13 @@ pprCLabel sty (IdLabel (CLabelId id) flavor) ppr_u u = prettyToUn (pprUnique u) +ppr_tycon sty tc + = let + str = showTyCon sty tc + in + --pprTrace "ppr_tycon:" (ppStr str) $ + uppStr str + ppFlavor :: IdLabelInfo -> Unpretty ppFlavor x = uppBeside pp_cSEP diff --git a/ghc/compiler/absCSyn/HeapOffs.lhs b/ghc/compiler/absCSyn/HeapOffs.lhs index 0ce2a41..0958307 100644 --- a/ghc/compiler/absCSyn/HeapOffs.lhs +++ b/ghc/compiler/absCSyn/HeapOffs.lhs @@ -26,9 +26,9 @@ module HeapOffs ( hpRelToInt, #endif - VirtualHeapOffset(..), HpRelOffset(..), - VirtualSpAOffset(..), VirtualSpBOffset(..), - SpARelOffset(..), SpBRelOffset(..) + SYN_IE(VirtualHeapOffset), SYN_IE(HpRelOffset), + SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset), + SYN_IE(SpARelOffset), SYN_IE(SpBRelOffset) ) where IMP_Ubiq(){-uitous-} diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 75cbf2b..fa3d01b 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -48,7 +48,7 @@ import SMRep ( getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr, ) import Unique ( pprUnique, Unique{-instance NamedThing-} ) import UniqSet ( emptyUniqSet, elementOfUniqSet, - addOneToUniqSet, UniqSet(..) + addOneToUniqSet, SYN_IE(UniqSet) ) import Unpretty -- ********** NOTE ********** import Util ( nOfThem, panic, assertPanic ) diff --git a/ghc/compiler/basicTypes/FieldLabel.lhs b/ghc/compiler/basicTypes/FieldLabel.lhs index 53a1b57..7e3b67c 100644 --- a/ghc/compiler/basicTypes/FieldLabel.lhs +++ b/ghc/compiler/basicTypes/FieldLabel.lhs @@ -11,7 +11,7 @@ module FieldLabel where IMP_Ubiq(){-uitous-} import Name ( Name{-instance Eq/Outputable-} ) -import Type ( Type(..) ) +import Type ( SYN_IE(Type) ) \end{code} \begin{code} diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index e379b95..7fc7505 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -6,102 +6,138 @@ \begin{code} #include "HsVersions.h" -module Id {- ( - GenId, Id(..), -- Abstract - StrictnessMark(..), -- An enumaration - ConTag(..), DictVar(..), DictFun(..), DataCon(..), +module Id ( + -- TYPES + GenId(..), -- *naughtily* used in some places (e.g., TcHsSyn) + SYN_IE(Id), IdDetails, + StrictnessMark(..), + SYN_IE(ConTag), fIRST_TAG, + SYN_IE(DataCon), SYN_IE(DictFun), SYN_IE(DictVar), -- CONSTRUCTION - mkSysLocal, mkUserLocal, - mkSpecPragmaId, - mkSpecId, mkSameSpecCon, - selectIdInfoForSpecId, - mkTemplateLocals, - mkImported, - mkDataCon, mkTupleCon, + mkConstMethodId, + mkDataCon, + mkDefaultMethodId, + mkDictFunId, mkIdWithNewUniq, - mkMethodSelId, mkSuperDictSelId, mkDefaultMethodId, - mkConstMethodId, getConstMethodId, - - updateIdType, - mkId, mkDictFunId, mkInstId, + mkImported, + mkInstId, + mkMethodSelId, + mkRecordSelId, + mkSuperDictSelId, + mkSysLocal, + mkTemplateLocals, + mkTupleCon, + mkUserId, + mkUserLocal, mkWorkerId, - localiseId, - -- DESTRUCTION + -- MANGLING + unsafeGenId2Id, + + -- DESTRUCTION (excluding pragmatic info) + idPrimRep, idType, - getIdInfo, replaceIdInfo, - getPragmaInfo, - idPrimRep, getInstIdModule, - getMentionedTyConsAndClassesFromId, + idUnique, - dataConTag, dataConStrictMarks, - dataConSig, dataConRawArgTys, dataConArgTys, - dataConTyCon, dataConArity, + dataConArgTys, + dataConArity, + dataConNumFields, dataConFieldLabels, + dataConRawArgTys, + dataConSig, + dataConStrictMarks, + dataConTag, + dataConTyCon, recordSelectorFieldLabel, -- PREDICATES - isDataCon, isTupleCon, - isNullaryDataCon, - isSpecId_maybe, isSpecPragmaId_maybe, - toplevelishId, externallyVisibleId, - isTopLevId, isWorkerId, isWrapperId, - isImportedId, isSysLocalId, - isBottomingId, - isMethodSelId, isDefaultMethodId_maybe, isSuperDictSelId_maybe, - isDictFunId, ---??? isInstId_maybe, - isConstMethodId_maybe, + cmpEqDataCon, + cmpId, cmpId_withSpecDataCon, - myWrapperMaybe, - whatsMentionedInId, - unfoldingUnfriendlyId, -- ToDo: rm, eventually + externallyVisibleId, + idHasNoFreeTyVars, idWantsToBeINLINEd, --- dataConMentionsNonPreludeTyCon, + isBottomingId, + isConstMethodId, + isConstMethodId_maybe, + isDataCon, + isDefaultMethodId, + isDefaultMethodId_maybe, + isDictFunId, + isImportedId, + isMethodSelId, + isNullaryDataCon, + isSpecPragmaId, + isSuperDictSelId_maybe, + isSysLocalId, + isTopLevId, + isTupleCon, + isWorkerId, + toplevelishId, + unfoldingUnfriendlyId, -- SUBSTITUTION - applySubstToId, applyTypeEnvToId, --- not exported: apply_to_Id, -- please don't use this, generally - - -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc) - getIdArity, addIdArity, - getIdDemandInfo, addIdDemandInfo, - getIdSpecialisation, addIdSpecialisation, - getIdStrictness, addIdStrictness, - getIdUnfolding, addIdUnfolding, - getIdUpdateInfo, addIdUpdateInfo, - getIdArgUsageInfo, addIdArgUsageInfo, - getIdFBTypeInfo, addIdFBTypeInfo, - -- don't export the types, lest OptIdInfo be dragged in! - - -- MISCELLANEOUS - unlocaliseId, - fIRST_TAG, - showId, - pprIdInUnfolding, - + applyTypeEnvToId, + apply_to_Id, + + -- PRINTING and RENUMBERING + addId, + nmbrDataCon, nmbrId, + pprId, + showId, - -- "Environments" keyed off of Ids, and sets of Ids - IdEnv(..), - lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv, - growIdEnv, growIdEnvList, isNullIdEnv, addOneToIdEnv, - delOneFromIdEnv, delManyFromIdEnv, modifyIdEnv, combineIdEnvs, - rngIdEnv, mapIdEnv, + -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc) + addIdArity, + addIdDemandInfo, + addIdStrictness, + addIdUpdateInfo, + getIdArity, + getIdDemandInfo, + getIdInfo, + getIdStrictness, + getIdUnfolding, + getIdUpdateInfo, + getPragmaInfo, - -- and to make the interface self-sufficient... - GenIdSet(..), IdSet(..) - )-} where + -- IdEnvs AND IdSets + SYN_IE(IdEnv), SYN_IE(GenIdSet), SYN_IE(IdSet), + addOneToIdEnv, + addOneToIdSet, + combineIdEnvs, + delManyFromIdEnv, + delOneFromIdEnv, + elementOfIdSet, + emptyIdSet, + growIdEnv, + growIdEnvList, + idSetToList, + intersectIdSets, + isEmptyIdSet, + isNullIdEnv, + lookupIdEnv, + lookupNoFailIdEnv, + mapIdEnv, + minusIdSet, + mkIdEnv, + mkIdSet, + modifyIdEnv, + nullIdEnv, + rngIdEnv, + unionIdSets, + unionManyIdSets, + unitIdEnv, + unitIdSet + ) where IMP_Ubiq() IMPORT_DELOOPER(IdLoop) -- for paranoia checking IMPORT_DELOOPER(TyLoop) -- for paranoia checking import Bag -import Class ( classOpString, Class(..), GenClass, ClassOp(..), GenClassOp ) -import CStrings ( identToC, cSEP ) +import Class ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClassOp ) import IdInfo import Maybes ( maybeToBool ) import Name ( appendRdr, nameUnique, mkLocalName, isLocalName, @@ -115,7 +151,7 @@ import Name ( appendRdr, nameUnique, mkLocalName, isLocalName, ) import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} ) import PragmaInfo ( PragmaInfo(..) ) -import PprEnv -- ( NmbrM(..), NmbrEnv(..) ) +import PprEnv -- ( SYN_IE(NmbrM), NmbrEnv(..) ) import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix, nmbrType, nmbrTyVar, GenType, GenTyVar @@ -125,11 +161,11 @@ import Pretty import SrcLoc ( mkBuiltinSrcLoc ) import TyCon ( TyCon, mkTupleTyCon, tyConDataCons ) import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy, - applyTyCon, isPrimType, instantiateTy, + applyTyCon, instantiateTy, tyVarsOfType, applyTypeEnvToTy, typePrimRep, - GenType, ThetaType(..), TauType(..), Type(..) + GenType, SYN_IE(ThetaType), SYN_IE(TauType), SYN_IE(Type) ) -import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) ) +import TyVar ( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) ) import UniqFM import UniqSet -- practically all of it import Unique ( getBuiltinUniques, pprUnique, showUnique, @@ -797,30 +833,15 @@ externallyVisibleId :: Id -> Bool externallyVisibleId id@(Id _ _ _ details _ _) = if isLocallyDefined id then - toplevelishId id && isExported id && not (weird_datacon details) + toplevelishId id && (isExported id || isDataCon id) + -- NB: the use of "isExported" is most dodgy; + -- We may eventually move to a situation where + -- every Id is "externallyVisible", even if the + -- module system's namespace control renders it + -- "not exported". else - not (weird_tuplecon details) + True -- if visible here, it must be visible elsewhere, too. - where - -- If it's a DataCon, it's not enough to know it (meaning - -- its TyCon) is exported; we need to know that it might - -- be visible outside. Consider: - -- - -- data Foo a = Mumble | BigFoo a WeirdLocalType - -- - -- We can't tell the outside world *anything* about Foo, because - -- of WeirdLocalType; but we need to know this when asked if - -- "Mumble" is externally visible... - -{- LATER: if at all: - weird_datacon (DataConId _ _ _ _ _ _ tycon) - = maybeToBool (maybePurelyLocalTyCon tycon) --} - weird_datacon not_a_datacon_therefore_not_weird = False - - weird_tuplecon (TupleConId arity) - = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use - weird_tuplecon _ = False \end{code} \begin{code} @@ -1050,12 +1071,19 @@ mk_classy_id details str op_str u rec_c ty info mkDictFunId u c ity full_ty from_here locn mod info = Id u n full_ty (DictFunId c ity mod) NoPragmaInfo info where - n = mkCompoundName2 u mod SLIT("dfun") (Left (origName "mkDictFunId" c) : map Right (getTypeString ity)) from_here locn + n = mkCompoundName2 u mod SLIT("dfun") (Left (origName "mkDictFunId" c) : renum_type_string full_ty ity) from_here locn mkConstMethodId u c op ity full_ty from_here locn mod info = Id u n full_ty (ConstMethodId c ity op mod) NoPragmaInfo info where - n = mkCompoundName2 u mod SLIT("const") (Left (origName "mkConstMethodId" c) : Right (classOpString op) : map Right (getTypeString ity)) from_here locn + n = mkCompoundName2 u mod SLIT("const") (Left (origName "mkConstMethodId" c) : Right (classOpString op) : renum_type_string full_ty ity) from_here locn + +renum_type_string full_ty ity + = initNmbr ( + nmbrType full_ty `thenNmbr` \ _ -> -- so all the tyvars get added to renumbering... + nmbrType ity `thenNmbr` \ rn_ity -> + returnNmbr (getTypeString rn_ity) + ) mkWorkerId u unwrkr ty info = Id u n ty (WorkerId unwrkr) NoPragmaInfo info @@ -1209,16 +1237,24 @@ besides the code-generator need arity info!) \begin{code} getIdArity :: Id -> ArityInfo -getIdArity (Id _ _ _ _ _ id_info) = getInfo id_info +getIdArity id@(Id _ _ _ _ _ id_info) + = --ASSERT( not (isDataCon id)) + getInfo id_info + +dataConArity, dataConNumFields :: DataCon -> Int -dataConArity :: DataCon -> Int dataConArity id@(Id _ _ _ _ _ id_info) = ASSERT(isDataCon id) case (arityMaybe (getInfo id_info)) of - Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id) Just i -> i + Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id) -isNullaryDataCon con = dataConArity con == 0 -- function of convenience +dataConNumFields id + = ASSERT(isDataCon id) + case (dataConSig id) of { (_, _, arg_tys, _) -> + length arg_tys } + +isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience addIdArity :: Id -> Int -> Id addIdArity (Id u n ty details pinfo info) arity @@ -1250,7 +1286,7 @@ mkDataCon n stricts fields tvs ctxt args_tys tycon n type_of_constructor (DataConId data_con_tag stricts fields tvs ctxt args_tys tycon) - NoPragmaInfo + IWantToBeINLINEd -- Always inline constructors if possible datacon_info data_con_tag = position_within fIRST_TAG data_con_family @@ -1274,7 +1310,7 @@ mkDataCon n stricts fields tvs ctxt args_tys tycon `addInfo` mkArityInfo arity --ToDo: `addInfo` specenv - arity = length args_tys + arity = length ctxt + length args_tys unfolding = noInfo_UF @@ -1740,15 +1776,15 @@ mkIdSet = mkUniqSet \end{code} \begin{code} -addId, nmbrId :: Id -> NmbrM Id +addId, nmbrId, nmbrDataCon :: Id -> NmbrM Id addId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) = case (lookupUFM_Directly idenv u) of - Just xx -> _trace "addId: already in map!" $ + Just xx -> trace "addId: already in map!" $ (nenv, xx) Nothing -> if toplevelishId id then - _trace "addId: can't add toplevelish!" $ + trace "addId: can't add toplevelish!" $ (nenv, id) else -- alloc a new unique for this guy -- and add an entry in the idenv @@ -1770,7 +1806,7 @@ nmbrId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) Just xx -> (nenv, xx) Nothing -> if not (toplevelishId id) then - _trace "nmbrId: lookup failed" $ + trace "nmbrId: lookup failed" $ (nenv, id) else let @@ -1781,6 +1817,25 @@ nmbrId id@(Id u n ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) in (nenv3, new_id) + -- used when renumbering TyCons to produce data decls... +nmbrDataCon id@(Id _ _ _ (TupleConId _) _ _) nenv + = (nenv, id) -- nothing to do for tuples + +nmbrDataCon id@(Id u n ty (DataConId tag marks fields tvs theta arg_tys tc) prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) + = case (lookupUFM_Directly idenv u) of + Just xx -> trace "nmbrDataCon: in env???\n" (nenv, xx) + Nothing -> + let + (nenv2, new_fields) = (mapNmbr nmbrField fields) nenv + (nenv3, new_arg_tys) = (mapNmbr nmbrType arg_tys) nenv2 + + new_det = DataConId tag marks new_fields (bottom "tvs") (bottom "theta") new_arg_tys tc + new_id = Id u n (bottom "ty") new_det prag info + in + (nenv3, new_id) + where + bottom msg = panic ("nmbrDataCon"++msg) + ------------ nmbr_details :: IdDetails -> NmbrM IdDetails diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 43c6b99..f6afdc1 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -30,7 +30,7 @@ module IdInfo ( mkDemandInfo, willBeDemanded, - MatchEnv, -- the SpecEnv + MatchEnv, -- the SpecEnv (why is this exported???) StrictnessInfo(..), -- non-abstract Demand(..), -- non-abstract @@ -47,14 +47,14 @@ module IdInfo ( UpdateInfo, mkUpdateInfo, - UpdateSpec(..), + SYN_IE(UpdateSpec), updateInfoMaybe, DeforestInfo(..), ArgUsageInfo, ArgUsage(..), - ArgUsageType(..), + SYN_IE(ArgUsageType), mkArgUsageInfo, getArgUsage, @@ -68,6 +68,7 @@ module IdInfo ( ) where IMP_Ubiq() +IMPORT_1_3(Char(toLower)) IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and -- we break those loops by using IdLoop and @@ -76,7 +77,7 @@ IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and import CmdLineOpts ( opt_OmitInterfacePragmas ) import Maybes ( firstJust ) -import MatchEnv ( nullMEnv, isEmptyMEnv, mEnvToList ) +import MatchEnv ( nullMEnv, isEmptyMEnv, mEnvToList, MatchEnv ) import Outputable ( ifPprInterface, Outputable(..){-instances-} ) import PprStyle ( PprStyle(..) ) import Pretty @@ -565,7 +566,7 @@ or an Absent {\em that we accept}. indicatesWorker :: [Demand] -> Bool indicatesWorker dems - = fake_mk_ww (_trace "mAX_WORKER_ARGS" 6 - nonAbsentArgs dems) dems + = fake_mk_ww (trace "mAX_WORKER_ARGS" 6 - nonAbsentArgs dems) dems where fake_mk_ww _ [] = False fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent diff --git a/ghc/compiler/basicTypes/IdLoop_1_3.lhi b/ghc/compiler/basicTypes/IdLoop_1_3.lhi new file mode 100644 index 0000000..9de57ba --- /dev/null +++ b/ghc/compiler/basicTypes/IdLoop_1_3.lhi @@ -0,0 +1,23 @@ +\begin{code} +interface IdLoop_1_3 1 +__exports__ +CoreSyn CoreExpr +CoreUnfold FormSummary (..) +CoreUnfold UnfoldingDetails (..) +CoreUnfold UnfoldingGuidance (..) +CoreUtils unTagBinders (..) +Id IdEnv +Id externallyVisibleId (..) +Id getIdInfo (..) +Id isDataCon (..) +Id isWorkerId (..) +Id lookupIdEnv (..) +Id nmbrId (..) +Id nullIdEnv (..) +Id unfoldingUnfriendlyId (..) +MagicUFs MagicUnfoldingFun +MagicUFs mkMagicUnfoldingFun (..) +OccurAnal occurAnalyseGlobalExpr (..) +PprType pprParendGenType (..) +WwLib mAX_WORKER_ARGS (..) +\end{code} diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index 1330a3d..5caf003 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -16,6 +16,7 @@ module Literal ( ) where IMP_Ubiq(){-uitous-} +IMPORT_1_3(Ratio) -- friends: import PrimRep ( PrimRep(..) ) -- non-abstract diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 7747daf..4a2b799 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -7,7 +7,7 @@ #include "HsVersions.h" module Name ( - Module(..), + SYN_IE(Module), OrigName(..), -- glorified pair qualToOrigName, -- a Qual to an OrigName @@ -58,18 +58,21 @@ module Name ( ) where IMP_Ubiq() +IMPORT_1_3(Char(isUpper,isLower)) -import CmdLineOpts ( maybe_CompilingPrelude ) -import CStrings ( identToC, cSEP ) +import CmdLineOpts ( maybe_CompilingGhcInternals ) +import CStrings ( identToC, modnameToC, cSEP ) import Outputable ( Outputable(..) ) import PprStyle ( PprStyle(..), codeStyle ) import PrelMods ( pRELUDE ) import Pretty -import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc ) +import SrcLoc ( mkBuiltinSrcLoc, mkUnknownSrcLoc, SrcLoc ) import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique, pprUnique, Unique ) -import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic ) +import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic, pprTrace{-ToDo:rm-} ) +import {-hide from mkdependHS-} + RnHsSyn ( RnName ) -- instance for specializing only #ifdef REALLY_HASKELL_1_3 ord = fromEnum :: Char -> Int @@ -145,7 +148,7 @@ instance NamedThing RdrName where locn = panic "NamedThing.RdrName:locn" getName rdr_name@(Qual m n) - = Global u m n prov ex [rdr_name] + = Global u m (Left n) prov ex [rdr_name] where u = panic "NamedThing.RdrName:Unique" prov = panic "NamedThing.RdrName:Provenance" @@ -155,13 +158,24 @@ instance Outputable RdrName where ppr sty (Unqual n) = pp_name sty n ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n) -pp_mod PprForC m = ppBesides [identToC m, ppPStr cSEP] -pp_mod (PprForAsm False _) m = ppBesides [identToC m, ppPStr cSEP] -pp_mod (PprForAsm True _) m = ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP] -pp_mod _ m = ppBesides [ppPStr m, ppChar '.'] +pp_mod sty m + = case sty of + PprForC -> pp_code + PprForAsm False _ -> pp_code + PprForAsm True _ -> ppBeside (ppPStr cSEP) pp_code + _ -> ppBeside (ppPStr m) (ppChar '.') + where + pp_code = ppBeside (ppPStr (modnameToC m)) (ppPStr cSEP) + +pp_name sty n = (if codeStyle sty then identToC else ppPStr) n + +pp_name2 sty pieces + = ppIntersperse sep (map pp_piece pieces) + where + sep = if codeStyle sty then ppPStr cSEP else ppChar '.' -pp_name sty n | codeStyle sty = identToC n - | otherwise = ppPStr n + pp_piece (Left (OrigName m n)) = ppBeside (pp_mod sty m) (pp_name sty n) + pp_piece (Right n) = pp_name sty n showRdr sty rdr = ppShow 100 (ppr sty rdr) @@ -202,7 +216,10 @@ data Name | Global Unique Module -- original name - FAST_STRING + (Either + FAST_STRING -- just an ordinary M.n name... or... + ([Either OrigName FAST_STRING])) + -- "dot" these bits of name together... Provenance -- where it came from ExportFlag -- is it exported? [RdrName] -- ordered occurrence names (usually just one); @@ -227,21 +244,21 @@ data Provenance \begin{code} mkLocalName = Local -mkTopLevName u (OrigName m n) locn exp occs = Global u m n (LocalDef locn) exp occs -mkImportedName u (OrigName m n) imp locn imp_locs exp occs = Global u m n (Imported imp locn imp_locs) exp occs +mkTopLevName u (OrigName m n) locn exp occs = Global u m (Left n) (LocalDef locn) exp occs +mkImportedName u (OrigName m n) imp locn imp_locs exp occs = Global u m (Left n) (Imported imp locn imp_locs) exp occs mkImplicitName :: Unique -> OrigName -> Name -mkImplicitName u (OrigName m n) = Global u m n Implicit NotExported [] +mkImplicitName u (OrigName m n) = Global u m (Left n) Implicit NotExported [] mkPrimitiveName :: Unique -> OrigName -> Name -mkPrimitiveName u (OrigName m n) = Global u m n Primitive NotExported [] +mkPrimitiveName u (OrigName m n) = Global u m (Left n) Primitive NotExported [] -mkWiredInName :: Unique -> OrigName -> Name -mkWiredInName u (OrigName m n) - = Global u m n (WiredIn from_here) (if from_here then ExportAll else NotExported) [] +mkWiredInName :: Unique -> OrigName -> ExportFlag -> Name +mkWiredInName u (OrigName m n) exp + = Global u m (Left n) (WiredIn from_here) exp [] where from_here - = case maybe_CompilingPrelude of + = case maybe_CompilingGhcInternals of Nothing -> False Just mod -> mod == _UNPK_ m @@ -254,11 +271,14 @@ mkCompoundName :: Unique mkCompoundName u m str ns (Local _ _ _ _) = panic "mkCompoundName:Local?" mkCompoundName u m str ns (Global _ _ _ prov exp _) - = Global u m (_CONCAT_ (glue ns [str])) prov exp [] + = Global u m (Right (Right str : ns)) prov exp [] -glue [] acc = reverse acc -glue (Left (OrigName m n):ns) acc = glue ns (_CONS_ '.' n : _CONS_ '.' m : acc) -glue (Right n :ns) acc = glue ns (_CONS_ '.' n : acc) +glue = glue1 +glue1 (Left (OrigName m n):ns) = m : _CONS_ '.' n : glue2 ns +glue1 (Right n :ns) = n : glue2 ns +glue2 [] = [] +glue2 (Left (OrigName m n):ns) = _CONS_ '.' m : _CONS_ '.' n : glue2 ns +glue2 (Right n :ns) = _CONS_ '.' n : glue2 ns -- this ugly one is used for instance-y things mkCompoundName2 :: Unique @@ -270,7 +290,7 @@ mkCompoundName2 :: Unique -> Name -- result! mkCompoundName2 u m str ns from_here locn - = Global u m (_CONCAT_ (glue ns [str])) + = Global u m (Right (Right str : ns)) (if from_here then LocalDef locn else Imported ExportAll locn []) ExportAll{-instances-} [] @@ -278,9 +298,9 @@ mkCompoundName2 u m str ns from_here locn mkFunTyConName = mkPrimitiveName funTyConKey (OrigName pRELUDE SLIT("->")) mkTupleDataConName arity - = mkWiredInName (mkTupleDataConUnique arity) (OrigName pRELUDE (mkTupNameStr arity)) + = mkWiredInName (mkTupleDataConUnique arity) (OrigName pRELUDE (mkTupNameStr arity)) ExportAll mkTupleTyConName arity - = mkWiredInName (mkTupleTyConUnique arity) (OrigName pRELUDE (mkTupNameStr arity)) + = mkWiredInName (mkTupleTyConUnique arity) (OrigName pRELUDE (mkTupNameStr arity)) ExportAll mkTupNameStr 0 = SLIT("()") mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???" @@ -354,14 +374,21 @@ nameUnique (Global u _ _ _ _ _) = u changeUnique (Local _ n b l) u = Local u n b l changeUnique (Global _ m n p e os) u = Global u m n p e os -nameOrigName msg (Global _ m n _ _ _) = OrigName m n +nameOrigName msg (Global _ m (Left n) _ _ _) = OrigName m n +nameOrigName msg (Global _ m (Right n) _ _ _) = let str = _CONCAT_ (glue n) in + pprTrace ("nameOrigName:"++msg) (ppPStr str) $ + OrigName m str #ifdef DEBUG nameOrigName msg (Local _ n _ _) = panic ("nameOrigName:Local:"++msg++":"++ _UNPK_ n) #endif nameOccName (Local _ n _ _) = Unqual n -nameOccName (Global _ m n _ _ [] ) = Qual m n -nameOccName (Global _ m n _ _ (o:_)) = o +nameOccName (Global _ m (Left n) _ _ [] ) = Qual m n +nameOccName (Global _ m (Right n) _ _ [] ) = let str = _CONCAT_ (glue n) in + pprTrace "nameOccName:" (ppPStr str) $ + Qual m str +nameOccName (Global _ m (Left _) _ _ (o:_)) = o +nameOccName (Global _ m (Right _) _ _ (o:_)) = panic "nameOccName:compound name" nameExportFlag (Local _ _ _ _) = NotExported nameExportFlag (Global _ _ _ _ exp _) = exp @@ -401,11 +428,18 @@ instance Outputable Name where | emph_uniq = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"] | otherwise = ppBesides [ppPStr n, ppStr "{-", pprUnique u, ppStr "-}"] - ppr PprDebug (Global u m n _ _ _) = ppBesides [ppr PprDebug (Qual m n), ppStr "{-", pprUnique u, ppStr "-}"] - ppr PprForUser (Global u m n _ _ [] ) = ppr PprForUser (Qual m n) - ppr PprForUser (Global u m n _ _ occs) = ppr PprForUser (head occs) - ppr PprShowAll (Global u m n prov exp occs) = pp_all (Qual m n) prov exp occs - ppr sty (Global u m n _ _ _) = ppr sty (Qual m n) + ppr PprDebug (Global u m (Left n) _ _ _) = ppBesides [pp_mod PprDebug m, pp_name PprDebug n, ppStr "{-", pprUnique u, ppStr "-}"] + ppr PprDebug (Global u m (Right n) _ _ _) = ppBesides [pp_mod PprDebug m, pp_name2 PprDebug n, ppStr "{-", pprUnique u, ppStr "-}"] + + ppr PprForUser (Global u m (Left n) _ _ [] ) = ppBeside (pp_mod PprForUser m) (pp_name PprForUser n) + ppr PprForUser (Global u m (Right n) _ _ [] ) = ppBeside (pp_mod PprForUser m) (pp_name2 PprForUser n) + ppr PprForUser (Global u m (Left _) _ _ occs) = ppr PprForUser (head occs) + +-- LATER:? +-- ppr PprShowAll (Global u m n prov exp occs) = pp_all (Qual m n) prov exp occs + + ppr sty (Global u m (Left n) _ _ _) = ppBeside (pp_mod sty m) (pp_name sty n) + ppr sty (Global u m (Right n) _ _ _) = ppBeside (pp_mod sty m) (pp_name2 sty n) pp_all orig prov exp occs = ppBesides [ppr PprShowAll orig, ppr PprShowAll occs, pp_prov prov, pp_exp exp] @@ -442,6 +476,9 @@ data ExportFlag exportFlagOn NotExported = False exportFlagOn _ = True +-- Be very wary about using "isExported"; perhaps you +-- really mean "externallyVisibleId"? + isExported a = exportFlagOn (getExportFlag a) \end{code} @@ -475,8 +512,11 @@ nameOf (OrigName m n) = n getLocalName n = case (getName n) of - Global _ m n _ _ _ -> n - Local _ n _ _ -> n + Local _ n _ _ -> n + Global _ m (Left n) _ _ _ -> n + Global _ m (Right n) _ _ _ -> let str = _CONCAT_ (glue n) in + -- pprTrace "getLocalName:" (ppPStr str) $ + str getOccName = nameOccName . getName getExportFlag = nameExportFlag . getName @@ -485,6 +525,24 @@ getImpLocs = nameImpLocs . getName isLocallyDefined = isLocallyDefinedName . getName \end{code} +\begin{code} +{-# SPECIALIZE getLocalName + :: Name -> FAST_STRING + , OrigName -> FAST_STRING + , RdrName -> FAST_STRING + , RnName -> FAST_STRING + #-} +{-# SPECIALIZE isLocallyDefined + :: Name -> Bool + , RnName -> Bool + #-} +{-# SPECIALIZE origName + :: String -> Name -> OrigName + , String -> RdrName -> OrigName + , String -> RnName -> OrigName + #-} +\end{code} + These functions test strings to see if they fit the lexical categories defined in the Haskell report. Normally applied as in e.g. @isCon (getLocalName foo)@. diff --git a/ghc/compiler/basicTypes/PprEnv.lhs b/ghc/compiler/basicTypes/PprEnv.lhs index 07dd8ec..a2af9ac 100644 --- a/ghc/compiler/basicTypes/PprEnv.lhs +++ b/ghc/compiler/basicTypes/PprEnv.lhs @@ -15,7 +15,7 @@ module PprEnv ( pTy, pTyVar, pUVar, pUse, NmbrEnv(..), - NmbrM(..), initNmbr, + SYN_IE(NmbrM), initNmbr, returnNmbr, thenNmbr, mapNmbr, mapAndUnzipNmbr -- nmbr1, nmbr2, nmbr3 @@ -25,7 +25,7 @@ module PprEnv ( IMP_Ubiq(){-uitous-} -import Pretty ( Pretty(..) ) +import Pretty ( SYN_IE(Pretty) ) import Unique ( initRenumberingUniques ) import UniqFM ( emptyUFM ) import Util ( panic ) diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs index 1f45155..88ac980 100644 --- a/ghc/compiler/basicTypes/UniqSupply.lhs +++ b/ghc/compiler/basicTypes/UniqSupply.lhs @@ -12,7 +12,7 @@ module UniqSupply ( getUnique, getUniques, -- basic ops - UniqSM(..), -- type: unique supply monad + SYN_IE(UniqSM), -- type: unique supply monad initUs, thenUs, returnUs, mapUs, mapAndUnzipUs, mapAndUnzip3Us, thenMaybeUs, mapAccumLUs, @@ -28,6 +28,12 @@ import Util import PreludeGlaST +#if __GLASGOW_HASKELL__ >= 200 +# define WHASH GHCbase.W# +#else +# define WHASH W# +#endif + w2i x = word2Int# x i2w x = int2Word# x i2w_s x = (x :: Int#) @@ -74,27 +80,34 @@ mkSplitUniqSupply (C# c#) -- here comes THE MAGIC: mk_supply# - = unsafe_interleave ( + = unsafeInterleavePrimIO {-unsafe_interleave-} ( mk_unique `thenPrimIO` \ uniq -> mk_supply# `thenPrimIO` \ s1 -> mk_supply# `thenPrimIO` \ s2 -> returnPrimIO (MkSplitUniqSupply uniq s1 s2) ) where +{- -- inlined copy of unsafeInterleavePrimIO; -- this is the single-most-hammered bit of code -- in the compiler.... + -- Too bad it's not 1.3-portable... unsafe_interleave m s = let (r, new_s) = m s in (r, s) +-} - mk_unique = _ccall_ genSymZh `thenPrimIO` \ (W# u#) -> + mk_unique = _ccall_ genSymZh `thenPrimIO` \ (WHASH u#) -> returnPrimIO (I# (w2i (mask# `or#` u#))) in +#if __GLASGOW_HASKELL__ >= 200 + primIOToIO mk_supply# +#else mk_supply# `thenPrimIO` \ s -> return s +#endif splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2) \end{code} diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 34172e6..2f2b1c8 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -323,11 +323,25 @@ pprUnique, pprUnique10 :: Unique -> Pretty pprUnique uniq = case unpkUnique uniq of - (tag, u) -> ppBeside (ppChar tag) (iToBase62 u) + (tag, u) -> finish_ppr tag u (iToBase62 u) pprUnique10 uniq -- in base-10, dudes = case unpkUnique uniq of - (tag, u) -> ppBeside (ppChar tag) (ppInt u) + (tag, u) -> finish_ppr tag u (ppInt u) + +finish_ppr tag u pp_u + = if tag /= 't' -- this is just to make v common tyvars, t1, t2, ... + -- come out as a, b, ... (shorter, easier to read) + then pp_all + else case u of + 1 -> ppChar 'a' + 2 -> ppChar 'b' + 3 -> ppChar 'c' + 4 -> ppChar 'd' + 5 -> ppChar 'e' + _ -> pp_all + where + pp_all = ppBeside (ppChar tag) pp_u showUnique :: Unique -> FAST_STRING showUnique uniq = _PK_ (ppShow 80 (pprUnique uniq)) @@ -349,12 +363,26 @@ A character-stingy way to read/write numbers (notably Uniques). The ``62-its'' are \tr{[0-9a-zA-Z]}. We don't handle negative Ints. Code stolen from Lennart. \begin{code} +#if __GLASGOW_HASKELL__ >= 200 +# define BYTE_ARRAY GHCbase.ByteArray +# define RUN_ST GHCbase.runST +# define AND_THEN >>= +# define AND_THEN_ >> +# define RETURN return +#else +# define BYTE_ARRAY _ByteArray +# define RUN_ST _runST +# define AND_THEN `thenStrictlyST` +# define AND_THEN_ `seqStrictlyST` +# define RETURN returnStrictlyST +#endif + iToBase62 :: Int -> Pretty iToBase62 n@(I# n#) = ASSERT(n >= 0) let - bytes = case chars62 of { _ByteArray bounds_who_needs_'em bytes -> bytes } + bytes = case chars62 of { BYTE_ARRAY bounds_who_needs_'em bytes -> bytes } in if n# <# 62# then case (indexCharArray# bytes n#) of { c -> @@ -365,20 +393,20 @@ iToBase62 n@(I# n#) ppBeside (iToBase62 q) (ppChar (C# c)) }} -- keep this at top level! (bug on 94/10/24 WDP) -chars62 :: _ByteArray Int +chars62 :: BYTE_ARRAY Int chars62 - = _runST ( - newCharArray (0, 61) `thenStrictlyST` \ ch_array -> + = RUN_ST ( + newCharArray (0, 61) AND_THEN \ ch_array -> fill_in ch_array 0 62 "0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" - `seqStrictlyST` + AND_THEN_ unsafeFreezeByteArray ch_array ) where fill_in ch_array i lim str | i == lim - = returnStrictlyST () + = RETURN () | otherwise - = writeCharArray ch_array i (str !! i) `seqStrictlyST` + = writeCharArray ch_array i (str !! i) AND_THEN_ fill_in ch_array (i+1) lim str \end{code} diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 92d6af2..0fc6bed 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -35,11 +35,11 @@ import CgMonad import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset ) import CLabel ( mkClosureLabel ) import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument ) -import HeapOffs ( VirtualHeapOffset(..), - VirtualSpAOffset(..), VirtualSpBOffset(..) +import HeapOffs ( SYN_IE(VirtualHeapOffset), + SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset) ) import Id ( idPrimRep, toplevelishId, isDataCon, - mkIdEnv, rngIdEnv, IdEnv(..), + mkIdEnv, rngIdEnv, SYN_IE(IdEnv), idSetToList, GenId{-instance NamedThing-} ) @@ -49,7 +49,7 @@ import Name ( isLocallyDefined, oddlyImportedName, Name{-instance NamedThing-} import PprAbsC ( pprAmode ) #endif import PprStyle ( PprStyle(..) ) -import StgSyn ( StgArg(..), StgLiveVars(..), GenStgArg(..) ) +import StgSyn ( SYN_IE(StgArg), SYN_IE(StgLiveVars), GenStgArg(..) ) import Unpretty ( uppShow ) import Util ( zipWithEqual, panic ) \end{code} @@ -196,11 +196,17 @@ getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo) getCAddrModeAndInfo id | not (isLocallyDefined name) || oddlyImportedName name + {- Why the "oddlyImported"? + Imagine you are compiling GHCbase.hs (a module that + supplies some of the wired-in values). What can + happen is that the compiler will inject calls to + (e.g.) GHCbase.unpackPS, where-ever it likes -- it + assumes those values are ubiquitously available. + The main point is: it may inject calls to them earlier + in GHCbase.hs than the actual definition... + -} = returnFC (global_amode, mkLFImported id) - | isDataCon id - = returnFC (global_amode, mkConLFInfo id) - | otherwise = -- *might* be a nested defn: in any case, it's something whose -- definition we will know about... lookupBindC id `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) -> diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 17d6126..538a9e3 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -46,10 +46,10 @@ import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel, import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon ) import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros ) import CostCentre ( useCurrentCostCentre ) -import HeapOffs ( VirtualSpBOffset(..), VirtualHeapOffset(..) ) +import HeapOffs ( SYN_IE(VirtualSpBOffset), SYN_IE(VirtualHeapOffset) ) import Id ( idPrimRep, toplevelishId, - dataConTag, fIRST_TAG, ConTag(..), - isDataCon, DataCon(..), + dataConTag, fIRST_TAG, SYN_IE(ConTag), + isDataCon, SYN_IE(DataCon), idSetToList, GenId{-instance Uniquable,Eq-} ) import Maybes ( catMaybes ) diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index cfd5cea..e2d6de9 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -13,7 +13,7 @@ with {\em closures} on the RHSs of let(rec)s. See also module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where IMP_Ubiq(){-uitous-} -IMPORT_DELOOPER(CgLoop2) ( cgExpr, cgSccExpr ) +IMPORT_DELOOPER(CgLoop2) ( cgExpr ) import CgMonad import AbsCSyn @@ -50,9 +50,9 @@ import ClosureInfo -- lots and lots of stuff import CmdLineOpts ( opt_ForConcurrent, opt_GranMacros ) import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts, noCostCentreAttached, costsAreSubsumed, - isCafCC, overheadCostCentre + isCafCC, isDictCC, overheadCostCentre ) -import HeapOffs ( VirtualHeapOffset(..) ) +import HeapOffs ( SYN_IE(VirtualHeapOffset) ) import Id ( idType, idPrimRep, showId, getIdStrictness, dataConTag, emptyIdSet, @@ -411,7 +411,7 @@ closureCodeBody binder_info closure_info cc [] body body_addr = CLbl (entryLabelFromCI closure_info) CodePtrRep body_code = profCtrC SLIT("ENT_THK") [] `thenC` enterCostCentreCode closure_info cc IsThunk `thenC` - thunkWrapper closure_info (cgSccExpr body) + thunkWrapper closure_info (cgExpr body) stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep \end{code} @@ -581,6 +581,9 @@ Node is guaranteed to point to it, if profiling and not inherited. \begin{code} data IsThunk = IsThunk | IsFunction -- Bool-like, local +#ifdef DEBUG + deriving Eq +#endif enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code @@ -588,37 +591,31 @@ enterCostCentreCode closure_info cc is_thunk = costCentresFlag `thenFC` \ profiling_on -> if not profiling_on then nopC - else -- down to business + else ASSERT(not (noCostCentreAttached cc)) if costsAreSubsumed cc then - nopC - - else if is_current_CC cc then -- fish the CC out of the closure, - -- where we put it when we alloc'd; - -- NB: chk defn of "is_current_CC" - -- if you go to change this! (WDP 94/12) - costCentresC - (case is_thunk of - IsThunk -> SLIT("ENTER_CC_TCL") - IsFunction -> SLIT("ENTER_CC_FCL")) - [CReg node] - - else if isCafCC cc then - costCentresC - SLIT("ENTER_CC_CAF") - [mkCCostCentre cc] + ASSERT(isToplevClosure closure_info) + ASSERT(is_thunk == IsFunction) + costCentresC SLIT("ENTER_CC_FSUB") [] + + else if currentOrSubsumedCosts cc then + -- i.e. current; subsumed dealt with above + -- get CCC out of the closure, where we put it when we alloc'd + case is_thunk of + IsThunk -> costCentresC SLIT("ENTER_CC_TCL") [CReg node] + IsFunction -> costCentresC SLIT("ENTER_CC_FCL") [CReg node] + + else if isCafCC cc && isToplevClosure closure_info then + ASSERT(is_thunk == IsThunk) + costCentresC SLIT("ENTER_CC_CAF") [mkCCostCentre cc] else -- we've got a "real" cost centre right here in our hands... - costCentresC - (case is_thunk of - IsThunk -> SLIT("ENTER_CC_T") - IsFunction -> SLIT("ENTER_CC_F")) - [mkCCostCentre cc] - where - is_current_CC cc - = currentOrSubsumedCosts cc - -- but we've already ruled out "subsumed", so it must be "current"! + case is_thunk of + IsThunk -> costCentresC SLIT("ENTER_CC_T") [mkCCostCentre cc] + IsFunction -> if isCafCC cc || isDictCC cc + then costCentresC SLIT("ENTER_CC_FCAF") [mkCCostCentre cc] + else costCentresC SLIT("ENTER_CC_FLOAD") [mkCCostCentre cc] \end{code} %************************************************************************ @@ -933,6 +930,7 @@ chooseDynCostCentres cc args fvs body | just1 == fun -> mkCCostCentre overheadCostCentre _ -> use_cc + -- if it's an utterly trivial RHS, then it must be -- one introduced by boxHigherOrderArgs for profiling, -- so we charge it to "OVERHEAD". diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index cb5337b..c2aa1f5 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -44,7 +44,7 @@ import CostCentre ( currentOrSubsumedCosts, useCurrentCostCentre, dontCareCostCentre ) import Id ( idPrimRep, dataConTag, dataConTyCon, - isDataCon, DataCon(..), + isDataCon, SYN_IE(DataCon), emptyIdSet ) import Literal ( Literal(..) ) diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index 2083d8f..e13d043 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -34,9 +34,9 @@ import ClosureInfo ( layOutStaticClosure, layOutDynCon, ) import CostCentre ( dontCareCostCentre ) import FiniteMap ( fmToList ) -import HeapOffs ( zeroOff, VirtualHeapOffset(..) ) +import HeapOffs ( zeroOff, SYN_IE(VirtualHeapOffset) ) import Id ( dataConTag, dataConRawArgTys, - dataConArity, fIRST_TAG, + dataConNumFields, fIRST_TAG, emptyIdSet, GenId{-instance NamedThing-} ) @@ -241,7 +241,6 @@ genConInfo comp_info tycon data_con zero_size arg_ty = getPrimRepSize (typePrimRep arg_ty) == 0 arg_tys = dataConRawArgTys data_con - con_arity = dataConArity data_con entry_label = mkConEntryLabel data_con closure_label = mkStaticClosureLabel data_con \end{code} @@ -339,7 +338,7 @@ genPhantomUpdInfo comp_info tycon data_con con_descr = _UNPK_ (nameOf (origName "con_descr2" data_con)) - con_arity = dataConArity data_con + con_arity = dataConNumFields data_con upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return) upd_label = mkConUpdCodePtrVecLabel tycon tag diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index a4a0746..212a728 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -10,7 +10,7 @@ \begin{code} #include "HsVersions.h" -module CgExpr ( cgExpr, cgSccExpr, getPrimOpArgAmodes ) where +module CgExpr ( cgExpr, getPrimOpArgAmodes ) where IMP_Ubiq(){-uitous-} IMPORT_DELOOPER(CgLoop2) -- here for paranoia-checking @@ -35,8 +35,8 @@ import CgTailCall ( cgTailCall, performReturn, ) import CLabel ( mkPhantomInfoTableLabel, mkInfoTableVecTblLabel ) import ClosureInfo ( mkClosureLFInfo ) -import CostCentre ( setToAbleCostCentre, isDupdCC ) -import HeapOffs ( VirtualSpBOffset(..) ) +import CostCentre ( sccAbleCostCentre, isDictCC, isSccCountCostCentre ) +import HeapOffs ( SYN_IE(VirtualSpBOffset) ) import Id ( mkIdSet, unionIdSets, GenId{-instance Outputable-} ) import PprStyle ( PprStyle(..) ) import PrimOp ( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..), @@ -270,30 +270,17 @@ cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body) SCC expressions are treated specially. They set the current cost centre. - -For evaluation scoping we also need to save the cost centre in an -``restore CC frame''. We only need to do this once before setting all -nested SCCs. - \begin{code} -cgExpr scc_expr@(StgSCC ty cc expr) = cgSccExpr scc_expr +cgExpr (StgSCC ty cc expr) + = ASSERT(sccAbleCostCentre cc) + costCentresC + (if isDictCC cc then SLIT("SET_DICT_CCC") else SLIT("SET_CCC")) + [mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)] + `thenC` + cgExpr expr \end{code} -@cgSccExpr@ (also used in \tr{CgClosure}): -We *don't* set the cost centre for CAF/Dict cost centres -[Likewise Subsumed and NoCostCentre, but they probably -don't exist in an StgSCC expression.] -\begin{code} -cgSccExpr (StgSCC ty cc expr) - = (if setToAbleCostCentre cc then - costCentresC SLIT("SET_CCC") - [mkCCostCentre cc, mkIntCLit (if isDupdCC cc then 1 else 0)] - else - nopC) `thenC` - cgSccExpr expr -cgSccExpr other - = cgExpr other -\end{code} +ToDo: counting of dict sccs ... %******************************************************** %* * diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 888908f..2d4abe2 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -28,7 +28,7 @@ import ClosureInfo ( closureSize, closureHdrSize, closureGoodStuffSize, slopSize, allocProfilingMsg, closureKind ) import HeapOffs ( isZeroOff, addOff, intOff, - VirtualHeapOffset(..) + SYN_IE(VirtualHeapOffset) ) import PrimRep ( PrimRep(..) ) \end{code} diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs index 3748ddd..3126b25 100644 --- a/ghc/compiler/codeGen/CgLetNoEscape.lhs +++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs @@ -28,7 +28,7 @@ import CgStackery ( mkVirtStkOffsets ) import CgUsages ( setRealAndVirtualSps, getVirtSps ) import CLabel ( mkStdEntryLabel ) import ClosureInfo ( mkLFLetNoEscape ) -import HeapOffs ( VirtualSpBOffset(..) ) +import HeapOffs ( SYN_IE(VirtualSpBOffset) ) import Id ( idPrimRep ) \end{code} diff --git a/ghc/compiler/codeGen/CgLoop1_1_3.lhi b/ghc/compiler/codeGen/CgLoop1_1_3.lhi new file mode 100644 index 0000000..c5b3d81 --- /dev/null +++ b/ghc/compiler/codeGen/CgLoop1_1_3.lhi @@ -0,0 +1,10 @@ +\begin{code} +interface CgLoop1_1_3 1 +__exports__ +CgBindery CgBindings(..) +CgBindery CgIdInfo(..) +CgBindery nukeVolatileBinds (..) +CgBindery maybeAStkLoc (..) +CgBindery maybeBStkLoc (..) +CgUsages getSpBRelOffset (..) +\end{code} diff --git a/ghc/compiler/codeGen/CgLoop2.lhi b/ghc/compiler/codeGen/CgLoop2.lhi index feda847..421fbfa 100644 --- a/ghc/compiler/codeGen/CgLoop2.lhi +++ b/ghc/compiler/codeGen/CgLoop2.lhi @@ -2,7 +2,7 @@ Break loops caused by cgExpr and getPrimOpArgAmodes. \begin{code} interface CgLoop2 where -import CgExpr ( cgExpr, cgSccExpr, getPrimOpArgAmodes ) +import CgExpr ( cgExpr, getPrimOpArgAmodes ) import AbsCSyn ( CAddrMode ) import CgMonad ( Code(..), FCode(..) ) @@ -10,6 +10,5 @@ import PrimOp ( PrimOp ) import StgSyn ( StgExpr(..), StgArg(..) ) cgExpr :: StgExpr -> Code -cgSccExpr :: StgExpr -> Code getPrimOpArgAmodes :: PrimOp -> [StgArg] -> FCode [CAddrMode] \end{code} diff --git a/ghc/compiler/codeGen/CgLoop2_1_3.lhi b/ghc/compiler/codeGen/CgLoop2_1_3.lhi new file mode 100644 index 0000000..7a0feb0 --- /dev/null +++ b/ghc/compiler/codeGen/CgLoop2_1_3.lhi @@ -0,0 +1,5 @@ +\begin{code} +interface CgLoop2_1_3 1 +__exports__ +Outputable Outputable (..) +\end{code} diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index ab22dae..8e9ae24 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -49,6 +49,7 @@ module CgMonad ( IMP_Ubiq(){-uitous-} IMPORT_DELOOPER(CgLoop1) -- stuff from CgBindery and CgUsages +IMPORT_1_3(List(nub)) import AbsCSyn import AbsCUtils ( mkAbsCStmts ) @@ -56,19 +57,19 @@ import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling, opt_OmitBlackHoling ) import HeapOffs ( maxOff, - VirtualSpAOffset(..), VirtualSpBOffset(..) + SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset) ) import Id ( idType, nullIdEnv, mkIdEnv, addOneToIdEnv, - modifyIdEnv, lookupIdEnv, rngIdEnv, IdEnv(..), - ConTag(..), GenId{-instance Outputable-} + modifyIdEnv, lookupIdEnv, rngIdEnv, SYN_IE(IdEnv), + SYN_IE(ConTag), GenId{-instance Outputable-} ) import Maybes ( maybeToBool ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) import Pretty ( ppAboves, ppCat, ppStr ) import PrimRep ( getPrimRepSize, PrimRep(..) ) -import StgSyn ( StgLiveVars(..) ) +import StgSyn ( SYN_IE(StgLiveVars) ) import Type ( typePrimRep ) import UniqSet ( elementOfUniqSet ) import Util ( sortLt, panic, pprPanic ) @@ -323,7 +324,7 @@ thenC :: Code -- thenC :: Code -> Code -> Code -- thenC :: Code -> FCode a -> FCode a -(m `thenC` k) info_down state +thenC m k info_down state = k info_down new_state where new_state = m info_down state @@ -353,7 +354,7 @@ thenFC :: FCode a -- thenFC :: FCode a -> (a -> FCode b) -> FCode b -- thenFC :: FCode a -> (a -> Code) -> Code -(m `thenFC` k) info_down state +thenFC m k info_down state = k m_result info_down new_state where (m_result, new_state) = m info_down state @@ -649,7 +650,7 @@ is just a wrapper for its lower-level @Bind@ routine (drop the \tr{C} on the end of each function name). A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple. -The name should not already be bound. +The name should not already be bound. (nice ASSERT, eh?) \begin{code} addBindC :: Id -> CgIdInfo -> Code addBindC name stuff_to_bind info_down (MkCgState absC binds usage) diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs index fa36440..5768b2d 100644 --- a/ghc/compiler/codeGen/CgRetConv.lhs +++ b/ghc/compiler/codeGen/CgRetConv.lhs @@ -35,7 +35,7 @@ import CgCompInfo ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS, ) import CmdLineOpts ( opt_ReturnInRegsThreshold ) import Id ( isDataCon, dataConRawArgTys, - DataCon(..), GenId{-instance Eq-} + SYN_IE(DataCon), GenId{-instance Eq-} ) import Maybes ( catMaybes ) import PprStyle ( PprStyle(..) ) diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs index caf3810..cc845bf 100644 --- a/ghc/compiler/codeGen/CgStackery.lhs +++ b/ghc/compiler/codeGen/CgStackery.lhs @@ -22,7 +22,7 @@ import CgMonad import AbsCSyn import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep ) -import HeapOffs ( VirtualSpAOffset(..), VirtualSpBOffset(..) ) +import HeapOffs ( SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset) ) import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep(..) ) diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 770c4b5..590a80a 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -37,14 +37,14 @@ import ClosureInfo ( nodeMustPointToIt, getEntryConvention, EntryConvention(..) ) import CmdLineOpts ( opt_DoSemiTagging ) -import HeapOffs ( zeroOff, VirtualSpAOffset(..) ) +import HeapOffs ( zeroOff, SYN_IE(VirtualSpAOffset) ) import Id ( idType, dataConTyCon, dataConTag, fIRST_TAG ) import Literal ( mkMachInt ) import Maybes ( assocMaybe ) import PrimRep ( PrimRep(..) ) -import StgSyn ( StgArg(..), GenStgArg(..), StgLiveVars(..) ) +import StgSyn ( SYN_IE(StgArg), GenStgArg(..), SYN_IE(StgLiveVars) ) import Type ( isPrimType ) import Util ( zipWithEqual, panic, assertPanic ) \end{code} diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs index e7e7b96..cab19c0 100644 --- a/ghc/compiler/codeGen/CgUsages.lhs +++ b/ghc/compiler/codeGen/CgUsages.lhs @@ -26,11 +26,11 @@ IMPORT_DELOOPER(CgLoop1) -- here for paranoia-checking import AbsCSyn ( RegRelative(..), AbstractC, CAddrMode ) import CgMonad import HeapOffs ( zeroOff, - VirtualHeapOffset(..), - VirtualSpAOffset(..), - VirtualSpBOffset(..) + SYN_IE(VirtualHeapOffset), + SYN_IE(VirtualSpAOffset), + SYN_IE(VirtualSpBOffset) ) -import Id ( IdEnv(..) ) +import Id ( SYN_IE(IdEnv) ) \end{code} %************************************************************************ diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index d24b55e..1c3d61a 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -41,6 +41,7 @@ module ClosureInfo ( closureSingleEntry, closureSemiTag, closureType, closureReturnsUnboxedType, getStandardFormThunkInfo, + isToplevClosure, closureKind, closureTypeDescr, -- profiling isStaticClosure, allocProfilingMsg, @@ -76,13 +77,13 @@ import CLabel ( mkStdEntryLabel, mkFastEntryLabel, import CmdLineOpts ( opt_SccProfilingOn, opt_ForConcurrent ) import HeapOffs ( intOff, addOff, totHdrSize, varHdrSize, intOffsetIntoGoods, - VirtualHeapOffset(..) + SYN_IE(VirtualHeapOffset) ) import Id ( idType, idPrimRep, getIdArity, externallyVisibleId, dataConTag, fIRST_TAG, isDataCon, isNullaryDataCon, dataConTyCon, - isTupleCon, DataCon(..), + isTupleCon, SYN_IE(DataCon), GenId{-instance Eq-} ) import IdInfo ( arityMaybe ) @@ -90,11 +91,12 @@ import Maybes ( assocMaybe, maybeToBool ) import Name ( isLocallyDefined, nameOf, origName ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) +import Pretty--ToDo:rm import PrelInfo ( maybeCharLikeTyCon, maybeIntLikeTyCon ) import PrimRep ( getPrimRepSize, separateByPtrFollowness ) import SMRep -- all of it import TyCon ( maybeTyConSingleCon, TyCon{-instance NamedThing-} ) -import Type ( isPrimType, splitForAllTy, splitFunTyExpandingDicts, +import Type ( isPrimType, splitForAllTy, splitFunTyExpandingDictsAndPeeking, mkFunTys, maybeAppSpecDataTyConExpandingDicts ) import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic ) @@ -1159,9 +1161,10 @@ closureReturnsUnboxedType other_closure = False fun_result_ty arity id = let (_, de_foralld_ty) = splitForAllTy (idType id) - (arg_tys, res_ty) = splitFunTyExpandingDicts de_foralld_ty + (arg_tys, res_ty) = splitFunTyExpandingDictsAndPeeking de_foralld_ty in - ASSERT(arity >= 0 && length arg_tys >= arity) + -- ASSERT(arity >= 0 && length arg_tys >= arity) + (if (arity >= 0 && length arg_tys >= arity) then (\x->x) else pprPanic "fun_result_ty:" (ppCat [ppInt arity, ppr PprShowAll id, ppr PprDebug (idType id)])) $ mkFunTys (drop arity arg_tys) res_ty \end{code} @@ -1175,6 +1178,16 @@ closureSemiTag (MkClosureInfo _ lf_info _) _ -> fromInteger oTHER_TAG \end{code} +\begin{code} +isToplevClosure :: ClosureInfo -> Bool + +isToplevClosure (MkClosureInfo _ lf_info _) + = case lf_info of + LFReEntrant top _ _ -> top + LFThunk top _ _ _ -> top + _ -> panic "ClosureInfo:isToplevClosure" +\end{code} + Label generation. \begin{code} diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 590aa9f..4a1fed5 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -31,7 +31,7 @@ import CgClosure ( cgTopRhsClosure ) import CgCon ( cgTopRhsCon ) import CgConTbls ( genStaticConBits ) import ClosureInfo ( mkClosureLFInfo ) -import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingPrelude, +import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingGhcInternals, opt_EnsureSplittableC, opt_SccGroup ) import CStrings ( modnameToC ) @@ -54,7 +54,7 @@ codeGen :: FAST_STRING -- module name codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg_pgm = let doing_profiling = opt_SccProfilingOn - compiling_prelude = opt_CompilingPrelude + compiling_prelude = opt_CompilingGhcInternals maybe_split = if maybeToBool (opt_EnsureSplittableC) then CSplitMarker else AbsCNop diff --git a/ghc/compiler/coreSyn/AnnCoreSyn.lhs b/ghc/compiler/coreSyn/AnnCoreSyn.lhs index 4e0a6a0..b5ce22a 100644 --- a/ghc/compiler/coreSyn/AnnCoreSyn.lhs +++ b/ghc/compiler/coreSyn/AnnCoreSyn.lhs @@ -11,7 +11,7 @@ really is} just like @CoreSyntax@.) #include "HsVersions.h" module AnnCoreSyn ( - AnnCoreBinding(..), AnnCoreExpr(..), + AnnCoreBinding(..), SYN_IE(AnnCoreExpr), AnnCoreExpr'(..), -- v sad that this must be exported AnnCoreCaseAlts(..), AnnCoreCaseDefault(..), diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs index a14bf3d..59c655a 100644 --- a/ghc/compiler/coreSyn/CoreLift.lhs +++ b/ghc/compiler/coreSyn/CoreLift.lhs @@ -12,8 +12,7 @@ module CoreLift ( mkLiftedId, liftExpr, bindUnlift, - applyBindUnlifts, - isUnboxedButNotState + applyBindUnlifts ) where @@ -22,7 +21,7 @@ IMP_Ubiq(){-uitous-} import CoreSyn import CoreUtils ( coreExprType ) import Id ( idType, mkSysLocal, - nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..), + nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv), GenId{-instances-} ) import Name ( isLocallyDefined, getSrcLoc ) diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index d7f70ca..f72c11e 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -21,7 +21,7 @@ import Literal ( literalType, Literal{-instance-} ) import Id ( idType, isBottomingId, dataConArgTys, GenId{-instances-}, emptyIdSet, mkIdSet, intersectIdSets, - unionIdSets, elementOfIdSet, IdSet(..) + unionIdSets, elementOfIdSet, SYN_IE(IdSet) ) import Maybes ( catMaybes ) import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-} ) @@ -44,7 +44,7 @@ import Type ( mkFunTy,getFunTy_maybe,mkForAllTy,mkForAllTys,getForAllTy_maybe, import TyCon ( isPrimTyCon ) import TyVar ( tyVarKind, GenTyVar{-instances-} ) import Unique ( Unique ) -import Usage ( GenUsage ) +import Usage ( GenUsage, SYN_IE(Usage) ) import Util ( zipEqual, pprTrace, pprPanic, assertPanic, panic ) infixr 9 `thenL`, `seqL`, `thenMaybeL`, `seqMaybeL` @@ -264,7 +264,7 @@ lintCoreArg :: {-Bool ->-} CoreExpr -> Type -> CoreArg -> LintM (Maybe Type) lintCoreArg e ty (LitArg lit) = -- Make sure function type matches argument - case (getFunTyExpandingDicts_maybe ty) of + case (getFunTyExpandingDicts_maybe False{-no peeking in newtypes-} ty) of Just (arg,res) | (lit_ty `eqTy` arg) -> returnL(Just res) _ -> addErrL (mkAppMsg ty lit_ty e) `seqL` returnL Nothing where @@ -274,7 +274,7 @@ lintCoreArg e ty (VarArg v) = -- Make sure variable is bound checkInScope v `seqL` -- Make sure function type matches argument - case (getFunTyExpandingDicts_maybe ty) of + case (getFunTyExpandingDicts_maybe False{-as above-} ty) of Just (arg,res) | (var_ty `eqTy` arg) -> returnL(Just res) _ -> addErrL (mkAppMsg ty var_ty e) `seqL` returnL Nothing where diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index d66f7b6..854969b 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -29,39 +29,35 @@ module CoreSyn ( rhssOfAlts, -- Common type instantiation... - CoreBinding(..), - CoreExpr(..), - CoreBinder(..), - CoreArg(..), - CoreCaseAlts(..), - CoreCaseDefault(..), + SYN_IE(CoreBinding), + SYN_IE(CoreExpr), + SYN_IE(CoreBinder), + SYN_IE(CoreArg), + SYN_IE(CoreCaseAlts), + SYN_IE(CoreCaseDefault), -- And not-so-common type instantiations... - TaggedCoreBinding(..), - TaggedCoreExpr(..), - TaggedCoreBinder(..), - TaggedCoreArg(..), - TaggedCoreCaseAlts(..), - TaggedCoreCaseDefault(..), - - SimplifiableCoreBinding(..), - SimplifiableCoreExpr(..), - SimplifiableCoreBinder(..), - SimplifiableCoreArg(..), - SimplifiableCoreCaseAlts(..), - SimplifiableCoreCaseDefault(..) + SYN_IE(TaggedCoreBinding), + SYN_IE(TaggedCoreExpr), + SYN_IE(TaggedCoreBinder), + SYN_IE(TaggedCoreArg), + SYN_IE(TaggedCoreCaseAlts), + SYN_IE(TaggedCoreCaseDefault), + + SYN_IE(SimplifiableCoreBinding), + SYN_IE(SimplifiableCoreExpr), + SYN_IE(SimplifiableCoreBinder), + SYN_IE(SimplifiableCoreArg), + SYN_IE(SimplifiableCoreCaseAlts), + SYN_IE(SimplifiableCoreCaseDefault) ) where IMP_Ubiq(){-uitous-} --- ToDo:rm: ---import PprCore ( GenCoreExpr{-instance-} ) ---import PprStyle ( PprStyle(..) ) - import CostCentre ( showCostCentre, CostCentre ) import Id ( idType, GenId{-instance Eq-} ) import Type ( isUnboxedType ) -import Usage ( UVar(..) ) +import Usage ( SYN_IE(UVar) ) import Util ( panic, assertPanic {-pprTrace:ToDo:rm-} ) \end{code} @@ -238,13 +234,9 @@ mkCoLetAny bind@(NonRec binder rhs) body \end{code} \begin{code} ---mkCoLetNoUnboxed :: --- GenCoreBinding val_bdr val_occ tyvar uvar -> --- GenCoreExpr val_bdr val_occ tyvar uvar -> --- GenCoreExpr val_bdr val_occ tyvar uvar - mkCoLetNoUnboxed bind@(Rec binds) body = mkCoLetrecNoUnboxed binds body + mkCoLetNoUnboxed bind@(NonRec binder rhs) body = --ASSERT (not (isUnboxedType (idType binder))) case body of @@ -256,10 +248,6 @@ mkCoLetNoUnboxed bind@(NonRec binder rhs) body mkCoLetsNoUnboxed [] expr = expr mkCoLetsNoUnboxed binds expr = foldr mkCoLetNoUnboxed expr binds -mkCoLetrecNoUnboxed :: [(GenId (GenType a b), GenCoreExpr (GenId (GenType a b)) c d e)] - -> GenCoreExpr (GenId (GenType a b)) c d e - -> GenCoreExpr (GenId (GenType a b)) c d e - mkCoLetrecNoUnboxed [] body = body mkCoLetrecNoUnboxed binds body = ASSERT (all is_boxed_bind binds) @@ -270,13 +258,9 @@ mkCoLetrecNoUnboxed binds body \end{code} \begin{code} ---mkCoLetUnboxedToCase :: --- GenCoreBinding val_bdr val_occ tyvar uvar -> --- GenCoreExpr val_bdr val_occ tyvar uvar -> --- GenCoreExpr val_bdr val_occ tyvar uvar - mkCoLetUnboxedToCase bind@(Rec binds) body = mkCoLetrecNoUnboxed binds body + mkCoLetUnboxedToCase bind@(NonRec binder rhs) body = case body of Var binder2 | binder == binder2 diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index c0f61a3..06f4be4 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -41,7 +41,7 @@ import CgCompInfo ( uNFOLDING_CHEAP_OP_COST, import CoreSyn import CoreUtils ( coreExprType, manifestlyWHNF ) import CostCentre ( ccMentionsId ) -import Id ( IdSet(..), GenId{-instances-} ) +import Id ( SYN_IE(IdSet), GenId{-instances-} ) import IdInfo ( bottomIsGuaranteed ) import Literal ( isNoRepLit, isLitLitLit ) import Pretty @@ -51,7 +51,7 @@ import Type ( getAppDataTyConExpandingDicts ) import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet, addOneToUniqSet, unionUniqSets ) -import Usage ( UVar(..) ) +import Usage ( SYN_IE(UVar) ) import Util ( isIn, panic ) whatsMentionedInId = panic "whatsMentionedInId (CoreUnfold)" @@ -263,7 +263,7 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr size_up (SCC lbl body) = if scc_s_OK then size_up body else Nothing - size_up (Coerce _ _ body) = size_up body + size_up (Coerce _ _ body) = size_up body -- Coercions cost nothing size_up (Con con args) = -- 1 + # of val args sizeN (1 + numValArgs args) @@ -316,7 +316,7 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr size_alg_alt (con,args,rhs) = size_up rhs -- Don't charge for args, so that wrappers look cheap - (tycon, _, _) = _trace "CoreUnfold.getAppDataTyConExpandingDicts" $ getAppDataTyConExpandingDicts scrut_ty + (tycon, _, _) = trace "CoreUnfold.getAppDataTyConExpandingDicts" $ getAppDataTyConExpandingDicts scrut_ty size_up_alts _ (PrimAlts alts deflt) = foldr (addSize . size_prim_alt) (size_up_deflt deflt) alts diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 80d0740..e0e65de 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -34,13 +34,13 @@ import CostCentre ( isDictCC ) import Id ( idType, mkSysLocal, getIdArity, isBottomingId, toplevelishId, mkIdWithNewUniq, applyTypeEnvToId, addOneToIdEnv, growIdEnvList, lookupIdEnv, - isNullIdEnv, IdEnv(..), + isNullIdEnv, SYN_IE(IdEnv), GenId{-instances-} ) import IdInfo ( arityMaybe ) import Literal ( literalType, isNoRepLit, Literal(..) ) import Maybes ( catMaybes, maybeToBool ) -import PprCore ( GenCoreExpr{-instances-}, GenCoreArg{-instances-} ) +import PprCore import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instances-} ) import Pretty ( ppAboves ) @@ -48,7 +48,7 @@ import PrelVals ( augmentId, buildId ) import PrimOp ( primOpType, fragilePrimOp, PrimOp(..) ) import SrcLoc ( mkUnknownSrcLoc ) import TyVar ( cloneTyVar, - isNullTyVarEnv, addOneToTyVarEnv, TyVarEnv(..) + isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv) ) import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy, getFunTy_maybe, applyTy, isPrimType, @@ -57,9 +57,9 @@ import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy, import TysWiredIn ( trueDataCon, falseDataCon ) import UniqSupply ( initUs, returnUs, thenUs, mapUs, mapAndUnzipUs, getUnique, - UniqSM(..), UniqSupply + SYN_IE(UniqSM), UniqSupply ) -import Usage ( UVar(..) ) +import Usage ( SYN_IE(UVar) ) import Util ( zipEqual, panic, pprPanic, assertPanic ) type TypeEnv = TyVarEnv Type diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs index 38de36c..979fd67 100644 --- a/ghc/compiler/coreSyn/FreeVars.lhs +++ b/ghc/compiler/coreSyn/FreeVars.lhs @@ -13,10 +13,10 @@ module FreeVars ( addTopBindsFVs, freeVarsOf, freeTyVarsOf, - FVCoreExpr(..), FVCoreBinding(..), + SYN_IE(FVCoreExpr), SYN_IE(FVCoreBinding), - CoreExprWithFVs(..), -- For the above functions - AnnCoreExpr(..), -- Dito + SYN_IE(CoreExprWithFVs), -- For the above functions + SYN_IE(AnnCoreExpr), -- Dito FVInfo(..), LeakInfo(..) ) where @@ -28,17 +28,17 @@ import CoreSyn import Id ( idType, getIdArity, isBottomingId, emptyIdSet, unitIdSet, mkIdSet, elementOfIdSet, minusIdSet, unionManyIdSets, - IdSet(..) + SYN_IE(IdSet) ) import IdInfo ( arityMaybe ) import PrimOp ( PrimOp(..) ) import Type ( tyVarsOfType ) import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet, intersectTyVarSets, - TyVarSet(..) + SYN_IE(TyVarSet) ) import UniqSet ( unionUniqSets ) -import Usage ( UVar(..) ) +import Usage ( SYN_IE(UVar) ) import Util ( panic, assertPanic ) \end{code} diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index fd2e03d..309d62d 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -28,7 +28,7 @@ IMP_Ubiq(){-uitous-} import CoreSyn import CostCentre ( showCostCentre ) import Id ( idType, getIdInfo, getIdStrictness, isTupleCon, - nullIdEnv, DataCon(..), GenId{-instances-} + nullIdEnv, SYN_IE(DataCon), GenId{-instances-} ) import IdInfo ( ppIdInfo, StrictnessInfo(..) ) import Literal ( Literal{-instances-} ) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index a1be8b4..da86031 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -19,7 +19,7 @@ import DsBinds ( dsBinds, dsInstBinds ) import DsUtils import Bag ( unionBags ) -import CmdLineOpts ( opt_DoCoreLinting ) +import CmdLineOpts ( opt_DoCoreLinting, opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs ) import CoreLift ( liftCoreBindings ) import CoreLint ( lintCoreBindings ) import Id ( nullIdEnv, mkIdEnv ) @@ -52,25 +52,29 @@ deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst (us3, us3a) = splitUniqSupply us2a (us4, us5) = splitUniqSupply us3a + auto_meth = opt_AutoSccsOnAllToplevs + auto_top = opt_AutoSccsOnAllToplevs + || opt_AutoSccsOnExportedToplevs + ((core_const_prs, consts_pairs), shadows1) = initDs us0 nullIdEnv mod_name (dsInstBinds [] const_inst_pairs) consts_env = mkIdEnv consts_pairs (core_clas_binds, shadows2) - = initDs us1 consts_env mod_name (dsBinds clas_binds) + = initDs us1 consts_env mod_name (dsBinds False clas_binds) core_clas_prs = pairsFromCoreBinds core_clas_binds (core_inst_binds, shadows3) - = initDs us2 consts_env mod_name (dsBinds inst_binds) + = initDs us2 consts_env mod_name (dsBinds auto_meth inst_binds) core_inst_prs = pairsFromCoreBinds core_inst_binds (core_val_binds, shadows4) - = initDs us3 consts_env mod_name (dsBinds val_binds) + = initDs us3 consts_env mod_name (dsBinds auto_top val_binds) core_val_pairs = pairsFromCoreBinds core_val_binds (core_recsel_binds, shadows5) - = initDs us4 consts_env mod_name (dsBinds recsel_binds) + = initDs us4 consts_env mod_name (dsBinds ({-trace "Desugar:core_recsel_binds"-} False) recsel_binds) core_recsel_prs = pairsFromCoreBinds core_recsel_binds final_binds diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 8238097..99cf6d4 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -29,10 +29,11 @@ import DsGRHSs ( dsGuarded ) import DsUtils import Match ( matchWrapper ) -import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingPrelude ) -import CostCentre ( mkAllDictsCC, preludeDictsCostCentre ) -import Id ( idType, DictVar(..), GenId ) +import CmdLineOpts ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, opt_CompilingGhcInternals ) +import CostCentre ( mkAutoCC, IsCafCC(..), mkAllDictsCC, preludeDictsCostCentre ) +import Id ( idType, SYN_IE(DictVar), GenId ) import ListSetOps ( minusList, intersectLists ) +import Name ( isExported ) import PprType ( GenType ) import PprStyle ( PprStyle(..) ) import Pretty ( ppShow ) @@ -60,7 +61,7 @@ that some of the binders are of unboxed type. This is sorted out when the caller wraps the bindings round an expression. \begin{code} -dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding] +dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding] \end{code} All ``real'' bindings are expressed in terms of the @@ -96,12 +97,12 @@ But there are lots of special cases. %============================================== \begin{code} -dsBinds (BindWith _ _) = panic "dsBinds:BindWith" -dsBinds EmptyBinds = returnDs [] -dsBinds (SingleBind bind) = dsBind [] [] id [] bind +dsBinds auto_scc (BindWith _ _) = panic "dsBinds:BindWith" +dsBinds auto_scc EmptyBinds = returnDs [] +dsBinds auto_scc (SingleBind bind) = dsBind auto_scc [] [] id [] bind -dsBinds (ThenBinds binds_1 binds_2) - = andDs (++) (dsBinds binds_1) (dsBinds binds_2) +dsBinds auto_scc (ThenBinds binds_1 binds_2) + = andDs (++) (dsBinds auto_scc binds_1) (dsBinds auto_scc binds_2) \end{code} @@ -130,7 +131,7 @@ definitions, which don't mention the type variables at all, so making them polymorphic is really overkill. @dsInstBinds@ deals with this case. \begin{code} -dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds) +dsBinds auto_scc (AbsBinds tyvars [] local_global_prs inst_binds val_binds) = mapDs mk_poly_private_binder private_binders `thenDs` \ poly_private_binders -> let @@ -149,7 +150,7 @@ dsBinds (AbsBinds tyvars [] local_global_prs inst_binds val_binds) dsInstBinds tyvars inst_binds `thenDs` \ (inst_bind_pairs, inst_env) -> extendEnvDs inst_env ( - dsBind tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds + dsBind auto_scc tyvars [] (lookupId full_local_global_prs) inst_bind_pairs val_binds )) where -- "private_binders" is the list of binders in val_binds @@ -195,7 +196,7 @@ the defn of f' can get floated out, notably if f gets specialised to a particular type for a. \begin{code} -dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds) +dsBinds auto_scc (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds) = -- If there is any non-overloaded polymorphism, make new locals with -- appropriate polymorphism (if null non_overloaded_tyvars @@ -231,7 +232,7 @@ dsBinds (AbsBinds all_tyvars dicts local_global_prs dict_binds val_binds) extendEnvDs inst_env ( - dsBind non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds + dsBind auto_scc non_overloaded_tyvars [] binder_subst_fn inst_bind_pairs val_binds )) `thenDs` \ core_binds -> let @@ -358,21 +359,20 @@ dsInstBinds tyvars ((inst, expr) : bs) -- if profiling, wrap the dict in "_scc_ DICT ": ds_dict_cc expr - | not opt_SccProfilingOn || - not (isDictTy inst_ty) + | not ( opt_SccProfilingOn || opt_AutoSccsOnAllToplevs) + -- the latter is so that -unprof-auto-scc-all adds dict sccs + || not (isDictTy inst_ty) = returnDs expr -- that's easy: do nothing - | opt_CompilingPrelude + | opt_CompilingGhcInternals = returnDs (SCC prel_dicts_cc expr) | otherwise - = getModuleAndGroupDs `thenDs` \ (mod_name, grp_name) -> - -- ToDo: do -dicts-all flag (mark dict things - -- with individual CCs) - let - dict_cc = mkAllDictsCC mod_name grp_name False{-not dupd-} - in - returnDs (SCC dict_cc expr) + = getModuleAndGroupDs `thenDs` \ (mod, grp) -> + + -- ToDo: do -dicts-all flag (mark dict things with individual CCs) + + returnDs (SCC (mkAllDictsCC mod grp False) expr) \end{code} %************************************************************************ @@ -387,22 +387,23 @@ some of the binders are of unboxed type. For an explanation of the first three args, see @dsMonoBinds@. \begin{code} -dsBind :: [TyVar] -> [DictVar] -- Abstract wrt these +dsBind :: Bool -- Add auto sccs to binds + -> [TyVar] -> [DictVar] -- Abstract wrt these -> (Id -> Id) -- Binder substitution -> [(Id,CoreExpr)] -- Inst bindings already dealt with -> TypecheckedBind -> DsM [CoreBinding] -dsBind tyvars dicts binder_subst inst_bind_pairs EmptyBind +dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs EmptyBind = returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs] -dsBind tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds) - = dsMonoBinds False tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs -> - returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] ) +dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs (NonRecBind monobinds) + = dsMonoBinds auto_scc False tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs -> + returnDs [NonRec binder rhs | (binder,rhs) <- inst_bind_pairs ++ val_bind_pairs] -dsBind tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds) - = dsMonoBinds True tyvars dicts binder_subst monobinds `thenDs` ( \ val_bind_pairs -> - returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)] ) +dsBind auto_scc tyvars dicts binder_subst inst_bind_pairs (RecBind monobinds) + = dsMonoBinds auto_scc True tyvars dicts binder_subst monobinds `thenDs` \ val_bind_pairs -> + returnDs [Rec (inst_bind_pairs ++ val_bind_pairs)] \end{code} @@ -425,7 +426,8 @@ of these binders into applications of the new binder to suitable type variables and dictionaries. \begin{code} -dsMonoBinds :: Bool -- True <=> recursive binding group +dsMonoBinds :: Bool -- True <=> add auto sccs + -> Bool -- True <=> recursive binding group -> [TyVar] -> [DictVar] -- Abstract wrt these -> (Id -> Id) -- Binder substitution -> TypecheckedMonoBinds @@ -439,11 +441,11 @@ dsMonoBinds :: Bool -- True <=> recursive binding group %============================================== \begin{code} -dsMonoBinds is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs [] +dsMonoBinds auto_scc is_rec tyvars dicts binder_subst EmptyMonoBinds = returnDs [] -dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2) - = andDs (++) (dsMonoBinds is_rec tyvars dicts binder_subst binds_1) - (dsMonoBinds is_rec tyvars dicts binder_subst binds_2) +dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2) + = andDs (++) (dsMonoBinds auto_scc is_rec tyvars dicts binder_subst binds_1) + (dsMonoBinds auto_scc is_rec tyvars dicts binder_subst binds_2) \end{code} @@ -451,45 +453,28 @@ dsMonoBinds is_rec tyvars dicts binder_subst (AndMonoBinds binds_1 binds_2) \subsubsection{Simple base cases: function and variable bindings} %============================================== -For the simplest bindings, we just heave them in the substitution env: - \begin{code} -{- THESE TWO ARE PLAIN WRONG. - The extendEnvDs only scopes over the nested call! - Let the simplifier do this. - -dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var (HsVar new_var)) - | not (is_rec || isExported was_var) - = extendEnvDs [(was_var, Var new_var)] ( - returnDs [] ) - -dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind was_var expr@(Lit _)) - | not (isExported was_var) - = dsExpr expr `thenDs` ( \ core_lit -> - extendEnvDs [(was_var, core_lit)] ( - returnDs [] )) --} - -dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr) +dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (VarMonoBind var expr) = dsExpr expr `thenDs` \ core_expr -> - returnDs [(binder_subst var, mkLam tyvars dicts core_expr)] -\end{code} + doSccAuto auto_scc [var] core_expr `thenDs` \ sccd_core_expr -> + returnDs [(binder_subst var, mkLam tyvars dicts sccd_core_expr)] -\begin{code} -dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn) +dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (FunMonoBind fun _ matches locn) = putSrcLocDs locn $ let new_fun = binder_subst fun error_string = "function " ++ showForErr fun in matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) -> + doSccAuto auto_scc [fun] body `thenDs` \ sccd_body -> returnDs [(new_fun, - mkLam tyvars (dicts ++ args) body)] + mkLam tyvars (dicts ++ args) sccd_body)] -dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn) +dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn) = putSrcLocDs locn $ dsGuarded grhss_and_binds `thenDs` \ body_expr -> - returnDs [(binder_subst v, mkLam tyvars dicts body_expr)] + doSccAuto auto_scc [v] body_expr `thenDs` \ sccd_body_expr -> + returnDs [(binder_subst v, mkLam tyvars dicts sccd_body_expr)] \end{code} %============================================== @@ -503,7 +488,7 @@ be empty. (Simple pattern bindings were handled above.) First, the paranoia check. \begin{code} -dsMonoBinds is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn) +dsMonoBinds auto_scc is_rec tyvars (_:_) binder_subst (PatMonoBind pat grhss_and_binds locn) = panic "Non-empty dict list in for pattern binding" \end{code} @@ -531,10 +516,11 @@ Then we transform to: \end{description} \begin{code} -dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn) +dsMonoBinds auto_scc is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn) = putSrcLocDs locn $ - dsGuarded grhss_and_binds `thenDs` \ body_expr -> + dsGuarded grhss_and_binds `thenDs` \ body_expr -> + doSccAuto auto_scc pat_binders body_expr `thenDs` \ sccd_body_expr -> {- KILLED by Sansom. 95/05 -- make *sure* there are no primitive types in the pattern @@ -547,11 +533,11 @@ dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn) -- we can just use the rhs directly else -} --- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug body_expr) $ +-- pprTrace "dsMonoBinds:PatMonoBind:" (ppr PprDebug sccd_body_expr) $ mkSelectorBinds tyvars pat [(binder, binder_subst binder) | binder <- pat_binders] - body_expr + sccd_body_expr where pat_binders = collectTypedPatBinders pat -- NB For a simple tuple pattern, these binders @@ -565,4 +551,39 @@ extra work to benefit only rather unusual constructs like \end{verbatim} Better to extend the whole thing for any irrefutable constructor, at least. +%************************************************************************ +%* * +\subsection[doSccAuto]{Adding automatic sccs} +%* * +%************************************************************************ + +\begin{code} +doSccAuto :: Bool -> [Id] -> CoreExpr -> DsM CoreExpr + +doSccAuto False binders core_expr + = returnDs core_expr + +doSccAuto True [] core_expr -- no binders + = returnDs core_expr + +doSccAuto True _ core_expr@(SCC _ _) -- already sccd + = returnDs core_expr +doSccAuto True _ core_expr@(Con _ _) -- dont bother for simple Con + = returnDs core_expr + +doSccAuto True binders core_expr + = let + scc_all = opt_AutoSccsOnAllToplevs + scc_export = not (null export_binders) + + export_binders = filter isExported binders + + scc_binder = head (if scc_all then binders else export_binders) + in + if scc_all || scc_export then + getModuleAndGroupDs `thenDs` \ (mod,grp) -> + returnDs (SCC (mkAutoCC scc_binder mod grp IsNotCafCC) core_expr) + else + returnDs core_expr +\end{code} diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 9ef9601..c8644dc 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -37,7 +37,7 @@ unboxing any boxed primitive arguments and boxing the result if desired. The state stuff just consists of adding in -@\ s -> case s of { S# s# -> ... }@ in an appropriate place. +@PrimIO (\ s -> case s of { S# s# -> ... })@ in an appropriate place. The unboxing is straightforward, as all information needed to unbox is available from the type. For each boxed-primitive argument, we @@ -68,10 +68,10 @@ follows: \end{verbatim} \begin{code} -dsCCall :: FAST_STRING -- C routine to invoke +dsCCall :: FAST_STRING -- C routine to invoke -> [CoreExpr] -- Arguments (desugared) - -> Bool -- True <=> might cause Haskell GC - -> Bool -- True <=> really a "_casm_" + -> Bool -- True <=> might cause Haskell GC + -> Bool -- True <=> really a "_casm_" -> Type -- Type of the result (a boxed-prim type) -> DsM CoreExpr @@ -89,11 +89,9 @@ dsCCall label args may_gc is_asm result_ty in mkPrimDs the_ccall_op (map VarArg final_args) `thenDs` \ the_prim_app -> let - the_body = foldr apply (res_wrapper the_prim_app) arg_wrappers + the_body = foldr ($) (res_wrapper the_prim_app) arg_wrappers in returnDs (Lam (ValBinder old_s) the_body) - where - apply f x = f x \end{code} \begin{code} diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index d1de630..d7b8e68 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -59,7 +59,7 @@ import TysWiredIn ( mkTupleTy, nilDataCon, consDataCon, charDataCon, charTy ) import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} ) -import Usage ( UVar(..) ) +import Usage ( SYN_IE(UVar) ) import Util ( zipEqual, pprError, panic, assertPanic ) mk_nil_con ty = mkCon nilDataCon [] [ty] [] -- micro utility... @@ -269,7 +269,7 @@ dsExpr (ListComp expr quals) dsListComp core_expr quals dsExpr (HsLet binds expr) - = dsBinds binds `thenDs` \ core_binds -> + = dsBinds False binds `thenDs` \ core_binds -> dsExpr expr `thenDs` \ core_expr -> returnDs ( mkCoLetsAny core_binds core_expr ) @@ -425,7 +425,7 @@ dsExpr (RecordUpdOut record_expr dicts rbinds) dsRbinds rbinds $ \ rbinds' -> let record_ty = coreExprType record_expr' - (tycon, inst_tys, cons) = _trace "DsExpr.getAppDataTyConExpandingDicts" $ + (tycon, inst_tys, cons) = trace "DsExpr.getAppDataTyConExpandingDicts" $ getAppDataTyConExpandingDicts record_ty cons_to_upd = filter has_all_fields cons @@ -657,8 +657,8 @@ dsDo then_id zero_id (stmt:stmts) VarArg (mkValLam [ignored_result_id] rest)] LetStmt binds -> - dsBinds binds `thenDs` \ binds2 -> - ds_rest `thenDs` \ rest -> + dsBinds False binds `thenDs` \ binds2 -> + ds_rest `thenDs` \ rest -> returnDs (mkCoLetsAny binds2 rest) BindStmtOut pat expr locn a b -> diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index fd8bec3..ee11244 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -16,7 +16,7 @@ import HsSyn ( GRHSsAndBinds(..), GRHS(..), import TcHsSyn ( TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..), TypecheckedPat(..), TypecheckedHsBinds(..), TypecheckedHsExpr(..) ) -import CoreSyn ( CoreBinding(..), CoreExpr(..), mkCoLetsAny ) +import CoreSyn ( SYN_IE(CoreBinding), SYN_IE(CoreExpr), mkCoLetsAny ) import DsMonad import DsUtils @@ -45,7 +45,7 @@ dsGuarded :: TypecheckedGRHSsAndBinds -> DsM CoreExpr dsGuarded (GRHSsAndBindsOut grhss binds err_ty) - = dsBinds binds `thenDs` \ core_binds -> + = dsBinds False binds `thenDs` \ core_binds -> dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) -> case can_it_fail of CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail"))) diff --git a/ghc/compiler/deSugar/DsLoop.lhi b/ghc/compiler/deSugar/DsLoop.lhi index 26a0c4b..fd329c0 100644 --- a/ghc/compiler/deSugar/DsLoop.lhi +++ b/ghc/compiler/deSugar/DsLoop.lhi @@ -26,6 +26,6 @@ matchSimply :: CoreExpr -- Scrutinee -> CoreExpr -- Return this if it does -> DsM CoreExpr -dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding] +dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding] dsExpr :: TypecheckedHsExpr -> DsM CoreExpr \end{code} diff --git a/ghc/compiler/deSugar/DsLoop_1_3.lhi b/ghc/compiler/deSugar/DsLoop_1_3.lhi new file mode 100644 index 0000000..6f11502 --- /dev/null +++ b/ghc/compiler/deSugar/DsLoop_1_3.lhi @@ -0,0 +1,5 @@ +\begin{code} +interface DsLoop_1_3 1 +__exports__ +Outputable Outputable (..) +\end{code} diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 618f8c9..a6c8b61 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -28,11 +28,11 @@ IMP_Ubiq() import Bag ( emptyBag, snocBag, bagToList ) import CmdLineOpts ( opt_SccGroup ) -import CoreSyn ( CoreExpr(..) ) +import CoreSyn ( SYN_IE(CoreExpr) ) import CoreUtils ( substCoreExpr ) import HsSyn ( OutPat ) import Id ( mkSysLocal, mkIdWithNewUniq, - lookupIdEnv, growIdEnvList, GenId, IdEnv(..) + lookupIdEnv, growIdEnvList, GenId, SYN_IE(IdEnv) ) import PprType ( GenType, GenTyVar ) import PprStyle ( PprStyle(..) ) @@ -42,7 +42,7 @@ import TcHsSyn ( TypecheckedPat(..) ) import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} ) import Unique ( Unique{-instances-} ) import UniqSupply ( splitUniqSupply, getUnique, getUniques, - mapUs, thenUs, returnUs, UniqSM(..) ) + mapUs, thenUs, returnUs, SYN_IE(UniqSM) ) import Util ( assoc, mapAccumL, zipWithEqual, panic ) infixr 9 `thenDs` diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 84e871f..b502469 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -44,14 +44,14 @@ import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId ) import Pretty ( ppShow ) import Id ( idType, dataConArgTys, mkTupleCon, pprId{-ToDo:rm-}, - DataCon(..), DictVar(..), Id(..), GenId ) + SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId ) import Literal ( Literal(..) ) import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons ) import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys, mkTheta, isUnboxedType, applyTyCon, getAppTyCon ) import TysPrim ( voidTy ) -import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) ) +import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) ) import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} ) import PprCore{-ToDo:rm-} --import PprType--ToDo:rm diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index a1d8fc7..e63d559 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -335,7 +335,7 @@ tidy1 v (RecPat con_id pat_ty rpats) match_result pats = map mk_pat tagged_arg_tys -- Boring stuff to find the arg-tys of the constructor - (_, inst_tys, _) = {-_trace "Match.getAppDataTyConExpandingDicts" $-} getAppDataTyConExpandingDicts pat_ty + (_, inst_tys, _) = {-trace "Match.getAppDataTyConExpandingDicts" $-} getAppDataTyConExpandingDicts pat_ty con_arg_tys' = dataConArgTys con_id inst_tys tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags @@ -607,7 +607,7 @@ matchWrapper kind [(PatMatch (WildPat ty) match)] error_string matchWrapper kind [(GRHSMatch (GRHSsAndBindsOut [OtherwiseGRHS expr _] binds _))] error_string - = dsBinds binds `thenDs` \ core_binds -> + = dsBinds False binds `thenDs` \ core_binds -> dsExpr expr `thenDs` \ core_expr -> returnDs ([], mkCoLetsAny core_binds core_expr) @@ -698,7 +698,7 @@ flattenMatches kind (match : matches) = flatten_match (pat:pats_so_far) match flatten_match pats_so_far (GRHSMatch (GRHSsAndBindsOut grhss binds ty)) - = dsBinds binds `thenDs` \ core_binds -> + = dsBinds False binds `thenDs` \ core_binds -> dsGRHSs ty kind pats grhss `thenDs` \ match_result -> returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result)) where diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index 8f34cfc..15c5519 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -16,7 +16,7 @@ import HsSyn ( HsLit(..), OutPat(..), HsExpr(..), import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..), TypecheckedPat(..) ) -import CoreSyn ( CoreExpr(..), CoreBinding(..) ) +import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding) ) import DsMonad import DsUtils diff --git a/ghc/compiler/deforest/Core2Def.lhs b/ghc/compiler/deforest/Core2Def.lhs index 2739c6e..87d92be 100644 --- a/ghc/compiler/deforest/Core2Def.lhs +++ b/ghc/compiler/deforest/Core2Def.lhs @@ -17,7 +17,7 @@ > import BinderInfo -- ( BinderInfo(..), isFun, isDupDanger ) > import CmdLineOpts ( switchIsOn, SwitchResult, SimplifierSwitch ) > import OccurAnal ( occurAnalyseBinds ) -> import SimplEnv ( SwitchChecker(..) ) +> import SimplEnv ( SYN_IE(SwitchChecker) ) > import Util > import Pretty > import Outputable diff --git a/ghc/compiler/deforest/Cyclic.lhs b/ghc/compiler/deforest/Cyclic.lhs index 48cde68..fa1fbcf 100644 --- a/ghc/compiler/deforest/Cyclic.lhs +++ b/ghc/compiler/deforest/Cyclic.lhs @@ -21,7 +21,6 @@ > getIdInfo, replaceIdInfo, eqId, Id > ) > import IdInfo -> import Maybes ( Maybe(..) ) > import Outputable > import Pretty > import UniqSupply diff --git a/ghc/compiler/deforest/Def2Core.lhs b/ghc/compiler/deforest/Def2Core.lhs index d8267e4..14802be 100644 --- a/ghc/compiler/deforest/Def2Core.lhs +++ b/ghc/compiler/deforest/Def2Core.lhs @@ -9,7 +9,7 @@ > def2core, d2c, > > -- and to make the interface self-sufficient, all this stuff: -> DefBinding(..), UniqSM(..), +> DefBinding(..), SYN_IE(UniqSM), > GenCoreBinding, Id, DefBindee, > defPanic > ) where @@ -17,7 +17,6 @@ > import DefSyn > import DefUtils > -> import Maybes ( Maybe(..) ) > import Outputable > import Pretty > import UniqSupply diff --git a/ghc/compiler/deforest/DefExpr.lhs b/ghc/compiler/deforest/DefExpr.lhs index bae8836..ffeceba 100644 --- a/ghc/compiler/deforest/DefExpr.lhs +++ b/ghc/compiler/deforest/DefExpr.lhs @@ -16,8 +16,8 @@ > import TreelessForm > import Cyclic -> import Type ( applyTypeEnvToTy, isPrimType, -> SigmaType(..), Type +> import Type ( applyTypeEnvToTy, +> SYN_IE(SigmaType), Type > ) > import CmdLineOpts ( SwitchResult, switchIsOn ) > import CoreUnfold ( UnfoldingDetails(..) ) @@ -27,7 +27,6 @@ > ) > import Inst -- Inst(..) > import IdInfo -> import Maybes ( Maybe(..) ) > import Outputable > import UniqSupply > import Util diff --git a/ghc/compiler/deforest/DefUtils.lhs b/ghc/compiler/deforest/DefUtils.lhs index 9e53ae0..24570b9 100644 --- a/ghc/compiler/deforest/DefUtils.lhs +++ b/ghc/compiler/deforest/DefUtils.lhs @@ -21,7 +21,7 @@ >#endif > import Type ( cloneTyVar, mkTyVarTy, applyTypeEnvToTy, -> tyVarsOfType, TyVar, SigmaType(..) +> tyVarsOfType, TyVar, SYN_IE(SigmaType) > ) > import Literal ( Literal ) -- for Eq Literal > import CoreSyn diff --git a/ghc/compiler/deforest/Deforest.lhs b/ghc/compiler/deforest/Deforest.lhs index 8c75121..471482f 100644 --- a/ghc/compiler/deforest/Deforest.lhs +++ b/ghc/compiler/deforest/Deforest.lhs @@ -25,7 +25,7 @@ > import Id ( getIdInfo, Id ) > import IdInfo > import Outputable -> import SimplEnv ( SwitchChecker(..) ) +> import SimplEnv ( SYN_IE(SwitchChecker) ) > import UniqSupply > import Util diff --git a/ghc/compiler/deforest/TreelessForm.lhs b/ghc/compiler/deforest/TreelessForm.lhs index 279130a..c690fe2 100644 --- a/ghc/compiler/deforest/TreelessForm.lhs +++ b/ghc/compiler/deforest/TreelessForm.lhs @@ -16,9 +16,8 @@ > import CoreUtils ( coreExprType ) > import Id ( replaceIdInfo, getIdInfo ) > import IdInfo -> import Maybes ( Maybe(..) ) > import Outputable -> import SimplEnv ( SwitchChecker(..) ) +> import SimplEnv ( SYN_IE(SwitchChecker) ) > import UniqSupply > import Util diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 5d6667c..fce12aa 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -21,7 +21,7 @@ import HsPragmas ( GenPragmas, ClassOpPragmas ) import HsTypes ( PolyType ) --others: -import Id ( DictVar(..), Id(..), GenId ) +import Id ( SYN_IE(DictVar), SYN_IE(Id), GenId ) import Name ( pprNonSym ) import Outputable ( interpp'SP, ifnotPprForUser, Outputable(..){-instance * (,)-} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 7aa5f9f..aac4f40 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -260,7 +260,7 @@ instance (NamedThing name, Outputable name, Outputable pat, Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar) => Outputable (InstDecl tyvar uvar name pat) where - ppr sty (InstDecl clas ty binds local modname uprags pragmas src_loc) + ppr sty (InstDecl clas ty binds from_here modname uprags pragmas src_loc) = let (context, inst_ty) = case ty of diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index b799db6..e8bb141 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -18,7 +18,7 @@ import HsMatches ( pprMatches, pprMatch, Match ) import HsTypes ( PolyType ) -- others: -import Id ( DictVar(..), GenId, Id(..) ) +import Id ( SYN_IE(DictVar), GenId, SYN_IE(Id) ) import Name ( pprNonSym, pprSym ) import Outputable ( interppSP, interpp'SP, ifnotPprForUser ) import PprType ( pprGenType, pprParendGenType, GenType{-instance-} ) diff --git a/ghc/compiler/hsSyn/HsLoop_1_3.lhi b/ghc/compiler/hsSyn/HsLoop_1_3.lhi new file mode 100644 index 0000000..20c936e --- /dev/null +++ b/ghc/compiler/hsSyn/HsLoop_1_3.lhi @@ -0,0 +1,10 @@ +\begin{code} +interface HsLoop_1_3 1 +__exports__ +HsBinds HsBinds +HsBinds nullBinds (..) +HsBinds MonoBinds +HsBinds Sig +HsBinds nullMonoBinds (..) +HsExpr HsExpr +\end{code} diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 5e46ea2..08537bc 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -15,16 +15,86 @@ module HsSyn ( -- NB: don't reexport HsCore or HsPragmas; -- this module tells about "real Haskell" - HsSyn.. , - HsBinds.. , - HsDecls.. , - HsExpr.. , - HsImpExp.. , - HsLit.. , - HsMatches.. , - HsPat.. , - HsTypes.. - + EXP_MODULE(HsSyn) , +#if (! defined(REALLY_HASKELL_1_3)) || PATRICK_FIXES_MODULE_DOTDOT_THING + EXP_MODULE(HsBinds) , + EXP_MODULE(HsDecls) , + EXP_MODULE(HsExpr) , + EXP_MODULE(HsImpExp) , + EXP_MODULE(HsLit) , + EXP_MODULE(HsMatches) , + EXP_MODULE(HsPat) , + EXP_MODULE(HsTypes) +#else + ArithSeqInfo(..), + BangType(..), + Bind(..), + ClassDecl(..), + ConDecl(..), + DefaultDecl(..), + FixityDecl(..), + GRHS(..), + GRHSsAndBinds(..), + HsBinds(..), + HsExpr(..), + HsLit(..), + IE(..), + ImportDecl(..), + InPat(..), + InstDecl(..), + Match(..), + MonoBinds(..), + MonoType(..), + OutPat(..), + PolyType(..), + Qualifier(..), + Sig(..), + SpecDataSig(..), + SpecInstSig(..), + Stmt(..), + TyDecl(..), + bindIsRecursive, + cmpContext, + cmpMonoType, + cmpPolyType, + collectBinders, + collectMonoBinders, + collectMonoBindersAndLocs, + collectPatBinders, + collectTopLevelBinders, + extractCtxtTyNames, + extractMonoTyNames, + failureFreePat, + irrefutablePat, + irrefutablePats, + isConPat, + isLitPat, + negLiteral, + nullBind, + nullBinds, + nullMonoBinds, + patsAreAllCons, + patsAreAllLits, + pp_condecls, + pp_decl_head, + pp_dotdot, + pp_rbinds, + pp_tydecl, + pprContext, + pprExpr, + pprGRHS, + pprGRHSsAndBinds, + pprMatch, + pprMatches, + pprParendExpr, + pprParendMonoType, + pprParendPolyType, + ppr_bang, + print_it, + SYN_IE(ClassAssertion), + SYN_IE(Context), + SYN_IE(HsRecordBinds) +#endif ) where IMP_Ubiq() diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 41e5527..239a627 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -12,7 +12,7 @@ you get part of GHC. module HsTypes ( PolyType(..), MonoType(..), - Context(..), ClassAssertion(..) + SYN_IE(Context), SYN_IE(ClassAssertion) #ifdef COMPILING_GHC , pprParendPolyType @@ -27,7 +27,6 @@ IMP_Ubiq() import Outputable ( interppSP, ifnotPprForUser ) import Pretty -import Type ( Kind ) import Util ( thenCmp, cmpList, isIn, panic# ) #endif {- COMPILING_GHC -} diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index d2ed9f7..99169c1 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -6,14 +6,99 @@ \begin{code} #include "HsVersions.h" -module CmdLineOpts where - +module CmdLineOpts ( + CoreToDo(..), + SimplifierSwitch(..), + StgToDo(..), + SwitchResult(..), + classifyOpts, + + intSwitchSet, + switchIsOn, + + maybe_CompilingGhcInternals, + opt_AllDemanded, + opt_AllStrict, + opt_AutoSccsOnAllToplevs, + opt_AutoSccsOnExportedToplevs, + opt_AutoSccsOnIndividualCafs, + opt_CompilingGhcInternals, + opt_UsingGhcInternals, + opt_D_dump_absC, + opt_D_dump_asm, + opt_D_dump_deforest, + opt_D_dump_deriv, + opt_D_dump_ds, + opt_D_dump_flatC, + opt_D_dump_occur_anal, + opt_D_dump_rdr, + opt_D_dump_realC, + opt_D_dump_rn, + opt_D_dump_simpl, + opt_D_dump_spec, + opt_D_dump_stg, + opt_D_dump_stranal, + opt_D_dump_tc, + opt_D_show_passes, + opt_D_simplifier_stats, + opt_D_source_stats, + opt_D_verbose_core2core, + opt_D_verbose_stg2stg, + opt_DoCoreLinting, + opt_DoSemiTagging, + opt_DoTickyProfiling, + opt_EnsureSplittableC, + opt_FoldrBuildOn, + opt_FoldrBuildTrace, + opt_ForConcurrent, + opt_GlasgowExts, + opt_GranMacros, + opt_Haskell_1_3, + opt_HiMap, + opt_HideBuiltinNames, + opt_HideMostBuiltinNames, + opt_IgnoreIfacePragmas, + opt_IgnoreStrictnessPragmas, + opt_IrrefutableEverything, + opt_IrrefutableTuples, + opt_NoImplicitPrelude, + opt_NumbersStrict, + opt_OmitBlackHoling, + opt_OmitDefaultInstanceMethods, + opt_OmitInterfacePragmas, + opt_PprStyle_All, + opt_PprStyle_Debug, + opt_PprStyle_User, + opt_ProduceC, + opt_ProduceHi, + opt_ProduceS, + opt_ReportWhyUnfoldingsDisallowed, + opt_ReturnInRegsThreshold, + opt_SccGroup, + opt_SccProfilingOn, + opt_ShowImportSpecs, + opt_ShowPragmaNameErrs, + opt_SigsRequired, + opt_SpecialiseAll, + opt_SpecialiseImports, + opt_SpecialiseOverloaded, + opt_SpecialiseTrace, + opt_SpecialiseUnboxed, + opt_StgDoLetNoEscapes, + opt_UnfoldingCreationThreshold, + opt_UnfoldingOverrideThreshold, + opt_UnfoldingUseThreshold, + opt_Verbose, + opt_WarnNameShadowing + ) where + +IMPORT_1_3(Array(array, (//))) import PreludeGlaST -- bad bad bad boy, Will (_Array internals) import Argv CHK_Ubiq() -- debugging consistency check -import Maybes ( assocMaybe, firstJust, maybeToBool, Maybe(..) ) +import Maybes ( assocMaybe, firstJust, maybeToBool ) import Util ( startsWith, panic, panic#, assertPanic ) \end{code} @@ -63,7 +148,6 @@ data CoreToDo -- These are diff core-to-core passes, | CoreDoStrictness | CoreDoSpecialising | CoreDoDeforest - | CoreDoAutoCostCentres | CoreDoFoldrBuildWorkerWrapper | CoreDoFoldrBuildWWAnal \end{code} @@ -139,11 +223,11 @@ data SimplifierSwitch %************************************************************************ \begin{code} -lookup :: FAST_STRING -> Bool +lookUp :: FAST_STRING -> Bool lookup_int :: String -> Maybe Int lookup_str :: String -> Maybe String -lookup sw = maybeToBool (assoc_opts sw) +lookUp sw = maybeToBool (assoc_opts sw) lookup_str sw = firstJust (map (startsWith sw) unpacked_opts) @@ -156,67 +240,68 @@ unpacked_opts = map _UNPK_ argv \end{code} \begin{code} -opt_AllDemanded = lookup SLIT("-fall-demanded") -opt_AllStrict = lookup SLIT("-fall-strict") -opt_AutoSccsOnAllToplevs = lookup SLIT("-fauto-sccs-on-all-toplevs") -opt_AutoSccsOnExportedToplevs = lookup SLIT("-fauto-sccs-on-exported-toplevs") -opt_AutoSccsOnIndividualCafs = lookup SLIT("-fauto-sccs-on-individual-cafs") -opt_D_dump_absC = lookup SLIT("-ddump-absC") -opt_D_dump_asm = lookup SLIT("-ddump-asm") -opt_D_dump_deforest = lookup SLIT("-ddump-deforest") -opt_D_dump_deriv = lookup SLIT("-ddump-deriv") -opt_D_dump_ds = lookup SLIT("-ddump-ds") -opt_D_dump_flatC = lookup SLIT("-ddump-flatC") -opt_D_dump_occur_anal = lookup SLIT("-ddump-occur-anal") -opt_D_dump_rdr = lookup SLIT("-ddump-rdr") -opt_D_dump_realC = lookup SLIT("-ddump-realC") -opt_D_dump_rn = lookup SLIT("-ddump-rn") -opt_D_dump_simpl = lookup SLIT("-ddump-simpl") -opt_D_dump_spec = lookup SLIT("-ddump-spec") -opt_D_dump_stg = lookup SLIT("-ddump-stg") -opt_D_dump_stranal = lookup SLIT("-ddump-stranal") -opt_D_dump_tc = lookup SLIT("-ddump-tc") -opt_D_show_passes = lookup SLIT("-dshow-passes") -opt_D_simplifier_stats = lookup SLIT("-dsimplifier-stats") -opt_D_source_stats = lookup SLIT("-dsource-stats") -opt_D_verbose_core2core = lookup SLIT("-dverbose-simpl") -opt_D_verbose_stg2stg = lookup SLIT("-dverbose-stg") -opt_DoCoreLinting = lookup SLIT("-dcore-lint") -opt_DoSemiTagging = lookup SLIT("-fsemi-tagging") -opt_DoTickyProfiling = lookup SLIT("-fticky-ticky") -opt_FoldrBuildOn = lookup SLIT("-ffoldr-build-on") -opt_FoldrBuildTrace = lookup SLIT("-ffoldr-build-trace") -opt_ForConcurrent = lookup SLIT("-fconcurrent") -opt_GranMacros = lookup SLIT("-fgransim") -opt_GlasgowExts = lookup SLIT("-fglasgow-exts") -opt_Haskell_1_3 = lookup SLIT("-fhaskell-1.3") -opt_HideBuiltinNames = lookup SLIT("-fhide-builtin-names") -opt_HideMostBuiltinNames = lookup SLIT("-fmin-builtin-names") -opt_IgnoreStrictnessPragmas = lookup SLIT("-fignore-strictness-pragmas") -opt_IrrefutableEverything = lookup SLIT("-firrefutable-everything") -opt_IrrefutableTuples = lookup SLIT("-firrefutable-tuples") -opt_WarnNameShadowing = lookup SLIT("-fwarn-name-shadowing") -opt_NumbersStrict = lookup SLIT("-fnumbers-strict") -opt_OmitBlackHoling = lookup SLIT("-dno-black-holing") -opt_OmitDefaultInstanceMethods = lookup SLIT("-fomit-default-instance-methods") -opt_OmitInterfacePragmas = lookup SLIT("-fomit-interface-pragmas") -opt_PprStyle_All = lookup SLIT("-dppr-all") -opt_PprStyle_Debug = lookup SLIT("-dppr-debug") -opt_PprStyle_User = lookup SLIT("-dppr-user") -opt_ReportWhyUnfoldingsDisallowed= lookup SLIT("-freport-disallowed-unfoldings") -opt_SccProfilingOn = lookup SLIT("-fscc-profiling") -opt_ShowImportSpecs = lookup SLIT("-fshow-import-specs") -opt_ShowPragmaNameErrs = lookup SLIT("-fshow-pragma-name-errs") -opt_SigsRequired = lookup SLIT("-fsignatures-required") -opt_SpecialiseAll = lookup SLIT("-fspecialise-all") -opt_SpecialiseImports = lookup SLIT("-fspecialise-imports") -opt_SpecialiseOverloaded = lookup SLIT("-fspecialise-overloaded") -opt_SpecialiseTrace = lookup SLIT("-ftrace-specialisation") -opt_SpecialiseUnboxed = lookup SLIT("-fspecialise-unboxed") -opt_StgDoLetNoEscapes = lookup SLIT("-flet-no-escape") -opt_Verbose = lookup SLIT("-v") -opt_CompilingPrelude = maybeToBool maybe_CompilingPrelude -maybe_CompilingPrelude = lookup_str "-fcompiling-prelude=" +opt_AllDemanded = lookUp SLIT("-fall-demanded") +opt_AllStrict = lookUp SLIT("-fall-strict") +opt_AutoSccsOnAllToplevs = lookUp SLIT("-fauto-sccs-on-all-toplevs") +opt_AutoSccsOnExportedToplevs = lookUp SLIT("-fauto-sccs-on-exported-toplevs") +opt_AutoSccsOnIndividualCafs = lookUp SLIT("-fauto-sccs-on-individual-cafs") +opt_D_dump_absC = lookUp SLIT("-ddump-absC") +opt_D_dump_asm = lookUp SLIT("-ddump-asm") +opt_D_dump_deforest = lookUp SLIT("-ddump-deforest") +opt_D_dump_deriv = lookUp SLIT("-ddump-deriv") +opt_D_dump_ds = lookUp SLIT("-ddump-ds") +opt_D_dump_flatC = lookUp SLIT("-ddump-flatC") +opt_D_dump_occur_anal = lookUp SLIT("-ddump-occur-anal") +opt_D_dump_rdr = lookUp SLIT("-ddump-rdr") +opt_D_dump_realC = lookUp SLIT("-ddump-realC") +opt_D_dump_rn = lookUp SLIT("-ddump-rn") +opt_D_dump_simpl = lookUp SLIT("-ddump-simpl") +opt_D_dump_spec = lookUp SLIT("-ddump-spec") +opt_D_dump_stg = lookUp SLIT("-ddump-stg") +opt_D_dump_stranal = lookUp SLIT("-ddump-stranal") +opt_D_dump_tc = lookUp SLIT("-ddump-tc") +opt_D_show_passes = lookUp SLIT("-dshow-passes") +opt_D_simplifier_stats = lookUp SLIT("-dsimplifier-stats") +opt_D_source_stats = lookUp SLIT("-dsource-stats") +opt_D_verbose_core2core = lookUp SLIT("-dverbose-simpl") +opt_D_verbose_stg2stg = lookUp SLIT("-dverbose-stg") +opt_DoCoreLinting = lookUp SLIT("-dcore-lint") +opt_DoSemiTagging = lookUp SLIT("-fsemi-tagging") +opt_DoTickyProfiling = lookUp SLIT("-fticky-ticky") +opt_FoldrBuildOn = lookUp SLIT("-ffoldr-build-on") +opt_FoldrBuildTrace = lookUp SLIT("-ffoldr-build-trace") +opt_ForConcurrent = lookUp SLIT("-fconcurrent") +opt_GranMacros = lookUp SLIT("-fgransim") +opt_GlasgowExts = lookUp SLIT("-fglasgow-exts") +opt_Haskell_1_3 = lookUp SLIT("-fhaskell-1.3") +opt_HideBuiltinNames = lookUp SLIT("-fhide-builtin-names") +opt_HideMostBuiltinNames = lookUp SLIT("-fmin-builtin-names") +opt_IgnoreStrictnessPragmas = lookUp SLIT("-fignore-strictness-pragmas") +opt_IrrefutableEverything = lookUp SLIT("-firrefutable-everything") +opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples") +opt_WarnNameShadowing = lookUp SLIT("-fwarn-name-shadowing") +opt_NumbersStrict = lookUp SLIT("-fnumbers-strict") +opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing") +opt_OmitDefaultInstanceMethods = lookUp SLIT("-fomit-default-instance-methods") +opt_OmitInterfacePragmas = lookUp SLIT("-fomit-interface-pragmas") +opt_PprStyle_All = lookUp SLIT("-dppr-all") +opt_PprStyle_Debug = lookUp SLIT("-dppr-debug") +opt_PprStyle_User = lookUp SLIT("-dppr-user") +opt_ReportWhyUnfoldingsDisallowed= lookUp SLIT("-freport-disallowed-unfoldings") +opt_SccProfilingOn = lookUp SLIT("-fscc-profiling") +opt_ShowImportSpecs = lookUp SLIT("-fshow-import-specs") +opt_ShowPragmaNameErrs = lookUp SLIT("-fshow-pragma-name-errs") +opt_SigsRequired = lookUp SLIT("-fsignatures-required") +opt_SpecialiseAll = lookUp SLIT("-fspecialise-all") +opt_SpecialiseImports = lookUp SLIT("-fspecialise-imports") +opt_SpecialiseOverloaded = lookUp SLIT("-fspecialise-overloaded") +opt_SpecialiseTrace = lookUp SLIT("-ftrace-specialisation") +opt_SpecialiseUnboxed = lookUp SLIT("-fspecialise-unboxed") +opt_StgDoLetNoEscapes = lookUp SLIT("-flet-no-escape") +opt_Verbose = lookUp SLIT("-v") +opt_UsingGhcInternals = lookUp SLIT("-fusing-ghc-internals") +opt_CompilingGhcInternals = maybeToBool maybe_CompilingGhcInternals +maybe_CompilingGhcInternals = lookup_str "-fcompiling-ghc-internals=" opt_SccGroup = lookup_str "-G=" opt_ProduceC = lookup_str "-C=" opt_ProduceS = lookup_str "-S=" @@ -228,8 +313,8 @@ opt_UnfoldingCreationThreshold = lookup_int "-funfolding-creation-threshold" opt_UnfoldingOverrideThreshold = lookup_int "-funfolding-override-threshold" opt_ReturnInRegsThreshold = lookup_int "-freturn-in-regs-threshold" -opt_NoImplicitPrelude = lookup SLIT("-fno-implicit-prelude") -opt_IgnoreIfacePragmas = lookup SLIT("-fignore-interface-pragmas") +opt_NoImplicitPrelude = lookUp SLIT("-fno-implicit-prelude") +opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas") \end{code} \begin{code} @@ -268,7 +353,6 @@ classifyOpts = sep argv [] [] -- accumulators... "-fstrictness" -> CORE_TD(CoreDoStrictness) "-fspecialise" -> CORE_TD(CoreDoSpecialising) "-fdeforest" -> CORE_TD(CoreDoDeforest) - "-fadd-auto-sccs" -> CORE_TD(CoreDoAutoCostCentres) "-ffoldr-build-worker-wrapper" -> CORE_TD(CoreDoFoldrBuildWorkerWrapper) "-ffoldr-build-ww-anal" -> CORE_TD(CoreDoFoldrBuildWWAnal) @@ -411,6 +495,17 @@ lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplDontFoldBackAppend) %************************************************************************ \begin{code} +#if __GLASGOW_HASKELL__ >= 200 +# define ARRAY Array +# define LIFT GHCbase.Lift +# define SET_TO =: +(=:) a b = (a,b) +#else +# define ARRAY _Array +# define LIFT _Lift +# define SET_TO := +#endif + isAmongSimpl :: [SimplifierSwitch] -> SimplifierSwitch -> SwitchResult isAmongSimpl on_switches @@ -423,22 +518,22 @@ isAmongSimpl on_switches all_undefined) // defined_elems - all_undefined = [ i := SwBool False | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ] + all_undefined = [ i SET_TO SwBool False | i <- [0 .. lAST_SIMPL_SWITCH_TAG ] ] defined_elems = map mk_assoc_elem tidied_on_switches in -- (avoid some unboxing, bounds checking, and other horrible things:) - case sw_tbl of { _Array bounds_who_needs_'em stuff -> + case sw_tbl of { ARRAY bounds_who_needs_'em stuff -> \ switch -> case (indexArray# stuff (tagOf_SimplSwitch switch)) of - _Lift v -> v + LIFT v -> v } where - mk_assoc_elem k@(MaxSimplifierIterations lvl) = IBOX(tagOf_SimplSwitch k) := SwInt lvl - mk_assoc_elem k@(SimplUnfoldingUseThreshold i) = IBOX(tagOf_SimplSwitch k) := SwInt i - mk_assoc_elem k@(SimplUnfoldingCreationThreshold i) = IBOX(tagOf_SimplSwitch k) := SwInt i + mk_assoc_elem k@(MaxSimplifierIterations lvl) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt lvl + mk_assoc_elem k@(SimplUnfoldingUseThreshold i) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt i + mk_assoc_elem k@(SimplUnfoldingCreationThreshold i) = IBOX(tagOf_SimplSwitch k) SET_TO SwInt i - mk_assoc_elem k = IBOX(tagOf_SimplSwitch k) := SwBool True -- I'm here, Mom! + mk_assoc_elem k = IBOX(tagOf_SimplSwitch k) SET_TO SwBool True -- I'm here, Mom! -- cannot have duplicates if we are going to use the array thing diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index 04ae96f..c0d0e71 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -7,7 +7,7 @@ #include "HsVersions.h" module ErrUtils ( - Error(..), Warning(..), Message(..), + SYN_IE(Error), SYN_IE(Warning), SYN_IE(Message), addErrLoc, addShortErrLocLine, addShortWarnLocLine, dontAddErrLoc, diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index c0d4791..8bd7f24 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -93,7 +93,7 @@ doIt (core_cmds, stg_cmds) input_pgm renameModule rn_uniqs rdr_module >>= \ (rn_mod, rn_env, import_names, - usage_stuff, + export_fn, usage_stuff, rn_errs_bag, rn_warns_bag) -> if (not (isEmptyBag rn_errs_bag)) then @@ -125,7 +125,7 @@ doIt (core_cmds, stg_cmds) input_pgm startIface mod_name >>= \ if_handle -> ifaceUsages if_handle usages_map >> ifaceVersions if_handle version_info >> - ifaceExportList if_handle rn_mod >> + ifaceExportList if_handle export_fn rn_mod >> ifaceFixities if_handle rn_mod >> ifaceInstanceModules if_handle instance_modules >> diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index a1cb9f7..99f12ea 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -24,7 +24,7 @@ import Bag ( emptyBag, snocBag, bagToList ) import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) ) import CmdLineOpts ( opt_ProduceHi ) import FieldLabel ( FieldLabel{-instance NamedThing-} ) -import FiniteMap ( fmToList ) +import FiniteMap ( fmToList, eltsFM ) import HsSyn import Id ( idType, dataConRawArgTys, dataConFieldLabels, dataConStrictMarks, StrictnessMark(..), @@ -32,7 +32,6 @@ import Id ( idType, dataConRawArgTys, dataConFieldLabels, ) import Name ( origName, nameOf, moduleOf, exportFlagOn, nameExportFlag, ExportFlag(..), - isExported, getExportFlag, isLexSym, isLocallyDefined, isWiredInName, RdrName(..){-instance Outputable-}, OrigName(..){-instance Ord-}, @@ -42,14 +41,15 @@ import ParseUtils ( UsagesMap(..), VersionsMap(..) ) import PprEnv -- not sure how much... import PprStyle ( PprStyle(..) ) import PprType -- most of it (??) -import PrelMods ( modulesWithBuiltins ) +--import PrelMods ( modulesWithBuiltins ) +import PrelInfo ( builtinNameInfo ) import Pretty ( prettyToUn ) import Unpretty -- ditto import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} ) import TcModule ( TcIfaceInfo(..) ) import TcInstUtil ( InstInfo(..) ) import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) ) -import Type ( mkSigmaTy, mkDictTy, getAppTyCon ) +import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy ) import Util ( sortLt, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} ) uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util @@ -82,6 +82,7 @@ ifaceVersions -> IO () ifaceExportList :: Maybe Handle + -> (Name -> ExportFlag) -> RenamedHsModule -> IO () ifaceFixities @@ -128,12 +129,12 @@ ifaceUsages (Just if_hdl) usages = hPutStr if_hdl "\n__usages__\n" >> hPutStr if_hdl (uppShow 0 (uppAboves (map upp_uses usages_list))) where - usages_list = filter has_no_builtins (fmToList usages) + usages_list = fmToList usages -- NO: filter has_no_builtins (...) - has_no_builtins (m, _) - = m `notElem` modulesWithBuiltins - -- Don't *have* to do this; save gratuitous spillage in - -- every interface. Could be flag-controlled... +-- has_no_builtins (m, _) +-- = m `notElem` modulesWithBuiltins +-- -- Don't *have* to do this; save gratuitous spillage in +-- -- every interface. Could be flag-controlled... upp_uses (m, (mv, versions)) = uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "), @@ -178,20 +179,32 @@ next...), and print. Note that the ``module'' now contains all the imported things that we are dealing with, thus including any entities that we are re-exporting from somewhere else. \begin{code} -ifaceExportList Nothing{-no iface handle-} _ = return () +ifaceExportList Nothing{-no iface handle-} _ _ = return () ifaceExportList (Just if_hdl) + export_fn -- sadly, just the HsModule isn't enough, + -- because it will have no record of exported + -- wired-in names. (HsModule _ _ _ _ _ typedecls _ classdecls _ _ _ binds sigs _) = let + (vals_wired, tcs_wired) + = case builtinNameInfo of { ((vals_fm,tcs_fm), _, _) -> + ([ getName rn | rn <- eltsFM vals_fm ] + ,[ getName rn | rn <- eltsFM tcs_fm ]) } + name_flag_pairs :: Bag (OrigName, ExportFlag) name_flag_pairs - = foldr from_ty + = foldr from_wired + (foldr from_wired + (foldr from_ty (foldr from_cls (foldr from_sig (from_binds binds emptyBag{-init accum-}) sigs) classdecls) - typedecls + typedecls) + tcs_wired) + vals_wired sorted_pairs = sortLt lexical_lt (bagToList name_flag_pairs) @@ -210,6 +223,13 @@ ifaceExportList (Just if_hdl) from_binds bs acc = maybe_add_list acc (collectTopLevelBinders bs) -------------- + from_wired n acc + | exportFlagOn ef = acc `snocBag` (origName "maybe_add" n, ef) + | otherwise = acc + where + ef = export_fn n + + -------------- maybe_add :: Bag (OrigName, ExportFlag) -> RnName -> Bag (OrigName, ExportFlag) maybe_add acc rn @@ -256,6 +276,8 @@ ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _) \end{code} \begin{code} +non_wired x = not (isWiredInName (getName x)) --ToDo:move? + ifaceDecls Nothing{-no iface handle-} _ = return () ifaceDecls (Just if_hdl) (vals, tycons, classes, _) @@ -263,8 +285,6 @@ ifaceDecls (Just if_hdl) (vals, tycons, classes, _) ASSERT(all isLocallyDefined tycons) ASSERT(all isLocallyDefined classes) let - non_wired x = not (isWiredInName (getName x)) - nonwired_classes = filter non_wired classes nonwired_tycons = filter non_wired tycons nonwired_vals = filter non_wired vals @@ -276,7 +296,7 @@ ifaceDecls (Just if_hdl) (vals, tycons, classes, _) sorted_vals = sortLt lt_lexical nonwired_vals in if (null sorted_classes && null sorted_tycons && null sorted_vals) then - -- You could have a module with just instances in it + -- You could have a module with just (re-)exports/instances in it return () else hPutStr if_hdl "\n__declarations__\n" >> @@ -322,7 +342,8 @@ ifaceInstances (Just if_hdl) (_, _, _, insts) forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty) renumbered_ty = initNmbr (nmbrType forall_ty) in - uppBesides [uppPStr SLIT("instance "), ppr_ty renumbered_ty, uppSemi] + case (splitForAllTy renumbered_ty) of { (rtvs, rrho_ty) -> + uppBesides [uppPStr SLIT("instance "), ppr_forall rtvs, ppr_ty rrho_ty, uppSemi] } \end{code} %************************************************************************ @@ -368,7 +389,11 @@ ppr_val v ty -- renumber the type first! pp_sig v (initNmbr (nmbrType ty)) pp_sig op ty - = uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_ty ty, uppSemi] + = case (splitForAllTy ty) of { (tvs, rho_ty) -> + uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_forall tvs, ppr_ty rho_ty, uppSemi] } + +ppr_forall [] = uppNil +ppr_forall tvs = uppBesides [ uppStr "__forall__ [", uppInterleave uppComma (map ppr_tyvar tvs), uppStr "] " ] \end{code} \begin{code} diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 830e450..144f586 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -31,7 +31,7 @@ import PrimRep ( isFloatingRep, PrimRep(..) ) import StixInfo ( genCodeInfoTable ) import StixMacro ( macroCode ) import StixPrim ( primCode, amodeToStix, amodeToStix' ) -import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) ) +import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) ) import Util ( naturalMergeSortLe, panic ) #ifdef REALLY_HASKELL_1_3 diff --git a/ghc/compiler/nativeGen/AsmCodeGen.lhs b/ghc/compiler/nativeGen/AsmCodeGen.lhs index 090e13f..50c6fae 100644 --- a/ghc/compiler/nativeGen/AsmCodeGen.lhs +++ b/ghc/compiler/nativeGen/AsmCodeGen.lhs @@ -22,7 +22,7 @@ import PrimOp ( commutableOp, PrimOp(..) ) import PrimRep ( PrimRep{-instance Eq-} ) import RegAllocInfo ( mkMRegsState, MRegsState ) import Stix ( StixTree(..), StixReg(..), CodeSegment ) -import UniqSupply ( returnUs, thenUs, mapUs, UniqSM(..) ) +import UniqSupply ( returnUs, thenUs, mapUs, SYN_IE(UniqSM) ) import Unpretty ( uppPutStr, uppShow, uppAboves, Unpretty(..) ) \end{code} diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index c9b671e..031c3ba 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -31,7 +31,7 @@ import Stix ( getUniqLabelNCG, StixTree(..), StixReg(..), CodeSegment(..) ) import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs, - mapAccumLUs, UniqSM(..) + mapAccumLUs, SYN_IE(UniqSM) ) import Unpretty ( uppPStr ) import Util ( panic, assertPanic ) diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs index 7493de4..b48f136 100644 --- a/ghc/compiler/nativeGen/MachRegs.lhs +++ b/ghc/compiler/nativeGen/MachRegs.lhs @@ -72,7 +72,7 @@ import Stix ( sStLitLbl, StixTree(..), StixReg(..), import Unique ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3, Unique{-instance Ord3-} ) -import UniqSupply ( getUnique, returnUs, thenUs, UniqSM(..) ) +import UniqSupply ( getUnique, returnUs, thenUs, SYN_IE(UniqSM) ) import Unpretty ( uppStr, Unpretty(..) ) import Util ( panic ) \end{code} diff --git a/ghc/compiler/nativeGen/NcgLoop_1_3.lhi b/ghc/compiler/nativeGen/NcgLoop_1_3.lhi new file mode 100644 index 0000000..5cc8f20 --- /dev/null +++ b/ghc/compiler/nativeGen/NcgLoop_1_3.lhi @@ -0,0 +1,6 @@ +\begin{code} +interface NcgLoop_1_3 1 +__exports__ +MachMisc underscorePrefix (..) +MachMisc fmtAsmLbl (..) +\end{code} diff --git a/ghc/compiler/nativeGen/Stix.lhs b/ghc/compiler/nativeGen/Stix.lhs index 2dd8169..c6ab81b 100644 --- a/ghc/compiler/nativeGen/Stix.lhs +++ b/ghc/compiler/nativeGen/Stix.lhs @@ -20,7 +20,7 @@ IMP_Ubiq(){-uitous-} import AbsCSyn ( node, infoptr, MagicId(..) ) import AbsCUtils ( magicIdPrimRep ) import CLabel ( mkAsmTempLabel ) -import UniqSupply ( returnUs, thenUs, getUnique, UniqSM(..) ) +import UniqSupply ( returnUs, thenUs, getUnique, SYN_IE(UniqSM) ) import Unpretty ( uppPStr, Unpretty(..) ) \end{code} diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs index 9afcec5..150dc41 100644 --- a/ghc/compiler/nativeGen/StixInfo.lhs +++ b/ghc/compiler/nativeGen/StixInfo.lhs @@ -25,7 +25,7 @@ import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..), ) import Stix -- all of it import StixPrim ( amodeToStix ) -import UniqSupply ( returnUs, UniqSM(..) ) +import UniqSupply ( returnUs, SYN_IE(UniqSM) ) import Unpretty ( uppBesides, uppPStr, uppInt, uppChar ) \end{code} diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index 5c90139..a019c52 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -29,7 +29,7 @@ import Stix ( getUniqLabelNCG, sStLitLbl, stgHp, stgHpLim, CodeSegment, StixReg ) import StixMacro ( macroCode, heapCheck ) -import UniqSupply ( returnUs, thenUs, UniqSM(..) ) +import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) ) import Util ( panic ) \end{code} diff --git a/ghc/compiler/nativeGen/StixMacro.lhs b/ghc/compiler/nativeGen/StixMacro.lhs index c4b8e3d..419283c 100644 --- a/ghc/compiler/nativeGen/StixMacro.lhs +++ b/ghc/compiler/nativeGen/StixMacro.lhs @@ -21,7 +21,7 @@ import OrdList ( OrdList ) import PrimOp ( PrimOp(..) ) import PrimRep ( PrimRep(..) ) import Stix -import UniqSupply ( returnUs, thenUs, UniqSM(..) ) +import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) ) \end{code} The @ARGS_CHK_A{_LOAD_NODE}@ macros check for sufficient arguments on diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index c986b31..cdb4fdb 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -29,7 +29,7 @@ import SMRep ( SMRep(..), SMSpecRepKind, SMUpdateKind ) import Stix import StixMacro ( heapCheck, smStablePtrTable ) import StixInteger {- everything -} -import UniqSupply ( returnUs, thenUs, UniqSM(..) ) +import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) ) import Unpretty ( uppBeside, uppPStr, uppInt ) import Util ( panic ) diff --git a/ghc/compiler/parser/UgenAll.lhs b/ghc/compiler/parser/UgenAll.lhs index d6ebf18..3a5f86c 100644 --- a/ghc/compiler/parser/UgenAll.lhs +++ b/ghc/compiler/parser/UgenAll.lhs @@ -8,21 +8,65 @@ module UgenAll ( returnUgn, thenUgn, -- stuff defined in utils module - UgenUtil.. , +#if (! defined(REALLY_HASKELL_1_3)) || PATRICK_FIXES_MODULE_DOTDOT_THING + EXP_MODULE(UgenUtil) , -- re-exported ugen-generated stuff - U_binding.. , - U_constr.. , - U_entidt.. , - U_list.. , - U_literal.. , - U_maybe.. , - U_either.. , - U_pbinding.. , - U_qid.. , - U_tree.. , - U_ttype.. - + EXP_MODULE(U_binding) , + EXP_MODULE(U_constr) , + EXP_MODULE(U_entidt) , + EXP_MODULE(U_list) , + EXP_MODULE(U_literal) , + EXP_MODULE(U_maybe) , + EXP_MODULE(U_either) , + EXP_MODULE(U_pbinding) , + EXP_MODULE(U_qid) , + EXP_MODULE(U_tree) , + EXP_MODULE(U_ttype) +#else + SYN_IE(ParseTree), + SYN_IE(U_VOID_STAR), + U_binding (..), + U_constr (..), + U_either (..), + U_entidt (..), + SYN_IE(U_hstring), + U_list (..), + U_literal (..), + SYN_IE(U_long), + U_maybe (..), + SYN_IE(U_numId), + U_pbinding (..), + U_qid (..), + SYN_IE(U_stringId), + U_tree (..), + U_ttype (..), + SYN_IE(UgnM), + getSrcFileUgn, + getSrcLocUgn, + getSrcModUgn, + initUgn, + ioToUgnM, + mkSrcLocUgn, + rdU_VOID_STAR, + rdU_binding, + rdU_constr, + rdU_either, + rdU_entidt, + rdU_hstring, + rdU_list, + rdU_literal, + rdU_long, + rdU_maybe, + rdU_numId, + rdU_pbinding, + rdU_qid, + rdU_stringId, + rdU_tree, + rdU_ttype, + setSrcFileUgn, + setSrcModUgn +#endif ) where import PreludeGlaST diff --git a/ghc/compiler/parser/UgenUtil.lhs b/ghc/compiler/parser/UgenUtil.lhs index a432c3c..e112d0c 100644 --- a/ghc/compiler/parser/UgenUtil.lhs +++ b/ghc/compiler/parser/UgenUtil.lhs @@ -9,15 +9,25 @@ module UgenUtil ( returnPrimIO, thenPrimIO, -- stuff defined here - UgenUtil.. + EXP_MODULE(UgenUtil) ) where +IMP_Ubiq() + import PreludeGlaST -IMP_Ubiq() +#if __GLASGOW_HASKELL__ >= 200 +# define ADDR GHCbase.Addr +# define PACK_STR packCString +# define PACK_BYTES packCBytes +#else +# define ADDR _Addr +# define PACK_STR _packCString +# define PACK_BYTES _packCBytes +#endif import Name ( RdrName(..) ) -import SrcLoc ( mkSrcLoc2, mkUnknownSrcLoc ) +import SrcLoc ( mkSrcLoc2, mkUnknownSrcLoc, SrcLoc ) \end{code} \begin{code} @@ -36,18 +46,25 @@ thenUgn x y stuff initUgn :: UgnM a -> IO a initUgn action - = action (SLIT(""),SLIT(""),mkUnknownSrcLoc) `thenPrimIO` \ result -> + = let + do_it = action (SLIT(""),SLIT(""),mkUnknownSrcLoc) + in +#if __GLASGOW_HASKELL__ >= 200 + primIOToIO do_it +#else + do_it `thenPrimIO` \ result -> return result +#endif ioToUgnM :: PrimIO a -> UgnM a ioToUgnM x stuff = x \end{code} \begin{code} -type ParseTree = _Addr +type ParseTree = ADDR -type U_VOID_STAR = _Addr -rdU_VOID_STAR :: _Addr -> UgnM U_VOID_STAR +type U_VOID_STAR = ADDR +rdU_VOID_STAR :: ADDR -> UgnM U_VOID_STAR rdU_VOID_STAR x = returnUgn x type U_long = Int @@ -55,20 +72,20 @@ rdU_long :: Int -> UgnM U_long rdU_long x = returnUgn x type U_stringId = FAST_STRING -rdU_stringId :: _Addr -> UgnM U_stringId +rdU_stringId :: ADDR -> UgnM U_stringId {-# INLINE rdU_stringId #-} -rdU_stringId s = returnUgn (_packCString s) +rdU_stringId s = returnUgn (PACK_STR s) type U_numId = Int -- ToDo: Int -rdU_numId :: _Addr -> UgnM U_numId +rdU_numId :: ADDR -> UgnM U_numId rdU_numId i = rdU_stringId i `thenUgn` \ y -> returnUgn ((read (_UNPK_ y))::Int) type U_hstring = FAST_STRING -rdU_hstring :: _Addr -> UgnM U_hstring +rdU_hstring :: ADDR -> UgnM U_hstring rdU_hstring x = ioToUgnM (_ccall_ get_hstring_len x) `thenUgn` \ len -> ioToUgnM (_ccall_ get_hstring_bytes x) `thenUgn` \ bytes -> - returnUgn (_packCBytes len bytes) + returnUgn (PACK_BYTES len bytes) \end{code} \begin{code} diff --git a/ghc/compiler/parser/hslexer.flex b/ghc/compiler/parser/hslexer.flex index ab3300e..a0033b1 100644 --- a/ghc/compiler/parser/hslexer.flex +++ b/ghc/compiler/parser/hslexer.flex @@ -478,6 +478,16 @@ NL [\n\r] hsnewid(yytext, yyleng); RETURN(isconstr(yytext) ? CONSYM : VARSYM); } +{Mod}"."{Id}"#" { + BOOLEAN is_constr; + if (! nonstandardFlag) { + char errbuf[ERR_BUF_SIZE]; + sprintf(errbuf, "Non-standard identifier (trailing `#'): %s\n", yytext); + hsperror(errbuf); + } + is_constr = hsnewqid(yytext, yyleng); + RETURN(is_constr ? QCONID : QVARID); + } {Mod}"."{Id} { BOOLEAN is_constr = hsnewqid(yytext, yyleng); RETURN(is_constr ? QCONID : QVARID); diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 466c140..8096274 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -9,14 +9,14 @@ module PrelInfo ( -- finite maps for built-in things (for the renamer and typechecker): - builtinNameInfo, BuiltinNames(..), - BuiltinKeys(..), BuiltinIdInfos(..), + builtinNameInfo, SYN_IE(BuiltinNames), + SYN_IE(BuiltinKeys), SYN_IE(BuiltinIdInfos), maybeCharLikeTyCon, maybeIntLikeTyCon ) where IMP_Ubiq() -IMPORT_DELOOPER(PrelLoop) ( primOpNameInfo ) +IMPORT_DELOOPER(PrelLoop) ( primOpNameInfo ) -- friends: import PrelMods -- Prelude module names @@ -32,9 +32,9 @@ import CmdLineOpts ( opt_HideBuiltinNames, opt_ForConcurrent ) import FiniteMap ( FiniteMap, emptyFM, listToFM ) -import Id ( mkTupleCon, GenId, Id(..) ) +import Id ( mkTupleCon, GenId, SYN_IE(Id) ) import Maybes ( catMaybes ) -import Name ( origName, OrigName(..) ) +import Name ( origName, OrigName(..), Name ) import RnHsSyn ( RnName(..) ) import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon ) import Type @@ -225,11 +225,11 @@ wired_in_ids = [ aBSENT_ERROR_ID , augmentId , buildId - , copyableId +-- , copyableId , eRROR_ID , foldlId , foldrId - , forkId +-- , forkId , iRREFUT_PAT_ERROR_ID , integerMinusOneId , integerPlusOneId @@ -238,23 +238,22 @@ wired_in_ids , nON_EXHAUSTIVE_GUARDS_ERROR_ID , nO_DEFAULT_METHOD_ERROR_ID , nO_EXPLICIT_METHOD_ERROR_ID - , noFollowId +-- , noFollowId , pAR_ERROR_ID , pAT_ERROR_ID , packStringForCId - , parAtAbsId - , parAtForNowId - , parAtId - , parAtRelId - , parGlobalId - , parId - , parLocalId +-- , parAtAbsId +-- , parAtForNowId +-- , parAtId +-- , parAtRelId +-- , parGlobalId +-- , parId +-- , parLocalId , rEC_CON_ERROR_ID , rEC_UPD_ERROR_ID , realWorldPrimId , runSTId - , seqId - , tRACE_ID +-- , seqId , tRACE_ID , unpackCString2Id , unpackCStringAppendId @@ -313,13 +312,13 @@ For the Ids we may also have some builtin IdInfo. id_keys_infos :: [(OrigName, Unique, Maybe IdInfo)] id_keys_infos = [ -- here so we can check the type of main/mainPrimIO - (OrigName SLIT("Main") SLIT("main"), mainIdKey, Nothing) - , (OrigName SLIT("Main") SLIT("mainPrimIO"), mainPrimIOIdKey, Nothing) + (OrigName SLIT("Main") SLIT("main"), mainIdKey, Nothing) + , (OrigName SLIT("GHCmain") SLIT("mainPrimIO"), mainPrimIOIdKey, Nothing) -- here because we use them in derived instances , (OrigName pRELUDE SLIT("&&"), andandIdKey, Nothing) , (OrigName pRELUDE SLIT("."), composeIdKey, Nothing) - , (OrigName pRELUDE SLIT("lex"), lexIdKey, Nothing) + , (OrigName gHC__ SLIT("lex"), lexIdKey, Nothing) , (OrigName pRELUDE SLIT("not"), notIdKey, Nothing) , (OrigName pRELUDE SLIT("readParen"), readParenIdKey, Nothing) , (OrigName pRELUDE SLIT("showParen"), showParenIdKey, Nothing) diff --git a/ghc/compiler/prelude/PrelLoop.lhi b/ghc/compiler/prelude/PrelLoop.lhi index c016e48..724a8a2 100644 --- a/ghc/compiler/prelude/PrelLoop.lhi +++ b/ghc/compiler/prelude/PrelLoop.lhi @@ -8,7 +8,7 @@ import PreludePS ( _PackedString ) import Class ( GenClass ) import CoreUnfold ( mkMagicUnfolding, UnfoldingDetails ) import IdUtils ( primOpNameInfo ) -import Name ( Name, OrigName, mkPrimitiveName, mkWiredInName ) +import Name ( Name, OrigName, mkPrimitiveName, mkWiredInName, ExportFlag ) import PrimOp ( PrimOp ) import RnHsSyn ( RnName ) import Type ( mkSigmaTy, mkFunTys, GenType ) @@ -18,7 +18,7 @@ import Usage ( GenUsage ) mkMagicUnfolding :: Unique -> UnfoldingDetails mkPrimitiveName :: Unique -> OrigName -> Name -mkWiredInName :: Unique -> OrigName -> Name +mkWiredInName :: Unique -> OrigName -> ExportFlag -> Name mkSigmaTy :: [a] -> [(GenClass (GenTyVar (GenUsage Unique)) Unique, GenType a b)] -> GenType a b -> GenType a b mkFunTys :: [GenType a b] -> GenType a b -> GenType a b diff --git a/ghc/compiler/prelude/PrelLoop_1_3.lhi b/ghc/compiler/prelude/PrelLoop_1_3.lhi new file mode 100644 index 0000000..cee1c67 --- /dev/null +++ b/ghc/compiler/prelude/PrelLoop_1_3.lhi @@ -0,0 +1,8 @@ +\begin{code} +interface PrelLoop_1_3 1 +__exports__ +Name mkWiredInName (..) +Type mkSigmaTy (..) +Type mkFunTys (..) +IdUtils primOpNameInfo (..) +\end{code} diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 30f24db..fe5b026 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -10,7 +10,7 @@ module PrelVals where IMP_Ubiq() IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..) ) -import Id ( Id(..), GenId, mkImported, mkUserId, mkTemplateLocals ) +import Id ( SYN_IE(Id), GenId, mkImported, mkUserId, mkTemplateLocals ) IMPORT_DELOOPER(PrelLoop) -- friends: @@ -19,45 +19,35 @@ import TysPrim import TysWiredIn -- others: -import CmdLineOpts ( maybe_CompilingPrelude ) +import CmdLineOpts ( maybe_CompilingGhcInternals ) import CoreSyn -- quite a bit import IdInfo -- quite a bit import Literal ( mkMachInt ) +import Name ( ExportFlag(..) ) import PragmaInfo import PrimOp ( PrimOp(..) ) -import SpecEnv ( SpecEnv(..), nullSpecEnv ) +import SpecEnv ( SYN_IE(SpecEnv), nullSpecEnv ) import Type ( mkTyVarTy ) import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, gammaTyVar ) import Unique -- lots of *Keys import Util ( panic ) \end{code} - - - \begin{code} -- only used herein: pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id pcMiscPrelId key m n ty info = let - name = mkWiredInName key (OrigName m n) + name = mkWiredInName key (OrigName m n) ExportAll imp = mkImported name ty info -- the usual case... in imp -- We lie and say the thing is imported; otherwise, we get into -- a mess with dependency analysis; e.g., core2stg may heave in - -- random calls to GHCbase.unpackPS. If GHCbase is the module + -- random calls to GHCbase.unpackPS__. If GHCbase is the module -- being compiled, then it's just a matter of luck if the definition -- will be in "the right place" to be in scope. -{- ??? - case maybe_CompilingPrelude of - Nothing -> imp - Just modname -> - if modname == _UNPK_ m -- we are compiling the module where this thing is defined... - then mkUserId name ty NoPragmaInfo - else imp --} \end{code} %************************************************************************ @@ -120,13 +110,10 @@ errorTy :: Type errorTy = mkSigmaTy [openAlphaTyVar] [] (mkFunTys [mkListTy charTy] (mkTyVarTy openAlphaTyVar)) \end{code} -We want \tr{_trace} (NB: name not in user namespace) to be wired in +We want \tr{GHCbase.trace} to be wired in because we don't want the strictness analyser to get ahold of it, decide that the second argument is strict, evaluate that first (!!), -and make a jolly old mess. Having \tr{_trace} wired in also helps when -attempting to re-export it---because it's in \tr{PreludeBuiltin}, it -won't get an \tr{import} declaration in the interface file, so the -importing-subsequently module needs to know it's magic. +and make a jolly old mess. \begin{code} tRACE_ID = pcMiscPrelId traceIdKey gHC__ SLIT("trace") traceTy @@ -143,33 +130,33 @@ tRACE_ID \begin{code} packStringForCId - = pcMiscPrelId packCStringIdKey{-ToDo:rename-} gHC__ SLIT("packStringForC") + = pcMiscPrelId packCStringIdKey{-ToDo:rename-} gHC__ SLIT("packStringForC__") (mkFunTys [stringTy] byteArrayPrimTy) noIdInfo -------------------------------------------------------------------- unpackCStringId - = pcMiscPrelId unpackCStringIdKey gHC__ SLIT("unpackPS") + = pcMiscPrelId unpackCStringIdKey gHC__ SLIT("unpackPS__") (mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo -- Andy says: -- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1) -- but I don't like wired-in IdInfos (WDP) unpackCString2Id -- for cases when a string has a NUL in it - = pcMiscPrelId unpackCString2IdKey gHC__ SLIT("unpackPS2") + = pcMiscPrelId unpackCString2IdKey gHC__ SLIT("unpackPS2__") (mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy) noIdInfo -------------------------------------------------------------------- unpackCStringAppendId - = pcMiscPrelId unpackCStringAppendIdKey gHC__ SLIT("unpackAppendPS") + = pcMiscPrelId unpackCStringAppendIdKey gHC__ SLIT("unpackAppendPS__") (mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy) ((noIdInfo {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey-}) `addInfo` mkArityInfo 2) unpackCStringFoldrId - = pcMiscPrelId unpackCStringFoldrIdKey gHC__ SLIT("unpackFoldrPS") + = pcMiscPrelId unpackCStringFoldrIdKey gHC__ SLIT("unpackFoldrPS__") (mkSigmaTy [alphaTyVar] [] (mkFunTys [addrPrimTy{-a "char *" pointer-}, mkFunTys [charTy, alphaTy] alphaTy, @@ -200,6 +187,7 @@ integerMinusOneId %************************************************************************ \begin{code} +{- OUT: -------------------------------------------------------------------- -- seqId :: "seq", used w/ GRIP, etc., is really quite similar to -- dangerousEval @@ -291,11 +279,12 @@ forkId = pcMiscPrelId forkIdKey gHC__ SLIT("fork") PrimAlts [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] (BindDefault z (Var y)))) - +-} \end{code} GranSim ones: \begin{code} +{- OUT: parLocalId = pcMiscPrelId parLocalIdKey gHC__ SLIT("parLocal") (mkSigmaTy [alphaTyVar, betaTyVar] [] (mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy)) @@ -368,7 +357,7 @@ parAtId = pcMiscPrelId parAtIdKey gHC__ SLIT("parAt") = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] ( Case (Prim ParAtOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) ( PrimAlts - [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] + [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])] (BindDefault z (Var y)))) parAtAbsId = pcMiscPrelId parAtAbsIdKey gHC__ SLIT("parAtAbs") @@ -444,7 +433,7 @@ parAtForNowId = pcMiscPrelId parAtForNowIdKey gHC__ SLIT("parAtForNow") = mkLam [alphaTyVar, betaTyVar, gammaTyVar] [w, g, s, p, v, x, y] ( Case (Prim ParAtForNowOp [TyArg alphaTy, TyArg betaTy, TyArg gammaTy, VarArg x, VarArg v, VarArg w, VarArg g, VarArg s, VarArg p, VarArg y]) ( PrimAlts - [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])] + [(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])] (BindDefault z (Var y)))) -- copyable and noFollow are currently merely hooks: they are translated into @@ -479,41 +468,25 @@ noFollowId = pcMiscPrelId noFollowIdKey gHC__ SLIT("noFollow") noFollow_template = mkLam [alphaTyVar] [x] ( Prim NoFollowOp [TyArg alphaTy, VarArg x] ) +-} \end{code} %************************************************************************ %* * -\subsection[PrelVals-deriving]{Values known about mainly for doing derived instance decls} -%* * -%************************************************************************ - -map :: (a -> b) -> [a] -> [b] - -- this is up in the here-because-of-unfolding list - ---??showChar :: Char -> ShowS -showSpace :: ShowS -- non-std: == "showChar ' '" -showString :: String -> ShowS -showParen :: Bool -> ShowS -> ShowS - -(++) :: [a] -> [a] -> [a] -readParen :: Bool -> ReadS a -> ReadS a -lex :: ReadS String - -%************************************************************************ -%* * -\subsection[PrelVals-runST]{@_runST@: Magic start-state-transformer function} +\subsection[PrelVals-runST]{@runST@: Magic start-state-transformer function} %* * %************************************************************************ -@_runST@ has a non-Haskell-able type: +@runST@ has a non-Haskell-able type: \begin{verbatim} --- _runST :: forall a. (forall s. _ST s a) -> a +-- runST :: forall a. (forall s. _ST s a) -> a -- which is to say :: -- forall a. (forall s. (_State s -> (a, _State s))) -> a -_runST a m = case m _RealWorld (S# _RealWorld realWorld#) of +runST a m = case m _RealWorld (S# _RealWorld realWorld#) of (r :: a, wild :: _State _RealWorld) -> r \end{verbatim} + We unfold always, just for simplicity: \begin{code} runSTId @@ -554,16 +527,16 @@ runSTId -} \end{code} -SLPJ 95/04: Why @_runST@ must not have an unfolding; consider: +SLPJ 95/04: Why @runST@ must not have an unfolding; consider: \begin{verbatim} f x = - _runST ( \ s -> let + runST ( \ s -> let (a, s') = newArray# 100 [] s (_, s'') = fill_in_array_or_something a x s' in freezeArray# a s'' ) \end{verbatim} -If we inline @_runST@, we'll get: +If we inline @runST@, we'll get: \begin{verbatim} f x = let (a, s') = newArray# 100 [] realWorld#{-NB-} diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 6556a87..8ab3a4b 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -37,7 +37,7 @@ import TysWiredIn import CStrings ( identToC ) import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE ) -import HeapOffs ( addOff, intOff, totHdrSize ) +import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset ) import PprStyle ( codeStyle, PprStyle(..){-ToDo:rm-} ) import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} ) import Pretty @@ -1292,30 +1292,31 @@ primOpInfo ForkOp -- fork# :: a -> Int# \begin{code} -- HWL: The first 4 Int# in all par... annotations denote: -- name, granularity info, size of result, degree of parallelism +-- Same structure as _seq_ i.e. returns Int# primOpInfo ParGlobalOp -- parGlobal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b - = AlgResult SLIT("parGlobal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] liftTyCon [betaTy] + = PrimResult SLIT("parGlobal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTyCon IntRep [] -- liftTyCon [betaTy] primOpInfo ParLocalOp -- parLocal# :: Int# -> Int# -> Int# -> Int# -> a -> b -> b - = AlgResult SLIT("parLocal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] liftTyCon [betaTy] + = PrimResult SLIT("parLocal#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTyCon IntRep [] -- liftTyCon [betaTy] primOpInfo ParAtOp -- parAt# :: Int# -> Int# -> Int# -> Int# -> a -> b -> c -> c - = AlgResult SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [alphaTy,betaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] liftTyCon [gammaTy] + = PrimResult SLIT("parAt#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTyCon IntRep [] -- liftTyCon [gammaTy] primOpInfo ParAtAbsOp -- parAtAbs# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b - = AlgResult SLIT("parAtAbs#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] liftTyCon [betaTy] + = PrimResult SLIT("parAtAbs#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTyCon IntRep [] -- liftTyCon [betaTy] primOpInfo ParAtRelOp -- parAtRel# :: Int# -> Int# -> Int# -> Int# -> Int# -> a -> b -> b - = AlgResult SLIT("parAtRel#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] liftTyCon [betaTy] + = PrimResult SLIT("parAtRel#") [alphaTyVar,betaTyVar] [alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,betaTy] intPrimTyCon IntRep [] -- liftTyCon [betaTy] 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] + = PrimResult SLIT("parAtForNow#") [alphaTyVar,betaTyVar,gammaTyVar] [betaTy,alphaTy,intPrimTy,intPrimTy,intPrimTy,intPrimTy,gammaTy] intPrimTyCon IntRep [] -- liftTyCon [gammaTy] primOpInfo CopyableOp -- copyable# :: a -> a - = AlgResult SLIT("copyable#") [alphaTyVar] [alphaTy] liftTyCon [alphaTy] + = PrimResult SLIT("copyable#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep [] -- liftTyCon [alphaTy] primOpInfo NoFollowOp -- noFollow# :: a -> a - = AlgResult SLIT("noFollow#") [alphaTyVar] [alphaTy] liftTyCon [alphaTy] + = PrimResult SLIT("noFollow#") [alphaTyVar] [alphaTy] intPrimTyCon IntRep [] -- liftTyCon [alphaTy] \end{code} %************************************************************************ @@ -1327,8 +1328,11 @@ primOpInfo NoFollowOp -- noFollow# :: a -> a \begin{code} primOpInfo ErrorIOPrimOp -- errorIO# :: PrimIO () -> State# RealWorld# = PrimResult SLIT("errorIO#") [] - [mkPrimIoTy unitTy] + [primio_ish_ty unitTy] statePrimTyCon VoidRep [realWorldTy] + where + primio_ish_ty result + = mkFunTys [mkStateTy realWorldTy] (mkTupleTy 2 [result, mkStateTy realWorldTy]) \end{code} %************************************************************************ @@ -1341,7 +1345,7 @@ 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 @@ -1757,9 +1761,7 @@ pprPrimOp sty other_op = let str = primOp_str other_op in - if codeStyle sty - then identToC str - else ppPStr str + (if codeStyle sty then identToC else ppPStr) str instance Outputable PrimOp where ppr sty op = pprPrimOp sty op diff --git a/ghc/compiler/prelude/TysPrim.lhs b/ghc/compiler/prelude/TysPrim.lhs index 08d49a8..954659a 100644 --- a/ghc/compiler/prelude/TysPrim.lhs +++ b/ghc/compiler/prelude/TysPrim.lhs @@ -18,12 +18,10 @@ import Name ( mkPrimitiveName ) import PrelMods ( gHC_BUILTINS ) import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn import TyCon ( mkPrimTyCon, mkDataTyCon, NewOrData(..) ) -import Type ( mkTyConTy ) +import Type ( applyTyCon, mkTyVarTys, mkTyConTy ) import TyVar ( GenTyVar(..), alphaTyVars ) -import Type ( applyTyCon, mkTyVarTys ) import Usage ( usageOmega ) import Unique - \end{code} \begin{code} diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 27a16da..6a5285a 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -43,10 +43,12 @@ module TysWiredIn ( mkLiftTy, mkListTy, mkPrimIoTy, + mkStateTy, mkStateTransformerTy, mkTupleTy, nilDataCon, primIoTyCon, + primIoDataCon, realWorldStateTy, return2GMPsTyCon, returnIntAndGMPTyCon, @@ -91,16 +93,16 @@ import PrelMods import TysPrim -- others: -import SpecEnv ( SpecEnv(..) ) +import SpecEnv ( SYN_IE(SpecEnv) ) import Kind ( mkBoxedTypeKind, mkArrowKind ) -import Name ( mkWiredInName ) +import Name ( mkWiredInName, ExportFlag(..) ) import SrcLoc ( mkBuiltinSrcLoc ) import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon, NewOrData(..), TyCon ) import Type ( mkTyConTy, applyTyCon, mkSigmaTy, mkFunTys, maybeAppTyCon, - GenType(..), ThetaType(..), TauType(..) ) + GenType(..), SYN_IE(ThetaType), SYN_IE(TauType) ) import TyVar ( tyVarKind, alphaTyVar, betaTyVar ) import Unique import Util ( assoc, panic ) @@ -122,7 +124,7 @@ pcDataTyCon = pc_tycon DataType pcNewTyCon = pc_tycon NewType pc_tycon new_or_data key mod str tyvars cons - = mkDataTyCon (mkWiredInName key (OrigName mod str)) tycon_kind + = mkDataTyCon (mkWiredInName key (OrigName mod str) ExportAll) tycon_kind tyvars [{-no context-}] cons [{-no derivings-}] new_or_data where @@ -131,7 +133,7 @@ pc_tycon new_or_data key mod str tyvars cons pcDataCon :: Unique{-DataConKey-} -> Module -> FAST_STRING -> [TyVar] -> ThetaType -> [TauType] -> TyCon -> SpecEnv -> Id pcDataCon key mod str tyvars context arg_tys tycon specenv - = mkDataCon (mkWiredInName key (OrigName mod str)) + = mkDataCon (mkWiredInName key (OrigName mod str) ExportAll) [ NotMarkedStrict | a <- arg_tys ] [ {- no labelled fields -} ] tyvars context arg_tys tycon @@ -453,17 +455,15 @@ stTyCon = pcNewTyCon stTyConKey gHC__ SLIT("ST") alpha_beta_tyvars [stDataCon] %* * %************************************************************************ -@PrimIO@ and @IO@ really are just plain synonyms. - \begin{code} mkPrimIoTy a = applyTyCon primIoTyCon [a] primIoTyCon = pcNewTyCon primIoTyConKey gHC__ SLIT("PrimIO") alpha_tyvar [primIoDataCon] + +primIoDataCon = pcDataCon primIoDataConKey gHC__ SLIT("PrimIO") + alpha_tyvar [] [ty] primIoTyCon nullSpecEnv where ty = mkFunTys [mkStateTy realWorldTy] (mkTupleTy 2 [alphaTy, mkStateTy realWorldTy]) - - primIoDataCon = pcDataCon primIoDataConKey gHC__ SLIT("PrimIO") - alpha_tyvar [] [ty] primIoTyCon nullSpecEnv \end{code} %************************************************************************ @@ -530,12 +530,12 @@ trueDataCon = pcDataCon trueDataConKey pRELUDE SLIT("True") [] [] [] boolTyCo %************************************************************************ Special syntax, deeply wired in, but otherwise an ordinary algebraic -data type: +data types: \begin{verbatim} -data List a = Nil | a : (List a) -ToDo: data [] a = [] | a : (List a) -ToDo: data () = () - data (,,) a b c = (,,) a b c +data [] a = [] | a : (List a) +data () = () +data (,) a b = (,,) a b +... \end{verbatim} \begin{code} diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index ad36f04..635e245 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -16,9 +16,10 @@ module CostCentre ( overheadCostCentre, dontCareCostCentre, mkUserCC, mkAutoCC, mkDictCC, mkAllCafsCC, mkAllDictsCC, - cafifyCC, unCafifyCC, dupifyCC, + cafifyCC, dupifyCC, isCafCC, isDictCC, isDupdCC, - setToAbleCostCentre, + isSccCountCostCentre, + sccAbleCostCentre, ccFromThisModule, ccMentionsId, @@ -29,9 +30,8 @@ module CostCentre ( IMP_Ubiq(){-uitous-} -import Id ( externallyVisibleId, GenId, Id(..) ) +import Id ( externallyVisibleId, GenId, SYN_IE(Id) ) import CStrings ( identToC, stringToC ) -import Maybes ( Maybe(..) ) import Name ( showRdr, getOccName, RdrName ) import Pretty ( ppShow, prettyToUn ) import PprStyle ( PprStyle(..) ) @@ -180,10 +180,10 @@ mkAllCafsCC m g = AllCafsCC m g mkAllDictsCC m g is_dupd = AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC) -cafifyCC, unCafifyCC, dupifyCC :: CostCentre -> CostCentre +cafifyCC, dupifyCC :: CostCentre -> CostCentre -cafifyCC cc@(AllDictsCC _ _ _) = cc -- ???????? ToDo -cafifyCC cc@(PreludeDictsCC _) = cc -- ditto +cafifyCC cc@(AllDictsCC _ _ _) = cc -- ToDo ??? +cafifyCC cc@(PreludeDictsCC _) = cc -- ditto cafifyCC (NormalCC kind m g is_dupd is_caf) = ASSERT(not_a_calf_already is_caf) NormalCC kind m g is_dupd IsCafCC @@ -192,14 +192,6 @@ cafifyCC (NormalCC kind m g is_dupd is_caf) not_a_calf_already _ = True cafifyCC cc = panic ("cafifyCC"++(showCostCentre PprDebug False cc)) --- WDP 95/07: pretty dodgy -unCafifyCC (NormalCC kind m g is_dupd IsCafCC) = NormalCC kind m g is_dupd IsNotCafCC -unCafifyCC (AllCafsCC _ _) = CurrentCC -unCafifyCC PreludeCafsCC = CurrentCC -unCafifyCC (AllDictsCC _ _ _) = CurrentCC -unCafifyCC (PreludeDictsCC _) = CurrentCC -unCafifyCC other_cc = other_cc - dupifyCC (AllDictsCC m g _) = AllDictsCC m g ADupdCC dupifyCC (PreludeDictsCC _) = PreludeDictsCC ADupdCC dupifyCC (NormalCC kind m g is_dupd is_caf) @@ -223,20 +215,33 @@ isDupdCC (PreludeDictsCC ADupdCC) = True isDupdCC (NormalCC _ _ _ ADupdCC _) = True isDupdCC _ = False -setToAbleCostCentre :: CostCentre -> Bool - -- Is this a cost-centre to which CCC might reasonably - -- be set? setToAbleCostCentre is allowed to panic on - -- "nonsense" cases, too... +isSccCountCostCentre :: CostCentre -> Bool + -- Is this a cost-centre which records scc counts -#ifdef DEBUG -setToAbleCostCentre NoCostCentre = panic "setToAbleCC:NoCostCentre" -setToAbleCostCentre SubsumedCosts = panic "setToAbleCC:SubsumedCosts" -setToAbleCostCentre CurrentCC = panic "setToAbleCC:CurrentCC" -setToAbleCostCentre DontCareCC = panic "setToAbleCC:DontCareCC" +#if DEBUG +isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre" +isSccCountCostCentre SubsumedCosts = panic "isSccCount:SubsumedCosts" +isSccCountCostCentre CurrentCC = panic "isSccCount:CurrentCC" +isSccCountCostCentre DontCareCC = panic "isSccCount:DontCareCC" #endif - -setToAbleCostCentre OverheadCC = False -- see comments in type defn -setToAbleCostCentre other = not (isCafCC other || isDictCC other) +isSccCountCostCentre OverheadCC = False +isSccCountCostCentre cc | isCafCC cc = False + | isDupdCC cc = False + | isDictCC cc = True + | otherwise = True + +sccAbleCostCentre :: CostCentre -> Bool + -- Is this a cost-centre which can be sccd ? + +#if DEBUG +sccAbleCostCentre NoCostCentre = panic "sccAbleCC:NoCostCentre" +sccAbleCostCentre SubsumedCosts = panic "sccAbleCC:SubsumedCosts" +sccAbleCostCentre CurrentCC = panic "sccAbleCC:CurrentCC" +sccAbleCostCentre DontCareCC = panic "sccAbleCC:DontCareCC" +#endif +sccAbleCostCentre OverheadCC = False +sccAbleCostCentre cc | isCafCC cc = False + | otherwise = True ccFromThisModule :: CostCentre -> FAST_STRING{-module name-} -> Bool @@ -270,8 +275,8 @@ cmpCostCentre DontCareCC DontCareCC = EQ_ cmpCostCentre (NormalCC k1 m1 _ _ c1) (NormalCC k2 m2 _ _ c2) -- first key is module name, then we use "kinds" (which include - -- names) - = _CMP_STRING_ m1 m2 `thenCmp` cmp_kind k1 k2 + -- names) and finally the caf flag + = _CMP_STRING_ m1 m2 `thenCmp` cmp_kind k1 k2 `thenCmp` cmp_caf c1 c2 cmpCostCentre other_1 other_2 = let @@ -307,6 +312,11 @@ cmp_kind other_1 other_2 tag_CcKind (UserCC _) = (ILIT(1) :: FAST_INT) tag_CcKind (AutoCC _) = ILIT(2) tag_CcKind (DictCC _) = ILIT(3) + +cmp_caf IsNotCafCC IsCafCC = LT_ +cmp_caf IsNotCafCC IsNotCafCC = EQ_ +cmp_caf IsCafCC IsCafCC = EQ_ +cmp_caf IsCafCC IsNotCafCC = GT_ \end{code} \begin{code} @@ -344,8 +354,7 @@ uppCostCentre sty print_as_string cc = let prefix_CC = uppPStr SLIT("CC_") - basic_thing -- (basic_thing, suffix_CAF) - = do_cc cc + basic_thing = do_cc cc basic_thing_string = if friendly_sty then basic_thing else stringToC basic_thing @@ -361,9 +370,6 @@ uppCostCentre sty print_as_string cc where friendly_sty = friendly_style sty - add_module_name_maybe m str - = if print_as_string then str else (str ++ ('.' : m)) - ---------------- do_cc OverheadCC = "OVERHEAD" do_cc DontCareCC = "DONT_CARE" @@ -384,14 +390,16 @@ uppCostCentre sty print_as_string cc do_cc (NormalCC kind mod_name grp_name is_dupd is_caf) = let - basic_kind = do_kind kind - is_a_calf = do_calved is_caf + basic_kind = do_caf is_caf ++ do_kind kind in if friendly_sty then - do_dupd is_dupd (basic_kind ++ ('/': _UNPK_ mod_name) ++ ('/': _UNPK_ grp_name) ++ is_a_calf) + do_dupd is_dupd (basic_kind ++ ('/': _UNPK_ mod_name) ++ ('/': _UNPK_ grp_name)) else basic_kind where + do_caf IsCafCC = "CAF:" + do_caf _ = "" + do_kind (UserCC name) = _UNPK_ name do_kind (AutoCC id) = do_id id ++ (if friendly_sty then "/AUTO" else "") do_kind (DictCC id) = do_id id ++ (if friendly_sty then "/DICT" else "") @@ -402,9 +410,6 @@ uppCostCentre sty print_as_string cc then showRdr sty (getOccName id) -- use occ name else showId sty id -- we really do - do_calved IsCafCC = "/CAF" - do_calved _ = "" - --------------- do_dupd ADupdCC str = if friendly_sty then str ++ "/DUPD" else str do_dupd _ str = str @@ -419,7 +424,7 @@ friendly_style sty -- i.e., probably for human consumption Printing unfoldings is sufficiently weird that we do it separately. This should only apply to CostCentres that can be ``set to'' (cf -@setToAbleCostCentre@). That excludes CAFs and +@sccAbleCostCentre@). That excludes CAFs and `overhead'---which are added at the very end---but includes dictionaries. Dict \tr{_scc_}s may cross module boundaries to show ``scope'' info; even if we won't ultimately do a \tr{SET_CCC} from it. @@ -430,7 +435,7 @@ upp_cc_uf (AllDictsCC m g d) = uppCat [uppPStr SLIT("_ALL_DICTS_CC_"), uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)), upp_dupd d] upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf) - = ASSERT(isDictCC cc || setToAbleCostCentre cc) + = ASSERT(sccAbleCostCentre cc) uppCat [pp_kind cc_kind, uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)), upp_dupd is_dupd, pp_caf is_caf] where diff --git a/ghc/compiler/profiling/SCCauto.lhs b/ghc/compiler/profiling/SCCauto.lhs deleted file mode 100644 index 331c371..0000000 --- a/ghc/compiler/profiling/SCCauto.lhs +++ /dev/null @@ -1,83 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 -% -\section[SCCauto]{Automated SCC annotations} - -Automatic insertion of \tr{_scc_} annotations for top-level bindings. - -Automatic insertion of \tr{_scc_} annotations on CAFs is better left -until STG land. We do DICT annotations there, too, but maybe that -will turn out to be a bummer... (WDP 94/06) - -This is a Core-to-Core pass (usually run {\em last}). - -\begin{code} -#include "HsVersions.h" - -module SCCauto ( addAutoCostCentres ) where - -IMP_Ubiq(){-uitous-} - -import CmdLineOpts ( opt_AutoSccsOnAllToplevs, - opt_AutoSccsOnExportedToplevs, - opt_SccGroup - ) -import CoreSyn -import CostCentre ( mkAutoCC, IsCafCC(..) ) -import Id ( isTopLevId, GenId{-instances-} ) -import Name ( isExported ) -\end{code} - -\begin{code} -addAutoCostCentres - :: FAST_STRING -- module name - -> [CoreBinding] -- input - -> [CoreBinding] -- output - -addAutoCostCentres mod_name binds - = if not doing_something then - binds -- now *that* was quick... - else - map scc_top_bind binds - where - doing_something = auto_all_switch_on || auto_exported_switch_on - - auto_all_switch_on = opt_AutoSccsOnAllToplevs -- only use! - auto_exported_switch_on = opt_AutoSccsOnExportedToplevs -- only use! - - grp_name - = case opt_SccGroup of - Just xx -> _PK_ xx - Nothing -> mod_name -- default: module name - - ----------------------------- - scc_top_bind (NonRec binder rhs) - = NonRec binder (scc_auto binder rhs) - - scc_top_bind (Rec pairs) - = Rec (map scc_pair pairs) - where - scc_pair (binder, rhs) = (binder, scc_auto binder rhs) - - ----------------------------- - -- Automatic scc annotation for user-defined top-level Ids - - scc_auto binder rhs - = if isTopLevId binder - && (auto_all_switch_on || isExported binder) - then scc_rhs rhs - else rhs - where - -- park auto SCC inside lambdas; don't put one there - -- if there already is one. - - scc_rhs rhs - = let - (usevars, tyvars, vars, body) = collectBinders rhs - in - case body of - SCC _ _ -> rhs -- leave it - Con _ _ -> rhs - _ -> mkUseLam usevars (mkLam tyvars vars - (SCC (mkAutoCC binder mod_name grp_name IsNotCafCC) body)) -\end{code} diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 7a61c55..89c4062 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -32,11 +32,12 @@ IMP_Ubiq(){-uitous-} import StgSyn import CmdLineOpts ( opt_AutoSccsOnIndividualCafs, - opt_CompilingPrelude + opt_CompilingGhcInternals ) import CostCentre -- lots of things import Id ( idType, mkSysLocal, emptyIdSet ) import Maybes ( maybeToBool ) +import PprStyle -- ToDo: rm import SrcLoc ( mkUnknownSrcLoc ) import Type ( splitSigmaTy, getFunTy_maybe ) import UniqSupply ( getUnique, splitUniqSupply ) @@ -72,7 +73,7 @@ stgMassageForProfiling mod_name grp_name us stg_binds ((fixed_ccs ++ local_ccs_no_dups, extern_ccs_no_dups), stg_binds2) where do_auto_sccs_on_cafs = opt_AutoSccsOnIndividualCafs -- only use! - doing_prelude = opt_CompilingPrelude + doing_prelude = opt_CompilingGhcInternals all_cafs_cc = if doing_prelude then preludeCafsCostCentre @@ -81,7 +82,7 @@ stgMassageForProfiling mod_name grp_name us stg_binds ---------- do_top_binding :: StgBinding -> MassageM StgBinding - do_top_binding (StgNonRec b rhs) + do_top_binding (StgNonRec b rhs) = do_top_rhs b rhs `thenMM` \ rhs' -> returnMM (StgNonRec b rhs') @@ -89,71 +90,75 @@ stgMassageForProfiling mod_name grp_name us stg_binds = mapMM do_pair pairs `thenMM` \ pairs2 -> returnMM (StgRec pairs2) where - do_pair (b, rhs) + do_pair (b, rhs) = do_top_rhs b rhs `thenMM` \ rhs2 -> returnMM (b, rhs2) ---------- do_top_rhs :: Id -> StgRhs -> MassageM StgRhs - do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc (StgCon con args lvs))) - -- top-level _scc_ around nothing but static data; toss it -- it's pointless + do_top_rhs binder (StgRhsClosure _ bi fv u [] (StgSCC ty cc (StgCon con args lvs))) + | not (isSccCountCostCentre cc) + -- Trivial _scc_ around nothing but static data + -- Eliminate _scc_ ... and turn into StgRhsCon = returnMM (StgRhsCon dontCareCostCentre con args) - do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc expr)) - -- Top level CAF with explicit scc expression. Attach CAF - -- cost centre to StgRhsClosure and collect. - = let - calved_cc = cafifyCC cc - in - collectCC calved_cc `thenMM_` - set_prevailing_cc calved_cc ( - do_expr expr - ) `thenMM` \ expr' -> - returnMM (StgRhsClosure calved_cc bi fv u [] expr') - - do_top_rhs binder (StgRhsClosure cc bi fv u [] body) - | noCostCentreAttached cc || currentOrSubsumedCosts cc - -- Top level CAF without a cost centre attached: Collect - -- cost centre with binder name, if collecting CAFs. + do_top_rhs binder (StgRhsClosure no_cc bi fv u [] (StgSCC ty cc expr)) + | (noCostCentreAttached no_cc || currentOrSubsumedCosts no_cc) + && not (isSccCountCostCentre cc) + -- Top level CAF without a cost centre attached + -- Attach and collect cc of trivial _scc_ in body + = collectCC cc `thenMM_` + set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' -> + returnMM (StgRhsClosure cc bi fv u [] expr') + + do_top_rhs binder (StgRhsClosure no_cc bi fv u [] body) + | noCostCentreAttached no_cc || currentOrSubsumedCosts no_cc + -- Top level CAF without a cost centre attached + -- Attach CAF cc (collect if individual CAF ccs) = let - (did_something, cc2) + (collect, caf_cc) = if do_auto_sccs_on_cafs then (True, mkAutoCC binder mod_name grp_name IsCafCC) else (False, all_cafs_cc) in - (if did_something - then collectCC cc2 - else nopMM) `thenMM_` - set_prevailing_cc cc2 ( - do_expr body - ) `thenMM` \body2 -> - returnMM (StgRhsClosure cc2 bi fv u [] body2) - - do_top_rhs binder (StgRhsClosure _ bi fv u args body@(StgSCC ty cc expr)) - -- We blindly use the cc off the _scc_ - = set_prevailing_cc cc ( - do_expr body - ) `thenMM` \ body2 -> - returnMM (StgRhsClosure cc bi fv u args body2) + (if collect then collectCC caf_cc else nopMM) `thenMM_` + set_prevailing_cc caf_cc (do_expr body) `thenMM` \ body' -> + returnMM (StgRhsClosure caf_cc bi fv u [] body') + + do_top_rhs binder (StgRhsClosure cc bi fv u [] body) + -- Top level CAF with cost centre attached + -- Should this be a CAF cc ??? Does this ever occur ??? + = trace ("SCCfinal: CAF with cc: " ++ showCostCentre PprDebug False cc) $ + collectCC cc `thenMM_` + set_prevailing_cc cc (do_expr body) `thenMM` \ body' -> + returnMM (StgRhsClosure cc bi fv u [] body') + + do_top_rhs binder (StgRhsClosure _ bi fv u args (StgSCC ty cc expr)) + | not (isSccCountCostCentre cc) + -- Top level function with trivial _scc_ in body + -- Attach and collect cc of trivial _scc_ + = collectCC cc `thenMM_` + set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' -> + returnMM (StgRhsClosure cc bi fv u args expr') do_top_rhs binder (StgRhsClosure cc bi fv u args body) + -- Top level function, probably subsumed = let - cc2 = if noCostCentreAttached cc - then subsumedCosts -- it's not a thunk; it is top-level & arity > 0 - else cc - in - set_prevailing_cc cc2 ( - do_expr body - ) `thenMM` \ body' -> - returnMM (StgRhsClosure cc2 bi fv u args body') + (cc_closure, cc_body) + = if noCostCentreAttached cc + then (subsumedCosts, useCurrentCostCentre) + else (cc, cc) + in + set_prevailing_cc cc_body (do_expr body) `thenMM` \ body' -> + returnMM (StgRhsClosure cc_closure bi fv u args body') do_top_rhs binder (StgRhsCon cc con args) - = returnMM (StgRhsCon dontCareCostCentre con args) -- Top-level (static) data is not counted in heap -- profiles; nor do we set CCC from it; so we -- just slam in dontCareCostCentre + = returnMM (StgRhsCon dontCareCostCentre con args) ------ do_expr :: StgExpr -> MassageM StgExpr @@ -168,10 +173,8 @@ stgMassageForProfiling mod_name grp_name us stg_binds = boxHigherOrderArgs (StgPrim op) args lvs do_expr (StgSCC ty cc expr) -- Ha, we found a cost centre! - = collectCC cc `thenMM_` - set_prevailing_cc cc ( - do_expr expr - ) `thenMM` \ expr' -> + = collectCC cc `thenMM_` + set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' -> returnMM (StgSCC ty cc expr') do_expr (StgCase expr fv1 fv2 uniq alts) @@ -179,7 +182,7 @@ stgMassageForProfiling mod_name grp_name us stg_binds do_alts alts `thenMM` \ alts' -> returnMM (StgCase expr' fv1 fv2 uniq alts') where - do_alts (StgAlgAlts ty alts def) + do_alts (StgAlgAlts ty alts def) = mapMM do_alt alts `thenMM` \ alts' -> do_deflt def `thenMM` \ def' -> returnMM (StgAlgAlts ty alts' def') @@ -188,7 +191,7 @@ stgMassageForProfiling mod_name grp_name us stg_binds = do_expr e `thenMM` \ e' -> returnMM (id, bs, use_mask, e') - do_alts (StgPrimAlts ty alts def) + do_alts (StgPrimAlts ty alts def) = mapMM do_alt alts `thenMM` \ alts' -> do_deflt def `thenMM` \ def' -> returnMM (StgPrimAlts ty alts' def') @@ -198,26 +201,24 @@ stgMassageForProfiling mod_name grp_name us stg_binds returnMM (l,e') do_deflt StgNoDefault = returnMM StgNoDefault - do_deflt (StgBindDefault b is_used e) + do_deflt (StgBindDefault b is_used e) = do_expr e `thenMM` \ e' -> returnMM (StgBindDefault b is_used e') do_expr (StgLet b e) - = set_prevailing_cc_maybe useCurrentCostCentre ( - do_binding b `thenMM` \ b' -> - do_expr e `thenMM` \ e' -> - returnMM (StgLet b' e') ) + = do_binding b `thenMM` \ b' -> + do_expr e `thenMM` \ e' -> + returnMM (StgLet b' e') do_expr (StgLetNoEscape lvs1 lvs2 rhs body) - = set_prevailing_cc_maybe useCurrentCostCentre ( - do_binding rhs `thenMM` \ rhs' -> - do_expr body `thenMM` \ body' -> - returnMM (StgLetNoEscape lvs1 lvs2 rhs' body') ) + = do_binding rhs `thenMM` \ rhs' -> + do_expr body `thenMM` \ body' -> + returnMM (StgLetNoEscape lvs1 lvs2 rhs' body') ---------- do_binding :: StgBinding -> MassageM StgBinding - do_binding (StgNonRec b rhs) + do_binding (StgNonRec b rhs) = do_rhs rhs `thenMM` \ rhs' -> returnMM (StgNonRec b rhs') @@ -231,33 +232,30 @@ stgMassageForProfiling mod_name grp_name us stg_binds do_rhs :: StgRhs -> MassageM StgRhs -- We play much the same game as we did in do_top_rhs above; - -- but we don't have to worry about cafifying, etc. - -- (ToDo: consolidate??) + -- but we don't have to worry about cafs etc. -{- Patrick says NO: it will mess up our counts (WDP 95/07) - do_rhs (StgRhsClosure _ bi fv u [] (StgSCC _ cc (StgCon con args lvs))) + do_rhs (StgRhsClosure _ bi fv u [] (StgSCC ty cc (StgCon con args lvs))) + | not (isSccCountCostCentre cc) = collectCC cc `thenMM_` returnMM (StgRhsCon cc con args) --} - do_rhs (StgRhsClosure _ bi fv u args body@(StgSCC _ cc _)) - = set_prevailing_cc cc ( - do_expr body - ) `thenMM` \ body' -> - returnMM (StgRhsClosure cc bi fv u args body') + do_rhs (StgRhsClosure _ bi fv u args (StgSCC ty cc expr)) + | not (isSccCountCostCentre cc) + = collectCC cc `thenMM_` + set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' -> + returnMM (StgRhsClosure cc bi fv u args expr') do_rhs (StgRhsClosure cc bi fv u args body) - = use_prevailing_cc_maybe cc `thenMM` \ cc2 -> - set_prevailing_cc cc2 ( - do_expr body - ) `thenMM` \ body' -> - returnMM (StgRhsClosure cc2 bi fv u args body') + = set_prevailing_cc_maybe cc $ \ cc' -> + set_lambda_cc (do_expr body) `thenMM` \ body' -> + returnMM (StgRhsClosure cc' bi fv u args body') do_rhs (StgRhsCon cc con args) - = use_prevailing_cc_maybe cc `thenMM` \ cc2 -> - returnMM (StgRhsCon cc2 con args) - -- ToDo: Box args (if lex) Pass back let binding??? - -- Nope: maybe later? WDP 94/06 + = set_prevailing_cc_maybe cc $ \ cc' -> + returnMM (StgRhsCon cc' con args) + + -- ToDo: Box args and sort out any let bindings ??? + -- Nope: maybe later? WDP 94/06 \end{code} %************************************************************************ @@ -269,53 +267,58 @@ stgMassageForProfiling mod_name grp_name us stg_binds \begin{code} boxHigherOrderArgs :: ([StgArg] -> StgLiveVars -> StgExpr) - -- An application lacking its arguments and live-var info - -> [StgArg] -- arguments which we might box + -- An application lacking its arguments and live-var info + -> [StgArg] -- arguments which we might box -> StgLiveVars -- live var info, which we do *not* try -- to maintain/update (setStgVarInfo will -- do that) -> MassageM StgExpr boxHigherOrderArgs almost_expr args live_vars - = mapAccumMM do_arg [] args `thenMM` \ (let_bindings, new_args) -> - get_prevailing_cc `thenMM` \ cc -> - returnMM (foldr (mk_stg_let cc) (almost_expr new_args live_vars) let_bindings) + = returnMM (almost_expr args live_vars) + +{- No boxing for now ... should be moved to desugarer and preserved ... + +boxHigherOrderArgs almost_expr args live_vars + = get_prevailing_cc `thenMM` \ cc -> + if (isCafCC cc || isDictCC cc) then + -- no boxing required inside CAF/DICT cc + -- since CAF/DICT functions are subsumed anyway + returnMM (almost_expr args live_vars) + else + mapAccumMM do_arg [] args `thenMM` \ (let_bindings, new_args) -> + returnMM (foldr (mk_stg_let cc) (almost_expr new_args live_vars) let_bindings) where --------------- - do_arg bindings atom@(StgLitArg _) = returnMM (bindings, atom) + do_arg bindings atom@(StgLitAtom _) = returnMM (bindings, atom) - do_arg bindings atom@(StgVarArg old_var) + do_arg bindings atom@(StgVarAtom old_var) = let - var_type = idType old_var + var_type = getIdUniType old_var in - if not (is_fun_type var_type) then - returnMM (bindings, atom) -- easy - else - -- make a trivial let-binding for the higher-order guy + if toplevelishId old_var && isFunType (getTauType var_type) + then + -- make a trivial let-binding for the top-level function getUniqueMM `thenMM` \ uniq -> let new_var = mkSysLocal SLIT("ho") uniq var_type mkUnknownSrcLoc in - returnMM ( (new_var, old_var) : bindings, StgVarArg new_var ) - where - is_fun_type ty - = case (splitSigmaTy ty) of { (_, _, tau_ty) -> - maybeToBool (getFunTy_maybe tau_ty) } + returnMM ( (new_var, old_var) : bindings, StgVarAtom new_var ) + else + returnMM (bindings, atom) --------------- mk_stg_let :: CostCentre -> (Id, Id) -> StgExpr -> StgExpr mk_stg_let cc (new_var, old_var) body = let - rhs_body = StgApp (StgVarArg old_var) [{-no args-}] bOGUS_LVs - - rhs = StgRhsClosure cc - stgArgOcc -- safe... - [{-junk-}] Updatable [{-no args-}] rhs_body - in - StgLet (StgNonRec new_var rhs) body + rhs_body = StgApp (StgVarAtom old_var) [{-args-}] bOGUS_LVs + rhs_closure = StgRhsClosure cc stgArgOcc [{-fvs-}] ReEntrant [{-args-}] rhs_body + in + StgLet (StgNonRec new_var rhs_closure) body where - bOGUS_LVs = emptyIdSet -- easier to print than: panic "mk_stg_let: LVs" + bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs" +-} \end{code} %************************************************************************ @@ -341,7 +344,7 @@ initMM :: FAST_STRING -- module name, which we may consult -> MassageM a -> (CollectedCCs, a) -initMM mod_name init_us m = m mod_name subsumedCosts{-top-level-} init_us ([],[]) +initMM mod_name init_us m = m mod_name noCostCentre init_us ([],[]) thenMM :: MassageM a -> (a -> MassageM b) -> MassageM b thenMM_ :: MassageM a -> (MassageM b) -> MassageM b @@ -383,47 +386,38 @@ getUniqueMM mod scope_cc us ccs = (ccs, getUnique us) \end{code} \begin{code} -set_prevailing_cc, set_prevailing_cc_maybe - :: CostCentre -> MassageM a -> MassageM a - +set_prevailing_cc :: CostCentre -> MassageM a -> MassageM a set_prevailing_cc cc_to_set_to action mod scope_cc us ccs + -- set unconditionally = action mod cc_to_set_to us ccs - -- set unconditionally -set_prevailing_cc_maybe cc_to_set_to action mod scope_cc us ccs +set_prevailing_cc_maybe :: CostCentre -> (CostCentre -> MassageM a) -> MassageM a +set_prevailing_cc_maybe cc_to_try action mod scope_cc us ccs + -- set only if a real cost centre = let - -- used when switching from top-level to nested - -- scope; if we were chugging along as "subsumed", - -- we change to the new thing; otherwise we - -- keep what we had. + cc_to_use + = if noCostCentreAttached cc_to_try || currentOrSubsumedCosts cc_to_try + then scope_cc -- carry on as before + else cc_to_try -- use new cost centre + in + action cc_to_use mod cc_to_use us ccs +set_lambda_cc :: MassageM a -> MassageM a +set_lambda_cc action mod scope_cc us ccs + -- used when moving inside a lambda; + -- if we were chugging along as "caf/dict" we change to "ccc" + = let cc_to_use - = if (costsAreSubsumed scope_cc) - then cc_to_set_to - else scope_cc -- carry on as before + = if isCafCC scope_cc || isDictCC scope_cc + then useCurrentCostCentre + else scope_cc in action mod cc_to_use us ccs + get_prevailing_cc :: MassageM CostCentre get_prevailing_cc mod scope_cc us ccs = (ccs, scope_cc) -use_prevailing_cc_maybe :: CostCentre -> MassageM CostCentre - -use_prevailing_cc_maybe cc_to_try mod scope_cc us ccs - = let - cc_to_use - = if not (noCostCentreAttached cc_to_try - || currentOrSubsumedCosts cc_to_try) then - cc_to_try - else - uncalved_scope_cc - -- carry on as before, but be sure it - -- isn't marked as CAFish (we're - -- crossing a lambda...) - in - (ccs, cc_to_use) - where - uncalved_scope_cc = unCafifyCC scope_cc \end{code} \begin{code} diff --git a/ghc/compiler/reader/PrefixSyn.lhs b/ghc/compiler/reader/PrefixSyn.lhs index 8cd388b..cd4d1b8 100644 --- a/ghc/compiler/reader/PrefixSyn.lhs +++ b/ghc/compiler/reader/PrefixSyn.lhs @@ -12,17 +12,18 @@ order that follows the \tr{Prefix_Form} document. module PrefixSyn ( RdrBinding(..), - RdrId(..), + SYN_IE(RdrId), RdrMatch(..), - SigConverter(..), - SrcFile(..), - SrcFun(..), - SrcLine(..), + SYN_IE(SigConverter), + SYN_IE(SrcFile), + SYN_IE(SrcFun), + SYN_IE(SrcLine), readInteger ) where IMP_Ubiq() +IMPORT_1_3(Char(isDigit)) import HsSyn import RdrHsSyn diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index cb5aa2b..7b44b59 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -10,41 +10,41 @@ they are used somewhat later on in the compiler...) #include "HsVersions.h" module RdrHsSyn ( - RdrNameArithSeqInfo(..), - RdrNameBangType(..), - RdrNameBind(..), - RdrNameClassDecl(..), - RdrNameClassOpSig(..), - RdrNameConDecl(..), - RdrNameContext(..), - RdrNameSpecDataSig(..), - RdrNameDefaultDecl(..), - RdrNameFixityDecl(..), - RdrNameGRHS(..), - RdrNameGRHSsAndBinds(..), - RdrNameHsBinds(..), - RdrNameHsExpr(..), - RdrNameHsModule(..), - RdrNameIE(..), - RdrNameImportDecl(..), - RdrNameInstDecl(..), - RdrNameMatch(..), - RdrNameMonoBinds(..), - RdrNameMonoType(..), - RdrNamePat(..), - RdrNamePolyType(..), - RdrNameQual(..), - RdrNameSig(..), - RdrNameSpecInstSig(..), - RdrNameStmt(..), - RdrNameTyDecl(..), + SYN_IE(RdrNameArithSeqInfo), + SYN_IE(RdrNameBangType), + SYN_IE(RdrNameBind), + SYN_IE(RdrNameClassDecl), + SYN_IE(RdrNameClassOpSig), + SYN_IE(RdrNameConDecl), + SYN_IE(RdrNameContext), + SYN_IE(RdrNameSpecDataSig), + SYN_IE(RdrNameDefaultDecl), + SYN_IE(RdrNameFixityDecl), + SYN_IE(RdrNameGRHS), + SYN_IE(RdrNameGRHSsAndBinds), + SYN_IE(RdrNameHsBinds), + SYN_IE(RdrNameHsExpr), + SYN_IE(RdrNameHsModule), + SYN_IE(RdrNameIE), + SYN_IE(RdrNameImportDecl), + SYN_IE(RdrNameInstDecl), + SYN_IE(RdrNameMatch), + SYN_IE(RdrNameMonoBinds), + SYN_IE(RdrNameMonoType), + SYN_IE(RdrNamePat), + SYN_IE(RdrNamePolyType), + SYN_IE(RdrNameQual), + SYN_IE(RdrNameSig), + SYN_IE(RdrNameSpecInstSig), + SYN_IE(RdrNameStmt), + SYN_IE(RdrNameTyDecl), - RdrNameClassOpPragmas(..), - RdrNameClassPragmas(..), - RdrNameDataPragmas(..), - RdrNameGenPragmas(..), - RdrNameInstancePragmas(..), - RdrNameCoreExpr(..), + SYN_IE(RdrNameClassOpPragmas), + SYN_IE(RdrNameClassPragmas), + SYN_IE(RdrNameDataPragmas), + SYN_IE(RdrNameGenPragmas), + SYN_IE(RdrNameInstancePragmas), + SYN_IE(RdrNameCoreExpr), getRawImportees, getRawExportees diff --git a/ghc/compiler/reader/ReadPrefix.lhs b/ghc/compiler/reader/ReadPrefix.lhs index 9353e87..17f2a49 100644 --- a/ghc/compiler/reader/ReadPrefix.lhs +++ b/ghc/compiler/reader/ReadPrefix.lhs @@ -9,6 +9,7 @@ module ReadPrefix ( rdModule ) where IMP_Ubiq() +IMPORT_1_3(IO(hPutStr, stderr)) import UgenAll -- all Yacc parser gumpff... import PrefixSyn -- and various syntaxen. @@ -77,13 +78,21 @@ cvFlag 1 = True %************************************************************************ \begin{code} +#if __GLASGOW_HASKELL__ >= 200 +# define PACK_STR packCString +# define CCALL_THEN `GHCbase.ccallThen` +#else +# define PACK_STR _packCString +# define CCALL_THEN `thenPrimIO` +#endif + rdModule :: IO (Module, -- this module's name RdrNameHsModule) -- the main goods rdModule - = _ccall_ hspmain `thenPrimIO` \ pt -> -- call the Yacc parser! + = _ccall_ hspmain CCALL_THEN \ pt -> -- call the Yacc parser! let - srcfile = _packCString ``input_filename'' -- What A Great Hack! (TM) + srcfile = PACK_STR ``input_filename'' -- What A Great Hack! (TM) in initUgn $ rdU_tree pt `thenUgn` \ (U_hmodule modname himplist hexplist hfixlist @@ -91,12 +100,12 @@ rdModule setSrcFileUgn srcfile $ setSrcModUgn modname $ - mkSrcLocUgn srcline $ \ src_loc -> + mkSrcLocUgn srcline $ \ src_loc -> - wlkMaybe rdEntities hexplist `thenUgn` \ exports -> - wlkList rdImport himplist `thenUgn` \ imports -> - wlkList rdFixOp hfixlist `thenUgn` \ fixities -> - wlkBinding hmodlist `thenUgn` \ binding -> + wlkMaybe rdEntities hexplist `thenUgn` \ exports -> + wlkList rdImport himplist `thenUgn` \ imports -> + wlkList rdFixOp hfixlist `thenUgn` \ fixities -> + wlkBinding hmodlist `thenUgn` \ binding -> case sepDeclsForTopBinds binding of (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) -> @@ -471,7 +480,11 @@ wlkLiteral ulit where as_char s = _HEAD_ s as_integer s = readInteger (_UNPK_ s) +#if __GLASGOW_HASKELL__ >= 200 + as_rational s = GHCbase.readRational__ (_UNPK_ s) -- non-std +#else as_rational s = _readRational (_UNPK_ s) -- non-std +#endif as_string s = s \end{code} @@ -565,7 +578,7 @@ wlkBinding binding ctxt_inst_ty = HsPreForAllTy ctxt inst_ty in returnUgn (RdrInstDecl - (InstDecl clas ctxt_inst_ty binds True modname uprags noInstancePragmas src_loc)) + (InstDecl clas ctxt_inst_ty binds True{-from here-} modname uprags noInstancePragmas src_loc)) -- "default" declaration U_dbind dbindts srcline -> diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index bc4137d..935c227 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -12,7 +12,7 @@ import RdrHsSyn -- oodles of synonyms import HsPragmas ( noGenPragmas ) import Bag ( emptyBag, unitBag, snocBag ) -import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM ) +import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap ) import Name ( ExportFlag(..), mkTupNameStr, preludeQual, RdrName(..){-instance Outputable:ToDo:rm-} ) @@ -54,6 +54,7 @@ parseIface = parseIToks . lexIface DCOLON { ITdcolon } DOTDOT { ITdotdot } EQUAL { ITequal } + FORALL { ITforall } INFIX { ITinfix } INFIXL { ITinfixl } INFIXR { ITinfixr } @@ -228,8 +229,10 @@ class :: { (RdrName, RdrName) } class : gtycon VARID { ($1, Unqual $2) } ctype :: { RdrNamePolyType } -ctype : context DARROW type { HsPreForAllTy $1 $3 } - | type { HsPreForAllTy [] $1 } +ctype : FORALL OBRACK tyvars CBRACK context DARROW type { HsForAllTy (map Unqual $3) $5 $7 } + | FORALL OBRACK tyvars CBRACK type { HsForAllTy (map Unqual $3) [] $5 } + | context DARROW type {{-ToDo:rm-} HsPreForAllTy $1 $3 } + | type {{-ToDo:change-} HsPreForAllTy [] $1 } type :: { RdrNameMonoType } type : btype { $1 } @@ -313,13 +316,9 @@ btyconapp :: { (RdrName, [RdrNameBangType]) } btyconapp : gtycon { ($1, []) } | btyconapp batype { case $1 of (tc,tys) -> (tc, tys ++ [$2]) } -bbtype :: { RdrNameBangType } -bbtype : btype { Unbanged (HsPreForAllTy [] $1) } - | BANG atype { Banged (HsPreForAllTy [] $2) } - batype :: { RdrNameBangType } -batype : atype { Unbanged (HsPreForAllTy [] $1) } - | BANG atype { Banged (HsPreForAllTy [] $2) } +batype : atype { Unbanged (HsForAllTy [{-ToDo:tvs-}] [] $1) } + | BANG atype { Banged (HsForAllTy [{-ToDo:tvs-}] [] $2) } batypes :: { [RdrNameBangType] } batypes : batype { [$1] } @@ -330,8 +329,8 @@ fields : field { [$1] } | fields COMMA field { $1 ++ [$3] } field :: { ([RdrName], RdrNameBangType) } -field : var DCOLON type { ([$1], Unbanged (HsPreForAllTy [] $3)) } - | var DCOLON BANG atype { ([$1], Banged (HsPreForAllTy [] $4)) } +field : var DCOLON type { ([$1], Unbanged (HsForAllTy [{-ToDo:tvs-}] [] $3)) } + | var DCOLON BANG atype { ([$1], Banged (HsForAllTy [{-ToDo:tvs-}] [] $4)) } constr1 :: { (RdrName, RdrNameMonoType) } constr1 : gtycon atype { ($1, $2) } @@ -347,11 +346,14 @@ qname : QVARID { $1 } | QCONSYM { $1 } name :: { FAST_STRING } -name : VARID { $1 } - | CONID { $1 } - | VARSYM { $1 } - | BANG { SLIT("!"){-sigh, double-sigh-} } - | CONSYM { $1 } +name : VARID { $1 } + | CONID { $1 } + | VARSYM { $1 } + | BANG { SLIT("!"){-sigh, double-sigh-} } + | CONSYM { $1 } + | OBRACK CBRACK { SLIT("[]") } + | OPAREN CPAREN { SLIT("()") } + | OPAREN commas CPAREN { mkTupNameStr $2 } instances_part :: { Bag RdrIfaceInst } instances_part : INSTANCES_PART instdecls { $2 } @@ -362,13 +364,15 @@ instdecls : instd { unitBag $1 } | instdecls instd { $1 `snocBag` $2 } instd :: { RdrIfaceInst } -instd : INSTANCE context DARROW gtycon restrict_inst SEMI { mk_inst $2 $4 $5 } - | INSTANCE gtycon general_inst SEMI { mk_inst [] $2 $3 } +instd : INSTANCE FORALL OBRACK tyvars CBRACK context DARROW gtycon restrict_inst SEMI { mk_inst (Just (map Unqual $4)) $6 $8 $9 } + | INSTANCE FORALL OBRACK tyvars CBRACK gtycon general_inst SEMI { mk_inst (Just (map Unqual $4)) [] $6 $7 } + | INSTANCE context DARROW gtycon restrict_inst SEMI {{-ToDo:rm-} mk_inst Nothing $2 $4 $5 } + | INSTANCE gtycon general_inst SEMI {{-ToDo:rm-} mk_inst Nothing [] $2 $3 } restrict_inst :: { RdrNameMonoType } restrict_inst : gtycon { MonoTyApp $1 [] } - | OPAREN gtyconvars CPAREN { case $2 of (tc,tvs) -> MonoTyApp tc (map en_mono tvs) } - | OPAREN VARID COMMA tyvar_list CPAREN { MonoTupleTy (map en_mono ($2:$4)) } + | OPAREN gtyconvars CPAREN { case $2 of (tc,tvs) -> MonoTyApp tc (map en_mono (reverse tvs)) } + | OPAREN VARID COMMA tyvars CPAREN { MonoTupleTy (map en_mono ($2:$4)) } | OBRACK VARID CBRACK { MonoListTy (en_mono $2) } | OPAREN VARID RARROW VARID CPAREN { MonoFunTy (en_mono $2) (en_mono $4) } @@ -379,9 +383,9 @@ general_inst : gtycon { MonoTyApp $1 [] } | OBRACK type CBRACK { MonoListTy $2 } | OPAREN btype RARROW type CPAREN { MonoFunTy $2 $4 } -tyvar_list :: { [FAST_STRING] } -tyvar_list : VARID { [$1] } - | tyvar_list COMMA VARID { $1 ++ [$3] +tyvars :: { [FAST_STRING] } +tyvars : VARID { [$1] } + | tyvars COMMA VARID { $1 ++ [$3] -------------------------------------------------------------------------- } diff --git a/ghc/compiler/rename/ParseUtils.lhs b/ghc/compiler/rename/ParseUtils.lhs index e71614f..dea7549 100644 --- a/ghc/compiler/rename/ParseUtils.lhs +++ b/ghc/compiler/rename/ParseUtils.lhs @@ -10,13 +10,16 @@ module ParseUtils where IMP_Ubiq(){-uitous-} +IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper)) +IMPORT_1_3(List(partition)) + import HsSyn -- quite a bit of stuff import RdrHsSyn -- oodles of synonyms import HsPragmas ( noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas ) -import ErrUtils ( Error(..) ) +import ErrUtils ( SYN_IE(Error) ) import FiniteMap ( unitFM, listToFM, lookupFM, plusFM, FiniteMap ) import Maybes ( maybeToBool, MaybeErr(..) ) import Name ( isLexConId, isLexVarId, isLexConSym, @@ -27,7 +30,7 @@ import PprStyle ( PprStyle(..) ) -- ToDo: rm debugging import PrelMods ( pRELUDE ) import Pretty ( ppCat, ppPStr, ppInt, ppShow, ppStr ) import SrcLoc ( mkIfaceSrcLoc ) -import Util ( startsWith, isIn, panic, assertPanic ) +import Util ( startsWith, isIn, panic, assertPanic, pprTrace{-ToDo:rm-} ) \end{code} \begin{code} @@ -96,6 +99,7 @@ data IfaceToken | ITinfixl | ITinfixr | ITinfix + | ITforall | ITbang -- magic symbols | ITvbar | ITdcolon @@ -205,15 +209,22 @@ mk_class ctxt (qclas@(Qual mod clas), tyvar) ops_and_sigs where opify (Sig f ty _ loc) = ClassOpSig f ty noClassOpPragmas loc -mk_inst :: RdrNameContext +mk_inst :: Maybe [RdrName] -- ToDo: de-maybe + -> RdrNameContext -> RdrName -- class -> RdrNameMonoType -- fish the tycon out yourself... -> RdrIfaceInst -mk_inst ctxt qclas@(Qual cmod cname) mono_ty - = InstSig qclas (tycon_name mono_ty) mkIfaceSrcLoc $ \ mod -> - InstDecl qclas (HsPreForAllTy ctxt mono_ty) - EmptyMonoBinds False mod [{-sigs-}] +mk_inst tvs ctxt qclas@(Qual cmod cname) mono_ty + = let + ty = case tvs of + Nothing -> HsPreForAllTy ctxt mono_ty -- ToDo: get rid of this + Just ts -> HsForAllTy ts ctxt mono_ty + in + -- pprTrace "mk_inst:" (ppr PprDebug ty) $ + InstSig qclas (tycon_name mono_ty) mkIfaceSrcLoc $ \ mod -> + InstDecl qclas ty + EmptyMonoBinds False{-not from_here-} mod [{-sigs-}] noInstancePragmas mkIfaceSrcLoc where tycon_name (MonoTyApp tc _) = tc @@ -277,10 +288,8 @@ lexIface input ITinteger (read num) : lexIface rest } ----------- - is_var_sym '_' = True - is_var_sym '\'' = True - is_var_sym '#' = True -- for Glasgow-extended names - is_var_sym c = isAlphanum c + is_var_sym c = isAlphanum c || c `elem` "_'#" + -- the last few for for Glasgow-extended names is_var_sym1 '\'' = False is_var_sym1 '#' = False @@ -289,6 +298,15 @@ lexIface input is_sym_sym c = c `elem` ":!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic + is_list_sym '[' = True + is_list_sym ']' = True + is_list_sym _ = False + + is_tuple_sym '(' = True + is_tuple_sym ')' = True + is_tuple_sym ',' = True + is_tuple_sym _ = False + ------------ lex_word str@(c:cs) -- we know we have a capital letter to start = -- we first try for "." on the front... @@ -299,6 +317,8 @@ lexIface input in_the_club [] = panic "lex_word:in_the_club" in_the_club (x:_) | isAlpha x = is_var_sym | is_sym_sym x = is_sym_sym + | x == '[' = is_list_sym + | x == '(' = is_tuple_sym | otherwise = panic ("lex_word:in_the_club="++[x]) module_dot (c:cs) @@ -338,18 +358,20 @@ lexIface input in case module_dot of Nothing -> - categ n (ITconid n) (ITvarid n) (ITconsym n) (ITvarsym n) + categ f n (ITconid n) (ITvarid n) (ITconsym n) (ITvarsym n) Just m -> let q = Qual m n in - categ n (ITqconid q) (ITqvarid q) (ITqconsym q) (ITqvarsym q) + categ f n (ITqconid q) (ITqvarid q) (ITqconsym q) (ITqvarsym q) ) : lexIface rest ; } ------------ - categ n conid varid consym varsym - = if isLexConId n then conid + categ f n conid varid consym varsym + = if f == '[' || f == '(' then + conid + else if isLexConId n then conid else if isLexVarId n then varid else if isLexConSym n then consym else varsym @@ -367,6 +389,7 @@ lexIface input ,("fixities__", ITfixities) ,("declarations__", ITdeclarations) ,("pragmas__", ITpragmas) + ,("forall__", ITforall) ,("data", ITdata) ,("type", ITtype) diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index d1b2fbc..8e9c81d 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -8,7 +8,7 @@ module Rename ( renameModule ) where -import PreludeGlaST ( thenPrimIO, newVar, MutableVar(..) ) +import PreludeGlaST ( thenPrimIO ) IMP_Ubiq() @@ -32,16 +32,16 @@ import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..), import RnMonad import RnNames ( getGlobalNames, GlobalNameInfo(..) ) import RnSource ( rnSource ) -import RnIfaces ( rnIfaces ) -import RnUtils ( RnEnv(..), extendGlobalRnEnv, emptyRnEnv ) +import RnIfaces ( rnIfaces, initIfaceCache, IfaceCache ) +import RnUtils ( SYN_IE(RnEnv), extendGlobalRnEnv, emptyRnEnv ) import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag ) import CmdLineOpts ( opt_HiMap, opt_NoImplicitPrelude ) -import ErrUtils ( Error(..), Warning(..) ) +import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) ) import FiniteMap ( emptyFM, eltsFM, fmToList, lookupFM{-ToDo:rm-} ) import Maybes ( catMaybes ) -import Name ( isLocallyDefined, mkWiredInName, Name, RdrName(..) ) -import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) ) +import Name ( isLocallyDefined, mkWiredInName, Name, RdrName(..), ExportFlag(..) ) +import PrelInfo ( builtinNameInfo, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) ) import Unique ( ixClassKey ) import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM ) import UniqSupply ( splitUniqSupply ) @@ -56,6 +56,7 @@ renameModule :: UniqSupply RnEnv, -- final env (for renaming derivings) [Module], -- imported modules; for profiling + Name -> ExportFlag, -- export info (UsagesMap, VersionsMap, -- version info; for usage [Module]), -- instance modules; for iface @@ -83,7 +84,7 @@ renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _) -} 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 -> + initIfaceCache modname hi_files >>= \ iface_cache -> fixIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) -> let @@ -130,10 +131,10 @@ renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _) top_warns `unionBags` src_warns `unionBags` listToBag occ_warns, occ_fm, export_fn) - }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, _) -> + }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, export_fn) -> if not (isEmptyBag errs_so_far) then - return (rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far) + return (rn_panic, rn_panic, rn_panic, rn_panic, rn_panic, errs_so_far, warns_so_far) else -- No errors renaming source so rename the interfaces ... @@ -181,7 +182,7 @@ renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _) | opt_NoImplicitPrelude = [{-no Prelude.hi, no point looking-}] | otherwise - = [ name_fn (mkWiredInName u orig) + = [ name_fn (mkWiredInName u orig ExportAll) | (orig@(OrigName mod str), (u, name_fn)) <- fmToList b_keys, str `notElem` [ SLIT("main"), SLIT("mainPrimIO")] ] in @@ -200,6 +201,7 @@ renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _) return (rn_module_with_imports, final_env, imp_mods, + export_fn, usage_stuff, errs_so_far `unionBags` iface_errs, warns_so_far `unionBags` iface_warns) diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index ab0e9ee..f1618ad 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -38,7 +38,7 @@ import PprStyle--ToDo:rm import Pretty import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet, unionUniqSets, unionManyUniqSets, - elementOfUniqSet, uniqSetToList, UniqSet(..) ) + elementOfUniqSet, uniqSetToList, SYN_IE(UniqSet) ) import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic, pprTrace{-ToDo:rm-} ) \end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 9e2697f..220a945 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -31,7 +31,7 @@ import Pretty import UniqFM ( lookupUFM, ufmToList{-ToDo:rm-} ) import UniqSet ( emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, - UniqSet(..) + SYN_IE(UniqSet) ) import Util ( Ord3(..), removeDups, panic ) \end{code} diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 596ed5f..e06d1e7 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -12,7 +12,7 @@ IMP_Ubiq() import HsSyn -import Id ( isDataCon, GenId, Id(..) ) +import Id ( isDataCon, GenId, SYN_IE(Id) ) import Name ( isLocalName, nameUnique, Name, RdrName(..){-ToDo: rm ..-}, mkLocalName{-ToDo:rm-} ) @@ -92,6 +92,14 @@ isRnImplicit _ = False isRnUnbound (RnUnbound _) = True isRnUnbound _ = False +isRnEntity (WiredInId _) = True +isRnEntity (WiredInTyCon _) = True +isRnEntity (RnName n) = not (isLocalName n) +isRnEntity (RnSyn _) = True +isRnEntity (RnData _ _ _) = True +isRnEntity (RnClass _ _) = True +isRnEntity _ = False + -- Very general NamedThing comparison, used when comparing -- Uniquable things with different types @@ -120,7 +128,7 @@ instance NamedThing RnName where getName (RnImplicit n) = n getName (RnImplicitTyCon n) = n getName (RnImplicitClass n) = n - getName (RnUnbound occ) = pprTrace "getRnName:RnUnbound: " (ppr PprDebug occ) + getName (RnUnbound occ) = --pprTrace "getRnName:RnUnbound: " (ppr PprDebug occ) (case occ of Unqual n -> mkLocalName bottom n False bottom2 Qual m n -> mkLocalName bottom n False bottom2) diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 3db7db8..965ab3f 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -8,14 +8,14 @@ module RnIfaces ( cachedIface, - cachedDecl, + cachedDecl, CachingResult(..), rnIfaces, - IfaceCache(..) + IfaceCache, initIfaceCache ) where IMP_Ubiq() -import PreludeGlaST ( thenPrimIO, seqPrimIO, readVar, writeVar, MutableVar(..) ) +import PreludeGlaST ( thenPrimIO, seqPrimIO, newVar, readVar, writeVar, MutableVar(..) ) import HsSyn import HsPragmas ( noGenPragmas ) @@ -24,7 +24,7 @@ import RnHsSyn import RnMonad import RnSource ( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) -import RnUtils ( RnEnv(..), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv ) +import RnUtils ( SYN_IE(RnEnv), emptyRnEnv, lookupRnEnv, lookupTcRnEnv, extendGlobalRnEnv ) import ParseIface ( parseIface ) import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..), VersionsMap(..), UsagesMap(..) @@ -32,7 +32,7 @@ import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..), import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags, unionManyBags, isEmptyBag, bagToList ) -import ErrUtils ( Error(..), Warning(..) ) +import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) ) import FiniteMap ( emptyFM, lookupFM, addToFM, addToFM_C, plusFM, eltsFM, fmToList, delListFromFM, sizeFM, foldFM, unitFM, plusFM_C, addListToFM, keysFM{-ToDo:rm-} @@ -42,7 +42,7 @@ import Name ( origName, moduleOf, nameOf, qualToOrigName, OrigName(..), isLexCon, RdrName(..), Name{-instance NamedThing-} ) import PprStyle -- ToDo:rm import Outputable -- ToDo:rm -import PrelInfo ( builtinNameInfo ) +import PrelInfo ( builtinNameInfo, SYN_IE(BuiltinNames) ) import Pretty import Maybes ( MaybeErr(..) ) import UniqFM ( emptyUFM ) @@ -55,12 +55,22 @@ import Util ( sortLt, removeDups, cmpPString, startsWith, type ModuleToIfaceContents = FiniteMap Module ParsedIface type ModuleToIfaceFilePath = FiniteMap Module FilePath -type IfaceCache - = MutableVar _RealWorld - (ModuleToIfaceContents, -- interfaces for individual interface files - ModuleToIfaceContents, -- merged interfaces based on module name - -- used for extracting info about original names - ModuleToIfaceFilePath) +data IfaceCache + = IfaceCache + Module -- the name of the module being compiled + BuiltinNames -- so we can avoid going after things + -- the compiler already knows about + (MutableVar _RealWorld + (ModuleToIfaceContents, -- interfaces for individual interface files + ModuleToIfaceContents, -- merged interfaces based on module name + -- used for extracting info about original names + ModuleToIfaceFilePath)) + +initIfaceCache mod hi_files + = newVar (emptyFM,emptyFM,hi_files) `thenPrimIO` \ iface_var -> + return (IfaceCache mod b_names iface_var) + where + b_names = case builtinNameInfo of (b_names,_,_) -> b_names \end{code} ********************************************************* @@ -92,13 +102,15 @@ ToDo: Check/Merge duplicate pragmas. \begin{code} -cachedIface :: Bool -- True => want merged interface for original name - -> IfaceCache -- False => want file interface only +cachedIface :: IfaceCache + -> Bool -- True => want merged interface for original name + -- False => want file interface only + -> FAST_STRING -- item that prompted search (debugging only!) -> Module -> IO (MaybeErr ParsedIface Error) -cachedIface want_orig_iface iface_cache modname - = readVar iface_cache `thenPrimIO` \ (iface_fm, orig_fm, file_fm) -> +cachedIface (IfaceCache _ _ iface_var) want_orig_iface item modname + = readVar iface_var `thenPrimIO` \ (iface_fm, orig_fm, file_fm) -> case (lookupFM iface_fm modname) of Just iface -> return (want_iface iface orig_fm) @@ -106,7 +118,7 @@ cachedIface want_orig_iface iface_cache modname case (lookupFM file_fm modname) of Nothing -> return (Failed (noIfaceErr modname)) Just file -> - readIface file modname >>= \ read_iface -> + readIface file modname item >>= \ read_iface -> case read_iface of Failed err -> -- pprTrace "module-file map:\n" (ppAboves [ppCat [ppPStr m, ppStr f] | (m,f) <- fmToList file_fm]) $ return (Failed err) @@ -115,7 +127,7 @@ cachedIface want_orig_iface iface_cache modname iface_fm' = addToFM iface_fm modname iface orig_fm' = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface in - writeVar iface_cache (iface_fm', orig_fm', file_fm) `seqPrimIO` + writeVar iface_var (iface_fm', orig_fm', file_fm) `seqPrimIO` return (want_iface iface orig_fm') where want_iface iface orig_fm @@ -161,26 +173,49 @@ mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs idecl_nm (ValSig n _ _) = n ---------- +data CachingResult + = CachingFail Error -- tried to find a decl, something went wrong + | CachingHit RdrIfaceDecl -- got it + | CachingAvoided (Maybe (Either RnName RnName)) + -- didn't look in the interface + -- file(s); Nothing => the thing + -- *should* be in the source module; + -- Just (Left ...) => builtin val name; + -- Just (Right ..) => builtin tc name + cachedDecl :: IfaceCache -> Bool -- True <=> tycon or class name -> OrigName - -> IO (MaybeErr RdrIfaceDecl Error) + -> IO CachingResult + +cachedDecl iface_cache@(IfaceCache this_mod (b_val_names,b_tc_names) _) + class_or_tycon name@(OrigName mod str) -cachedDecl iface_cache class_or_tycon name@(OrigName mod str) = -- pprTrace "cachedDecl:" (ppr PprDebug name) $ - cachedIface True iface_cache mod >>= \ maybe_iface -> - case maybe_iface of - 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) - Nothing -> return (Failed (noDeclInIfaceErr mod str)) + if mod == this_mod then -- some i/face has made a reference + return (CachingAvoided Nothing) -- to something from this module + else + let + b_env = if class_or_tycon then b_tc_names else b_val_names + in + case (lookupFM b_env name) of + Just rn -> -- in builtins! + return (CachingAvoided (Just ((if class_or_tycon then Right else Left) rn))) + + Nothing -> + cachedIface iface_cache True str mod >>= \ maybe_iface -> + case maybe_iface of + Failed err -> --pprTrace "cachedDecl:fail:" (ppr PprDebug orig) $ + return (CachingFail err) + Succeeded (ParsedIface _ _ _ _ _ _ exps _ _ tdefs vdefs _ _) -> + case (lookupFM (if class_or_tycon then tdefs else vdefs) str) of + Just decl -> return (CachingHit decl) + Nothing -> return (CachingFail (noDeclInIfaceErr mod str)) ---------- cachedDeclByType :: IfaceCache -> RnName{-NB: diff type than cachedDecl -} - -> IO (MaybeErr RdrIfaceDecl Error) + -> IO CachingResult cachedDeclByType iface_cache rn -- the idea is: check that, e.g., if we're given an @@ -189,11 +224,12 @@ cachedDeclByType iface_cache rn = cachedDecl iface_cache (isRnTyConOrClass rn) (origName "cachedDeclByType" rn) >>= \ maybe_decl -> let return_maybe_decl = return maybe_decl - return_failed msg = return (Failed msg) + return_failed msg = return (CachingFail msg) in case maybe_decl of - Failed io_msg -> return_failed (ifaceIoErr io_msg rn) - Succeeded if_decl -> + CachingAvoided _ -> return_maybe_decl + CachingFail io_msg -> return_failed (ifaceIoErr io_msg rn) + CachingHit if_decl -> case rn of WiredInId _ -> return_failed (ifaceLookupWiredErr "value" rn) WiredInTyCon _ -> return_failed (ifaceLookupWiredErr "type constructor" rn) @@ -234,16 +270,16 @@ cachedDeclByType iface_cache rn \end{code} \begin{code} -readIface :: FilePath -> Module -> IO (MaybeErr ParsedIface Error) +readIface :: FilePath -> Module -> FAST_STRING -> IO (MaybeErr ParsedIface Error) -readIface file modname - = hPutStr stderr (" reading "++file) >> +readIface file modname item + = --hPutStr stderr (" reading "++file++" ("++ _UNPK_ item ++")") >> readFile file `thenPrimIO` \ read_result -> case read_result of Left err -> return (Failed (cannaeReadErr file err)) - Right contents -> hPutStr stderr ".." >> + Right contents -> --hPutStr stderr ".." >> let parsed = parseIface contents in - hPutStr stderr "..\n" >> + --hPutStr stderr "..\n" >> return ( case parsed of Failed _ -> parsed @@ -392,11 +428,15 @@ 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) $ - do_decls ns down (add_err err to_return) + CachingAvoided _ -> + pprTrace "do_decls:caching avoided:" (ppr PprDebug n) $ + do_decls ns down to_return + + CachingFail err -> -- add the error, but keep going: + --pprTrace "do_decls:cache error:" (ppr PprDebug n) $ + do_decls ns down (add_err err to_return) - Succeeded iface_decl -> -- something needing renaming! + CachingHit iface_decl -> -- something needing renaming! let (us1, us2) = splitUniqSupply (uniqsupply down) in @@ -579,21 +619,22 @@ sub (val_ment, tc_ment) (val_defds, tc_defds) \begin{code} cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error) -cacheInstModules iface_cache imp_mods - = readVar iface_cache `thenPrimIO` \ (iface_fm, _, _) -> + +cacheInstModules iface_cache@(IfaceCache _ _ iface_var) imp_mods + = readVar iface_var `thenPrimIO` \ (iface_fm, _, _) -> let imp_ifaces = [ iface | Just iface <- map (lookupFM iface_fm) 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 -> + accumulate (map (cachedIface iface_cache False SLIT("instance_modules")) imp_imods) >>= \ err_or_ifaces -> -- Sanity Check: -- Assert that instance modules given by direct imports contains -- instance modules extracted from all visited modules - readVar iface_cache `thenPrimIO` \ (all_iface_fm, _, _) -> + readVar iface_var `thenPrimIO` \ (all_iface_fm, _, _) -> let all_ifaces = eltsFM all_iface_fm (all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces)))) @@ -625,21 +666,22 @@ rnIfaceInstStuff RnEnv, -- final occ env [RnName]) -- new unknown names -rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return +rnIfaceInstStuff iface_cache@(IfaceCache _ _ iface_var) modname us occ_env done_inst_env to_return = -- all the instance decls we might even want to consider -- are in the ParsedIfaces that are in our cache - readVar iface_cache `thenPrimIO` \ (_, orig_iface_fm, _) -> + readVar iface_var `thenPrimIO` \ (_, orig_iface_fm, _) -> let all_ifaces = eltsFM orig_iface_fm - all_insts = unionManyBags (map get_insts all_ifaces) - interesting_insts = filter want_inst (bagToList all_insts) + all_insts = concat (map get_insts all_ifaces) + interesting_insts = filter want_inst all_insts -- Sanity Check: -- Assert that there are no more instances for the done instances - claim_done = filter is_done_inst (bagToList all_insts) + claim_done = filter is_done_inst all_insts claim_done_env = foldr add_done_inst emptyFM claim_done + has_val fm (k,i) = case lookupFM fm k of { Nothing -> False; Just v -> i == v } in {- @@ -651,8 +693,8 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return case (initRn False{-iface-} modname occ_env us ( setExtraRn emptyUFM{-no fixities-} $ - mapRn (rnIfaceInst modname) interesting_insts `thenRn` \ insts -> - getImplicitUpRn `thenRn` \ implicits -> + mapRn rnIfaceInst interesting_insts `thenRn` \ insts -> + getImplicitUpRn `thenRn` \ implicits -> returnRn (insts, implicits))) of { ((if_insts, if_implicits), if_errs, if_warns) -> @@ -665,14 +707,14 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits)) } where - get_insts (ParsedIface _ _ _ _ _ _ _ _ _ _ _ insts _) = insts + get_insts (ParsedIface imod _ _ _ _ _ _ _ _ _ _ insts _) = [(imod, inst) | inst <- bagToList insts] tycon_class clas tycon = (qualToOrigName clas, qualToOrigName tycon) - add_done_inst (InstSig clas tycon _ _) inst_env + add_done_inst (_, InstSig clas tycon _ _) inst_env = addToFM_C (+) inst_env (tycon_class clas tycon) 1 - is_done_inst (InstSig clas tycon _ _) + is_done_inst (_, InstSig clas tycon _ _) = maybeToBool (lookupFM done_inst_env (tycon_class clas tycon)) add_imp_occs (val_imps, tc_imps) occ_env @@ -683,7 +725,7 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ] -- again, this hackery because we are reusing the RnEnv technology - want_inst i@(InstSig clas tycon _ _) + want_inst i@(imod, 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)]) $ @@ -710,9 +752,9 @@ rnIfaceInstStuff iface_cache modname us occ_env done_inst_env to_return \end{code} \begin{code} -rnIfaceInst :: Module -> RdrIfaceInst -> RnM_Fixes _RealWorld RenamedInstDecl +rnIfaceInst :: (Module, RdrIfaceInst) -> RnM_Fixes _RealWorld RenamedInstDecl -rnIfaceInst mod (InstSig _ _ _ inst_decl) = rnInstDecl (inst_decl mod) +rnIfaceInst (imod, InstSig _ _ _ inst_decl) = rnInstDecl (inst_decl imod) \end{code} \begin{code} @@ -730,13 +772,13 @@ finalIfaceInfo :: VersionsMap, -- info about version numbers [Module]) -- special instance modules -finalIfaceInfo iface_cache modname if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls +finalIfaceInfo iface_cache@(IfaceCache _ _ iface_var) modname if_final_env@((qual, unqual, tc_qual, tc_unqual), stack) if_instdecls = -- pprTrace "usageIf:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $ -- 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, _) -> + readVar iface_var `thenPrimIO` \ (_, orig_iface_fm, _) -> let all_ifaces = eltsFM orig_iface_fm -- all the interfaces we have looked at @@ -771,28 +813,26 @@ finalIfaceInfo iface_cache modname if_final_env@((qual, unqual, tc_qual, tc_unqu | m == modname -- this module => add to "versions" = (usages, addToFM versions n 1{-stub-}) | otherwise -- from another module => add to "usages" - = (add_to_usages usages key, versions) + = case (add_to_usages usages key) of + Nothing -> as_before + Just new_usages -> (new_usages, 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) - ) + = case (lookupFM big_mv_map m) of + Nothing -> Nothing + Just mv -> + case (lookupFM big_version_map key) of + Nothing -> Nothing + Just kv -> + Just $ addToFM usages m ( + case (lookupFM usages m) of + Nothing -> -- nothing for this module yet... + (mv, unitFM n kv) + + Just (mversion, mstuff) -> -- the "new" stuff will shadow the old + ASSERT(mversion == mv) + (mversion, addToFM mstuff n kv) + ) irrelevant (RnConstr _ _) = True -- We don't report these in their irrelevant (RnField _ _) = True -- own right in usages/etc. diff --git a/ghc/compiler/rename/RnLoop_1_3.lhi b/ghc/compiler/rename/RnLoop_1_3.lhi new file mode 100644 index 0000000..d87183d --- /dev/null +++ b/ghc/compiler/rename/RnLoop_1_3.lhi @@ -0,0 +1,5 @@ +\begin{code} +interface RnLoop_1_3 1 +__exports__ +Outputable Outputable (..) +\end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 1d7cc96..e6b7c93 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -7,7 +7,7 @@ #include "HsVersions.h" module RnMonad ( - RnMonad(..), RnM(..), RnM_Fixes(..), RnDown, SST_R, + SYN_IE(RnMonad), SYN_IE(RnM), SYN_IE(RnM_Fixes), RnDown, SST_R, initRn, thenRn, thenRn_, andRn, returnRn, mapRn, mapAndUnzipRn, mapAndUnzip3Rn, @@ -16,7 +16,7 @@ module RnMonad ( setExtraRn, getExtraRn, getRnEnv, getModuleRn, pushSrcLocRn, getSrcLocRn, getSourceRn, getOccurrenceUpRn, - getImplicitUpRn, ImplicitEnv(..), emptyImplicitEnv, + getImplicitUpRn, SYN_IE(ImplicitEnv), emptyImplicitEnv, rnGetUnique, rnGetUniques, newLocalNames, @@ -24,13 +24,14 @@ module RnMonad ( lookupTyCon, lookupClass, lookupTyConOrClass, extendSS2, extendSS, - TyVarNamesEnv(..), mkTyVarNamesEnv, domTyVarNamesEnv, + SYN_IE(TyVarNamesEnv), mkTyVarNamesEnv, domTyVarNamesEnv, lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs, fixIO ) where IMP_Ubiq(){-uitous-} +IMPORT_1_3(GHCbase(fixIO)) import SST @@ -40,7 +41,7 @@ import RnHsSyn ( RnName, mkRnName, mkRnUnbound, mkRnImplicit, isRnLocal, isRnWired, isRnTyCon, isRnClass, isRnTyConOrClass, isRnConstr, isRnField, isRnClassOp, RenamedFixityDecl(..) ) -import RnUtils ( RnEnv(..), extendLocalRnEnv, +import RnUtils ( SYN_IE(RnEnv), extendLocalRnEnv, lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv, qualNameErr, dupNamesErr ) @@ -48,22 +49,22 @@ import RnUtils ( RnEnv(..), extendLocalRnEnv, import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) import CmdLineOpts ( opt_WarnNameShadowing ) import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine, - Error(..), Warning(..) + SYN_IE(Error), SYN_IE(Warning) ) import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM, fmToList{-ToDo:rm-} ) import Maybes ( assocMaybe ) -import Name ( Module(..), RdrName(..), isQual, +import Name ( SYN_IE(Module), RdrName(..), isQual, OrigName(..), Name, mkLocalName, mkImplicitName, getOccName, pprNonSym ) -import PrelInfo ( builtinNameInfo, BuiltinNames(..), BuiltinKeys(..) ) +import PrelInfo ( builtinNameInfo, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) ) import PrelMods ( pRELUDE ) import PprStyle{-ToDo:rm-} import Outputable{-ToDo:rm-} -import Pretty--ToDo:rm ( Pretty(..), PrettyRep ) +import Pretty--ToDo:rm ( SYN_IE(Pretty), PrettyRep ) import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) import UniqFM ( UniqFM, emptyUFM ) -import UniqSet ( UniqSet(..), mkUniqSet, minusUniqSet ) +import UniqSet ( SYN_IE(UniqSet), mkUniqSet, minusUniqSet ) import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply ) import Unique ( Unique ) import Util @@ -101,18 +102,23 @@ type ImplicitEnv = (FiniteMap OrigName RnName, FiniteMap OrigName RnName) emptyImplicitEnv :: ImplicitEnv emptyImplicitEnv = (emptyFM, emptyFM) --- With a builtin polymorphic type for _runSST the type for --- initTc should use RnM s r instead of RnM _RealWorld r +-- With a builtin polymorphic type for runSST the type for +-- initTc should use RnM s r instead of RnM RealWorld r +#if __GLASGOW_HASKELL__ >= 200 +# define REAL_WORLD GHCbuiltins.RealWorld +#else +# define REAL_WORLD _RealWorld +#endif initRn :: Bool -- True => Source; False => Iface -> Module -> RnEnv -> UniqSupply - -> RnM _RealWorld r + -> RnM REAL_WORLD r -> (r, Bag Error, Bag Warning) initRn source mod env us do_rn - = _runSST ( + = runSST ( newMutVarSST emptyBag `thenSST` \ occ_var -> newMutVarSST emptyImplicitEnv `thenSST` \ imp_var -> newMutVarSST us `thenSST` \ us_var -> @@ -541,12 +547,17 @@ lookupTyVarName env occ \begin{code} +#if __GLASGOW_HASKELL__ >= 200 + -- can get it from GHCbase +#else fixIO :: (a -> IO a) -> IO a + fixIO k s = let result = k loop s (Right loop, _) = result in result +#endif \end{code} ********************************************************* diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index cd256b9..55aeb1b 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -20,8 +20,8 @@ import RdrHsSyn import RnHsSyn import RnMonad -import RnIfaces ( IfaceCache(..), cachedIface, cachedDecl ) -import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, +import RnIfaces ( IfaceCache, cachedIface, cachedDecl, CachingResult(..) ) +import RnUtils ( SYN_IE(RnEnv), emptyRnEnv, extendGlobalRnEnv, lubExportFlag, qualNameErr, dupNamesErr ) import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), ExportsMap(..), RdrIfaceInst ) @@ -29,8 +29,8 @@ import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), ExportsMap(..), RdrIfaceI import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags, unionManyBags, mapBag, filterBag, listToBag, bagToList ) -import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingPrelude ) -import ErrUtils ( Error(..), Warning(..), addErrLoc, addShortErrLocLine, addShortWarnLocLine ) +import CmdLineOpts ( opt_NoImplicitPrelude, opt_CompilingGhcInternals ) +import ErrUtils ( SYN_IE(Error), SYN_IE(Warning), addErrLoc, addShortErrLocLine, addShortWarnLocLine ) import FiniteMap ( emptyFM, addToFM, addListToFM, lookupFM, fmToList, eltsFM, delListFromFM, keysFM{-ToDo:rm-} ) import Id ( GenId ) import Maybes ( maybeToBool, catMaybes, MaybeErr(..) ) @@ -41,7 +41,7 @@ import Name ( RdrName(..), Name, isQual, mkTopLevName, mkWiredInName, origName, moduleNamePair, pprNonSym, isLexCon, ExportFlag(..), OrigName(..) ) -import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) ) +import PrelInfo ( SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) ) import PrelMods ( pRELUDE, gHC_BUILTINS, modulesWithBuiltins ) import Pretty import SrcLoc ( SrcLoc, mkBuiltinSrcLoc ) @@ -302,7 +302,7 @@ newGlobalName locn maybe_exp is_val_name (Unqual name) (uniq, is_toplev) = case (lookupFM b_keys orig) of Just (key,_) -> (key, True) - Nothing -> if not opt_CompilingPrelude then (u,True) else -- really here just to save gratuitous lookup + Nothing -> if not opt_CompilingGhcInternals then (u,True) else -- really here just to save gratuitous lookup case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of Nothing -> (u, True) Just xx -> (uniqueOf xx, False{-builtin!-}) @@ -313,12 +313,12 @@ newGlobalName locn maybe_exp is_val_name (Unqual name) n = if is_toplev then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s - else mkWiredInName uniq orig + else mkWiredInName uniq orig exp in returnRn n newGlobalName locn maybe_exp is_val_name rdr@(Qual mod name) - | opt_CompilingPrelude + | opt_CompilingGhcInternals -- we are actually defining something that compiler knows about (e.g., Bool) = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) -> @@ -338,7 +338,7 @@ newGlobalName locn maybe_exp is_val_name rdr@(Qual mod name) n = if is_toplev then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s - else mkWiredInName uniq orig + else mkWiredInName uniq orig exp in returnRn n @@ -395,7 +395,7 @@ doImportDecls iface_cache g_info us src_imps -- 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) >> + accumulate (map (cachedIface iface_cache False SLIT("doImportDecls")) imp_mods) >> -- process the imports doImports iface_cache i_info us all_imps @@ -521,7 +521,7 @@ doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc) \ iface -> ([], [], emptyBag)) else --pprTrace "doImport:" (ppPStr mod) $ - cachedIface False iface_cache mod >>= \ maybe_iface -> + cachedIface iface_cache False SLIT("doImport") mod >>= \ maybe_iface -> return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec') ) >>= \ (maybe_iface, do_ies) -> @@ -748,6 +748,7 @@ doOrigIE :: IfaceCache doOrigIE iface_cache info mod src_loc us ie = with_decl iface_cache (ie_name ie) + avoided_fn (\ err -> (emptyBag, emptyBag, emptyBag, unitBag err, emptyBag)) (\ decl -> case initRn True mod emptyRnEnv us (setExtraRn info $ @@ -755,6 +756,14 @@ doOrigIE iface_cache info mod src_loc us ie getIfaceDeclNames ie decl) of ((vals, tcs, imps), errs, warns) -> (vals, tcs, imps, errs, warns)) + where + avoided_fn Nothing -- the thing should be in the source + = (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag) + avoided_fn (Just (Left rn)) -- a builtin value brought into scope + = (unitBag rn, emptyBag, emptyBag, emptyBag, emptyBag) + avoided_fn (Just (Right rn)) -- a builtin tc/class brought into scope + = --pprTrace "avoided:Right:" (ppr PprShowAll rn) $ + (emptyBag, unitBag rn, emptyBag, emptyBag, emptyBag) ------------------------- checkOrigIE :: IfaceCache @@ -763,6 +772,7 @@ checkOrigIE :: IfaceCache checkOrigIE iface_cache (IEThingAll n, ExportAbs) = with_decl iface_cache n + (\ _ -> (emptyBag, emptyBag)) (\ err -> (unitBag (\ mod locn -> err), emptyBag)) (\ decl -> case decl of TypeSig _ _ _ -> (emptyBag, unitBag (allWhenSynImpSpecWarn n)) @@ -773,6 +783,7 @@ checkOrigIE iface_cache (IEThingWith n ns, ExportAbs) checkOrigIE iface_cache (IEThingWith n ns, ExportAll) = with_decl iface_cache n + (\ _ -> (emptyBag, emptyBag)) (\ err -> (unitBag (\ mod locn -> err), emptyBag)) (\ decl -> case decl of NewTypeSig _ con _ _ -> (check_with "constructors" [con] ns, emptyBag) @@ -791,15 +802,17 @@ checkOrigIE iface_cache other ----------------------- with_decl :: IfaceCache -> OrigName - -> (Error -> something) -- if an error... - -> (RdrIfaceDecl -> something) -- if OK... + -> (Maybe (Either RnName RnName) -> something) -- if avoided.. + -> (Error -> something) -- if an error... + -> (RdrIfaceDecl -> something) -- if OK... -> IO something -with_decl iface_cache n do_err do_decl +with_decl iface_cache n do_avoid do_err do_decl = cachedDecl iface_cache (isLexCon (nameOf n)) n >>= \ maybe_decl -> case maybe_decl of - Failed err -> return (do_err err) - Succeeded decl -> return (do_decl decl) + CachingAvoided info -> return (do_avoid info) + CachingFail err -> return (do_err err) + CachingHit decl -> return (do_decl decl) ------------- getFixityDecl :: IfaceCache @@ -812,7 +825,7 @@ getFixityDecl iface_cache rn succeeded infx i = return (Just (infx rn i), emptyBag) in - cachedIface True iface_cache mod >>= \ maybe_iface -> + cachedIface iface_cache True str mod >>= \ maybe_iface -> case maybe_iface of Failed err -> return (Nothing, unitBag err) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 3831ec0..ce3359f 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -17,13 +17,14 @@ import RdrHsSyn import RnHsSyn import RnMonad import RnBinds ( rnTopBinds, rnMethodBinds ) -import RnUtils ( lookupGlobalRnEnv, lubExportFlag ) +import RnUtils ( getLocalsFromRnEnv, lookupGlobalRnEnv, lubExportFlag ) import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList ) import Class ( derivableClassKeys ) -import CmdLineOpts ( opt_CompilingPrelude ) +import CmdLineOpts ( opt_CompilingGhcInternals ) import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine ) import FiniteMap ( emptyFM, lookupFM, addListToFM_C ) +import Id ( GenId{-instance NamedThing-} ) import ListSetOps ( unionLists, minusList ) import Maybes ( maybeToBool, catMaybes ) import Name ( isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..), @@ -32,11 +33,12 @@ import Outputable -- ToDo:rm import PprStyle -- ToDo:rm import Pretty import SrcLoc ( SrcLoc ) +import TyCon ( tyConDataCons, TyCon{-instance NamedThing-} ) import Unique ( Unique ) import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, plusUFM, lookupUFM, eltsUFM ) -import UniqSet ( UniqSet(..) ) +import UniqSet ( SYN_IE(UniqSet) ) import Util ( isIn, isn'tIn, thenCmp, sortLt, removeDups, mapAndUnzip3, cmpPString, - assertPanic, pprTrace{-ToDo:rm-} ) + panic, assertPanic, pprTrace{-ToDo:rm-} ) \end{code} rnSource `renames' the source module and export list. @@ -121,7 +123,9 @@ rnExports mods unqual_imps Nothing = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported) rnExports mods unqual_imps (Just exps) - = mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) -> + = getModuleRn `thenRn` \ this_mod -> + getRnEnv `thenRn` \ rn_env -> + mapAndUnzipRn (rnIE mods) exps `thenRn` \ (mod_maybes, exp_bags) -> let (tc_bags, val_bags) = unzip exp_bags tc_names = bagToList (unionManyBags tc_bags) @@ -134,11 +138,17 @@ rnExports mods unqual_imps (Just exps) cmp_fst (x,_) (y,_) = x `cmp` y (uniq_mods, dup_mods) = removeDups cmpPString exp_mods + (expmods_this, expmods_imps) = partition (== this_mod) uniq_mods - -- Get names for exported modules + -- Get names for module This_Mod export + (this_tcs, this_vals) + = if null expmods_this + then ([], []) + else getLocalsFromRnEnv rn_env + -- Get names for exported imported modules (mod_tcs, mod_vals, empty_mods) - = case mapAndUnzip3 get_mod_names uniq_mods of + = case mapAndUnzip3 get_mod_names expmods_imps of (tcs, vals, emptys) -> (concat tcs, concat vals, catMaybes emptys) (unqual_tcs, unqual_vals) = partition (isRnTyConOrClass.snd) (bagToList unqual_imps) @@ -156,12 +166,15 @@ rnExports mods unqual_imps (Just exps) -- Build finite map of exported names to export flag tc_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst tc_names) - tc_map = addListToUFM_C lub_expflag tc_map0 (map pair_fst mod_tcs) + tc_map1 = addListToUFM_C lub_expflag tc_map0 (map pair_fst mod_tcs) + tc_map = addListToUFM_C lub_expflag tc_map1 (map (pair_fst.exp_all) this_tcs) val_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst val_names) - val_map = addListToUFM_C lub_expflag val_map0 (map pair_fst mod_vals) + val_map1 = addListToUFM_C lub_expflag val_map0 (map pair_fst mod_vals) + val_map = addListToUFM_C lub_expflag val_map1 (map (pair_fst.exp_all) this_vals) - pair_fst p@(f,_) = (f,p) + pair_fst pr@(n,_) = (n,pr) + exp_all rn = (getName rn, ExportAll) lub_expflag (n, flag1) (_, flag2) = (n, lubExportFlag flag1 flag2) -- Check for exporting of duplicate local names @@ -174,8 +187,8 @@ rnExports mods unqual_imps (Just exps) -- Build export flag function final_exp_map = plusUFM tc_map val_map exp_fn n = case lookupUFM final_exp_map n of - Nothing -> NotExported - Just (_,flag) -> flag + Nothing -> NotExported + Just (_,flag) -> flag in getSrcLocRn `thenRn` \ src_loc -> mapRn (addWarnRn . dupNameExportWarn src_loc) dup_tc_names `thenRn_` @@ -192,20 +205,26 @@ rnIE mods (IEVar name) checkIEVar rn `thenRn` \ exps -> returnRn (Nothing, exps) where - checkIEVar (RnName n) = returnRn (emptyBag, unitBag (n,ExportAll)) + checkIEVar (RnName n) = returnRn (emptyBag, unitBag (n,ExportAll)) + checkIEVar (WiredInId i) = returnRn (emptyBag, unitBag (getName i, ExportAll)) checkIEVar rn@(RnClassOp _ _) = getSrcLocRn `thenRn` \ src_loc -> failButContinueRn (emptyBag, emptyBag) (classOpExportErr rn src_loc) - checkIEVar rn = returnRn (emptyBag, emptyBag) + checkIEVar rn@(RnField _ _) = getSrcLocRn `thenRn` \ src_loc -> + failButContinueRn (emptyBag, emptyBag) (fieldExportErr rn src_loc) + checkIEVar rn = --pprTrace "rnIE:IEVar:panic? ToDo?:" (ppr PprDebug rn) $ + returnRn (emptyBag, emptyBag) rnIE mods (IEThingAbs name) = lookupTyConOrClass name `thenRn` \ rn -> checkIEAbs rn `thenRn` \ exps -> returnRn (Nothing, exps) where - checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs), emptyBag) - checkIEAbs (RnData n _ _) = returnRn (unitBag (n,ExportAbs), emptyBag) - checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs), emptyBag) - checkIEAbs rn = returnRn (emptyBag, emptyBag) + checkIEAbs (RnSyn n) = returnRn (unitBag (n,ExportAbs), emptyBag) + checkIEAbs (RnData n _ _) = returnRn (unitBag (n,ExportAbs), emptyBag) + checkIEAbs (RnClass n _) = returnRn (unitBag (n,ExportAbs), emptyBag) + checkIEAbs (WiredInTyCon t) = returnRn (unitBag (getName t,ExportAbs), emptyBag) + checkIEAbs rn = --pprTrace "rnIE:IEAbs:panic? ToDo?:" (ppr PprDebug rn) $ + returnRn (emptyBag, emptyBag) rnIE mods (IEThingAll name) = lookupTyConOrClass name `thenRn` \ rn -> @@ -213,14 +232,24 @@ rnIE mods (IEThingAll name) checkImportAll rn `thenRn_` returnRn (Nothing, exps) where - checkIEAll (RnData n cons fields) = returnRn (unitBag (exp_all n), listToBag (map exp_all cons) - `unionBags` - listToBag (map exp_all fields)) - checkIEAll (RnClass n ops) = returnRn (unitBag (exp_all n), listToBag (map exp_all ops)) - checkIEAll rn@(RnSyn n) = getSrcLocRn `thenRn` \ src_loc -> - warnAndContinueRn (unitBag (n, ExportAbs), emptyBag) - (synAllExportErr False{-warning-} rn src_loc) - checkIEAll rn = returnRn (emptyBag, emptyBag) + checkIEAll (RnData n cons fields) + = returnRn (unitBag (exp_all n), + listToBag (map exp_all cons) `unionBags` listToBag (map exp_all fields)) + + checkIEAll (WiredInTyCon t) + = returnRn (unitBag (exp_all (getName t)), listToBag (map exp_all cons)) + where + cons = map getName (tyConDataCons t) + + checkIEAll (RnClass n ops) + = returnRn (unitBag (exp_all n), listToBag (map exp_all ops)) + checkIEAll rn@(RnSyn n) + = getSrcLocRn `thenRn` \ src_loc -> + warnAndContinueRn (unitBag (n, ExportAbs), emptyBag) + (synAllExportErr False{-warning-} rn src_loc) + + checkIEAll rn = pprTrace "rnIE:IEAll:panic? ToDo?:" (ppr PprDebug rn) $ + returnRn (emptyBag, emptyBag) exp_all n = (n, ExportAll) @@ -246,8 +275,10 @@ rnIE mods (IEThingWith name names) checkIEWith rn@(RnSyn _) rns = getSrcLocRn `thenRn` \ src_loc -> failButContinueRn (emptyBag, emptyBag) (synAllExportErr True{-error-} rn src_loc) + checkIEWith (WiredInTyCon _) rns = panic "RnSource.rnIE:checkIEWith:WiredInTyCon:ToDo (boring)" checkIEWith rn rns - = returnRn (emptyBag, emptyBag) + = pprTrace "rnIE:IEWith:panic? ToDo?:" (ppr PprDebug rn) $ + returnRn (emptyBag, emptyBag) exp_all n = (n, ExportAll) @@ -590,8 +621,8 @@ rnFixes fixities rn_fixity_pieces mk_fixity name i fix = getRnEnv `thenRn` \ env -> case lookupGlobalRnEnv env name of - Just res | isLocallyDefined res || opt_CompilingPrelude - -- the opt_CompilingPrelude thing is a *HACK* to get (:)'s + Just res | isLocallyDefined res || opt_CompilingGhcInternals + -- the opt_CompilingGhcInternals thing is a *HACK* to get (:)'s -- fixity decl to go through. It has a builtin name, which -- doesn't respond to isLocallyDefined... sigh. -> returnRn (Just (mk_fixity res i)) @@ -716,7 +747,11 @@ dupLocalsExportErr locn locals@((str,_):_) classOpExportErr op locn = addShortErrLocLine locn $ \ sty -> - ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with class"] + ppBesides [ppStr "class operation `", ppr sty op, ppStr "' can only be exported with its class"] + +fieldExportErr op locn + = addShortErrLocLine locn $ \ sty -> + ppBesides [ppStr "field name `", ppr sty op, ppStr "' can only be exported with its data type"] synAllExportErr is_error syn locn = (if is_error then addShortErrLocLine else addShortWarnLocLine) locn $ \ sty -> diff --git a/ghc/compiler/rename/RnUtils.lhs b/ghc/compiler/rename/RnUtils.lhs index 7e50792..781aa8b 100644 --- a/ghc/compiler/rename/RnUtils.lhs +++ b/ghc/compiler/rename/RnUtils.lhs @@ -7,10 +7,11 @@ #include "HsVersions.h" module RnUtils ( - RnEnv(..), QualNames(..), - UnqualNames(..), ScopeStack(..), + SYN_IE(RnEnv), SYN_IE(QualNames), + SYN_IE(UnqualNames), SYN_IE(ScopeStack), emptyRnEnv, extendGlobalRnEnv, extendLocalRnEnv, lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv, + getLocalsFromRnEnv, lubExportFlag, @@ -19,14 +20,16 @@ module RnUtils ( ) where IMP_Ubiq(){-uitous-} +IMPORT_1_3(List(partition)) import Bag ( Bag, emptyBag, snocBag, unionBags ) -import CmdLineOpts ( opt_CompilingPrelude ) +import CmdLineOpts ( opt_CompilingGhcInternals ) import ErrUtils ( addShortErrLocLine ) import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, - lookupFM, addListToFM, addToFM ) + lookupFM, addListToFM, addToFM, eltsFM ) import Maybes ( maybeToBool ) -import Name ( RdrName(..), isQual, pprNonSym, getLocalName, ExportFlag(..) ) +import Name ( RdrName(..), ExportFlag(..), + isQual, pprNonSym, getLocalName, isLocallyDefined ) import PprStyle ( PprStyle(..) ) import Pretty import RnHsSyn ( RnName ) @@ -56,6 +59,9 @@ extendLocalRnEnv :: Bool -> RnEnv -> [RnName] -> (RnEnv, [RnName]) lookupRnEnv :: RnEnv -> RdrName -> Maybe RnName lookupGlobalRnEnv :: RnEnv -> RdrName -> Maybe RnName lookupTcRnEnv :: RnEnv -> RdrName -> Maybe RnName + +getLocalsFromRnEnv :: RnEnv -> ([RnName], [RnName]) + -- grabs the locally defined names from the unqual envs \end{code} If the @RdrName@ is a @Qual@, @lookupValue@ looks it up in the global @@ -129,8 +135,9 @@ lookupRnEnv ((qual, unqual, _, _), stack) rdr = case rdr of Unqual str -> lookup stack str (lookup unqual str Nothing) Qual mod str -> lookup qual (str,mod) - (if not opt_CompilingPrelude -- see below - then Nothing + (if not opt_CompilingGhcInternals -- see below + then -- pprTrace "lookupRnEnv:" (ppAboves (ppCat [ppPStr mod, ppPStr str] : [ ppCat [ppPStr m, ppPStr s] | (s,m) <- keysFM qual ])) $ + Nothing else lookup unqual str Nothing) where lookup fm thing do_on_fail @@ -143,7 +150,7 @@ lookupGlobalRnEnv ((qual, unqual, _, _), _) rdr Unqual str -> lookupFM unqual str Qual mod str -> case (lookupFM qual (str,mod)) of Just xx -> Just xx - Nothing -> if not opt_CompilingPrelude then + Nothing -> if not opt_CompilingGhcInternals then Nothing else -- "[]" may have turned into "Prelude.[]" and -- we are actually compiling "data [] a = ..."; @@ -156,10 +163,14 @@ lookupTcRnEnv ((_, _, tc_qual, tc_unqual), _) rdr Unqual str -> lookupFM tc_unqual str Qual mod str -> case (lookupFM tc_qual (str,mod)) of -- as above Just xx -> Just xx - Nothing -> if not opt_CompilingPrelude then + Nothing -> if not opt_CompilingGhcInternals then Nothing else lookupFM tc_unqual str + +getLocalsFromRnEnv ((_, vals, _, tcs), _) + = (filter isLocallyDefined (eltsFM vals), + filter isLocallyDefined (eltsFM tcs)) \end{code} ********************************************************* diff --git a/ghc/compiler/simplCore/AnalFBWW.lhs b/ghc/compiler/simplCore/AnalFBWW.lhs index 6c83afa..33ee877 100644 --- a/ghc/compiler/simplCore/AnalFBWW.lhs +++ b/ghc/compiler/simplCore/AnalFBWW.lhs @@ -10,7 +10,7 @@ module AnalFBWW ( analFBWW ) where IMP_Ubiq(){-uitous-} -import CoreSyn ( CoreBinding(..) ) +import CoreSyn ( SYN_IE(CoreBinding) ) import Util ( panic{-ToDo:rm-} ) --import Util diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index b52523b..9cf9d7c 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -23,7 +23,7 @@ import CoreSyn import FreeVars import Id ( emptyIdSet, unionIdSets, unionManyIdSets, - elementOfIdSet, IdSet(..) + elementOfIdSet, SYN_IE(IdSet), GenId ) import Util ( nOfThem, panic, zipEqual ) \end{code} @@ -198,7 +198,7 @@ fiExpr to_drop (_, AnnSCC cc expr) \begin{code} fiExpr to_drop (_, AnnCoerce c ty expr) - = _trace "fiExpr:Coerce:wimping out" $ + = trace "fiExpr:Coerce:wimping out" $ mkCoLets' to_drop (Coerce c ty (fiExpr [] expr)) \end{code} diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs index 361b3cf..b66b618 100644 --- a/ghc/compiler/simplCore/FloatOut.lhs +++ b/ghc/compiler/simplCore/FloatOut.lhs @@ -11,23 +11,24 @@ module FloatOut ( floatOutwards ) where IMP_Ubiq(){-uitous-} +IMPORT_1_3(List(partition)) import CoreSyn import CmdLineOpts ( opt_D_verbose_core2core, opt_D_simplifier_stats ) import CostCentre ( dupifyCC ) -import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList, IdEnv(..), +import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList, SYN_IE(IdEnv), GenId{-instance Outputable-} ) import Outputable ( Outputable(..){-instance (,)-} ) -import PprCore ( GenCoreBinding{-instance-} ) +import PprCore import PprStyle ( PprStyle(..) ) import PprType ( GenTyVar ) import Pretty ( ppInt, ppStr, ppBesides, ppAboves ) import SetLevels -- all of it import TyVar ( GenTyVar{-instance Eq-} ) import Unique ( Unique{-instance Eq-} ) -import Usage ( UVar(..) ) +import Usage ( SYN_IE(UVar) ) import Util ( pprTrace, panic ) \end{code} diff --git a/ghc/compiler/simplCore/FoldrBuildWW.lhs b/ghc/compiler/simplCore/FoldrBuildWW.lhs index 40fbba2..a3e559d 100644 --- a/ghc/compiler/simplCore/FoldrBuildWW.lhs +++ b/ghc/compiler/simplCore/FoldrBuildWW.lhs @@ -10,7 +10,8 @@ module FoldrBuildWW ( mkFoldrBuildWW ) where IMP_Ubiq(){-uitous-} -import CoreSyn ( CoreBinding(..) ) +import CoreSyn ( SYN_IE(CoreBinding) ) +import UniqSupply ( UniqSupply ) import Util ( panic{-ToDo:rm?-} ) --import Type ( cloneTyVarFromTemplate, mkTyVarTy, @@ -18,7 +19,7 @@ import Util ( panic{-ToDo:rm?-} ) --import TysPrim ( alphaTy ) --import TyVar ( alphaTyVar ) -- ---import Type ( Type(..) ) -- **** CAN SEE THE CONSTRUCTORS **** +--import Type ( SYN_IE(Type) ) -- **** CAN SEE THE CONSTRUCTORS **** --import UniqSupply ( runBuiltinUs ) --import WwLib -- share the same monad (is this eticit ?) --import PrelInfo ( listTyCon, mkListTy, nilDataCon, consDataCon, diff --git a/ghc/compiler/simplCore/MagicUFs.lhs b/ghc/compiler/simplCore/MagicUFs.lhs index 1df7968..1bef715 100644 --- a/ghc/compiler/simplCore/MagicUFs.lhs +++ b/ghc/compiler/simplCore/MagicUFs.lhs @@ -18,7 +18,7 @@ IMPORT_DELOOPER(IdLoop) -- paranoia checking import CoreSyn import SimplEnv ( SimplEnv ) -import SimplMonad ( SmplM(..), SimplCount ) +import SimplMonad ( SYN_IE(SmplM), SimplCount ) import Type ( mkFunTys ) import TysWiredIn ( mkListTy ) import Unique ( Unique{-instances-} ) @@ -79,8 +79,8 @@ magic_UFs_table (SLIT("build"), MUF build_fun), (SLIT("foldl"), MUF foldl_fun), (SLIT("foldr"), MUF foldr_fun), - (SLIT("unpackFoldrPS#"), MUF unpack_foldr_fun), - (SLIT("unpackAppendPS#"), MUF unpack_append_fun)] + (SLIT("unpackFoldrPS__"), MUF unpack_foldr_fun), + (SLIT("unpackAppendPS__"), MUF unpack_append_fun)] \end{code} %************************************************************************ @@ -227,7 +227,7 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list -- | do_fb_red && arg_list_isStringForm -- ok, its a string! - -- foldr f z "foo" => unpackFoldrPS# f z "foo"# + -- foldr f z "foo" => unpackFoldrPS__ f z "foo"# = tick Str_FoldrStr `thenSmpl_` returnSmpl (Just (mkGenApp (Var unpackCStringFoldrId) (TypeArg ty2: diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 4d36323..8a91871 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -25,16 +25,16 @@ import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) ) import CoreSyn import Digraph ( stronglyConnComp ) import Id ( idWantsToBeINLINEd, isConstMethodId, + externallyVisibleId, emptyIdSet, unionIdSets, mkIdSet, unitIdSet, elementOfIdSet, - addOneToIdSet, IdSet(..), + addOneToIdSet, SYN_IE(IdSet), nullIdEnv, unitIdEnv, combineIdEnvs, delOneFromIdEnv, delManyFromIdEnv, - mapIdEnv, lookupIdEnv, IdEnv(..), + mapIdEnv, lookupIdEnv, SYN_IE(IdEnv), GenId{-instance Eq-} ) import Maybes ( maybeToBool ) -import Name ( isExported ) import Outputable ( Outputable(..){-instance * (,) -} ) import PprCore import PprStyle ( PprStyle(..) ) @@ -138,7 +138,7 @@ tagBinder usage binder ) usage_of usage binder - | isExported binder = ManyOcc 0 -- Exported things count as many + | externallyVisibleId binder = ManyOcc 0 -- Visible-elsewhere things count as many | otherwise = case (lookupIdEnv usage binder) of Nothing -> DeadCode @@ -171,7 +171,7 @@ occurAnalyseBinds binds simplifier_sw_chkr binds' | otherwise = binds' where - (_, binds') = do initial_env binds + (_, binds') = doo initial_env binds initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings) (simplifier_sw_chkr KeepSpecPragmaIds) @@ -179,12 +179,12 @@ occurAnalyseBinds binds simplifier_sw_chkr (simplifier_sw_chkr IgnoreINLINEPragma) emptyIdSet - do env [] = (emptyDetails, []) - do env (bind:binds) + doo env [] = (emptyDetails, []) + doo env (bind:binds) = (final_usage, new_binds ++ the_rest) where new_env = env `addNewCands` (bindersOf bind) - (binds_usage, the_rest) = do new_env binds + (binds_usage, the_rest) = doo new_env binds (final_usage, new_binds) = occAnalBind env bind binds_usage \end{code} diff --git a/ghc/compiler/simplCore/SAT.lhs b/ghc/compiler/simplCore/SAT.lhs index cac46f1..7ef97db 100644 --- a/ghc/compiler/simplCore/SAT.lhs +++ b/ghc/compiler/simplCore/SAT.lhs @@ -49,7 +49,6 @@ doStaticArgs = panic "SAT.doStaticArgs (ToDo)" {- LATER: to end of file: -import Maybes ( Maybe(..) ) import SATMonad import Util \end{code} diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs index 029d856..e37a9fd 100644 --- a/ghc/compiler/simplCore/SATMonad.lhs +++ b/ghc/compiler/simplCore/SATMonad.lhs @@ -32,12 +32,11 @@ module SATMonad ( import Type ( mkTyVarTy, mkSigmaTy, TyVarTemplate, splitSigmaTy, splitFunTy, - glueTyArgs, instantiateTy, TauType(..), - Class, ThetaType(..), SigmaType(..), + glueTyArgs, instantiateTy, SYN_IE(TauType), + Class, SYN_IE(ThetaType), SYN_IE(SigmaType), InstTyEnv(..) ) import Id ( mkSysLocal, idType ) -import Maybes ( Maybe(..) ) import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) import UniqSupply import Util diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index f4bdc82..08f4b16 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -32,7 +32,7 @@ import Id ( idType, mkSysLocal, toplevelishId, nullIdEnv, addOneToIdEnv, growIdEnvList, unionManyIdSets, minusIdSet, mkIdSet, idSetToList, - lookupIdEnv, IdEnv(..) + lookupIdEnv, SYN_IE(IdEnv) ) import Pretty ( ppStr, ppBesides, ppChar, ppInt ) import SrcLoc ( mkUnknownSrcLoc ) @@ -40,13 +40,14 @@ import Type ( isPrimType, mkTyVarTys, mkForAllTys ) import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList, lookupTyVarEnv, tyVarSetToList, - TyVarEnv(..), + SYN_IE(TyVarEnv), unionManyTyVarSets ) import UniqSupply ( thenUs, returnUs, mapUs, mapAndUnzipUs, - mapAndUnzip3Us, getUnique, UniqSM(..) + mapAndUnzip3Us, getUnique, SYN_IE(UniqSM), + UniqSupply ) -import Usage ( UVar(..) ) +import Usage ( SYN_IE(UVar) ) import Util ( mapAccumL, zipWithEqual, zipEqual, panic, assertPanic ) isLeakFreeType x y = False -- safe option; ToDo @@ -406,7 +407,7 @@ setFloatLevel alreadyLetBound ctxt_lvl envs@(venv, tenv) -- any harm, and not floating it may pin something important. For -- example -- --- x = let v = Nil +-- x = let v = [] -- w = 1:v -- in ... -- diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs index 8e7656b..aa63f03 100644 --- a/ghc/compiler/simplCore/SimplCase.lhs +++ b/ghc/compiler/simplCore/SimplCase.lhs @@ -24,7 +24,7 @@ import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp, unTagBindersAlts ) import Id ( idType, isDataCon, getIdDemandInfo, - DataCon(..), GenId{-instance Eq-} + SYN_IE(DataCon), GenId{-instance Eq-} ) import IdInfo ( willBeDemanded, DemandInfo ) import Literal ( isNoRepLit, Literal{-instance Eq-} ) diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index c8235b2..ebd97c2 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -41,7 +41,7 @@ import FoldrBuildWW ( mkFoldrBuildWW ) import Id ( idType, toplevelishId, idWantsToBeINLINEd, unfoldingUnfriendlyId, nullIdEnv, addOneToIdEnv, delOneFromIdEnv, - lookupIdEnv, IdEnv(..), + lookupIdEnv, SYN_IE(IdEnv), GenId{-instance Outputable-} ) import IdInfo ( mkUnfolding ) @@ -49,12 +49,11 @@ import LiberateCase ( liberateCase ) import MagicUFs ( MagicUnfoldingFun ) import Maybes ( maybeToBool ) import Outputable ( Outputable(..){-instance * (,) -} ) -import PprCore ( pprCoreBinding, GenCoreExpr{-instance Outputable-} ) +import PprCore import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} ) import Pretty ( ppShow, ppAboves, ppAbove, ppCat, ppStr ) import SAT ( doStaticArgs ) -import SCCauto ( addAutoCostCentres ) import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount ) import SimplPgm ( simplifyPgm ) import SimplVar ( leastItCouldCost ) @@ -241,16 +240,9 @@ core2core core_todos module_name ppr_style us local_tycons tycon_specs binds end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation" } #endif - CoreDoAutoCostCentres - -> _scc_ "AutoSCCs" - begin_pass "AutoSCCs" >> - case (addAutoCostCentres module_name binds) of { binds2 -> - end_pass False us2 binds2 inline_env spec_data simpl_stats "AutoSCCs" } - CoreDoPrintCore -- print result of last pass -> end_pass True us2 binds inline_env spec_data simpl_stats "Print" - ------------------------------------------------- begin_pass diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 7cd9524..0ec9ac5 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -31,16 +31,16 @@ module SimplEnv ( setEnclosingCC, -- Types - SwitchChecker(..), + SYN_IE(SwitchChecker), SimplEnv, EnclosingCcDetails(..), - InIdEnv(..), IdVal(..), InTypeEnv(..), + SYN_IE(InIdEnv), IdVal(..), SYN_IE(InTypeEnv), UnfoldEnv, UnfoldItem, UnfoldConApp, - InId(..), InBinder(..), InBinding(..), InType(..), - OutId(..), OutBinder(..), OutBinding(..), OutType(..), + SYN_IE(InId), SYN_IE(InBinder), SYN_IE(InBinding), SYN_IE(InType), + SYN_IE(OutId), SYN_IE(OutBinder), SYN_IE(OutBinding), SYN_IE(OutType), - InExpr(..), InAlts(..), InDefault(..), InArg(..), - OutExpr(..), OutAlts(..), OutDefault(..), OutArg(..) + SYN_IE(InExpr), SYN_IE(InAlts), SYN_IE(InDefault), SYN_IE(InArg), + SYN_IE(OutExpr), SYN_IE(OutAlts), SYN_IE(OutDefault), SYN_IE(OutArg) ) where IMP_Ubiq(){-uitous-} @@ -63,7 +63,7 @@ import Id ( idType, getIdUnfolding, getIdStrictness, applyTypeEnvToId, nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv, addOneToIdEnv, modifyIdEnv, mkIdSet, - IdEnv(..), IdSet(..), GenId ) + SYN_IE(IdEnv), SYN_IE(IdSet), GenId ) import IdInfo ( bottomIsGuaranteed, StrictnessInfo ) import Literal ( isNoRepLit, Literal{-instances-} ) import Maybes ( maybeToBool ) @@ -75,16 +75,15 @@ import PprStyle ( PprStyle(..) ) import PprType ( GenType, GenTyVar ) import Pretty import Type ( eqTy, getAppDataTyConExpandingDicts, applyTypeEnvToTy ) -import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv, - growTyVarEnvList, - TyVarEnv(..), GenTyVar{-instance Eq-} +import TyVar ( nullTyVarEnv, addOneToTyVarEnv, growTyVarEnvList, + SYN_IE(TyVarEnv), GenTyVar{-instance Eq-} ) import Unique ( Unique{-instance Outputable-} ) import UniqFM ( addToUFM_Directly, lookupUFM_Directly, delFromUFM_Directly, delFromUFM, ufmToList ) --import UniqSet -- lots of things -import Usage ( UVar(..), GenUsage{-instances-} ) +import Usage ( SYN_IE(UVar), GenUsage{-instances-} ) import Util ( zipEqual, thenCmp, cmpList, panic, panic#, assertPanic ) type TypeEnv = TyVarEnv Type @@ -453,9 +452,6 @@ type OutAlts = CoreCaseAlts type OutDefault = CoreCaseDefault type OutArg = CoreArg -\end{code} - -\begin{code} type SwitchChecker = SimplifierSwitch -> SwitchResult \end{code} diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index f1a1257..9413623 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -7,7 +7,7 @@ #include "HsVersions.h" module SimplMonad ( - SmplM(..), + SYN_IE(SmplM), initSmpl, returnSmpl, thenSmpl, thenSmpl_, mapSmpl, mapAndUnzipSmpl, @@ -21,6 +21,7 @@ module SimplMonad ( ) where IMP_Ubiq(){-uitous-} +IMPORT_1_3(Ix) IMPORT_DELOOPER(SmplLoop) -- well, cheating sort of @@ -140,9 +141,9 @@ data TickType | Foldr_Cons_Nil -- foldr (:) [] => id | Foldr_Cons -- foldr (:) => flip (++) - | Str_FoldrStr -- foldr f z "hello" => unpackFoldrPS# f z "hello" - | Str_UnpackCons -- unpackFoldrPS# (:) z "hello" => unpackAppendPS# z "hello" - | Str_UnpackNil -- unpackAppendPS# [] "hello" => "hello" + | Str_FoldrStr -- foldr f z "hello" => unpackFoldrPS__ f z "hello" + | Str_UnpackCons -- unpackFoldrPS# (:) z "hello" => unpackAppendPS__ z "hello" + | Str_UnpackNil -- unpackAppendPS__ [] "hello" => "hello" {- END F/B ENTRIES -} deriving (Eq, Ord, Ix) diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs index 692f720..8786a69 100644 --- a/ghc/compiler/simplCore/SimplPgm.lhs +++ b/ghc/compiler/simplCore/SimplPgm.lhs @@ -16,18 +16,17 @@ import CmdLineOpts ( opt_D_verbose_core2core, import CoreSyn import CoreUtils ( substCoreExpr ) import Id ( externallyVisibleId, - mkIdEnv, lookupIdEnv, IdEnv(..), + mkIdEnv, lookupIdEnv, SYN_IE(IdEnv), GenId{-instance Ord3-} ) import Maybes ( catMaybes ) -import Name ( isExported ) import OccurAnal ( occurAnalyseBinds ) import Pretty ( ppAboves, ppBesides, ppInt, ppChar, ppStr ) import SimplEnv import SimplMonad import Simplify ( simplTopBinds ) -import TyVar ( nullTyVarEnv, TyVarEnv(..) ) -import UniqSupply ( thenUs, returnUs, mapUs, splitUniqSupply, UniqSM(..) ) +import TyVar ( nullTyVarEnv, SYN_IE(TyVarEnv) ) +import UniqSupply ( thenUs, returnUs, mapUs, splitUniqSupply, SYN_IE(UniqSM) ) import Util ( isIn, isn'tIn, removeDups, pprTrace ) \end{code} @@ -144,7 +143,7 @@ tidy_top binds_in find_cand blast_list (Rec _) = blast_list -- recursively paranoid, as usual find_cand blast_list (NonRec binder rhs) - = if not (isExported binder) then + = if not (externallyVisibleId binder) then blast_list else case rhs_equiv_to_local_var rhs of diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index 043cd3d..be0ac48 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -46,6 +46,32 @@ import Util ( pprTrace, assertPanic, panic ) This where all the heavy-duty unfolding stuff comes into its own. + +completeVar env var args + | has_magic_unfolding + = tick MagicUnfold `thenSmpl_` + doMagicUnfold + + | has_unfolding && ok_to_inline + = tick UnfoldingDone `thenSmpl_` + simplExpr env the_unfolding args + + | has_specialisation + = tick SpecialisationDone `thenSmpl_` + simplExpr (extendTyEnvList env spec_bindings) + the_specialisation + remaining_args + + | otherwise + = mkGenApp (Var var) args + + where + unfolding = lookupUnfolding env var + + (has_magic_unfolding, do_magic_unfold) + = case unfolding of + MagicForm str magic_fn + \begin{code} completeVar :: SimplEnv -> OutId -> [OutArg] -> SmplM OutExpr diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 240f4b3..99367d2 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -14,6 +14,7 @@ IMPORT_DELOOPER(SmplLoop) -- paranoia checking import BinderInfo import CmdLineOpts ( SimplifierSwitch(..) ) import ConFold ( completePrim ) +import CostCentre ( isSccCountCostCentre, cmpCostCentre ) import CoreSyn import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp, unTagBinders, squashableDictishCcExpr, @@ -482,32 +483,45 @@ simplExpr env (Coerce coercion ty body) args Set-cost-centre ~~~~~~~~~~~~~~~ -A special case we do: -\begin{verbatim} - scc "foo" (\x -> e) ===> \x -> scc "foo" e -\end{verbatim} -Simon thinks it's OK, at least for lexical scoping; and it makes -interfaces change less (arities). +1) Eliminating nested sccs ... +We must be careful to maintain the scc counts ... \begin{code} +simplExpr env (SCC cc1 (SCC cc2 expr)) args + | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False } + -- eliminate inner scc if no call counts and same cc as outer + = simplExpr env (SCC cc1 expr) args + + | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1) + -- eliminate outer scc if no call counts associated with either ccs + = simplExpr env (SCC cc2 expr) args +\end{code} + +2) Moving sccs inside lambdas ... + +\begin{code} +simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args + | not (isSccCountCostCentre cc) + -- move scc inside lambda only if no call counts + = simplExpr env (Lam binder (SCC cc body)) args + simplExpr env (SCC cc (Lam binder body)) args + -- always ok to move scc inside type/usage lambda = simplExpr env (Lam binder (SCC cc body)) args \end{code} -Some other slightly turgid SCC tidying-up cases: -\begin{code} -simplExpr env (SCC cc1 expr@(SCC _ _)) args - = simplExpr env expr args - -- the outer _scc_ serves no purpose +3) Eliminating dict sccs ... +\begin{code} simplExpr env (SCC cc expr) args | squashableDictishCcExpr cc expr + -- eliminate dict cc if trivial dict expression = simplExpr env expr args - -- the DICT-ish CC is no longer serving any purpose \end{code} -NB: for other set-cost-centre we move arguments inside the body. -ToDo: check with Patrick that this is ok. +4) Moving arguments inside the body of an scc ... +This moves the cost of doing the application inside the scc +(which may include the cost of extracting methods etc) \begin{code} simplExpr env (SCC cost_centre body) args diff --git a/ghc/compiler/simplCore/SmplLoop_1_3.lhi b/ghc/compiler/simplCore/SmplLoop_1_3.lhi new file mode 100644 index 0000000..ef837c9 --- /dev/null +++ b/ghc/compiler/simplCore/SmplLoop_1_3.lhi @@ -0,0 +1,8 @@ +\begin{code} +interface SmplLoop_1_3 1 +__exports__ +SimplUtils simplIdWantsToBeINLINEd (..) +Simplify simplExpr (..) +Simplify simplBind (..) +MagicUFs MagicUnfoldingFun +\end{code} diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs index 1d88e2f..5f14b60 100644 --- a/ghc/compiler/simplStg/LambdaLift.lhs +++ b/ghc/compiler/simplStg/LambdaLift.lhs @@ -15,8 +15,8 @@ import StgSyn import Bag ( emptyBag, unionBags, unitBag, snocBag, bagToList ) import Id ( idType, mkSysLocal, addIdArity, mkIdSet, unitIdSet, minusIdSet, - unionManyIdSets, idSetToList, IdSet(..), - nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..) + unionManyIdSets, idSetToList, SYN_IE(IdSet), + nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv) ) import SrcLoc ( mkUnknownSrcLoc ) import Type ( splitForAllTy, mkForAllTys, mkFunTys ) @@ -148,7 +148,7 @@ liftExpr expr@(StgPrim op args lvs) = returnLM (expr, emptyLiftInfo) liftExpr expr@(StgApp (StgLitArg lit) args lvs) = returnLM (expr, emptyLiftInfo) liftExpr expr@(StgApp (StgVarArg v) args lvs) - = lookup v `thenLM` \ ~(sc, sc_args) -> -- NB the ~. We don't want to + = lookUp v `thenLM` \ ~(sc, sc_args) -> -- NB the ~. We don't want to -- poke these bindings too early! returnLM (StgApp (StgVarArg sc) (map StgVarArg sc_args ++ args) lvs, emptyLiftInfo) @@ -447,8 +447,8 @@ newSupercombinator ty arity ci us idenv where uniq = getUnique us -lookup :: Id -> LiftM (Id,[Id]) -lookup v ci us idenv +lookUp :: Id -> LiftM (Id,[Id]) +lookUp v ci us idenv = case (lookupIdEnv idenv v) of Just result -> result Nothing -> (v, []) diff --git a/ghc/compiler/simplStg/SatStgRhs.lhs b/ghc/compiler/simplStg/SatStgRhs.lhs index 9feec28..725bf48 100644 --- a/ghc/compiler/simplStg/SatStgRhs.lhs +++ b/ghc/compiler/simplStg/SatStgRhs.lhs @@ -67,12 +67,12 @@ import StgSyn import CostCentre ( isCafCC, subsumedCosts, useCurrentCostCentre ) import Id ( idType, getIdArity, addIdArity, mkSysLocal, nullIdEnv, addOneToIdEnv, growIdEnvList, - lookupIdEnv, IdEnv(..) + lookupIdEnv, SYN_IE(IdEnv) ) import IdInfo ( arityMaybe ) import SrcLoc ( mkUnknownSrcLoc ) import Type ( splitSigmaTy, splitForAllTy, splitFunTyExpandingDicts ) -import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) ) +import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) ) import Util ( panic, assertPanic ) type Count = Int @@ -292,10 +292,10 @@ saturate other _ = panic "SatStgRhs: saturate" \begin{code} lookupArgs :: SatEnv -> [StgArg] -> [StgArg] -lookupArgs env args = map do args +lookupArgs env args = map doo args where - do (StgVarArg v) = StgVarArg (lookupVar env v) - do a@(StgLitArg lit) = a + doo (StgVarArg v) = StgVarArg (lookupVar env v) + doo a@(StgLitArg lit) = a lookupVar :: SatEnv -> Id -> Id lookupVar env v = case lookupIdEnv env v of diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index f57744c..1f45f07 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -9,6 +9,7 @@ module SimplStg ( stg2stg ) where IMP_Ubiq(){-uitous-} +IMPORT_1_3(IO(hPutStr,stderr)) import StgSyn import StgUtils @@ -27,12 +28,12 @@ import CmdLineOpts ( opt_EnsureSplittableC, opt_SccGroup, opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg, StgToDo(..) ) -import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv, - growIdEnvList, isNullIdEnv, IdEnv(..), +import Id ( externallyVisibleId, + nullIdEnv, lookupIdEnv, addOneToIdEnv, + growIdEnvList, isNullIdEnv, SYN_IE(IdEnv), GenId{-instance Eq/Outputable -} ) import Maybes ( maybeToBool ) -import Name ( isExported ) import PprType ( GenType{-instance Outputable-} ) import Pretty ( ppShow, ppAbove, ppAboves, ppStr ) import UniqSupply ( splitUniqSupply ) @@ -320,8 +321,8 @@ elimIndirections binds_in lambda_args (StgApp (StgVarArg local_binder) fun_args _) )) - | isExported exported_binder && -- Only if this is exported - not (isExported local_binder) && -- Only if this one is defined in this + | externallyVisibleId exported_binder && -- Only if this is exported + not (externallyVisibleId local_binder) && -- Only if this one is defined in this isLocallyDefined local_binder && -- module, so that we *can* change its -- binding to be the exported thing! not (in_dom env_so_far local_binder) && -- Only if we havn't seen it before diff --git a/ghc/compiler/simplStg/StgSAT.lhs b/ghc/compiler/simplStg/StgSAT.lhs index 3d82b27..9e356f0 100644 --- a/ghc/compiler/simplStg/StgSAT.lhs +++ b/ghc/compiler/simplStg/StgSAT.lhs @@ -36,7 +36,7 @@ module StgSAT ( doStaticArgs ) where IMP_Ubiq(){-uitous-} import StgSyn -import UniqSupply ( UniqSM(..) ) +import UniqSupply ( SYN_IE(UniqSM) ) import Util ( panic ) \end{code} diff --git a/ghc/compiler/simplStg/StgStats.lhs b/ghc/compiler/simplStg/StgStats.lhs index d1dd34c..27b5822 100644 --- a/ghc/compiler/simplStg/StgStats.lhs +++ b/ghc/compiler/simplStg/StgStats.lhs @@ -29,7 +29,7 @@ IMP_Ubiq(){-uitous-} import StgSyn -import FiniteMap ( emptyFM, plusFM_C, unitFM, fmToList ) +import FiniteMap ( emptyFM, plusFM_C, unitFM, fmToList, FiniteMap ) \end{code} \begin{code} diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs index 1947e95..76403af 100644 --- a/ghc/compiler/simplStg/StgVarInfo.lhs +++ b/ghc/compiler/simplStg/StgVarInfo.lhs @@ -18,10 +18,10 @@ import StgSyn import Id ( emptyIdSet, mkIdSet, minusIdSet, unionIdSets, unionManyIdSets, isEmptyIdSet, unitIdSet, intersectIdSets, - addOneToIdSet, IdSet(..), + addOneToIdSet, SYN_IE(IdSet), nullIdEnv, growIdEnvList, lookupIdEnv, unitIdEnv, combineIdEnvs, delManyFromIdEnv, - rngIdEnv, IdEnv(..), + rngIdEnv, SYN_IE(IdEnv), GenId{-instance Eq-} ) import Maybes ( maybeToBool ) @@ -622,12 +622,12 @@ returnLne :: a -> LneM a returnLne e sw env lvs_cont = e thenLne :: LneM a -> (a -> LneM b) -> LneM b -(m `thenLne` k) sw env lvs_cont +thenLne m k sw env lvs_cont = case (m sw env lvs_cont) of m_result -> k m_result sw env lvs_cont thenLne_ :: LneM a -> LneM b -> LneM b -(m `thenLne_` k) sw env lvs_cont +thenLne_ m k sw env lvs_cont = case (m sw env lvs_cont) of _ -> k sw env lvs_cont diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs index 103b633..5a98a3e 100644 --- a/ghc/compiler/simplStg/UpdAnal.lhs +++ b/ghc/compiler/simplStg/UpdAnal.lhs @@ -22,11 +22,10 @@ > > {- LATER: to end of file: > --import Type ( splitFunTy, splitSigmaTy, Class, TyVarTemplate, -> -- TauType(..) +> -- SYN_IE(TauType) > -- ) > --import Id > --import IdInfo -> --import Outputable ( isExported ) > --import Pretty > --import SrcLoc ( mkUnknownSrcLoc ) > --import StgSyn @@ -507,7 +506,7 @@ suffice for now. > StgRec bs -> StgRec [ (attachOne v, rhs) | (v, rhs) <- bs ] > > where attachOne v -> | isExported v +> | externallyVisibleId v > = let c = lookup v p in > addIdUpdateInfo v > (mkUpdateInfo (mkUpdateSpec v c)) diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs index 28b306d..2d94809 100644 --- a/ghc/compiler/specialise/SpecEnv.lhs +++ b/ghc/compiler/specialise/SpecEnv.lhs @@ -7,7 +7,7 @@ #include "HsVersions.h" module SpecEnv ( - SpecEnv(..), MatchEnv, + SYN_IE(SpecEnv), MatchEnv, nullSpecEnv, isNullSpecEnv, addOneToSpecEnv, lookupSpecEnv, specEnvToList @@ -17,7 +17,7 @@ IMP_Ubiq() import MatchEnv import Type ( matchTys, isTyVarTy ) -import Usage ( UVar(..) ) +import Usage ( SYN_IE(UVar) ) \end{code} @@ -36,6 +36,22 @@ then \begin{verbatim} f (List Int) Bool d ===> f' Int Bool \end{verbatim} +All the stuff about how many dictionaries to discard, and what types +to apply the specialised function to, are handled by the fact that the +SpecEnv contains a template for the result of the specialisation. + +There is one more exciting case, which is dealt with in exactly the same +way. If the specialised value is unboxed then it is lifted at its +definition site and unlifted at its uses. For example: + + pi :: forall a. Num a => a + +might have a specialisation + + [Int#] ===> (case pi' of Lift pi# -> pi#) + +where pi' :: Lift Int# is the specialised version of pi. + \begin{code} nullSpecEnv :: SpecEnv diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index 62d9a01..bd7ec63 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -8,7 +8,7 @@ module SpecUtils ( specialiseCallTys, - ConstraintVector(..), + SYN_IE(ConstraintVector), getIdOverloading, mkConstraintVector, isUnboxedSpecialisation, diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index dcbf88c..266d177 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -14,30 +14,32 @@ module Specialise ( ) where IMP_Ubiq(){-uitous-} +IMPORT_1_3(List(partition)) import Bag ( emptyBag, unitBag, isEmptyBag, unionBags, partitionBag, listToBag, bagToList ) import Class ( GenClass{-instance Eq-} ) import CmdLineOpts ( opt_SpecialiseImports, opt_D_simplifier_stats, - opt_CompilingPrelude, opt_SpecialiseTrace, + opt_CompilingGhcInternals, opt_SpecialiseTrace, opt_SpecialiseOverloaded, opt_SpecialiseUnboxed, opt_SpecialiseAll ) import CoreLift ( mkLiftedId, liftExpr, bindUnlift, applyBindUnlifts ) import CoreSyn import CoreUtils ( coreExprType, squashableDictishCcExpr ) -import FiniteMap ( addListToFM_C ) +import FiniteMap ( addListToFM_C, FiniteMap ) +import Kind ( mkBoxedTypeKind ) import Id ( idType, isDefaultMethodId_maybe, toplevelishId, isSuperDictSelId_maybe, isBottomingId, isConstMethodId_maybe, isDataCon, isImportedId, mkIdWithNewUniq, dataConTyCon, applyTypeEnvToId, nullIdEnv, addOneToIdEnv, growIdEnvList, - lookupIdEnv, IdEnv(..), + lookupIdEnv, SYN_IE(IdEnv), emptyIdSet, mkIdSet, unitIdSet, elementOfIdSet, minusIdSet, - unionIdSets, unionManyIdSets, IdSet(..), + unionIdSets, unionManyIdSets, SYN_IE(IdSet), GenId{-instance Eq-} ) import Literal ( Literal{-instance Outputable-} ) @@ -50,7 +52,7 @@ import PprType ( pprGenType, pprParendGenType, pprMaybeTy, TyCon{-ditto-} ) import Pretty ( ppHang, ppCat, ppStr, ppAboves, ppBesides, - ppInt, ppSP, ppInterleave, ppNil, Pretty(..) + ppInt, ppSP, ppInterleave, ppNil, SYN_IE(Pretty) ) import PrimOp ( PrimOp(..) ) import SpecUtils @@ -58,9 +60,9 @@ import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, getAppDataTyConExpandingDicts, tyVarsOfTypes, applyTypeEnvToTy, isUnboxedType ) import TyCon ( TyCon{-instance Eq-} ) -import TyVar ( cloneTyVar, - elementOfTyVarSet, TyVarSet(..), - nullTyVarEnv, growTyVarEnvList, TyVarEnv(..), +import TyVar ( cloneTyVar, mkSysTyVar, + elementOfTyVarSet, SYN_IE(TyVarSet), + nullTyVarEnv, growTyVarEnvList, SYN_IE(TyVarEnv), GenTyVar{-instance Eq-} ) import TysWiredIn ( liftDataCon ) @@ -87,7 +89,6 @@ isSpecId_maybe = panic "Specialise.isSpecId_maybe (ToDo)" isSpecPragmaId_maybe = panic "Specialise.isSpecPragmaId_maybe (ToDo)" lookupClassInstAtSimpleType = panic "Specialise.lookupClassInstAtSimpleType (ToDo)" lookupSpecEnv = panic "Specialise.lookupSpecEnv (ToDo)" -mkPolySysTyVar = panic "Specialise.mkPolySysTyVar (ToDo)" mkSpecEnv = panic "Specialise.mkSpecEnv (ToDo)" mkSpecId = panic "Specialise.mkSpecId (ToDo)" selectIdInfoForSpecId = panic "Specialise.selectIdInfoForSpecId (ToDo)" @@ -1198,7 +1199,7 @@ specTyConsAndScope scopeM = scopeM `thenSM` \ (binds, scope_uds) -> let (tycons_cis, gotci_scope_uds) - = getLocalSpecTyConIs opt_CompilingPrelude scope_uds + = getLocalSpecTyConIs opt_CompilingGhcInternals scope_uds tycon_specs_list = collectTyConSpecs tycons_cis in @@ -2418,10 +2419,8 @@ newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore newTyVars :: Int -> SpecM [TyVar] -newTyVars n tvenv idenv us - = map mkPolySysTyVar uniqs - where - uniqs = getUniques n us +newTyVars n tvenv idenv us + = [mkSysTyVar uniq mkBoxedTypeKind | uniq <- getUniques n us] \end{code} @cloneLambdaOrCaseBinders@ and @cloneLetBinders@ take a bunch of diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 59e1c40..7d7f5e3 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -9,13 +9,13 @@ Convert a @CoreSyntax@ program to a @StgSyntax@ program. - \begin{code} #include "HsVersions.h" module CoreToStg ( topCoreBindsToStg ) where IMP_Ubiq(){-uitous-} +IMPORT_1_3(Ratio(numerator,denominator)) import CoreSyn -- input import StgSyn -- output @@ -24,11 +24,11 @@ import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList ) import CoreUtils ( coreExprType ) import CostCentre ( noCostCentre ) import Id ( mkSysLocal, idType, isBottomingId, + externallyVisibleId, nullIdEnv, addOneToIdEnv, lookupIdEnv, - IdEnv(..), GenId{-instance NamedThing-} + SYN_IE(IdEnv), GenId{-instance NamedThing-} ) import Literal ( mkMachInt, Literal(..) ) -import Name ( isExported ) import PrelVals ( unpackCStringId, unpackCString2Id, integerZeroId, integerPlusOneId, integerPlusTwoId, integerMinusOneId @@ -197,12 +197,13 @@ coreBindToStg env (NonRec binder rhs) let -- Binds to return if RHS is trivial - triv_binds = if isExported binder then + triv_binds = if externallyVisibleId binder then + -- pprTrace "coreBindToStg:keeping:" (ppCat [ppr PprDebug binder, ppr PprDebug (externallyVisibleId binder)]) $ [StgNonRec binder stg_rhs] -- Retain it else + -- pprTrace "coreBindToStg:tossing:" (ppCat [ppr PprDebug binder, ppr PprDebug (externallyVisibleId binder)]) $ [] -- Discard it in - -- pprTrace "coreBindToStg:" (ppCat [ppr PprDebug binder, ppr PprDebug (isExported binder)]) $ case stg_rhs of StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) -> -- Trivial RHS, so augment envt, and ditch the binding @@ -645,9 +646,7 @@ coreExprToStg env (SCC cc expr) \end{code} \begin{code} -coreExprToStg env (Coerce c ty expr) - = coreExprToStg env expr -- `thenUs` \ (stg_expr, binds) -> --- returnUs (StgSCC (coreExprType expr) cc stg_expr, binds) +coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr \end{code} diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index d549f56..6d0c4e9 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -16,7 +16,7 @@ import Bag ( emptyBag, isEmptyBag, snocBag, foldBag ) import Id ( idType, isDataCon, dataConArgTys, emptyIdSet, isEmptyIdSet, elementOfIdSet, mkIdSet, intersectIdSets, - unionIdSets, idSetToList, IdSet(..), + unionIdSets, idSetToList, SYN_IE(IdSet), GenId{-instanced NamedThing-} ) import Literal ( literalType, Literal{-instance Outputable-} ) @@ -522,7 +522,7 @@ pp_expr sty expr = ppr sty expr sleazy_eq_ty ty1 ty2 -- NB: probably severe overkill (WDP 95/04) - = _trace "StgLint.sleazy_eq_ty:use eqSimplTy?" $ + = trace "StgLint.sleazy_eq_ty:use eqSimplTy?" $ case (splitFunTyExpandingDicts ty1) of { (tyargs1,tyres1) -> case (splitFunTyExpandingDicts ty2) of { (tyargs2,tyres2) -> let diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index c4fca6d..bac7e8a 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -13,7 +13,7 @@ suited to spineless tagless code generation. module StgSyn ( GenStgArg(..), - GenStgLiveVars(..), + SYN_IE(GenStgLiveVars), GenStgBinding(..), GenStgExpr(..), GenStgRhs(..), GenStgCaseAlts(..), GenStgCaseDefault(..), @@ -26,23 +26,23 @@ module StgSyn ( combineStgBinderInfo, -- a set of synonyms for the most common (only :-) parameterisation - StgArg(..), StgLiveVars(..), - StgBinding(..), StgExpr(..), StgRhs(..), - StgCaseAlts(..), StgCaseDefault(..), + SYN_IE(StgArg), SYN_IE(StgLiveVars), + SYN_IE(StgBinding), SYN_IE(StgExpr), SYN_IE(StgRhs), + SYN_IE(StgCaseAlts), SYN_IE(StgCaseDefault), pprPlainStgBinding, getArgPrimRep, isLitLitArg, stgArity, - collectExportedStgBinders + collectFinalStgBinders ) where IMP_Ubiq(){-uitous-} import CostCentre ( showCostCentre ) -import Id ( idPrimRep, GenId{-instance NamedThing-} ) +import Id ( externallyVisibleId, idPrimRep, GenId{-instance NamedThing-} ) import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} ) -import Name ( isExported, isSymLexeme ) +import Name ( isSymLexeme ) import Outputable ( ifPprDebug, interppSP, interpp'SP, Outputable(..){-instance * Bool-} ) @@ -51,7 +51,7 @@ import PprType ( GenType{-instance Outputable-} ) import Pretty -- all of it import PrimOp ( PrimOp{-instance Outputable-} ) import Unique ( pprUnique ) -import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet(..) ) +import UniqSet ( isEmptyUniqSet, uniqSetToList, SYN_IE(UniqSet) ) import Util ( panic ) \end{code} @@ -476,17 +476,17 @@ final pre-codegen STG code, so as to be sure we have the latest/greatest pragma info. \begin{code} -collectExportedStgBinders +collectFinalStgBinders :: [StgBinding] -- input program - -> [Id] -- exported top-level Ids + -> [Id] -- final externally-visible top-level Ids -collectExportedStgBinders binds +collectFinalStgBinders binds = ex [] binds where ex es [] = es ex es ((StgNonRec b _) : binds) - = if not (isExported b) then + = if not (externallyVisibleId b) then ex es binds else ex (b:es) binds @@ -706,7 +706,7 @@ pprStgRhs sty (StgRhsClosure cc bi free_vars upd_flag args body) pprStgRhs sty (StgRhsCon cc con args) = ppBesides [ ppStr (showCostCentre sty True{-as String-} cc), - ppSP, ppr sty con, ppStr " [", interppSP sty args, ppStr "]" ] + ppSP, ppr sty con, ppStr "! [", interppSP sty args, ppStr "]" ] -------------- pp_binder_info PprForUser _ = ppNil diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs index f09e9c9..2050131 100644 --- a/ghc/compiler/stranal/SaLib.lhs +++ b/ghc/compiler/stranal/SaLib.lhs @@ -11,8 +11,8 @@ See also: the ``library'' for the ``back end'' (@SaBackLib@). module SaLib ( AbsVal(..), AnalysisKind(..), - AbsValEnv{-abstract-}, StrictEnv(..), AbsenceEnv(..), - StrAnalFlags(..), getStrAnalFlags, + AbsValEnv{-abstract-}, SYN_IE(StrictEnv), SYN_IE(AbsenceEnv), + SYN_IE(StrAnalFlags), getStrAnalFlags, nullAbsValEnv, addOneToAbsValEnv, growAbsValEnvList, lookupAbsValEnv, absValFromStrictness @@ -20,9 +20,9 @@ module SaLib ( IMP_Ubiq(){-uitous-} -import CoreSyn ( CoreExpr(..) ) +import CoreSyn ( SYN_IE(CoreExpr) ) import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList, - lookupIdEnv, IdEnv(..), + lookupIdEnv, SYN_IE(IdEnv), GenId{-instance Outputable-} ) import IdInfo ( StrictnessInfo(..), Demand{-instance Outputable-} ) diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 873c25f..e433e94 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -14,13 +14,13 @@ import CoreSyn import CoreUnfold ( UnfoldingGuidance(..) ) import CoreUtils ( coreExprType ) import Id ( idWantsToBeINLINEd, getIdStrictness, mkWorkerId, - getIdInfo + getIdInfo, GenId ) import IdInfo ( noIdInfo, addInfo_UF, indicatesWorker, mkStrictnessInfo, StrictnessInfo(..) ) import SaLib -import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) ) +import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) ) import WwLib import Util ( panic{-ToDo:rm-} ) diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 4f68efb..f2762b7 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -23,7 +23,7 @@ import Type ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys, maybeAppDataTyConExpandingDicts ) import UniqSupply ( returnUs, thenUs, thenMaybeUs, - getUniques, UniqSM(..) + getUniques, SYN_IE(UniqSM) ) import Util ( zipWithEqual, assertPanic, panic ) \end{code} diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs index e86accf..5c06e2f 100644 --- a/ghc/compiler/typecheck/GenSpecEtc.lhs +++ b/ghc/compiler/typecheck/GenSpecEtc.lhs @@ -9,7 +9,7 @@ module GenSpecEtc ( TcSigInfo(..), genBinds, - checkSigTyVars, checkSigTyVarsGivenGlobals + checkSigTyVars ) where IMP_Ubiq() @@ -17,8 +17,8 @@ IMP_Ubiq() import TcMonad hiding ( rnMtoTcM ) import Inst ( Inst, InstOrigin(..), LIE(..), plusLIE, newDicts, tyVarsOfInst, instToId ) -import TcEnv ( tcGetGlobalTyVars ) -import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals ) +import TcEnv ( tcGetGlobalTyVars, tcExtendGlobalTyVars ) +import TcSimplify ( tcSimplify, tcSimplifyAndCheck ) import TcType ( TcType(..), TcThetaType(..), TcTauType(..), TcTyVarSet(..), TcTyVar(..), newTyVarTy, zonkTcType, zonkTcTyVar, zonkTcTyVars @@ -32,19 +32,19 @@ import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcHsBinds(..), TcBind(..), TcExpr(. import Bag ( Bag, foldBag, bagToList, listToBag, isEmptyBag ) import Class ( GenClass ) -import Id ( GenId, Id(..), mkUserId, idType ) +import Id ( GenId, SYN_IE(Id), mkUserId, idType ) import Kind ( isUnboxedKind, isTypeKind, mkBoxedTypeKind ) import ListSetOps ( minusList, unionLists, intersectLists ) -import Maybes ( Maybe(..), allMaybes ) +import Maybes ( allMaybes ) import Name ( Name{--O only-} ) import Outputable ( interppSP, interpp'SP ) import Pretty import PprType ( GenClass, GenType, GenTyVar ) import Type ( mkTyVarTy, splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, getTyVar_maybe, tyVarsOfTypes, eqSimpleTheta ) -import TyVar ( GenTyVar, TyVar(..), tyVarKind, minusTyVarSet, emptyTyVarSet, +import TyVar ( GenTyVar, SYN_IE(TyVar), tyVarKind, minusTyVarSet, emptyTyVarSet, elementOfTyVarSet, unionTyVarSets, tyVarSetToList ) -import Usage ( UVar(..) ) +import Usage ( SYN_IE(UVar) ) import Unique ( Unique ) import Util \end{code} @@ -150,10 +150,11 @@ genBinds binder_names mono_ids bind lie sig_infos prag_info_fn let mentioned_tyvars = tyVarsOfTypes mono_id_types tyvars_to_gen = mentioned_tyvars `minusTyVarSet` free_tyvars + tysig_vars = [sig_var | (TySigInfo sig_var _ _ _ _) <- sig_infos] in -- DEAL WITH OVERLOADING - resolveOverloading tyvars_to_gen lie bind sig_infos + resolveOverloading tyvars_to_gen lie bind tysig_vars (head thetas) `thenTc` \ (lie', reduced_tyvars_to_gen, dict_binds, dicts_bound) -> -- Check for generaliseation over unboxed types, and @@ -173,6 +174,7 @@ genBinds binder_names mono_ids bind lie sig_infos prag_info_fn -- and it's better done there because we have more -- precise origin information + -- Default any TypeKind variables to BoxedTypeKind mapTc box_it unresolved_kind_tyvars `thenTc_` -- BUILD THE NEW LOCALS @@ -203,14 +205,16 @@ resolveOverloading :: TcTyVarSet s -- Tyvars over which we are going to generalise -> LIE s -- The LIE to deal with -> TcBind s -- The binding group - -> [TcSigInfo s] -- And its real type-signature information + -> [TcIdBndr s] -- Variables in type signatures + -> TcThetaType s -- *Zonked* theta for the overloading in type signature + -- (if there are any type signatures; error otherwise) -> TcM s (LIE s, -- LIE to pass up the way; a fixed point of -- the current substitution TcTyVarSet s, -- Revised tyvars to generalise [(TcIdOcc s, TcExpr s)], -- Dict bindings [TcIdOcc s]) -- List of dicts to bind here -resolveOverloading tyvars_to_gen dicts bind ty_sigs +resolveOverloading tyvars_to_gen dicts bind tysig_vars theta | not (isUnRestrictedGroup tysig_vars bind) = -- Restricted group, so bind no dictionaries, and -- remove from tyvars_to_gen any constrained type variables @@ -256,7 +260,9 @@ resolveOverloading tyvars_to_gen dicts bind ty_sigs -- may gratuitouslyconstrain some tyvars over which we *are* going -- to generalise. -- For example d::Eq (Foo a b), where Foo is instanced as above. - tcSimplifyWithExtraGlobals constrained_tyvars reduced_tyvars_to_gen dicts + tcExtendGlobalTyVars constrained_tyvars ( + tcSimplify reduced_tyvars_to_gen dicts + ) `thenTc` \ (dicts_free, dicts_binds, dicts_sig2) -> ASSERT(isEmptyBag dicts_sig2) @@ -267,32 +273,29 @@ resolveOverloading tyvars_to_gen dicts bind ty_sigs -- The returned LIE should be a fixed point of the substitution - | otherwise -- An unrestricted group - = case ty_sigs of - [] -> -- NO TYPE SIGNATURES - - tcSimplify tyvars_to_gen dicts `thenTc` \ (dicts_free, dict_binds, dicts_sig) -> - returnTc (dicts_free, tyvars_to_gen, dict_binds, - map instToId (bagToList dicts_sig)) - - (TySigInfo _ _ theta _ _ : other) -> -- TYPE SIGNATURES PRESENT! - - tcAddErrCtxt (sigsCtxt tysig_vars) $ - - newDicts SignatureOrigin theta `thenNF_Tc` \ (dicts_sig, dict_ids) -> - - -- Check that the needed dicts can be expressed in - -- terms of the signature ones - tcSimplifyAndCheck + | null tysig_vars -- An unrestricted group with no type signaturs + = tcSimplify tyvars_to_gen dicts `thenTc` \ (dicts_free, dict_binds, dicts_sig) -> + returnTc (dicts_free, tyvars_to_gen, dict_binds, + map instToId (bagToList dicts_sig)) + + | otherwise -- An unrestricted group with type signatures + = tcAddErrCtxt (sigsCtxt tysig_vars) $ + newDicts SignatureOrigin theta `thenNF_Tc` \ (dicts_sig, dict_ids) -> + -- It's important that theta is pre-zonked, because + -- dict_id is later used to form the type of the polymorphic thing, + -- and forall-types must be zonked so far as their bound variables + -- are concerned + + -- Check that the needed dicts can be expressed in + -- terms of the signature ones + tcSimplifyAndCheck tyvars_to_gen -- Type vars over which we will quantify dicts_sig -- Available dicts dicts -- Want bindings for these dicts `thenTc` \ (dicts_free, dict_binds) -> - returnTc (dicts_free, tyvars_to_gen, dict_binds, dict_ids) - where - tysig_vars = [sig_var | (TySigInfo sig_var _ _ _ _) <- ty_sigs] + returnTc (dicts_free, tyvars_to_gen, dict_binds, dict_ids) \end{code} @checkSigMatch@ does the next step in checking signature matching. @@ -378,19 +381,8 @@ checkSigTyVars :: [TcTyVar s] -- The original signature type variables -> TcM s () checkSigTyVars sig_tyvars sig_tau - = checkSigTyVarsGivenGlobals emptyTyVarSet sig_tyvars sig_tau - -checkSigTyVarsGivenGlobals - :: 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 extra_globals sig_tyvars sig_tau - = zonkTcTyVars extra_globals `thenNF_Tc` \ extra_tyvars' -> - tcGetGlobalTyVars `thenNF_Tc` \ env_tyvars -> + = tcGetGlobalTyVars `thenNF_Tc` \ globals -> let - globals = env_tyvars `unionTyVarSets` extra_tyvars' mono_tyvars = filter (`elementOfTyVarSet` globals) sig_tyvars in -- TEMPORARY FIX diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 562cd6c..d33c7a7 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -44,9 +44,9 @@ import TcType ( TcType(..), TcRhoType(..), TcMaybe, TcTyVarSet(..), import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag ) import Class ( isCcallishClass, isNoDictClass, classInstEnv, - Class(..), GenClass, ClassInstEnv(..) + SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv) ) -import ErrUtils ( addErrLoc, Error(..) ) +import ErrUtils ( addErrLoc, SYN_IE(Error) ) import Id ( GenId, idType, mkInstId ) import MatchEnv ( lookupMEnv, insertMEnv ) import Name ( mkLocalName, getLocalName, Name ) @@ -55,7 +55,7 @@ import PprType ( GenClass, TyCon, GenType, GenTyVar ) import PprStyle ( PprStyle(..) ) import Pretty import RnHsSyn ( RnName{-instance NamedThing-} ) -import SpecEnv ( SpecEnv(..) ) +import SpecEnv ( SYN_IE(SpecEnv) ) import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) import Type ( GenType, eqSimpleTy, instantiateTy, isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy, diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index e6f78b3..4348b01 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -35,7 +35,7 @@ import Unify ( unifyTauTy ) import Kind ( mkBoxedTypeKind, mkTypeKind ) import Id ( GenId, idType, mkUserId ) import IdInfo ( noIdInfo ) -import Maybes ( assocMaybe, catMaybes, Maybe(..) ) +import Maybes ( assocMaybe, catMaybes ) import Name ( pprNonSym ) import PragmaInfo ( PragmaInfo(..) ) import Pretty diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 90a5af4..298df68 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -25,9 +25,9 @@ import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..), import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), TcMonoBinds(..), TcExpr(..), mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType ) -import Inst ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts ) -import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds) -import TcInstDcls ( processInstBinds, newMethodId ) +import Inst ( Inst, InstOrigin(..), LIE(..), emptyLIE, plusLIE, newDicts, newMethod ) +import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcExtendGlobalTyVars ) +import TcInstDcls ( processInstBinds ) import TcKind ( TcKind ) import TcKind ( unifyKind ) import TcMonad hiding ( rnMtoTcM ) @@ -48,12 +48,12 @@ import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID ) import PprStyle import Pretty import PprType ( GenType, GenTyVar, GenClassOp ) -import SpecEnv ( SpecEnv(..) ) +import SpecEnv ( SYN_IE(SpecEnv) ) import SrcLoc ( mkGeneratedSrcLoc ) import Type ( mkFunTy, mkTyVarTy, mkTyVarTys, mkDictTy, mkForAllTy, mkSigmaTy, splitSigmaTy) import TysWiredIn ( stringTy ) -import TyVar ( mkTyVarSet, GenTyVar ) +import TyVar ( unitTyVarSet, GenTyVar ) import Unique ( Unique ) import Util @@ -551,20 +551,22 @@ buildDefaultMethodBinds clas clas_tyvar = 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 + avail_insts = this_dict `plusLIE` unionManyBags insts_s -- Insts available + clas_tyvar_set = unitTyVarSet clas_tyvar in - processInstBinds - clas - (makeClassDeclDefaultMethodRhs clas local_defm_ids) - [clas_tyvar] -- Tyvars in scope - avail_insts - local_defm_ids - default_binds `thenTc` \ (insts_needed, default_binds') -> + tcExtendGlobalTyVars clas_tyvar_set ( + processInstBinds + clas + (makeClassDeclDefaultMethodRhs clas local_defm_ids) + avail_insts + local_defm_ids + default_binds + ) `thenTc` \ (insts_needed, default_binds') -> tcSimplifyAndCheck - (mkTyVarSet [clas_tyvar]) + clas_tyvar_set avail_insts - insts_needed `thenTc` \ (const_lie, dict_binds) -> + insts_needed `thenTc` \ (const_lie, dict_binds) -> let @@ -578,7 +580,7 @@ buildDefaultMethodBinds clas clas_tyvar returnTc (const_lie, defm_binds) where inst_ty = mkTyVarTy clas_tyvar - mk_method defm_id = newMethodId defm_id inst_ty origin + mk_method defm_id = newMethod origin (RealId defm_id) [inst_ty] origin = ClassDeclOrigin \end{code} diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index e699cc0..39f6968 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -28,14 +28,14 @@ import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs ) import TcSimplify ( tcSimplifyThetas ) import RnMonad -import RnUtils ( RnEnv(..), extendGlobalRnEnv ) +import RnUtils ( SYN_IE(RnEnv), extendGlobalRnEnv ) import RnBinds ( rnMethodBinds, rnTopBinds ) import Bag ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag ) import Class ( classKey, needsDataDeclCtxtClassKeys, GenClass ) -import ErrUtils ( pprBagOfErrors, addErrLoc, Error(..) ) +import ErrUtils ( pprBagOfErrors, addErrLoc, SYN_IE(Error) ) import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId ) -import Maybes ( maybeToBool, Maybe(..) ) +import Maybes ( maybeToBool ) import Name ( isLocallyDefined, getSrcLoc, mkTopLevName, origName, mkImplicitName, ExportFlag(..), RdrName(..), Name{--O only-} @@ -43,7 +43,7 @@ import Name ( isLocallyDefined, getSrcLoc, import Outputable ( Outputable(..){-instances e.g., (,)-} ) import PprType ( GenType, GenTyVar, GenClass, TyCon ) import PprStyle ( PprStyle(..) ) -import Pretty ( ppAbove, ppAboves, ppCat, ppBesides, ppStr, ppHang, Pretty(..) ) +import Pretty ( ppAbove, ppAboves, ppCat, ppBesides, ppStr, ppHang, SYN_IE(Pretty) ) import Pretty--ToDo:rm import FiniteMap--ToDo:rm import SrcLoc ( mkGeneratedSrcLoc, SrcLoc ) @@ -51,7 +51,7 @@ import TyCon ( tyConTyVars, tyConDataCons, tyConDerivings, tyConTheta, maybeTyConSingleCon, isEnumerationTyCon, isDataTyCon, TyCon ) -import Type ( GenType(..), TauType(..), mkTyVarTys, applyTyCon, +import Type ( GenType(..), SYN_IE(TauType), mkTyVarTys, applyTyCon, mkSigmaTy, mkDictTy, isPrimType, instantiateTy, getAppDataTyCon, getAppTyCon ) diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 0c299a5..896d581 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -17,14 +17,14 @@ module TcEnv( tcLookupGlobalValue, tcLookupGlobalValueByKey, newMonoIds, newLocalIds, newLocalId, - tcGetGlobalTyVars + tcGetGlobalTyVars, tcExtendGlobalTyVars ) where IMP_Ubiq() IMPORT_DELOOPER(TcMLoop) -- for paranoia checking -import Id ( Id(..), GenId, idType, mkUserLocal ) +import Id ( SYN_IE(Id), GenId, idType, mkUserLocal ) import TcHsSyn ( TcIdBndr(..), TcIdOcc(..) ) import TcKind ( TcKind, newKindVars, tcDefaultKind, kindToTcKind ) import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..), @@ -33,7 +33,7 @@ import TcType ( TcType(..), TcMaybe, TcTyVar(..), TcTyVarSet(..), import TyVar ( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet ) import Type ( tyVarsOfTypes ) import TyCon ( TyCon, tyConKind, synTyConArity ) -import Class ( Class(..), GenClass, classSig ) +import Class ( SYN_IE(Class), GenClass, classSig ) import TcMonad hiding ( rnMtoTcM ) @@ -100,8 +100,7 @@ tcTyVarScopeGivenKinds names kinds thing_inside -- Construct the real TyVars let - tyvars = zipWithEqual "tcTyVarScopeGivenKinds" mk_tyvar names kinds' - mk_tyvar name kind = mkTyVar name (uniqueOf name) kind + tyvars = zipWithEqual "tcTyVarScopeGivenKinds" mkTyVar names kinds' in returnTc (tyvars, result) ) `thenTc` \ (_,result) -> @@ -232,6 +231,15 @@ tcGetGlobalTyVars zonkTcTyVars global_tvs `thenNF_Tc` \ global_tvs' -> tcWriteMutVar gtvs global_tvs' `thenNF_Tc_` returnNF_Tc global_tvs' + +tcExtendGlobalTyVars extra_global_tvs scope + = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> + tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> + let + new_global_tyvars = global_tvs `unionTyVarSets` extra_global_tvs + in + tcNewMutVar new_global_tyvars `thenNF_Tc` \ gtvs' -> + tcSetEnv (TcEnv tve tce ce gve lve gtvs') scope \end{code} \begin{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 11f6365..d3860c7 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -30,23 +30,24 @@ import Inst ( Inst, InstOrigin(..), OverloadedLit(..), newMethod, newMethodWithGivenTy, newDicts ) import TcBinds ( tcBindsAndThen ) import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey, - tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars + tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars, + tcExtendGlobalTyVars ) import TcMatches ( tcMatchesCase, tcMatch ) import TcMonoType ( tcPolyType ) import TcPat ( tcPat ) import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 ) import TcType ( TcType(..), TcMaybe(..), - tcInstId, tcInstType, tcInstSigTyVars, + tcInstId, tcInstType, tcInstSigTcType, tcInstSigType, tcInstTcType, tcInstTheta, newTyVarTy, zonkTcTyVars, zonkTcType ) import TcKind ( TcKind ) -import Class ( Class(..), classSig ) +import Class ( SYN_IE(Class), classSig ) import FieldLabel ( fieldLabelName ) -import Id ( idType, dataConFieldLabels, dataConSig, Id(..), GenId ) +import Id ( idType, dataConFieldLabels, dataConSig, SYN_IE(Id), GenId ) import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind ) -import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals ) +import GenSpecEtc ( checkSigTyVars ) import Name ( Name{-instance Eq-} ) import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy, getTyVar_maybe, getFunTy_maybe, instantiateTy, @@ -54,13 +55,13 @@ import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, mkRhoTy, isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe, getAppDataTyCon, maybeAppDataTyCon ) -import TyVar ( GenTyVar, TyVarSet(..), unionTyVarSets, mkTyVarSet ) +import TyVar ( GenTyVar, SYN_IE(TyVarSet), unionTyVarSets, mkTyVarSet ) import TysPrim ( intPrimTy, charPrimTy, doublePrimTy, floatPrimTy, addrPrimTy ) import TysWiredIn ( addrTy, boolTy, charTy, stringTy, mkListTy, - mkTupleTy, mkPrimIoTy + mkTupleTy, mkPrimIoTy, primIoDataCon ) import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) import Unique ( Unique, cCallableClassKey, cReturnableClassKey, @@ -68,7 +69,6 @@ import Unique ( Unique, cCallableClassKey, cReturnableClassKey, enumFromToClassOpKey, enumFromThenToClassOpKey, thenMClassOpKey, zeroClassOpKey ) ---import Name ( Name ) -- Instance import Outputable ( interpp'SP ) import PprType ( GenType, GenTyVar ) -- Instances import Maybes ( maybeToBool ) @@ -269,7 +269,8 @@ tcExpr (CCall lbl args may_gc is_asm ignored_fake_result_ty) mapNF_Tc new_arg_dict (zipEqual "tcExpr:CCall" args arg_tys) `thenNF_Tc` \ ccarg_dicts_s -> newDicts result_origin [(cReturnableClass, result_ty)] `thenNF_Tc` \ (ccres_dict, _) -> - returnTc (CCall lbl args' may_gc is_asm result_ty, + returnTc (HsCon primIoDataCon [result_ty] [CCall lbl args' may_gc is_asm result_ty], + -- do the wrapping in the newtype constructor here foldr plusLIE ccres_dict ccarg_dicts_s `plusLIE` args_lie, mkPrimIoTy result_ty) \end{code} @@ -375,7 +376,7 @@ tcExpr (RecordUpd record_expr rbinds) -- Check that the field names are plausible zonkTcType record_ty `thenNF_Tc` \ record_ty' -> let - (tycon, inst_tys, data_cons) = _trace "TcExpr.getAppDataTyCon" $ getAppDataTyCon record_ty' + (tycon, inst_tys, data_cons) = trace "TcExpr.getAppDataTyCon" $ getAppDataTyCon record_ty' -- The record binds are non-empty (syntax); so at least one field -- label will have been unified with record_ty by tcRecordBinds; -- field labels must be of data type; hencd the getAppDataTyCon must succeed. @@ -571,16 +572,15 @@ tcArg expected_arg_ty arg -- 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. + tcInstSigTcType expected_arg_ty `thenNF_Tc` \ (sig_tyvars, sig_rho) -> let - (expected_tyvars, expected_theta, expected_tau) = splitSigmaTy expected_arg_ty + (sig_theta, sig_tau) = splitRhoTy sig_rho 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_` + ASSERT( null sig_theta ) -- And expected_tyvars are all DontBind things -- 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_` ( + unifyTauTy sig_tau actual_arg_ty `thenTc_` -- Check that the arg_tyvars havn't been constrained -- The interesting bit here is that we must include the free variables @@ -593,22 +593,22 @@ tcArg expected_arg_ty arg -- 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) $ - checkSigTyVarsGivenGlobals - (tyVarsOfType expected_arg_ty) - expected_tyvars expected_tau `thenTc_` - - -- Check that there's no overloading involved - -- Even if there isn't, there may be some Insts which mention the expected_tyvars, - -- but which, on simplification, don't actually need a dictionary involving - -- the tyvar. So we have to do a proper simplification right here. - tcSimplifyRank2 (mkTyVarSet expected_tyvars) - lie_arg `thenTc` \ (free_insts, inst_binds) -> - - -- This HsLet binds any Insts which came out of the simplification. - -- It's a bit out of place here, but using AbsBind involves inventing - -- a couple of new names which seems worse. - returnTc (TyLam expected_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts) + tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) ( + tcExtendGlobalTyVars (tyVarsOfType expected_arg_ty) ( + checkSigTyVars sig_tyvars sig_tau + ) `thenTc_` + + -- Check that there's no overloading involved + -- Even if there isn't, there may be some Insts which mention the expected_tyvars, + -- but which, on simplification, don't actually need a dictionary involving + -- the tyvar. So we have to do a proper simplification right here. + tcSimplifyRank2 (mkTyVarSet sig_tyvars) + lie_arg `thenTc` \ (free_insts, inst_binds) -> + + -- This HsLet binds any Insts which came out of the simplification. + -- It's a bit out of place here, but using AbsBind involves inventing + -- a couple of new names which seems worse. + returnTc (TyLam sig_tyvars (HsLet (mk_binds inst_binds) arg'), free_insts) ) where diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index d79ca49..f449cca 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -63,17 +63,18 @@ module TcGenDeriv ( ) where IMP_Ubiq() +IMPORT_1_3(List(partition)) import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qualifier(..), Stmt, ArithSeqInfo, Sig, PolyType, FixityDecl, Fake ) -import RdrHsSyn ( RdrNameMonoBinds(..), RdrNameHsExpr(..), RdrNamePat(..) ) +import RdrHsSyn ( SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat) ) import RnHsSyn ( RenamedFixityDecl(..) ) --import RnUtils -import Id ( GenId, dataConArity, isNullaryDataCon, dataConTag, +import Id ( GenId, dataConNumFields, isNullaryDataCon, dataConTag, dataConRawArgTys, fIRST_TAG, - isDataCon, DataCon(..), ConTag(..) ) + isDataCon, SYN_IE(DataCon), SYN_IE(ConTag) ) import IdUtils ( primOpId ) import Maybes ( maybeToBool ) import Name ( origName, preludeQual, nameOf, RdrName(..), OrigName(..) ) @@ -200,7 +201,7 @@ gen_Eq_binds tycon con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed) data_con_PN = qual_orig_name data_con - con_arity = dataConArity data_con + con_arity = length tys_needed as_needed = take con_arity as_PNs bs_needed = take con_arity bs_PNs tys_needed = dataConRawArgTys data_con @@ -212,15 +213,6 @@ gen_Eq_binds tycon = 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] = - 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] [] $ @@ -347,7 +339,7 @@ gen_Ord_binds tycon (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) + = partition isNullaryDataCon (tyConDataCons tycon) cmp_eq = mk_FunMonoBind cmp_eq_PN (map pats_etc nonnullary_cons ++ deflt_pats_etc) @@ -360,7 +352,7 @@ gen_Ord_binds tycon con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed) data_con_PN = qual_orig_name data_con - con_arity = dataConArity data_con + con_arity = length tys_needed as_needed = take con_arity as_PNs bs_needed = take con_arity bs_PNs tys_needed = dataConRawArgTys data_con @@ -491,7 +483,7 @@ gen_Bounded_binds tycon data_con_N_PN = qual_orig_name data_con_N ----- single-constructor-flavored: ------------- - arity = dataConArity data_con_1 + arity = dataConNumFields data_con_1 min_bound_1con = mk_easy_FunMonoBind minBound_PN [] [] $ mk_easy_App data_con_1_PN (nOfThem arity minBound_PN) @@ -622,7 +614,7 @@ gen_Ix_binds tycon else dc - con_arity = dataConArity data_con + con_arity = dataConNumFields data_con data_con_PN = qual_orig_name data_con con_pat xs = ConPatIn data_con_PN (map VarPatIn xs) con_expr xs = mk_easy_App data_con_PN xs @@ -684,7 +676,7 @@ gen_Read_binds fixities tycon where ----------------------------------------------------------------------- read_list = mk_easy_FunMonoBind readList_PN [] [] - (HsApp (HsVar _readList_PN) (HsPar (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0))))) + (HsApp (HsVar readList___PN) (HsPar (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0))))) ----------------------------------------------------------------------- reads_prec = let @@ -699,7 +691,7 @@ gen_Read_binds fixities tycon = let data_con_PN = qual_orig_name data_con data_con_str= nameOf (origName "gen_Read_binds" data_con) - con_arity = dataConArity data_con + con_arity = dataConNumFields 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 @@ -749,7 +741,7 @@ gen_Show_binds fixities tycon where ----------------------------------------------------------------------- show_list = mk_easy_FunMonoBind showList_PN [] [] - (HsApp (HsVar _showList_PN) (HsPar (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)) @@ -757,7 +749,7 @@ gen_Show_binds fixities tycon pats_etc data_con = let data_con_PN = qual_orig_name data_con - con_arity = dataConArity data_con + con_arity = dataConNumFields data_con bs_needed = take con_arity bs_PNs con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed) nullary_con = isNullaryDataCon data_con @@ -823,7 +815,7 @@ gen_tag_n_con_monobind (pn, tycon, GenCon2Tag) = ASSERT(isDataCon var) ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))) where - pat = ConPatIn var_PN (nOfThem (dataConArity var) WildPatIn) + pat = ConPatIn var_PN (nOfThem (dataConNumFields var) WildPatIn) var_PN = qual_orig_name var gen_tag_n_con_monobind (pn, tycon, GenTag2Con) @@ -1115,10 +1107,10 @@ error_PN = preludeQual SLIT("error") showString_PN = preludeQual SLIT("showString") showParen_PN = preludeQual SLIT("showParen") readParen_PN = preludeQual SLIT("readParen") -lex_PN = preludeQual SLIT("lex") +lex_PN = Qual gHC__ SLIT("lex") showSpace_PN = Qual gHC__ SLIT("showSpace") -_showList_PN = Qual gHC__ SLIT("showList__") -_readList_PN = Qual gHC__ SLIT("readList__") +showList___PN = Qual gHC__ SLIT("showList__") +readList___PN = Qual gHC__ SLIT("readList__") a_Expr = HsVar a_PN b_Expr = HsVar b_PN diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 93149e4..a0f779f 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -38,8 +38,8 @@ IMP_Ubiq(){-uitous-} -- friends: import HsSyn -- oodles of it import Id ( GenId(..), IdDetails, PragmaInfo, -- Can meddle modestly with Ids - DictVar(..), idType, - IdEnv(..), growIdEnvList, lookupIdEnv + SYN_IE(DictVar), idType, + SYN_IE(IdEnv), growIdEnvList, lookupIdEnv ) -- others: @@ -48,13 +48,13 @@ import TcMonad hiding ( rnMtoTcM ) import TcType ( TcType(..), TcMaybe, TcTyVar(..), zonkTcTypeToType, zonkTcTyVarToTyVar ) -import Usage ( UVar(..) ) +import Usage ( SYN_IE(UVar) ) import Util ( zipEqual, panic, pprPanic, pprTrace ) import PprType ( GenType, GenTyVar ) -- instances import Type ( mkTyVarTy, tyVarsOfType ) import TyVar ( GenTyVar {- instances -}, - TyVarEnv(..), growTyVarEnvList, emptyTyVarSet ) + SYN_IE(TyVarEnv), growTyVarEnvList, emptyTyVarSet ) import TysPrim ( voidTy ) import Unique ( Unique ) -- instances import UniqFM diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 7326d93..b8e1b1a 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -16,7 +16,7 @@ import TcMonoType ( tcPolyType ) import HsSyn ( Sig(..), PolyType ) import RnHsSyn ( RenamedSig(..), RnName(..) ) -import CmdLineOpts ( opt_CompilingPrelude ) +import CmdLineOpts ( opt_CompilingGhcInternals ) import Id ( mkImported ) --import Name ( Name(..) ) import Maybes ( maybeToBool ) @@ -56,7 +56,7 @@ tcInterfaceSigs (Sig name ty pragmas src_loc : sigs) | otherwise -- odd name... = case name of - WiredInId _ | opt_CompilingPrelude + WiredInId _ | opt_CompilingGhcInternals -> tcInterfaceSigs sigs _ -> tcAddSrcLoc src_loc $ failTc (ifaceSigNameErr name) diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index aa8590a..cef6f6a 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -9,8 +9,7 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2, - processInstBinds, - newMethodId + processInstBinds ) where @@ -34,19 +33,19 @@ import TcHsSyn ( TcIdOcc(..), TcHsBinds(..), import TcMonad hiding ( rnMtoTcM ) -import GenSpecEtc ( checkSigTyVarsGivenGlobals ) +import GenSpecEtc ( checkSigTyVars ) import Inst ( Inst, InstOrigin(..), InstanceMapper(..), newDicts, newMethod, LIE(..), emptyLIE, plusLIE ) import TcBinds ( tcPragmaSigs ) import TcDeriv ( tcDeriving ) -import TcEnv ( tcLookupClass, tcTyVarScope, newLocalId ) +import TcEnv ( tcLookupClass, tcTyVarScope, newLocalId, tcExtendGlobalTyVars ) import TcGRHSs ( tcGRHSsAndBinds ) import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs ) import TcKind ( TcKind, unifyKind ) import TcMatches ( tcMatchesFun ) import TcMonoType ( tcContext, tcMonoTypeKind ) import TcSimplify ( tcSimplifyAndCheck ) -import TcType ( TcType(..), TcTyVar(..), +import TcType ( TcType(..), TcTyVar(..), TcTyVarSet(..), tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType ) import Unify ( unifyTauTy, unifyTauTyLists ) @@ -54,7 +53,7 @@ import Unify ( unifyTauTy, unifyTauTyLists ) import Bag ( emptyBag, unitBag, unionBags, unionManyBags, concatBag, foldBag, bagToList ) -import CmdLineOpts ( opt_GlasgowExts, +import CmdLineOpts ( opt_GlasgowExts, opt_CompilingGhcInternals, opt_OmitDefaultInstanceMethods, opt_SpecialiseOverloaded ) @@ -74,13 +73,13 @@ import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon, ) import PprStyle import Pretty -import RnUtils ( RnEnv(..) ) +import RnUtils ( SYN_IE(RnEnv) ) import TyCon ( isSynTyCon, derivedFor ) -import Type ( GenType(..), ThetaType(..), mkTyVarTys, +import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys, splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy, - getTyCon_maybe, maybeBoxedPrimType, splitRhoTy + getTyCon_maybe, maybeBoxedPrimType, splitRhoTy, eqTy ) -import TyVar ( GenTyVar, mkTyVarSet, unionTyVarSets ) +import TyVar ( GenTyVar, GenTyVarSet(..), mkTyVarSet, unionTyVarSets ) import TysWiredIn ( stringTy ) import Unique ( Unique ) import Util ( zipEqual, panic ) @@ -369,7 +368,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 + mk_method sel_id = newMethod origin (RealId sel_id) [inst_ty'] in -- Create dictionary Ids from the specified instance contexts. newDicts origin sc_theta' `thenNF_Tc` \ (sc_dicts, sc_dict_ids) -> @@ -382,6 +381,8 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty -- Collect available Insts let + inst_tyvars_set' = mkTyVarSet inst_tyvars' + avail_insts -- These insts are in scope; quite a few, eh? = unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s) @@ -391,8 +392,9 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty else makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id in - processInstBinds clas mk_method_expr inst_tyvars' avail_insts meth_ids monobinds - `thenTc` \ (insts_needed, method_mbinds) -> + tcExtendGlobalTyVars inst_tyvars_set' ( + processInstBinds clas mk_method_expr avail_insts meth_ids monobinds + ) `thenTc` \ (insts_needed, method_mbinds) -> let -- Create the dict and method binds dict_bind @@ -401,7 +403,6 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_ty dict_and_method_binds = dict_bind `AndMonoBinds` method_mbinds - inst_tyvars_set' = mkTyVarSet inst_tyvars' in -- Check the overloading constraints of the methods and superclasses tcAddErrCtxt (bindSigCtxt meth_ids) ( @@ -448,62 +449,6 @@ 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: - - (a) For methods with no local polymorphism, we can make an Inst of the - class-op selector function and a corresp InstId; - which is good because then other methods which call - this one will do so directly. - - (b) For methods with local polymorphism, we can't do this. For example, - - class Foo a where - op :: (Num b) => a -> b -> a - - Here the type of the class-op-selector is - - forall a b. (Foo a, Num b) => a -> b -> a - - The locally defined method at (say) type Float will have type - - forall b. (Num b) => Float -> b -> Float - - and the one is not an instance of the other. - - 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 - = 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 - case sel_tyvars of - -- Ah! a selector for a class op with no local polymorphism - -- Build an Inst for this - [clas_tyvar] -> newMethod origin (RealId sel_id) [inst_ty] - - -- Ho! a selector for a class op with local polymorphism. - -- Just make a suitably typed local id for this - (clas_tyvar:local_tyvars) -> - tcInstType [(clas_tyvar,inst_ty)] - (mkSigmaTy local_tyvars meth_theta sel_tau) - `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 the appropriate instance type. @@ -583,7 +528,6 @@ do differs between instance and class decls. processInstBinds :: Class -> (Int -> NF_TcM s (TcExpr s)) -- Function to make default method - -> [TcTyVar s] -- Tyvars for this instance decl -> LIE s -- available Insts -> [TcIdOcc s] -- Local method ids in tag order -- (instance tyvars are free in their types) @@ -591,10 +535,10 @@ processInstBinds -> TcM s (LIE s, -- These are required TcMonoBinds s) -processInstBinds clas mk_default_method_rhs inst_tyvars avail_insts method_ids monobinds +processInstBinds clas mk_default_method_rhs avail_insts method_ids monobinds = -- Process the explicitly-given method bindings - processInstBinds1 clas inst_tyvars avail_insts method_ids monobinds + processInstBinds1 clas avail_insts method_ids monobinds `thenTc` \ (tags, insts_needed_in_methods, method_binds) -> -- Find the methods not handled, and make default method bindings for them. @@ -616,7 +560,6 @@ processInstBinds clas mk_default_method_rhs inst_tyvars avail_insts method_ids m \begin{code} processInstBinds1 :: Class - -> [TcTyVar s] -- Tyvars for this instance decl -> LIE s -- available Insts -> [TcIdOcc s] -- Local method ids in tag order (instance tyvars are free), -> RenamedMonoBinds @@ -624,13 +567,13 @@ processInstBinds1 LIE s, -- These are required TcMonoBinds s) -processInstBinds1 clas inst_tyvars avail_insts method_ids EmptyMonoBinds +processInstBinds1 clas avail_insts method_ids EmptyMonoBinds = returnTc ([], emptyLIE, EmptyMonoBinds) -processInstBinds1 clas inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2) - = processInstBinds1 clas inst_tyvars avail_insts method_ids mb1 +processInstBinds1 clas avail_insts method_ids (AndMonoBinds mb1 mb2) + = processInstBinds1 clas avail_insts method_ids mb1 `thenTc` \ (op_tags1,dicts1,method_binds1) -> - processInstBinds1 clas inst_tyvars avail_insts method_ids mb2 + processInstBinds1 clas avail_insts method_ids mb2 `thenTc` \ (op_tags2,dicts2,method_binds2) -> returnTc (op_tags1 ++ op_tags2, dicts1 `unionBags` dicts2, @@ -638,7 +581,7 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids (AndMonoBinds mb1 mb2) \end{code} \begin{code} -processInstBinds1 clas inst_tyvars avail_insts method_ids mbind +processInstBinds1 clas avail_insts method_ids mbind = -- Find what class op is being defined here. The complication is -- that we could have a PatMonoBind or a FunMonoBind. If the @@ -693,13 +636,14 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids mbind newLocalId occ method_tau `thenNF_Tc` \ local_id -> newLocalId occ method_ty `thenNF_Tc` \ copy_id -> let - inst_tyvar_set = mkTyVarSet inst_tyvars - inst_method_tyvar_set = inst_tyvar_set `unionTyVarSets` (mkTyVarSet sig_tyvars) + sig_tyvar_set = mkTyVarSet sig_tyvars in -- Typecheck the method tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) -> -- Check the overloading part of the signature. + + -- =========== POSSIBLE BUT NOT DONE ================= -- Simplify everything fully, even though some -- constraints could "really" be left to the next -- level out. The case which forces this is @@ -708,13 +652,18 @@ processInstBinds1 clas inst_tyvars avail_insts method_ids mbind -- -- Here we must simplify constraints on "a" to catch all -- the Bar-ish things. + + -- We don't do this because it's currently illegal Haskell (not sure why), + -- and because the local type of the method would have a context at + -- the front with no for-all, which confuses the hell out of everything! + -- ==================================================== + tcAddErrCtxt (methodSigCtxt op method_ty) ( - checkSigTyVarsGivenGlobals - inst_tyvar_set + checkSigTyVars sig_tyvars method_tau `thenTc_` tcSimplifyAndCheck - inst_method_tyvar_set + sig_tyvar_set (method_dicts `plusLIE` avail_insts) lieIop ) `thenTc` \ (f_dicts, dict_binds) -> @@ -906,12 +855,11 @@ scrutiniseInstanceType from_here clas inst_tau = failTc (instTypeErr inst_tau) -- IMPORTED INSTANCES ARE OK (but see tcInstDecl1) - | from_here + | not from_here = returnTc (inst_tycon,arg_tys) -- TYVARS CHECK | not (all isTyVarTy arg_tys || - not from_here || opt_GlasgowExts) = failTc (instTypeErr inst_tau) @@ -928,7 +876,9 @@ scrutiniseInstanceType from_here clas inst_tau -- A user declaration of a CCallable/CReturnable instance -- must be for a "boxed primitive" type. isCcallishClass clas - && not (maybeToBool (maybeBoxedPrimType inst_tau)) + && not (maybeToBool (maybeBoxedPrimType inst_tau) + || opt_CompilingGhcInternals) -- this lets us get up to mischief; + -- e.g., instance CCallable () = failTc (nonBoxedPrimCCallErr clas inst_tau) | otherwise diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index fde76aa..c30a90a 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -24,7 +24,7 @@ import TcMonad hiding ( rnMtoTcM ) import Inst ( InstanceMapper(..) ) import Bag ( bagToList ) -import Class ( GenClass, GenClassOp, ClassInstEnv(..), +import Class ( GenClass, GenClassOp, SYN_IE(ClassInstEnv), classBigSig, classOps, classOpLocalType ) import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp ) import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal ) @@ -33,10 +33,10 @@ import Maybes ( MaybeErr(..), mkLookupFunDef ) import Name ( getSrcLoc, Name{--O only-} ) import PprType ( GenClass, GenType, GenTyVar ) import Pretty -import SpecEnv ( SpecEnv(..), nullSpecEnv, addOneToSpecEnv ) +import SpecEnv ( SYN_IE(SpecEnv), nullSpecEnv, addOneToSpecEnv ) import SrcLoc ( SrcLoc ) import Type ( mkSigmaTy, mkForAllTys, mkDictTy, mkTyVarTys, - splitForAllTy, instantiateTy, matchTy, ThetaType(..) ) + splitForAllTy, instantiateTy, matchTy, SYN_IE(ThetaType) ) import TyVar ( GenTyVar ) import Unique ( Unique ) import Util ( equivClasses, zipWithEqual, panic ) diff --git a/ghc/compiler/typecheck/TcLoop_1_3.lhi b/ghc/compiler/typecheck/TcLoop_1_3.lhi new file mode 100644 index 0000000..69488fe --- /dev/null +++ b/ghc/compiler/typecheck/TcLoop_1_3.lhi @@ -0,0 +1,5 @@ +\begin{code} +interface TcLoop_1_3 1 +__exports__ +Outputable Outputable (..) +\end{code} diff --git a/ghc/compiler/typecheck/TcMLoop_1_3.lhi b/ghc/compiler/typecheck/TcMLoop_1_3.lhi new file mode 100644 index 0000000..1ea9fcf --- /dev/null +++ b/ghc/compiler/typecheck/TcMLoop_1_3.lhi @@ -0,0 +1,5 @@ +\begin{code} +interface TcMLoop_1_3 1 +__exports__ +Outputable Outputable (..) +\end{code} diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index fed6045..3cd3df5 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -158,6 +158,9 @@ tcMatch (PatMatch pat match) = let binders = collectPatBinders pat in newMonoIds binders mkTypeKind (\ _ -> + -- NB TypeKind; lambda-bound variables are allowed + -- to unify with unboxed types. + tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) -> tcMatch match `thenTc` \ (match', lie_match, match_ty) -> returnTc (PatMatch pat' match', diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 1dd4a42..7410a7f 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -43,16 +43,16 @@ import TcTyDecls ( mkDataBinds ) import Bag ( listToBag ) import Class ( GenClass, classSelIds ) -import ErrUtils ( Warning(..), Error(..) ) -import Id ( idType, isMethodSelId, isTopLevId, GenId, IdEnv(..), nullIdEnv ) +import ErrUtils ( SYN_IE(Warning), SYN_IE(Error) ) +import Id ( idType, isMethodSelId, isTopLevId, GenId, SYN_IE(IdEnv), nullIdEnv ) import Maybes ( catMaybes ) -import Name ( isExported, isLocallyDefined ) +import Name ( isLocallyDefined ) import Pretty -import RnUtils ( RnEnv(..) ) +import RnUtils ( SYN_IE(RnEnv) ) import TyCon ( TyCon ) import Type ( applyTyCon ) import TysWiredIn ( unitTy, mkPrimIoTy ) -import TyVar ( TyVarEnv(..), nullTyVarEnv ) +import TyVar ( SYN_IE(TyVarEnv), nullTyVarEnv ) import Unify ( unifyTauTy ) import UniqFM ( lookupUFM_Directly, lookupWithDefaultUFM_Directly, filterUFM, eltsUFM ) @@ -269,42 +269,46 @@ tcModule rn_env %************************************************************************ -checkTopLevelIds checks that Main.main or Main.mainPrimIO has correct type. +checkTopLevelIds checks that Main.main or GHCmain.mainPrimIO has correct type. \begin{code} checkTopLevelIds :: FAST_STRING -> TcEnv s -> TcM s () + checkTopLevelIds mod final_env - | mod /= SLIT("Main") + | mod /= SLIT("Main") && mod /= SLIT("GHCmain") = returnTc () - | otherwise + | mod == SLIT("Main") = tcSetEnv final_env ( tcLookupLocalValueByKey mainIdKey `thenNF_Tc` \ maybe_main -> - tcLookupLocalValueByKey mainPrimIOIdKey `thenNF_Tc` \ maybe_prim -> tcLookupTyConByKey iOTyConKey `thenNF_Tc` \ io_tc -> - - case (maybe_main, maybe_prim) of - (Just main, Nothing) -> tcAddErrCtxt mainCtxt $ - unifyTauTy (applyTyCon io_tc [unitTy]) - (idType main) - (Nothing, Just prim) -> tcAddErrCtxt primCtxt $ - unifyTauTy (mkPrimIoTy unitTy) - (idType prim) + case maybe_main of + Just main -> tcAddErrCtxt mainCtxt $ + unifyTauTy (applyTyCon io_tc [unitTy]) + (idType main) + + Nothing -> failTc (mainNoneIdErr "Main" "main") + ) + + | mod == SLIT("GHCmain") + = tcSetEnv final_env ( + tcLookupLocalValueByKey mainPrimIOIdKey `thenNF_Tc` \ maybe_prim -> + + case maybe_prim of + Just prim -> tcAddErrCtxt primCtxt $ + unifyTauTy (mkPrimIoTy unitTy) + (idType prim) - (Just _ , Just _ ) -> failTc mainBothIdErr - (Nothing, Nothing) -> failTc mainNoneIdErr + Nothing -> failTc (mainNoneIdErr "GHCmain" "mainPrimIO") ) mainCtxt sty - = ppStr "main should have type IO ()" + = ppStr "Main.main should have type IO ()" primCtxt sty - = ppStr "mainPrimIO should have type PrimIO ()" - -mainBothIdErr sty - = ppStr "module Main contains definitions for both main and mainPrimIO" + = ppStr "GHCmain.mainPrimIO should have type PrimIO ()" -mainNoneIdErr sty - = ppStr "module Main does not contain a definition for main (or mainPrimIO)" +mainNoneIdErr mod n sty + = ppCat [ppPStr SLIT("module"), ppStr mod, ppPStr SLIT("does not contain a definition for"), ppStr n] \end{code} diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index b5853aa..8a636e6 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -39,23 +39,23 @@ IMP_Ubiq(){-uitous-} IMPORT_DELOOPER(TcMLoop) ( TcEnv, initEnv, TcMaybe ) -- We need the type TcEnv and an initial Env -import Type ( Type(..), GenType ) -import TyVar ( TyVar(..), GenTyVar ) -import Usage ( Usage(..), GenUsage ) -import ErrUtils ( Error(..), Message(..), ErrCtxt(..), - Warning(..) ) +import Type ( SYN_IE(Type), GenType ) +import TyVar ( SYN_IE(TyVar), GenTyVar ) +import Usage ( SYN_IE(Usage), GenUsage ) +import ErrUtils ( SYN_IE(Error), SYN_IE(Message), ErrCtxt(..), + SYN_IE(Warning) ) import SST -import RnMonad ( RnM(..), RnDown, initRn, setExtraRn, +import RnMonad ( SYN_IE(RnM), RnDown, initRn, setExtraRn, returnRn, thenRn, getImplicitUpRn ) -import RnUtils ( RnEnv(..) ) +import RnUtils ( SYN_IE(RnEnv) ) import Bag ( Bag, emptyBag, isEmptyBag, foldBag, unitBag, unionBags, snocBag ) -import FiniteMap ( FiniteMap, emptyFM, isEmptyFM ) +import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, keysFM{-ToDo:rm-} ) --import Outputable ( Outputable(..), NamedThing(..), ExportFlag ) -import ErrUtils ( Error(..) ) +import ErrUtils ( SYN_IE(Error) ) import Maybes ( MaybeErr(..) ) --import Name ( Name ) import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) @@ -79,8 +79,8 @@ type TcM s r = TcDown s -> TcEnv s -> FSST s r () \end{code} \begin{code} --- With a builtin polymorphic type for _runSST the type for --- initTc should use TcM s r instead of TcM _RealWorld r +-- With a builtin polymorphic type for runSST the type for +-- initTc should use TcM s r instead of TcM RealWorld r initTc :: UniqSupply -> TcM _RealWorld r @@ -88,7 +88,7 @@ initTc :: UniqSupply (Bag Error, Bag Warning) initTc us do_this - = _runSST ( + = runSST ( newMutVarSST us `thenSST` \ us_var -> newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var -> newMutVarSST emptyUFM `thenSST` \ tvs_var -> @@ -233,7 +233,7 @@ forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env (us1, us2) = splitUniqSupply us in writeMutVarSST u_var us1 `thenSST_` - returnSST (_runSST ( + returnSST ( runSST ( newMutVarSST us2 `thenSST` \ u_var' -> newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' -> newMutVarSST emptyUFM `thenSST` \ tv_var' -> @@ -310,8 +310,20 @@ recoverNF_Tc recover m down env tryTc :: TcM s r -> TcM s r -> TcM s r tryTc recover m down env = recoverFSST (\ _ -> recover down env) $ + newMutVarSST (emptyBag,emptyBag) `thenSST` \ new_errs_var -> - m (setTcErrs down new_errs_var) env + + m (setTcErrs down new_errs_var) env `thenFSST` \ result -> + + -- Check that m has no errors; if it has internal recovery + -- mechanisms it might "succeed" but having found a bunch of + -- errors along the way. If so we want tryTc to use + -- "recover" instead + readMutVarSST new_errs_var `thenSST` \ (_,errs) -> + if isEmptyBag errs then + returnFSST result + else + recover down env checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true checkTc True err = returnTc () @@ -473,7 +485,9 @@ rnMtoTcM rn_env rn_action down env getImplicitUpRn `thenRn` \ implicit_env@(v_env,tc_env) -> if (isEmptyFM v_env && isEmptyFM tc_env) then returnRn result - else panic "rnMtoTcM: non-empty ImplicitEnv!" + else pprPanic "rnMtoTcM: non-empty ImplicitEnv!" + (ppAboves ([ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM v_env] + ++ [ ppCat [ppPStr m, ppPStr n] | (OrigName m n) <- keysFM tc_env])) ) in returnSST (rn_result, rn_errs) diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index dfa3e59..35f8353 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -24,11 +24,11 @@ import TcKind ( TcKind, mkTcTypeKind, mkBoxedTypeKind, mkTcArrowKind, unifyKind, newKindVar, kindToTcKind ) -import Type ( GenType, Type(..), ThetaType(..), +import Type ( GenType, SYN_IE(Type), SYN_IE(ThetaType), mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy, mkSigmaTy ) -import TyVar ( GenTyVar, TyVar(..), mkTyVar ) +import TyVar ( GenTyVar, SYN_IE(TyVar) ) import Type ( mkDictTy ) import Class ( cCallishClassKeys ) import TyCon ( TyCon ) diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 45aaa5d..e7056b2 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -37,7 +37,7 @@ import Pretty import RnHsSyn ( RnName{-instance Outputable-} ) import Type ( splitFunTy, splitRhoTy, splitSigmaTy, mkTyVarTys, getFunTy_maybe, maybeAppDataTyCon, - Type(..), GenType + SYN_IE(Type), GenType ) import TyVar ( GenTyVar ) import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, diff --git a/ghc/compiler/typecheck/TcPragmas.lhs b/ghc/compiler/typecheck/TcPragmas.lhs index 5ce5ca7..e28f90a 100644 --- a/ghc/compiler/typecheck/TcPragmas.lhs +++ b/ghc/compiler/typecheck/TcPragmas.lhs @@ -26,7 +26,7 @@ import HsPragmas -- ****** NEED TO SEE CONSTRUCTORS ****** import Id import IdInfo --import WwLib ( mkWwBodies ) -import Maybes ( assocMaybe, catMaybes, Maybe(..) ) +import Maybes ( assocMaybe, catMaybes ) --import CoreLint ( lintUnfolding ) import TcMonoType ( tcMonoType, tcPolyType ) import Util diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index c6089d0..a1e987a 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -7,7 +7,7 @@ #include "HsVersions.h" module TcSimplify ( - tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals, + tcSimplify, tcSimplifyAndCheck, tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyRank2, bindInstsOfLocalFuns ) where @@ -34,22 +34,22 @@ import Unify ( unifyTauTy ) import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList, snocBag, consBag, unionBags, isEmptyBag ) -import Class ( GenClass, Class(..), ClassInstEnv(..), +import Class ( GenClass, SYN_IE(Class), SYN_IE(ClassInstEnv), isNumericClass, isStandardClass, isCcallishClass, isSuperClassOf, classSuperDictSelId, classInstEnv ) import Id ( GenId ) -import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool, Maybe(..) ) +import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool ) import Outputable ( Outputable(..){-instance * []-} ) import PprStyle--ToDo:rm import PprType ( GenType, GenTyVar, GenClass{-instance Outputable;ToDo:rm-} ) import Pretty import SrcLoc ( mkUnknownSrcLoc ) import Util -import Type ( GenType, Type(..), TauType(..), mkTyVarTy, getTyVar, eqSimpleTy, +import Type ( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy, getTyVar_maybe ) import TysWiredIn ( intTy ) -import TyVar ( GenTyVar, GenTyVarSet(..), +import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), elementOfTyVarSet, emptyTyVarSet, unionTyVarSets, isEmptyTyVarSet, tyVarSetToList ) import Unique ( Unique ) @@ -162,26 +162,6 @@ tcSimplify local_tvs wanteds tcSimpl False global_tvs local_tvs emptyBag wanteds \end{code} -@tcSimplifyWithExtraGlobals@ is just like @tcSimplify@ except that you get -to specify some extra global type variables that the simplifer will treat -as free in the environment. - -\begin{code} -tcSimplifyWithExtraGlobals - :: TcTyVarSet s -- Extra ``Global'' type variables - -> TcTyVarSet s -- ``Local'' type variables - -> LIE s -- Wanted - -> TcM s (LIE s, -- Free - [(TcIdOcc s,TcExpr s)], -- Bindings - LIE s) -- Remaining wanteds; no dups - -tcSimplifyWithExtraGlobals extra_global_tvs local_tvs wanteds - = tcGetGlobalTyVars `thenNF_Tc` \ global_tvs -> - tcSimpl False - (global_tvs `unionTyVarSets` extra_global_tvs) - local_tvs emptyBag wanteds -\end{code} - @tcSimplifyAndCheck@ is similar to the above, except that it checks that there is an empty wanted-set at the end. It may still return some of constant insts, which have to be resolved finally at the end. diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 8ee07e5..ae2cb40 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -29,12 +29,12 @@ import TcKind ( TcKind, newKindVars ) import TcTyDecls ( tcTyDecl, mkDataBinds ) import Bag -import Class ( Class(..), classSelIds ) +import Class ( SYN_IE(Class), classSelIds ) import Digraph ( findSCCs, SCC(..) ) import Name ( getSrcLoc ) import PprStyle import Pretty -import UniqSet ( UniqSet(..), emptyUniqSet, +import UniqSet ( SYN_IE(UniqSet), emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, uniqSetToList ) import SrcLoc ( SrcLoc ) diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 0191ba6..a45e600 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -45,7 +45,7 @@ import Id ( mkDataCon, dataConSig, mkRecordSelId, idType, ) import FieldLabel import Kind ( Kind, mkArrowKind, mkBoxedTypeKind ) -import SpecEnv ( SpecEnv(..), nullSpecEnv ) +import SpecEnv ( SYN_IE(SpecEnv), nullSpecEnv ) import Name ( nameSrcLoc, isLocallyDefinedName, getSrcLoc, Name{-instance Ord3-} ) @@ -62,7 +62,7 @@ import Type ( GenType, -- instances import PprType ( GenTyVar{-instance Outputable-}{-ToDo:possibly rm-} ) import TyVar ( tyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} ) import Unique ( Unique {- instance Eq -}, evalClassKey ) -import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet(..) ) +import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, SYN_IE(UniqSet) ) import Util ( equivClasses, zipEqual, nOfThem, panic, assertPanic ) \end{code} diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index a237dc6..5b18277 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -22,7 +22,7 @@ module TcType ( tcInstTyVars, tcInstSigTyVars, - tcInstType, tcInstSigType, tcInstTcType, + tcInstType, tcInstSigType, tcInstTcType, tcInstSigTcType, tcInstTheta, tcInstId, zonkTcTyVars, @@ -36,13 +36,13 @@ module TcType ( -- friends: -import Type ( Type(..), ThetaType(..), GenType(..), +import Type ( SYN_IE(Type), SYN_IE(ThetaType), GenType(..), tyVarsOfTypes, getTyVar_maybe, splitForAllTy, splitRhoTy, mkForAllTys, instantiateTy ) -import TyVar ( TyVar(..), GenTyVar(..), TyVarSet(..), GenTyVarSet(..), - TyVarEnv(..), lookupTyVarEnv, addOneToTyVarEnv, +import TyVar ( SYN_IE(TyVar), GenTyVar(..), SYN_IE(TyVarSet), SYN_IE(GenTyVarSet), + SYN_IE(TyVarEnv), lookupTyVarEnv, addOneToTyVarEnv, nullTyVarEnv, mkTyVarEnv, tyVarSetToList ) @@ -53,7 +53,7 @@ import Id ( idType ) import Kind ( Kind ) import TcKind ( TcKind ) import TcMonad hiding ( rnMtoTcM ) -import Usage ( Usage(..), GenUsage, UVar(..), duffUsage ) +import Usage ( SYN_IE(Usage), GenUsage, SYN_IE(UVar), duffUsage ) import TysPrim ( voidTy ) @@ -170,6 +170,15 @@ tcInstTcType ty where (tyvars, rho) = splitForAllTy ty +tcInstSigTcType :: TcType s -> NF_TcM s ([TcTyVar s], TcType s) +tcInstSigTcType ty + = case tyvars of + [] -> returnNF_Tc ([], ty) -- Nothing to do + other -> tcInstSigTyVars 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) diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs index 77742f4..bc654dc 100644 --- a/ghc/compiler/typecheck/Unify.lhs +++ b/ghc/compiler/typecheck/Unify.lhs @@ -17,7 +17,7 @@ IMP_Ubiq() import TcMonad hiding ( rnMtoTcM ) import Type ( GenType(..), typeKind, mkFunTy, getFunTy_maybe ) import TyCon ( TyCon, mkFunTyCon ) -import TyVar ( GenTyVar(..), TyVar(..), tyVarKind ) +import TyVar ( GenTyVar(..), SYN_IE(TyVar), tyVarKind ) import TcType ( TcType(..), TcMaybe(..), TcTauType(..), TcTyVar(..), newTyVarTy, tcReadTyVar, tcWriteTyVar, zonkTcType ) @@ -124,6 +124,14 @@ uTys ps_ty1 (TyConTy con1 _) ps_ty2 (TyConTy con2 _) uTys ps_ty1 (SynTy con1 args1 ty1) ps_ty2 ty2 = uTys ps_ty1 ty1 ps_ty2 ty2 uTys ps_ty1 ty1 ps_ty2 (SynTy con2 args2 ty2) = uTys ps_ty1 ty1 ps_ty2 ty2 + -- Not expecting for-alls in unification +#ifdef DEBUG +uTys ps_ty1 (ForAllTy _ _) ps_ty2 ty2 = panic "Unify.uTys:ForAllTy (1st arg)" +uTys ps_ty1 ty1 ps_ty2 (ForAllTy _ _) = panic "Unify.uTys:ForAllTy (2nd arg)" +uTys ps_ty1 (ForAllUsageTy _ _ _) ps_ty2 ty2 = panic "Unify.uTys:ForAllUsageTy (1st arg)" +uTys ps_ty1 ty1 ps_ty2 (ForAllUsageTy _ _ _) = panic "Unify.uTys:ForAllUsageTy (2nd arg)" +#endif + -- Anything else fails uTys ps_ty1 ty1 ps_ty2 ty2 = failTc (unifyMisMatch ps_ty1 ps_ty2) \end{code} diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 2a38d47..e976349 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -7,7 +7,7 @@ #include "HsVersions.h" module Class ( - GenClass(..), Class(..), + GenClass(..), SYN_IE(Class), mkClass, classKey, classOps, classSelIds, @@ -20,12 +20,12 @@ module Class ( cCallishClassKeys, isNoDictClass, isNumericClass, isStandardClass, isCcallishClass, - GenClassOp(..), ClassOp(..), + GenClassOp(..), SYN_IE(ClassOp), mkClassOp, classOpTag, classOpString, classOpLocalType, - ClassInstEnv(..) + SYN_IE(ClassInstEnv) ) where CHK_Ubiq() -- debugging consistency check @@ -33,13 +33,14 @@ CHK_Ubiq() -- debugging consistency check IMPORT_DELOOPER(TyLoop) import TyCon ( TyCon ) -import TyVar ( TyVar(..), GenTyVar ) -import Usage ( GenUsage, Usage(..), UVar(..) ) +import TyVar ( SYN_IE(TyVar), GenTyVar ) +import Usage ( GenUsage, SYN_IE(Usage), SYN_IE(UVar) ) -import Maybes ( assocMaybe, Maybe ) -import Name ( changeUnique ) +import MatchEnv ( MatchEnv ) +import Maybes ( assocMaybe ) +import Name ( changeUnique, Name ) import Unique -- Keys for built-in classes -import Pretty ( Pretty(..), ppCat{-ToDo:rm-}, ppPStr{-ditto-} ) +import Pretty ( SYN_IE(Pretty), ppCat{-ToDo:rm-}, ppPStr{-ditto-} ) import PprStyle ( PprStyle ) import SrcLoc ( SrcLoc ) import Util diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index a4c6d2c..5c34749 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -34,10 +34,10 @@ import Type ( GenType(..), maybeAppTyCon, splitForAllTy, splitSigmaTy, splitRhoTy, splitAppTy ) import TyVar ( GenTyVar(..) ) import TyCon ( TyCon(..), NewOrData ) -import Class ( Class(..), GenClass(..), - ClassOp(..), GenClassOp(..) ) +import Class ( SYN_IE(Class), GenClass(..), + SYN_IE(ClassOp), GenClassOp(..) ) import Kind ( Kind(..) ) -import Usage ( GenUsage(..) ) +import Usage ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar) ) -- others: import CStrings ( identToC ) @@ -53,7 +53,6 @@ import Pretty import TysWiredIn ( listTyCon ) import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList{-ToDo:rm-} ) import Unique ( pprUnique10, pprUnique, incrUnique, listTyConKey ) -import Usage ( UVar(..), pprUVar ) import Util \end{code} @@ -167,13 +166,12 @@ ppr_ty sty env ctxt_prec ty@(AppTy _ _) where (fun_ty, arg_tys) = splitAppTy ty -{- OLD: -ppr_ty PprInterface env ctxt_prec (SynTy tycon tys expansion) - -- always expand types in an interface - = ppr_ty PprInterface env ctxt_prec expansion --} - ppr_ty sty env ctxt_prec (SynTy tycon tys expansion) + | codeStyle sty + -- always expand types that squeak into C-variable names + = ppr_ty sty env ctxt_prec expansion + + | otherwise = ppBeside (ppr_app sty env ctxt_prec (ppr sty tycon) tys) (ifPprShowAll sty (ppCat [ppStr " {- expansion:", @@ -183,7 +181,6 @@ ppr_ty sty env ctxt_prec (SynTy tycon tys expansion) ppr_ty sty env ctxt_prec (DictTy clas ty usage) = ppr_dict sty env ctxt_prec (clas, ty) - -- Some help functions ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys | length arg_tys == 2 @@ -192,6 +189,7 @@ ppr_corner sty env ctxt_prec (TyConTy FunTyCon usage) arg_tys (ty1:ty2:_) = arg_tys ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys + | not (codeStyle sty) -- no magic in that case = --ASSERT(length arg_tys == a) (if (length arg_tys /= a) then pprTrace "ppr_corner:" (ppCat [ppInt a, ppInterleave ppComma (map (pprGenType PprDebug) arg_tys)]) else id) $ ppBesides [ppLparen, arg_tys_w_commas, ppRparen] @@ -199,7 +197,7 @@ ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys) ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys - | tycon == listTyCon + | not (codeStyle sty) && tycon == listTyCon = ASSERT(length arg_tys == 1) ppBesides [ppLbrack, ppr_ty sty env tOP_PREC ty1, ppRbrack] where @@ -210,7 +208,7 @@ ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys ppr_corner sty env ctxt_prec (TyVarTy tyvar) arg_tys = ppr_app sty env ctxt_prec (ppr_tyvar env tyvar) arg_tys - + ppr_app sty env ctxt_prec pp_fun [] = pp_fun @@ -267,6 +265,9 @@ maybeParen ctxt_prec inner_prec pretty \begin{code} pprGenTyVar sty (TyVar uniq kind name usage) + | codeStyle sty + = pp_u + | otherwise = case sty of PprInterface -> pp_u _ -> ppBesides [pp_name, ppStr "{-", pp_u, ppStr "-}"] @@ -293,32 +294,42 @@ ToDo; all this is suspiciously like getOccName! showTyCon :: PprStyle -> TyCon -> String showTyCon sty tycon = ppShow 80 (pprTyCon sty tycon) -maybe_code sty = if codeStyle sty then identToC else ppPStr +maybe_code sty x + = if codeStyle sty + then ppBesides (ppPStr SLIT("Prelude_") : map mangle x) + else ppStr x + where + -- ToDo: really should be in CStrings + mangle '(' = ppPStr SLIT("Z40") -- decimal ascii #s + mangle ')' = ppPStr SLIT("Z41") + mangle '[' = ppPStr SLIT("Z91") + mangle ']' = ppPStr SLIT("Z93") + mangle ',' = ppPStr SLIT("Z44") + mangle '-' = ppPStr SLIT("Zm") + mangle '>' = ppPStr SLIT("Zg") pprTyCon :: PprStyle -> TyCon -> Pretty pprTyCon sty (PrimTyCon _ name _ _) = ppr sty name -pprTyCon sty FunTyCon = maybe_code sty SLIT("(->)") +pprTyCon sty FunTyCon = maybe_code sty "->" pprTyCon sty (TupleTyCon _ _ arity) = case arity of - 0 -> maybe_code sty SLIT("()") - 2 -> maybe_code sty SLIT("(,)") - 3 -> maybe_code sty SLIT("(,,)") - 4 -> maybe_code sty SLIT("(,,,)") - 5 -> maybe_code sty SLIT("(,,,,)") - n -> maybe_code sty (_PK_ ( "(" ++ nOfThem (n-1) ',' ++ ")")) + 0 -> maybe_code sty "()" + 2 -> maybe_code sty "(,)" + 3 -> maybe_code sty "(,,)" + 4 -> maybe_code sty "(,,,)" + 5 -> maybe_code sty "(,,,,)" + n -> maybe_code sty ( "(" ++ nOfThem (n-1) ',' ++ ")" ) pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd) | uniq == listTyConKey - = maybe_code sty SLIT("[]") + = maybe_code sty "[]" | otherwise = ppr sty name pprTyCon sty (SpecTyCon tc ty_maybes) = ppBeside (pprTyCon sty tc) - (if (codeStyle sty) - then identToC tys_stuff - else ppPStr tys_stuff) + ((if (codeStyle sty) then identToC else ppPStr) tys_stuff) where tys_stuff = specMaybeTysSuffix ty_maybes @@ -348,14 +359,15 @@ ppr_class_op sty tyvars (ClassOp op_name i ty) = case sty of PprForC -> pp_C PprForAsm _ _ -> pp_C - PprInterface -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty] - PprShowAll -> ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty] + PprInterface -> pp_sigd + PprShowAll -> pp_sigd _ -> pp_user where pp_C = ppPStr op_name pp_user = if isLexVarSym op_name && not (isLexSpecialSym op_name) then ppParens pp_C else pp_C + pp_sigd = ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty] \end{code} @@ -368,18 +380,30 @@ ppr_class_op sty tyvars (ClassOp op_name i ty) \begin{code} -- Shallowly magical; converts a type into something -- vaguely close to what can be used in C identifier. - -- Don't forget to include the module name!!! -getTypeString :: Type -> [FAST_STRING] -getTypeString ty = [mod, string] - where - string = _PK_ (tidy (ppShow 1000 ppr_t)) - ppr_t = pprGenType PprForC ty - -- PprForC expands type synonyms as it goes + -- Produces things like what we have in mkCompoundName, + -- which can be "dot"ted together... + +getTypeString :: Type -> [Either OrigName FAST_STRING] - mod - = case (maybeAppTyCon ty) of - Nothing -> panic "getTypeString" - Just (tycon,_) -> moduleOf (origName "getTypeString" tycon) +getTypeString ty + = case (splitAppTy ty) of { (tc, args) -> + do_tc tc : map do_arg_ty args } + where + do_tc (TyConTy tc _) = Left (origName "do_tc" tc) + do_tc (SynTy _ _ ty) = do_tc ty + do_tc other = pprTrace "getTypeString:do_tc:" (pprType PprDebug other) $ + Right (_PK_ (ppShow 1000 (pprType PprForC other))) + + do_arg_ty (TyConTy tc _) = Left (origName "do_arg_ty" tc) + do_arg_ty (TyVarTy tv) = Right (_PK_ (ppShow 80 (ppr PprForC tv))) + do_arg_ty (SynTy _ _ ty) = do_arg_ty ty + do_arg_ty other = pprTrace "getTypeString:do_arg_ty:" (pprType PprDebug other) $ + Right (_PK_ (ppShow 1000 (pprType PprForC other))) + + -- PprForC expands type synonyms as it goes; + -- it also forces consistent naming of tycons + -- (e.g., can't have both "(,) a b" and "(a,b)": + -- must be consistent! -------------------------------------------------- -- tidy: very ad-hoc @@ -399,17 +423,20 @@ getTypeString ty = [mod, string] no_leading_sps (' ':xs) = no_leading_sps xs no_leading_sps other = other -typeMaybeString :: Maybe Type -> [FAST_STRING] -typeMaybeString Nothing = [SLIT("!")] +typeMaybeString :: Maybe Type -> [Either OrigName FAST_STRING] +typeMaybeString Nothing = [Right SLIT("!")] typeMaybeString (Just t) = getTypeString t specMaybeTysSuffix :: [Maybe Type] -> FAST_STRING specMaybeTysSuffix ty_maybes + = panic "PprType.specMaybeTysSuffix" +{- LATER: = let ty_strs = concat (map typeMaybeString ty_maybes) dotted_tys = [ _CONS_ '.' str | str <- ty_strs ] in _CONCAT_ dotted_tys +-} \end{code} ToDo: possibly move: @@ -557,7 +584,7 @@ addUVar, nmbrUVar :: UVar -> NmbrM UVar addUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) = case (lookupUFM_Directly uvenv u) of - Just xx -> _trace "addUVar: already in map!" $ + Just xx -> trace "addUVar: already in map!" $ (nenv, xx) Nothing -> let @@ -573,6 +600,6 @@ nmbrUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) = case (lookupUFM_Directly uvenv u) of Just xx -> (nenv, xx) Nothing -> - _trace "nmbrUVar: lookup failed" $ + trace "nmbrUVar: lookup failed" $ (nenv, u) \end{code} diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 02a7dd3..d79ce4d 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -9,10 +9,10 @@ module TyCon( TyCon(..), -- NB: some pals need to see representation - Arity(..), NewOrData(..), + SYN_IE(Arity), NewOrData(..), isFunTyCon, isPrimTyCon, isBoxedTyCon, - isDataTyCon, isSynTyCon, isNewTyCon, + isDataTyCon, isSynTyCon, isNewTyCon, maybeNewTyCon, mkDataTyCon, mkFunTyCon, @@ -40,15 +40,16 @@ module TyCon( CHK_Ubiq() -- debugging consistency check -IMPORT_DELOOPER(TyLoop) ( Type(..), GenType, - Class(..), GenClass, - Id(..), GenId, - mkTupleCon, isNullaryDataCon, - specMaybeTysSuffix +IMPORT_DELOOPER(TyLoop) ( SYN_IE(Type), GenType, + SYN_IE(Class), GenClass, + SYN_IE(Id), GenId, + splitSigmaTy, splitFunTy, + mkTupleCon, isNullaryDataCon, idType + --LATER: specMaybeTysSuffix ) -import TyVar ( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar ) -import Usage ( GenUsage, Usage(..) ) +import TyVar ( GenTyVar, alphaTyVars, alphaTyVar, betaTyVar, SYN_IE(TyVar) ) +import Usage ( GenUsage, SYN_IE(Usage) ) import Kind ( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind ) import Maybes @@ -56,10 +57,10 @@ import Name ( Name, RdrName(..), appendRdr, nameUnique, mkTupleTyConName, mkFunTyConName ) import Unique ( Unique, funTyConKey, mkTupleTyConUnique ) -import Pretty ( Pretty(..), PrettyRep ) +import Pretty ( SYN_IE(Pretty), PrettyRep ) import PrimRep ( PrimRep(..) ) import SrcLoc ( SrcLoc, mkBuiltinSrcLoc ) -import Util ( panic, panic#, pprPanic{-ToDo:rm-}, nOfThem, isIn, Ord3(..) ) +import Util ( nOfThem, isIn, Ord3(..), panic, panic#, assertPanic, pprPanic{-ToDo:rm-} ) import {-hide me-} PprType (pprTyCon) import {-hide me-} @@ -132,12 +133,9 @@ mkTupleTyCon arity n = mkTupleTyConName arity u = uniqueOf n -mkDataTyCon name - = DataTyCon (nameUnique name) name -mkPrimTyCon name - = PrimTyCon (nameUnique name) name -mkSynTyCon name - = SynTyCon (nameUnique name) name +mkDataTyCon name = DataTyCon (nameUnique name) name +mkPrimTyCon name = PrimTyCon (nameUnique name) name +mkSynTyCon name = SynTyCon (nameUnique name) name isFunTyCon FunTyCon = True isFunTyCon _ = False @@ -155,6 +153,16 @@ isDataTyCon (DataTyCon _ _ _ _ _ _ _ DataType) = True isDataTyCon (TupleTyCon _ _ _) = True isDataTyCon other = False +maybeNewTyCon :: TyCon -> Maybe ([TyVar], Type) -- Returns representation type info +maybeNewTyCon (DataTyCon _ _ _ _ _ (con:null_cons) _ NewType) + = ASSERT( null null_cons && null null_tys) + Just (tyvars, rep_ty) + where + (tyvars, theta, tau) = splitSigmaTy (idType con) + (rep_ty:null_tys, res_ty) = splitFunTy tau + +maybeNewTyCon other = Nothing + isNewTyCon (DataTyCon _ _ _ _ _ _ _ NewType) = True isNewTyCon other = False diff --git a/ghc/compiler/types/TyLoop.lhi b/ghc/compiler/types/TyLoop.lhi index 9fb866f..31e348c 100644 --- a/ghc/compiler/types/TyLoop.lhi +++ b/ghc/compiler/types/TyLoop.lhi @@ -9,12 +9,12 @@ import Unique ( Unique ) import FieldLabel ( FieldLabel ) import Id ( Id, GenId, StrictnessMark, mkTupleCon, mkDataCon, - isNullaryDataCon, dataConArgTys ) + isNullaryDataCon, dataConArgTys, idType ) import PprType ( specMaybeTysSuffix ) import Name ( Name ) import TyCon ( TyCon ) import TyVar ( GenTyVar, TyVar ) -import Type ( GenType, Type ) +import Type ( splitSigmaTy, splitFunTy, GenType, Type ) import Usage ( GenUsage ) import Class ( Class, GenClass ) import TysPrim ( voidTy ) @@ -34,6 +34,9 @@ type Id = GenId (GenType (GenTyVar (GenUsage Unique)) Unique) mkTupleCon :: Int -> Id isNullaryDataCon :: Id -> Bool specMaybeTysSuffix :: [Maybe Type] -> _PackedString +idType :: Id -> Type +splitSigmaTy :: GenType t u -> ([t], [(Class,GenType t u)], GenType t u) +splitFunTy :: GenType t u -> ([GenType t u], GenType t u) instance Eq (GenClass a b) -- Needed in Type diff --git a/ghc/compiler/types/TyLoop.lhs b/ghc/compiler/types/TyLoop.lhs deleted file mode 100644 index e7ba125..0000000 --- a/ghc/compiler/types/TyLoop.lhs +++ /dev/null @@ -1,23 +0,0 @@ - -\begin{code} -module AllTypes( - TyCon, Arity(..), - Class, ClassOp, - GenTyVar, GenType, Type, - Id, - - -- Functions which are, alas, necessary to break loops - mkTupleCon, -- Used in TyCon - - - Kind, -- Not necessary to break loops, but useful - GenUsage -- to get when importing AllTypes -) where - -import TyCon ( TyCon, Arity(..) ) -import Type ( GenTyVar, TyVar(..), GenType, Type(..) ) -import Class ( Class,ClassOp ) -import Id ( Id, mkTupleCon ) -import Kind ( Kind ) -import Usage ( GenUsage, Usage(..) ) -\end{code} diff --git a/ghc/compiler/types/TyLoop_1_3.lhi b/ghc/compiler/types/TyLoop_1_3.lhi new file mode 100644 index 0000000..ebd4bfa --- /dev/null +++ b/ghc/compiler/types/TyLoop_1_3.lhi @@ -0,0 +1,20 @@ +\begin{code} +interface TyLoop_1_3 1 +__exports__ +Outputable Outputable (..) +Type Type +Type GenType +Type splitSigmaTy (..) +Type splitFunTy (..) +Class Class +Class GenClass +Id StrictnessMark(..) +Id Id +Id GenId +Id mkDataCon (..) +Id mkTupleCon (..) +Id idType (..) +Id isNullaryDataCon (..) +Id dataConArgTys (..) +TysPrim voidTy (..) +\end{code} diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs index 7ba82cd..553ad73 100644 --- a/ghc/compiler/types/TyVar.lhs +++ b/ghc/compiler/types/TyVar.lhs @@ -2,8 +2,8 @@ #include "HsVersions.h" module TyVar ( - GenTyVar(..), TyVar(..), - mkTyVar, + GenTyVar(..), SYN_IE(TyVar), + mkTyVar, mkSysTyVar, tyVarKind, -- TyVar -> Kind cloneTyVar, @@ -12,11 +12,11 @@ module TyVar ( -- We also export "environments" keyed off of -- TyVars and "sets" containing TyVars: - TyVarEnv(..), + SYN_IE(TyVarEnv), nullTyVarEnv, mkTyVarEnv, addOneToTyVarEnv, growTyVarEnvList, isNullTyVarEnv, lookupTyVarEnv, - GenTyVarSet(..), TyVarSet(..), + SYN_IE(GenTyVarSet), SYN_IE(TyVarSet), emptyTyVarSet, unitTyVarSet, unionTyVarSets, unionManyTyVarSets, intersectTyVarSets, mkTyVarSet, tyVarSetToList, elementOfTyVarSet, minusTyVarSet, @@ -27,7 +27,7 @@ CHK_Ubiq() -- debugging consistency check IMPORT_DELOOPER(IdLoop) -- for paranoia checking -- friends -import Usage ( GenUsage, Usage(..), usageOmega ) +import Usage ( GenUsage, SYN_IE(Usage), usageOmega ) import Kind ( Kind, mkBoxedTypeKind, mkTypeKind ) -- others @@ -35,9 +35,8 @@ import UniqSet -- nearly all of it import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM, plusUFM, sizeUFM, UniqFM ) -import Maybes ( Maybe(..) ) import Name ( mkLocalName, changeUnique, Name, RdrName(..) ) -import Pretty ( Pretty(..), PrettyRep, ppBeside, ppPStr ) +import Pretty ( SYN_IE(Pretty), PrettyRep, ppBeside, ppPStr ) import PprStyle ( PprStyle ) --import Outputable ( Outputable(..), NamedThing(..), ExportFlag(..) ) import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) @@ -61,11 +60,17 @@ type TyVar = GenTyVar Usage -- Usage slot makes sense only if Kind = Type Simple construction and analysis functions ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -mkTyVar :: Name -> Unique -> Kind -> TyVar -mkTyVar name uniq kind = TyVar uniq - kind - (Just (changeUnique name uniq)) - usageOmega +mkTyVar :: Name -> Kind -> TyVar +mkTyVar name kind = TyVar (uniqueOf name) + kind + (Just name) + usageOmega + +mkSysTyVar :: Unique -> Kind -> TyVar +mkSysTyVar uniq kind = TyVar uniq + kind + Nothing + usageOmega tyVarKind :: GenTyVar flexi -> Kind tyVarKind (TyVar _ kind _ _) = kind diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 41f3cce..bebf0f5 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -2,11 +2,12 @@ #include "HsVersions.h" module Type ( - GenType(..), Type(..), TauType(..), + GenType(..), SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, isTyVarTy, mkAppTy, mkAppTys, splitAppTy, - mkFunTy, mkFunTys, splitFunTy, splitFunTyExpandingDicts, + mkFunTy, mkFunTys, + splitFunTy, splitFunTyExpandingDicts, splitFunTyExpandingDictsAndPeeking, getFunTy_maybe, getFunTyExpandingDicts_maybe, mkTyConTy, getTyCon_maybe, applyTyCon, mkSynTy, @@ -18,7 +19,7 @@ module Type ( #endif isPrimType, isUnboxedType, typePrimRep, - RhoType(..), SigmaType(..), ThetaType(..), + SYN_IE(RhoType), SYN_IE(SigmaType), SYN_IE(ThetaType), mkDictTy, mkRhoTy, splitRhoTy, mkTheta, mkSigmaTy, splitSigmaTy, @@ -46,14 +47,15 @@ IMPORT_DELOOPER(PrelLoop) -- for paranoia checking -- friends: import Class ( classSig, classOpLocalType, GenClass{-instances-} ) -import Kind ( mkBoxedTypeKind, resultKind, notArrowKind ) -import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, isPrimTyCon, isDataTyCon, isSynTyCon, +import Kind ( mkBoxedTypeKind, resultKind, notArrowKind, Kind ) +import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon, + isPrimTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon, tyConKind, tyConDataCons, getSynTyConDefn, TyCon ) -import TyVar ( tyVarKind, GenTyVar{-instances-}, GenTyVarSet(..), +import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet), emptyTyVarSet, unionTyVarSets, minusTyVarSet, unitTyVarSet, nullTyVarEnv, lookupTyVarEnv, - addOneToTyVarEnv, TyVarEnv(..) ) -import Usage ( usageOmega, GenUsage, Usage(..), UVar(..), UVarEnv(..), + addOneToTyVarEnv, SYN_IE(TyVarEnv), SYN_IE(TyVar) ) +import Usage ( usageOmega, GenUsage, SYN_IE(Usage), SYN_IE(UVar), SYN_IE(UVarEnv), nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar, eqUsage ) @@ -233,19 +235,36 @@ getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res) getFunTy_maybe (SynTy _ _ t) = getFunTy_maybe t getFunTy_maybe other = Nothing -getFunTyExpandingDicts_maybe :: Type -> Maybe (Type, Type) -getFunTyExpandingDicts_maybe (FunTy arg result _) = Just (arg,result) -getFunTyExpandingDicts_maybe - (AppTy (AppTy (TyConTy tycon _) arg) res) | isFunTyCon tycon = Just (arg, res) -getFunTyExpandingDicts_maybe (SynTy _ _ t) = getFunTyExpandingDicts_maybe t -getFunTyExpandingDicts_maybe ty@(DictTy _ _ _) = getFunTyExpandingDicts_maybe (expandTy ty) -getFunTyExpandingDicts_maybe other = Nothing - -splitFunTy :: GenType t u -> ([GenType t u], GenType t u) -splitFunTyExpandingDicts :: Type -> ([Type], Type) +getFunTyExpandingDicts_maybe :: Bool -- True <=> peek inside newtype applicatons + -> Type + -> Maybe (Type, Type) -splitFunTy t = split_fun_ty getFunTy_maybe t -splitFunTyExpandingDicts t = split_fun_ty getFunTyExpandingDicts_maybe t +getFunTyExpandingDicts_maybe peek (FunTy arg result _) = Just (arg,result) +getFunTyExpandingDicts_maybe peek + (AppTy (AppTy (TyConTy tycon _) arg) res) | isFunTyCon tycon = Just (arg, res) +getFunTyExpandingDicts_maybe peek (SynTy _ _ t) = getFunTyExpandingDicts_maybe peek t +getFunTyExpandingDicts_maybe peek ty@(DictTy _ _ _) = getFunTyExpandingDicts_maybe peek (expandTy ty) +getFunTyExpandingDicts_maybe peek other + | not peek = Nothing -- that was easy + | otherwise + = case (maybeAppTyCon other) of + Nothing -> Nothing + Just (tc, arg_tys) + | not (isNewTyCon tc) -> Nothing + | otherwise -> + let + [newtype_con] = tyConDataCons tc -- there must be exactly one... + [inside_ty] = dataConArgTys newtype_con arg_tys + in + getFunTyExpandingDicts_maybe peek inside_ty + +splitFunTy :: GenType t u -> ([GenType t u], GenType t u) +splitFunTyExpandingDicts :: Type -> ([Type], Type) +splitFunTyExpandingDictsAndPeeking :: Type -> ([Type], Type) + +splitFunTy t = split_fun_ty getFunTy_maybe t +splitFunTyExpandingDicts t = split_fun_ty (getFunTyExpandingDicts_maybe False) t +splitFunTyExpandingDictsAndPeeking t = split_fun_ty (getFunTyExpandingDicts_maybe True) t split_fun_ty get t = go t [] where @@ -606,7 +625,7 @@ applyTypeEnvToTy tenv ty deflt_forall_tv tv = case (lookup_tv tv) of Nothing -> tv Just (TyVarTy tv2) -> tv2 - _ -> panic "applyTypeEnvToTy" + _ -> pprPanic "applyTypeEnvToTy:" (ppAbove (ppr PprShowAll tv) (ppr PprShowAll ty)) \end{code} \begin{code} @@ -616,15 +635,25 @@ instantiateUsage instantiateUsage = panic "instantiateUsage: not implemented" \end{code} + At present there are no unboxed non-primitive types, so isUnboxedType is the same as isPrimType. +We're a bit cavalier about finding out whether something is +primitive/unboxed or not. Rather than deal with the type +arguemnts we just zoom into the function part of the type. +That is, given (T a) we just recurse into the "T" part, +ignoring "a". + \begin{code} -isPrimType, isUnboxedType :: GenType tyvar uvar -> Bool +isPrimType, isUnboxedType :: Type -> Bool isPrimType (AppTy ty _) = isPrimType ty isPrimType (SynTy _ _ ty) = isPrimType ty -isPrimType (TyConTy tycon _) = isPrimTyCon tycon +isPrimType (TyConTy tycon _) = case maybeNewTyCon tycon of + Just (tyvars, ty) -> isPrimType ty + Nothing -> isPrimTyCon tycon + isPrimType _ = False isUnboxedType = isPrimType @@ -632,17 +661,19 @@ isUnboxedType = isPrimType This is *not* right: it is a placeholder (ToDo 96/03 WDP): \begin{code} -typePrimRep :: GenType tyvar uvar -> PrimRep +typePrimRep :: Type -> PrimRep typePrimRep (SynTy _ _ ty) = typePrimRep ty typePrimRep (AppTy ty _) = typePrimRep ty -typePrimRep (TyConTy tc _) = if not (isPrimTyCon tc) then - PtrRep - else - case (assocMaybe tc_primrep_list (uniqueOf tc)) of +typePrimRep (TyConTy tc _) + | isPrimTyCon tc = case (assocMaybe tc_primrep_list (uniqueOf tc)) of Just xx -> xx Nothing -> pprPanic "typePrimRep:" (pprTyCon PprDebug tc) + | otherwise = case maybeNewTyCon tc of + Just (tyvars, ty) | isPrimType ty -> typePrimRep ty + _ -> PtrRep -- Default + typePrimRep _ = PtrRep -- the "default" tc_primrep_list diff --git a/ghc/compiler/types/Usage.lhs b/ghc/compiler/types/Usage.lhs index c5e26d2..e13a619 100644 --- a/ghc/compiler/types/Usage.lhs +++ b/ghc/compiler/types/Usage.lhs @@ -7,7 +7,7 @@ #include "HsVersions.h" module Usage ( - GenUsage(..), Usage(..), UVar(..), UVarEnv(..), + GenUsage(..), SYN_IE(Usage), SYN_IE(UVar), SYN_IE(UVarEnv), usageOmega, pprUVar, duffUsage, nullUVarEnv, mkUVarEnv, addOneToUVarEnv, growUVarEnvList, isNullUVarEnv, lookupUVarEnv, @@ -16,7 +16,7 @@ module Usage ( IMP_Ubiq(){-uitous-} -import Pretty ( Pretty(..), PrettyRep, ppPStr, ppBeside ) +import Pretty ( SYN_IE(Pretty), PrettyRep, ppPStr, ppBeside ) import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM, plusUFM, sizeUFM, UniqFM ) diff --git a/ghc/compiler/utils/Argv.lhs b/ghc/compiler/utils/Argv.lhs index 58926a8..821a806 100644 --- a/ghc/compiler/utils/Argv.lhs +++ b/ghc/compiler/utils/Argv.lhs @@ -12,10 +12,18 @@ import PreludeGlaST ( indexAddrOffAddr ) CHK_Ubiq() -- debugging consistency check +#if __GLASGOW_HASKELL__ >= 200 +# define ADDR GHCbase.Addr +# define PACK_STR packCString +#else +# define ADDR _Addr +# define PACK_STR _packCString +#endif + argv :: [FAST_STRING] argv = unpackArgv ``prog_argv'' (``prog_argc''::Int) -unpackArgv :: _Addr -> Int -> [FAST_STRING] -- argv[1 .. argc-1] +unpackArgv :: ADDR -> Int -> [FAST_STRING] -- argv[1 .. argc-1] unpackArgv argv argc = unpack 1 where @@ -24,6 +32,6 @@ unpackArgv argv argc = unpack 1 = if (n >= argc) then ([] :: [FAST_STRING]) else case (indexAddrOffAddr argv n) of { item -> - _packCString item : unpack (n + 1) + PACK_STR item : unpack (n + 1) } \end{code} diff --git a/ghc/compiler/utils/Digraph.lhs b/ghc/compiler/utils/Digraph.lhs index 2e8b032..a76c7e4 100644 --- a/ghc/compiler/utils/Digraph.lhs +++ b/ghc/compiler/utils/Digraph.lhs @@ -17,10 +17,12 @@ module Digraph ( ) where CHK_Ubiq() -- debugging consistency check +IMPORT_1_3(List(partition)) -import Maybes ( Maybe, MaybeErr(..), maybeToBool ) +import Maybes ( MaybeErr(..), maybeToBool ) import Bag ( Bag, filterBag, bagToList, listToBag ) import FiniteMap ( FiniteMap, listToFM, lookupFM, lookupWithDefaultFM ) +import Unique ( Unique ) import Util \end{code} @@ -105,6 +107,8 @@ dfs eq r (vs,ns) (x:xs) \end{code} \begin{code} +{-# SPECIALIZE findSCCs :: (a -> (Unique, Bag Unique)) -> Bag a -> [SCC a] #-} + findSCCs :: Ord key => (vertex -> (key, Bag key)) -- Give key of vertex, and keys of thing's -- immediate neighbours. It's ok for the diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs index e2a9ec5..3eab99e 100644 --- a/ghc/compiler/utils/FiniteMap.lhs +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -60,7 +60,7 @@ module FiniteMap ( #ifdef COMPILING_GHC , bagToFM - , FiniteSet(..), emptySet, mkSet, isEmptySet + , SYN_IE(FiniteSet), emptySet, mkSet, isEmptySet , elementOf, setToList, union, minusSet #endif ) where @@ -73,11 +73,14 @@ IMP_Ubiq(){-uitous-} import Pretty # endif import Bag ( foldBag ) -#if ! OMIT_NATIVE_CODEGEN -#define IF_NCG(a) a -#else -#define IF_NCG(a) {--} -#endif +import {-hide from mkdependHS-} + Name ( RdrName, OrigName ) -- specialising only + +# if ! OMIT_NATIVE_CODEGEN +# define IF_NCG(a) a +# else +# define IF_NCG(a) {--} +# endif #endif -- SIGH: but we use unboxed "sizes"... @@ -756,46 +759,53 @@ When the FiniteMap module is used in GHC, we specialise it for {-# SPECIALIZE addListToFM :: 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 COMMA elt)] -> FiniteMap Reg elt) #-} {-# SPECIALIZE addListToFM_C - :: (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 + :: (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) #-} {-# 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 + :: 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 + , FiniteMap OrigName elt -> OrigName -> elt -> FiniteMap OrigName elt IF_NCG(COMMA FiniteMap Reg elt -> Reg -> elt -> FiniteMap Reg elt) #-} {-# 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 + :: (elt -> elt -> elt) -> FiniteMap (RdrName, RdrName) elt -> (RdrName, RdrName) -> elt -> FiniteMap (RdrName, RdrName) elt + , (elt -> elt -> elt) -> FiniteMap (OrigName, OrigName) elt -> (OrigName, OrigName) -> elt -> FiniteMap (OrigName, OrigName) 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) #-} {-# SPECIALIZE bagToFM :: Bag (FAST_STRING,elt) -> FiniteMap FAST_STRING elt #-} {-# SPECIALIZE delListFromFM - :: FiniteMap RdrName elt -> [RdrName] -> FiniteMap RdrName elt, - FiniteMap FAST_STRING elt -> [FAST_STRING] -> FiniteMap FAST_STRING elt + :: FiniteMap RdrName elt -> [RdrName] -> FiniteMap RdrName elt + , FiniteMap OrigName elt -> [OrigName] -> FiniteMap OrigName elt + , FiniteMap FAST_STRING elt -> [FAST_STRING] -> FiniteMap FAST_STRING elt IF_NCG(COMMA FiniteMap Reg elt -> [Reg] -> 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 + :: [([Char],elt)] -> FiniteMap [Char] elt + , [(FAST_STRING,elt)] -> FiniteMap FAST_STRING elt + , [((FAST_STRING,FAST_STRING),elt)] -> FiniteMap (FAST_STRING, FAST_STRING) elt + , [(OrigName,elt)] -> FiniteMap OrigName elt IF_NCG(COMMA [(Reg COMMA elt)] -> FiniteMap Reg elt) #-} {-# SPECIALIZE lookupFM - :: 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 RdrName elt -> RdrName -> Maybe elt, - FiniteMap (RdrName,RdrName) elt -> (RdrName,RdrName) -> 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 OrigName elt -> OrigName -> Maybe elt + , FiniteMap (OrigName,OrigName) elt -> (OrigName,OrigName) -> 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 @@ -803,8 +813,9 @@ When the FiniteMap module is used in GHC, we specialise it for IF_NCG(COMMA FiniteMap Reg elt -> elt -> Reg -> elt) #-} {-# SPECIALIZE plusFM - :: FiniteMap RdrName elt -> FiniteMap RdrName elt -> FiniteMap RdrName elt, - FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt -> FiniteMap FAST_STRING elt + :: FiniteMap RdrName elt -> FiniteMap RdrName elt -> FiniteMap RdrName elt + , FiniteMap OrigName elt -> FiniteMap OrigName elt -> FiniteMap OrigName 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 diff --git a/ghc/compiler/utils/Maybes.lhs b/ghc/compiler/utils/Maybes.lhs index c40ffb2..5ed4ac3 100644 --- a/ghc/compiler/utils/Maybes.lhs +++ b/ghc/compiler/utils/Maybes.lhs @@ -39,6 +39,8 @@ module Maybes ( CHK_Ubiq() -- debugging consistency check +import Unique (Unique) -- only for specialising + #endif \end{code} @@ -129,14 +131,11 @@ assocMaybe alist key lookup ((tv,ty):rest) = if key == tv then Just ty else lookup rest #if defined(COMPILING_GHC) -{-? SPECIALIZE assocMaybe - :: [(String, b)] -> String -> Maybe b, - [(Id, b)] -> Id -> Maybe b, - [(Class, b)] -> Class -> Maybe b, - [(Int, b)] -> Int -> Maybe b, - [(Name, b)] -> Name -> Maybe b, - [(TyVar, b)] -> TyVar -> Maybe b, - [(TyVarTemplate, b)] -> TyVarTemplate -> Maybe b +{-# SPECIALIZE assocMaybe + :: [(FAST_STRING, b)] -> FAST_STRING -> Maybe b + , [(Int, b)] -> Int -> Maybe b + , [(Unique, b)] -> Unique -> Maybe b + , [(RdrName, b)] -> RdrName -> Maybe b #-} #endif \end{code} diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs index 8cb2440..985666d 100644 --- a/ghc/compiler/utils/Pretty.lhs +++ b/ghc/compiler/utils/Pretty.lhs @@ -149,6 +149,7 @@ ppInt n width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls) ppInteger n = ppStr (show n) ppDouble n = ppStr (show n) ppFloat n = ppStr (show n) + ppRational n = ppStr (show (fromRationalX n)) -- _showRational 30 n) ppSP = ppChar ' ' diff --git a/ghc/compiler/utils/SST.lhs b/ghc/compiler/utils/SST.lhs index b3fe532..4c4cbb4 100644 --- a/ghc/compiler/utils/SST.lhs +++ b/ghc/compiler/utils/SST.lhs @@ -5,25 +5,34 @@ #include "HsVersions.h" module SST( - SST(..), SST_R, FSST(..), FSST_R, + SYN_IE(SST), SST_R, SYN_IE(FSST), FSST_R, - _runSST, sstToST, stToSST, + runSST, sstToST, stToSST, thenSST, thenSST_, returnSST, fixSST, thenFSST, thenFSST_, returnFSST, failFSST, recoverFSST, recoverSST, fixFSST, - MutableVar(..), _MutableArray, newMutVarSST, readMutVarSST, writeMutVarSST +#if __GLASGOW_HASKELL__ >= 200 + , MutableVar +#else + , MutableVar(..), _MutableArray +#endif ) where -import PreludeGlaST( MutableVar(..), _MutableArray(..), ST(..) ) +#if __GLASGOW_HASKELL__ >= 200 +import GHCbase +#else +import PreludeGlaST ( MutableVar(..), _MutableArray(..), ST(..) ) +#endif CHK_Ubiq() -- debugging consistency check \end{code} \begin{code} data SST_R s r = SST_R r (State# s) -type SST s r = State# s -> SST_R s r +type SST s r = State# s -> SST_R s r + \end{code} \begin{code} @@ -32,40 +41,57 @@ type SST s r = State# s -> SST_R s r sstToST :: SST s r -> ST s r stToSST :: ST s r -> SST s r +#if __GLASGOW_HASKELL__ >= 200 + +sstToST sst = ST $ \ (S# s) -> + case sst s of SST_R r s' -> (r, S# s') + +stToSST (ST st) = \ s -> + case st (S# s) of (r, S# s') -> SST_R r s' + +#else sstToST sst (S# s) = case sst s of SST_R r s' -> (r, S# s') stToSST st s = case st (S# s) of (r, S# s') -> SST_R r s' - +#endif -- Type of runSST should be builtin ... -- runSST :: forall r. (forall s. SST s r) -> r -_runSST :: SST _RealWorld r -> r -_runSST m = case m realWorld# of SST_R r s -> r +#if __GLASGOW_HASKELL__ >= 200 +# define REAL_WORLD RealWorld +# define MUT_ARRAY MutableArray +#else +# define REAL_WORLD _RealWorld +# define MUT_ARRAY _MutableArray +#endif +runSST :: SST REAL_WORLD r -> r +runSST m = case m realWorld# of SST_R r s -> r -thenSST :: SST s r -> (r -> State# s -> b) -> State# s -> b +returnSST :: r -> SST s r +thenSST :: SST s r -> (r -> State# s -> b) -> State# s -> b +thenSST_ :: SST s r -> (State# s -> b) -> State# s -> b +fixSST :: (r -> SST s r) -> SST s r +{-# INLINE returnSST #-} {-# INLINE thenSST #-} +{-# INLINE thenSST_ #-} + -- Hence: -- thenSST :: SST s r -> (r -> SST s r') -> SST s r' -- and thenSST :: SST s r -> (r -> FSST s r' err) -> FSST s r' err -thenSST m k s = case m s of { SST_R r s' -> k r s' } - -thenSST_ :: SST s r -> (State# s -> b) -> State# s -> b -{-# INLINE thenSST_ #-} -- Hence: -- thenSST_ :: SST s r -> SST s r' -> SST s r' -- and thenSST_ :: SST s r -> FSST s r' err -> FSST s r' err +thenSST m k s = case m s of { SST_R r s' -> k r s' } + thenSST_ m k s = case m s of { SST_R r s' -> k s' } -returnSST :: r -> SST s r -{-# INLINE returnSST #-} returnSST r s = SST_R r s -fixSST :: (r -> SST s r) -> SST s r fixSST m s = result where result = m loop s @@ -77,50 +103,48 @@ fixSST m s = result %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -data FSST_R s r err = FSST_R_OK r (State# s) - | FSST_R_Fail err (State# s) +data FSST_R s r err + = FSST_R_OK r (State# s) + | FSST_R_Fail err (State# s) -type FSST s r err = State# s -> FSST_R s r err +type FSST s r err = State# s -> FSST_R s r err \end{code} \begin{code} -thenFSST :: FSST s r err -> (r -> FSST s r' err) -> FSST s r' err +failFSST :: err -> FSST s r err +fixFSST :: (r -> FSST s r err) -> FSST s r err +recoverFSST :: (err -> FSST s r err) -> FSST s r err -> FSST s r err +recoverSST :: (err -> SST s r) -> FSST s r err -> SST s r +returnFSST :: r -> FSST s r err +thenFSST :: FSST s r err -> (r -> FSST s r' err) -> FSST s r' err +thenFSST_ :: FSST s r err -> FSST s r' err -> FSST s r' err +{-# INLINE failFSST #-} +{-# INLINE returnFSST #-} {-# INLINE thenFSST #-} +{-# INLINE thenFSST_ #-} + thenFSST m k s = case m s of FSST_R_OK r s' -> k r s' FSST_R_Fail err s' -> FSST_R_Fail err s' -thenFSST_ :: FSST s r err -> FSST s r' err -> FSST s r' err -{-# INLINE thenFSST_ #-} thenFSST_ m k s = case m s of FSST_R_OK r s' -> k s' FSST_R_Fail err s' -> FSST_R_Fail err s' -returnFSST :: r -> FSST s r err -{-# INLINE returnFSST #-} returnFSST r s = FSST_R_OK r s -failFSST :: err -> FSST s r err -{-# INLINE failFSST #-} failFSST err s = FSST_R_Fail err s -recoverFSST :: (err -> FSST s r err) - -> FSST s r err - -> FSST s r err recoverFSST recovery_fn m s = case m s of FSST_R_OK r s' -> FSST_R_OK r s' FSST_R_Fail err s' -> recovery_fn err s' -recoverSST :: (err -> SST s r) - -> FSST s r err - -> SST s r recoverSST recovery_fn m s = case m s of FSST_R_OK r s' -> SST_R r s' FSST_R_Fail err s' -> recovery_fn err s' -fixFSST :: (r -> FSST s r err) -> FSST s r err fixFSST m s = result where result = m loop s @@ -132,20 +156,21 @@ Mutables Here we implement mutable variables. ToDo: get rid of the array impl. \begin{code} -newMutVarSST :: a -> SST s (MutableVar s a) +newMutVarSST :: a -> SST s (MutableVar s a) +readMutVarSST :: MutableVar s a -> SST s a +writeMutVarSST :: MutableVar s a -> a -> SST s () + newMutVarSST init s# = case (newArray# 1# init s#) of { StateAndMutableArray# s2# arr# -> - SST_R (_MutableArray vAR_IXS arr#) s2# } + SST_R (MUT_ARRAY vAR_IXS arr#) s2# } where vAR_IXS = error "Shouldn't access `bounds' of a MutableVar\n" -readMutVarSST :: MutableVar s a -> SST s a -readMutVarSST (_MutableArray _ var#) s# +readMutVarSST (MUT_ARRAY _ var#) s# = case readArray# var# 0# s# of { StateAndPtr# s2# r -> SST_R r s2# } -writeMutVarSST :: MutableVar s a -> a -> SST s () -writeMutVarSST (_MutableArray _ var#) val s# +writeMutVarSST (MUT_ARRAY _ var#) val s# = case writeArray# var# 0# val s# of { s2# -> SST_R () s2# } \end{code} diff --git a/ghc/compiler/utils/Ubiq_1_3.lhi b/ghc/compiler/utils/Ubiq_1_3.lhi new file mode 100644 index 0000000..ffc378a --- /dev/null +++ b/ghc/compiler/utils/Ubiq_1_3.lhi @@ -0,0 +1,67 @@ +\begin{code} +interface Ubiq_1_3 1 +__exports__ +GHCbase trace (..) +GHCbase PrimIO -- this is here because of the bug preventing it getting into PreludeGlaST +GHCps nilPS (..) +-- GHCps substrPS (..) +-- GHCps tailPS (..) +GHCps appendPS (..) +GHCps concatPS (..) +GHCps consPS (..) +GHCps headPS (..) +GHCps lengthPS (..) +GHCps nullPS (..) +GHCps packCString (..) +GHCps packCBytes (..) +GHCps packString (..) +GHCps unpackPS (..) +Bag Bag +BinderInfo BinderInfo +CLabel CLabel +Class Class +ClosureInfo ClosureInfo +CoreSyn GenCoreExpr +CoreUnfold UnfoldingDetails +CoreUnfold UnfoldingGuidance +CostCentre CostCentre +HeapOffs HeapOffset +HsCore UnfoldingCoreExpr +HsPragmas ClassOpPragmas +HsPragmas ClassPragmas +HsPragmas DataPragmas +HsPragmas GenPragmas +HsPragmas InstancePragmas +Id Id +IdInfo ArityInfo +IdInfo DeforestInfo +IdInfo Demand +IdInfo IdInfo +IdInfo OptIdInfo(..) +IdInfo StrictnessInfo +IdInfo UpdateInfo +Kind Kind +Literal Literal +Maybes MaybeErr +Name ExportFlag +Name Module +Name NamedThing (..) +Name OrigName (..) +Name RdrName (..) +Outputable Outputable (..) +PprStyle PprStyle +PrimOp PrimOp +PrimRep PrimRep +SrcLoc SrcLoc +TyCon Arity +TyCon TyCon +TyVar TyVar +Type GenType +Type Type +UniqFM UniqFM +UniqFM Uniquable (..) +UniqSupply UniqSupply +Unique Unique +Usage GenUsage +Util Ord3 (..) +\end{code} diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs index a2f4880..f7f1cba 100644 --- a/ghc/compiler/utils/UniqFM.lhs +++ b/ghc/compiler/utils/UniqFM.lhs @@ -55,12 +55,15 @@ module UniqFM ( #if defined(COMPILING_GHC) IMP_Ubiq(){-uitous-} +import {-hide from mkdependHS-} + Name ( Name ) -- specialising only +import {-hide from mkdependHS-} + RnHsSyn ( RnName ) -- specialising only #endif import Unique ( Unique, u2i, mkUniqueGrimily ) import Util ---import Outputable ( Outputable(..), ExportFlag ) -import Pretty ( Pretty(..), PrettyRep ) +import Pretty ( SYN_IE(Pretty), PrettyRep ) import PprStyle ( PprStyle ) import SrcLoc ( SrcLoc ) @@ -139,89 +142,34 @@ ufmToList :: UniqFM elt -> [(Unique, elt)] %************************************************************************ \begin{code} -#if 0 - -type IdFinMap elt = UniqFM elt -type TyVarFinMap elt = UniqFM elt -type NameFinMap elt = UniqFM elt -type RegFinMap elt = UniqFM elt - #ifdef __GLASGOW_HASKELL__ -- I don't think HBC was too happy about this (WDP 94/10) {-# SPECIALIZE - unitUFM :: Id -> elt -> IdFinMap elt, - TyVar -> elt -> TyVarFinMap elt, - Name -> elt -> NameFinMap elt - IF_NCG(COMMA Reg -> elt -> RegFinMap elt) - #-} -{-# SPECIALIZE - listToUFM :: [(Id, elt)] -> IdFinMap elt, - [(TyVar,elt)] -> TyVarFinMap elt, - [(Name, elt)] -> NameFinMap elt - IF_NCG(COMMA [(Reg COMMA elt)] -> RegFinMap elt) - #-} -{-# SPECIALIZE - addToUFM :: IdFinMap elt -> Id -> elt -> IdFinMap elt, - TyVarFinMap elt -> TyVar -> elt -> TyVarFinMap elt, - NameFinMap elt -> Name -> elt -> NameFinMap elt - IF_NCG(COMMA RegFinMap elt -> Reg -> elt -> RegFinMap elt) + addListToUFM :: UniqFM elt -> [(Name, elt)] -> UniqFM elt + , UniqFM elt -> [(RnName, elt)] -> UniqFM elt #-} {-# SPECIALIZE - addListToUFM :: IdFinMap elt -> [(Id, elt)] -> IdFinMap elt, - TyVarFinMap elt -> [(TyVar,elt)] -> TyVarFinMap elt, - NameFinMap elt -> [(Name,elt)] -> NameFinMap elt - IF_NCG(COMMA RegFinMap elt -> [(Reg COMMA elt)] -> RegFinMap elt) + addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name, elt)] -> UniqFM elt + , (elt -> elt -> elt) -> UniqFM elt -> [(RnName,elt)] -> UniqFM elt #-} {-# SPECIALIZE - addToUFM_C :: (elt -> elt -> elt) - -> IdFinMap elt -> Id -> elt -> IdFinMap elt, - (elt -> elt -> elt) - -> TyVarFinMap elt -> TyVar -> elt -> TyVarFinMap elt, - (elt -> elt -> elt) - -> NameFinMap elt -> Name -> elt -> NameFinMap elt - IF_NCG(COMMA (elt -> elt -> elt) - -> RegFinMap elt -> Reg -> elt -> RegFinMap elt) + addToUFM :: UniqFM elt -> Unique -> elt -> UniqFM elt #-} {-# SPECIALIZE - addListToUFM_C :: (elt -> elt -> elt) - -> IdFinMap elt -> [(Id,elt)] -> IdFinMap elt, - (elt -> elt -> elt) - -> TyVarFinMap elt -> [(TyVar,elt)] -> TyVarFinMap elt, - (elt -> elt -> elt) - -> NameFinMap elt -> [(Name,elt)] -> NameFinMap elt - IF_NCG(COMMA (elt -> elt -> elt) - -> RegFinMap elt -> [(Reg COMMA elt)] -> RegFinMap elt) + listToUFM :: [(Unique, elt)] -> UniqFM elt + , [(RnName, elt)] -> UniqFM elt #-} {-# SPECIALIZE - delFromUFM :: IdFinMap elt -> Id -> IdFinMap elt, - TyVarFinMap elt -> TyVar -> TyVarFinMap elt, - NameFinMap elt -> Name -> NameFinMap elt - IF_NCG(COMMA RegFinMap elt -> Reg -> RegFinMap elt) - #-} -{-# SPECIALIZE - delListFromUFM :: IdFinMap elt -> [Id] -> IdFinMap elt, - TyVarFinMap elt -> [TyVar] -> TyVarFinMap elt, - NameFinMap elt -> [Name] -> NameFinMap elt - IF_NCG(COMMA RegFinMap elt -> [Reg] -> RegFinMap elt) - #-} - -{-# SPECIALIZE - lookupUFM :: IdFinMap elt -> Id -> Maybe elt, - TyVarFinMap elt -> TyVar -> Maybe elt, - NameFinMap elt -> Name -> Maybe elt - IF_NCG(COMMA RegFinMap elt -> Reg -> Maybe elt) + lookupUFM :: UniqFM elt -> Name -> Maybe elt + , UniqFM elt -> RnName -> Maybe elt + , UniqFM elt -> Unique -> Maybe elt #-} {-# SPECIALIZE - lookupWithDefaultUFM - :: IdFinMap elt -> elt -> Id -> elt, - TyVarFinMap elt -> elt -> TyVar -> elt, - NameFinMap elt -> elt -> Name -> elt - IF_NCG(COMMA RegFinMap elt -> elt -> Reg -> elt) + lookupWithDefaultUFM :: UniqFM elt -> elt -> RnName -> elt #-} #endif {- __GLASGOW_HASKELL__ -} -#endif {- 0 -} \end{code} %************************************************************************ @@ -441,8 +389,8 @@ minusUFM fm1 fm2 = minus_trees fm1 fm2 -- -- Notice the asymetry of subtraction -- - minus_trees lf@(LeafUFM i a) t2 = - case lookup t2 i of + minus_trees lf@(LeafUFM i a) t2 = + case lookUp t2 i of Nothing -> lf Just b -> EmptyUFM @@ -513,12 +461,12 @@ intersectUFM_C f _ EmptyUFM = EmptyUFM intersectUFM_C f fm1 fm2 = intersect_trees fm1 fm2 where intersect_trees (LeafUFM i a) t2 = - case lookup t2 i of + case lookUp t2 i of Nothing -> EmptyUFM Just b -> mkLeafUFM i (f a b) intersect_trees t1 (LeafUFM i a) = - case lookup t1 i of + case lookUp t1 i of Nothing -> EmptyUFM Just b -> mkLeafUFM i (f b a) @@ -601,21 +549,21 @@ looking up in a hurry is the {\em whole point} of this binary tree lark. Lookup up a binary tree is easy (and fast). \begin{code} -lookupUFM fm key = lookup fm (u2i (uniqueOf key)) -lookupUFM_Directly fm key = lookup fm (u2i key) +lookupUFM fm key = lookUp fm (u2i (uniqueOf key)) +lookupUFM_Directly fm key = lookUp fm (u2i key) lookupWithDefaultUFM fm deflt key - = case lookup fm (u2i (uniqueOf key)) of + = case lookUp fm (u2i (uniqueOf key)) of Nothing -> deflt Just elt -> elt lookupWithDefaultUFM_Directly fm deflt key - = case lookup fm (u2i key) of + = case lookUp fm (u2i key) of Nothing -> deflt Just elt -> elt -lookup EmptyUFM _ = Nothing -lookup fm i = lookup_tree fm +lookUp EmptyUFM _ = Nothing +lookUp fm i = lookup_tree fm where lookup_tree :: UniqFM a -> Maybe a diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs index 4e516ac..5216e14 100644 --- a/ghc/compiler/utils/UniqSet.lhs +++ b/ghc/compiler/utils/UniqSet.lhs @@ -11,7 +11,7 @@ Basically, the things need to be in class @Uniquable@. #include "HsVersions.h" module UniqSet ( - UniqSet(..), -- abstract type: NOT + SYN_IE(UniqSet), -- abstract type: NOT mkUniqSet, uniqSetToList, emptyUniqSet, unitUniqSet, addOneToUniqSet, @@ -22,15 +22,17 @@ module UniqSet ( IMP_Ubiq(){-uitous-} -import Maybes ( maybeToBool, Maybe ) +import Maybes ( maybeToBool ) import UniqFM import Unique ( Unique ) ---import Outputable ( Outputable(..), ExportFlag ) import SrcLoc ( SrcLoc ) -import Pretty ( Pretty(..), PrettyRep ) +import Pretty ( SYN_IE(Pretty), PrettyRep ) import PprStyle ( PprStyle ) import Util ( Ord3(..) ) +import {-hide from mkdependHS-} + RnHsSyn ( RnName ) -- specialising only + #if ! OMIT_NATIVE_CODEGEN #define IF_NCG(a) a #else @@ -98,52 +100,22 @@ mapUniqSet f (MkUniqSet set) | thing <- eltsUFM set ]) \end{code} -%************************************************************************ -%* * -\subsection{The @IdSet@ and @TyVarSet@ specialisations for sets of Ids/TyVars} -%* * -%************************************************************************ - -@IdSet@ is a specialised version, optimised for sets of Ids. - \begin{code} ---type NameSet = UniqSet Name ---type GenTyVarSet flexi = UniqSet (GenTyVar flexi) ---type GenIdSet ty = UniqSet (GenId ty) - -#if ! OMIT_NATIVE_CODEGEN ---type RegSet = UniqSet Reg -#endif - -#if 0 #if __GLASGOW_HASKELL__ {-# SPECIALIZE - unitUniqSet :: GenId ty -> GenIdSet ty, - GenTyVar flexi -> GenTyVarSet flexi, - Name -> NameSet - IF_NCG(COMMA Reg -> RegSet) + addOneToUniqSet :: UniqSet Unique -> Unique -> UniqSet Unique #-} - {-# SPECIALIZE - mkUniqSet :: [GenId ty] -> GenIdSet ty, - [GenTyVar flexi] -> GenTyVarSet flexi, - [Name] -> NameSet - IF_NCG(COMMA [Reg] -> RegSet) + elementOfUniqSet :: RnName -> UniqSet RnName -> Bool + , Unique -> UniqSet Unique -> Bool #-} - {-# SPECIALIZE - elementOfUniqSet :: GenId ty -> GenIdSet ty -> Bool, - GenTyVar flexi -> GenTyVarSet flexi -> Bool, - Name -> NameSet -> Bool - IF_NCG(COMMA Reg -> RegSet -> Bool) + mkUniqSet :: [RnName] -> UniqSet RnName #-} {-# SPECIALIZE - mapUniqSet :: (GenId ty -> GenId ty) -> GenIdSet ty -> GenIdSet ty, - (GenTyVar flexi -> GenTyVar flexi) -> GenTyVarSet flexi -> GenTyVarSet flexi, - (Name -> Name) -> NameSet -> NameSet - IF_NCG(COMMA (Reg -> Reg) -> RegSet -> RegSet) + unitUniqSet :: RnName -> UniqSet RnName + , Unique -> UniqSet Unique #-} #endif -#endif \end{code} diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index 37cb8c0..1b92fff 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -776,7 +776,11 @@ panic x = error ("panic! (the `impossible' happened):\n\t" pprPanic heading pretty_msg = panic (heading++(ppShow 80 pretty_msg)) pprError heading pretty_msg = error (heading++(ppShow 80 pretty_msg)) +#if __GLASGOW_HASKELL__ >= 200 +pprTrace heading pretty_msg = GHCbase.trace (heading++(ppShow 80 pretty_msg)) +#else pprTrace heading pretty_msg = trace (heading++(ppShow 80 pretty_msg)) +#endif -- #-versions because panic can't return an unboxed int, and that's -- what TAG_ is with GHC at the moment. Ugh. (Simon)