#endif
-#ifdef __GLASGOW_HASKELL__
-#define TAG_ Int#
-#define LT_ -1#
-#define EQ_ 0#
-#define GT_ 1#
-#endif
-#define GT__ _
-
#define COMMA ,
#ifdef DEBUG
#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#)
#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
*/
SuffixRules_flexish()
SuffixRule_c_o()
-LitSuffixRule(.lprl,.prl) /* for makeSymbolList.prl */
.SUFFIXES: .lhi
.lhi.hi:
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 \
compile(prelude/TysPrim,lhs,)
compile(prelude/TysWiredIn,lhs,)
-compile(profiling/SCCauto,lhs,)
compile(profiling/SCCfinal,lhs,)
compile(profiling/CostCentre,lhs,)
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)
--- /dev/null
+\begin{code}
+interface AbsCLoop_1_3 1
+__exports__
+MachMisc fixedHdrSizeInWords (..)
+MachMisc varHdrSizeInWords (..)
+CgRetConv ctrlReturnConvAlg (..)
+CgRetConv CtrlReturnConvention(..)
+\end{code}
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(..) )
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-} )
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:
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))
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)
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
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-}
)
import Unique ( pprUnique, Unique{-instance NamedThing-} )
import UniqSet ( emptyUniqSet, elementOfUniqSet,
- addOneToUniqSet, UniqSet(..)
+ addOneToUniqSet, SYN_IE(UniqSet)
)
import Unpretty -- ********** NOTE **********
import Util ( nOfThem, panic, assertPanic )
IMP_Ubiq(){-uitous-}
import Name ( Name{-instance Eq/Outputable-} )
-import Type ( Type(..) )
+import Type ( SYN_IE(Type) )
\end{code}
\begin{code}
\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,
)
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
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,
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}
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
\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
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
`addInfo` mkArityInfo arity
--ToDo: `addInfo` specenv
- arity = length args_tys
+ arity = length ctxt + length args_tys
unfolding
= noInfo_UF
\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
Just xx -> (nenv, xx)
Nothing ->
if not (toplevelishId id) then
- _trace "nmbrId: lookup failed" $
+ trace "nmbrId: lookup failed" $
(nenv, id)
else
let
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
mkDemandInfo,
willBeDemanded,
- MatchEnv, -- the SpecEnv
+ MatchEnv, -- the SpecEnv (why is this exported???)
StrictnessInfo(..), -- non-abstract
Demand(..), -- non-abstract
UpdateInfo,
mkUpdateInfo,
- UpdateSpec(..),
+ SYN_IE(UpdateSpec),
updateInfoMaybe,
DeforestInfo(..),
ArgUsageInfo,
ArgUsage(..),
- ArgUsageType(..),
+ SYN_IE(ArgUsageType),
mkArgUsageInfo,
getArgUsage,
) 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
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
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
--- /dev/null
+\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}
) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(Ratio)
-- friends:
import PrimRep ( PrimRep(..) ) -- non-abstract
#include "HsVersions.h"
module Name (
- Module(..),
+ SYN_IE(Module),
OrigName(..), -- glorified pair
qualToOrigName, -- a Qual to an OrigName
) 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
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"
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)
| 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);
\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
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
-> 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-}
[]
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 ???"
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
| 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]
exportFlagOn NotExported = False
exportFlagOn _ = True
+-- Be very wary about using "isExported"; perhaps you
+-- really mean "externallyVisibleId"?
+
isExported a = exportFlagOn (getExportFlag a)
\end{code}
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
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)@.
pTy, pTyVar, pUVar, pUse,
NmbrEnv(..),
- NmbrM(..), initNmbr,
+ SYN_IE(NmbrM), initNmbr,
returnNmbr, thenNmbr,
mapNmbr, mapAndUnzipNmbr
-- nmbr1, nmbr2, nmbr3
IMP_Ubiq(){-uitous-}
-import Pretty ( Pretty(..) )
+import Pretty ( SYN_IE(Pretty) )
import Unique ( initRenumberingUniques )
import UniqFM ( emptyUFM )
import Util ( panic )
getUnique, getUniques, -- basic ops
- UniqSM(..), -- type: unique supply monad
+ SYN_IE(UniqSM), -- type: unique supply monad
initUs, thenUs, returnUs,
mapUs, mapAndUnzipUs, mapAndUnzip3Us,
thenMaybeUs, mapAccumLUs,
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#)
-- 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}
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))
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 ->
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}
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-}
)
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}
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) ->
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 )
module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(CgLoop2) ( cgExpr, cgSccExpr )
+IMPORT_DELOOPER(CgLoop2) ( cgExpr )
import CgMonad
import AbsCSyn
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,
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}
\begin{code}
data IsThunk = IsThunk | IsFunction -- Bool-like, local
+#ifdef DEBUG
+ deriving Eq
+#endif
enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
= 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}
%************************************************************************
| 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".
dontCareCostCentre
)
import Id ( idPrimRep, dataConTag, dataConTyCon,
- isDataCon, DataCon(..),
+ isDataCon, SYN_IE(DataCon),
emptyIdSet
)
import Literal ( Literal(..) )
)
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-}
)
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}
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
\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
)
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(..),
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 ...
%********************************************************
%* *
slopSize, allocProfilingMsg, closureKind
)
import HeapOffs ( isZeroOff, addOff, intOff,
- VirtualHeapOffset(..)
+ SYN_IE(VirtualHeapOffset)
)
import PrimRep ( PrimRep(..) )
\end{code}
import CgUsages ( setRealAndVirtualSps, getVirtSps )
import CLabel ( mkStdEntryLabel )
import ClosureInfo ( mkLFLetNoEscape )
-import HeapOffs ( VirtualSpBOffset(..) )
+import HeapOffs ( SYN_IE(VirtualSpBOffset) )
import Id ( idPrimRep )
\end{code}
--- /dev/null
+\begin{code}
+interface CgLoop1_1_3 1
+__exports__
+CgBindery CgBindings(..)
+CgBindery CgIdInfo(..)
+CgBindery nukeVolatileBinds (..)
+CgBindery maybeAStkLoc (..)
+CgBindery maybeBStkLoc (..)
+CgUsages getSpBRelOffset (..)
+\end{code}
\begin{code}
interface CgLoop2 where
-import CgExpr ( cgExpr, cgSccExpr, getPrimOpArgAmodes )
+import CgExpr ( cgExpr, getPrimOpArgAmodes )
import AbsCSyn ( CAddrMode )
import CgMonad ( Code(..), FCode(..) )
import StgSyn ( StgExpr(..), StgArg(..) )
cgExpr :: StgExpr -> Code
-cgSccExpr :: StgExpr -> Code
getPrimOpArgAmodes :: PrimOp -> [StgArg] -> FCode [CAddrMode]
\end{code}
--- /dev/null
+\begin{code}
+interface CgLoop2_1_3 1
+__exports__
+Outputable Outputable (..)
+\end{code}
IMP_Ubiq(){-uitous-}
IMPORT_DELOOPER(CgLoop1) -- stuff from CgBindery and CgUsages
+IMPORT_1_3(List(nub))
import AbsCSyn
import AbsCUtils ( mkAbsCStmts )
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 )
-- 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
-- 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
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)
)
import CmdLineOpts ( opt_ReturnInRegsThreshold )
import Id ( isDataCon, dataConRawArgTys,
- DataCon(..), GenId{-instance Eq-}
+ SYN_IE(DataCon), GenId{-instance Eq-}
)
import Maybes ( catMaybes )
import PprStyle ( PprStyle(..) )
import AbsCSyn
import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
-import HeapOffs ( VirtualSpAOffset(..), VirtualSpBOffset(..) )
+import HeapOffs ( SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset) )
import PrimRep ( getPrimRepSize, separateByPtrFollowness,
PrimRep(..)
)
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}
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}
%************************************************************************
closureSingleEntry, closureSemiTag, closureType,
closureReturnsUnboxedType, getStandardFormThunkInfo,
+ isToplevClosure,
closureKind, closureTypeDescr, -- profiling
isStaticClosure, allocProfilingMsg,
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 )
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 )
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}
_ -> 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}
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 )
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
#include "HsVersions.h"
module AnnCoreSyn (
- AnnCoreBinding(..), AnnCoreExpr(..),
+ AnnCoreBinding(..), SYN_IE(AnnCoreExpr),
AnnCoreExpr'(..), -- v sad that this must be exported
AnnCoreCaseAlts(..), AnnCoreCaseDefault(..),
mkLiftedId,
liftExpr,
bindUnlift,
- applyBindUnlifts,
- isUnboxedButNotState
+ applyBindUnlifts
) where
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 )
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-} )
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`
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
= -- 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
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}
\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
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)
\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
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
import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet,
addOneToUniqSet, unionUniqSets
)
-import Usage ( UVar(..) )
+import Usage ( SYN_IE(UVar) )
import Util ( isIn, panic )
whatsMentionedInId = panic "whatsMentionedInId (CoreUnfold)"
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)
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
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 )
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,
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
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
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}
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-} )
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 )
(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
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 )
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
%==============================================
\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}
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
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
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
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
-- if profiling, wrap the dict in "_scc_ DICT <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}
%************************************************************************
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}
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
%==============================================
\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}
\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}
%==============================================
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}
\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
-- 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
\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}
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
\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
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}
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...
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 )
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
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 ->
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
-> 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")))
-> CoreExpr -- Return this if it does
-> DsM CoreExpr
-dsBinds :: TypecheckedHsBinds -> DsM [CoreBinding]
+dsBinds :: Bool -> TypecheckedHsBinds -> DsM [CoreBinding]
dsExpr :: TypecheckedHsExpr -> DsM CoreExpr
\end{code}
--- /dev/null
+\begin{code}
+interface DsLoop_1_3 1
+__exports__
+Outputable Outputable (..)
+\end{code}
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(..) )
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`
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
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
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)
= 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
import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..),
TypecheckedPat(..)
)
-import CoreSyn ( CoreExpr(..), CoreBinding(..) )
+import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding) )
import DsMonad
import DsUtils
> 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
> getIdInfo, replaceIdInfo, eqId, Id
> )
> import IdInfo
-> import Maybes ( Maybe(..) )
> import Outputable
> import Pretty
> import UniqSupply
> def2core, d2c,
>
> -- and to make the interface self-sufficient, all this stuff:
-> DefBinding(..), UniqSM(..),
+> DefBinding(..), SYN_IE(UniqSM),
> GenCoreBinding, Id, DefBindee,
> defPanic
> ) where
> import DefSyn
> import DefUtils
>
-> import Maybes ( Maybe(..) )
> import Outputable
> import Pretty
> import UniqSupply
> import TreelessForm
> import Cyclic
-> import Type ( applyTypeEnvToTy, isPrimType,
-> SigmaType(..), Type
+> import Type ( applyTypeEnvToTy,
+> SYN_IE(SigmaType), Type
> )
> import CmdLineOpts ( SwitchResult, switchIsOn )
> import CoreUnfold ( UnfoldingDetails(..) )
> )
> import Inst -- Inst(..)
> import IdInfo
-> import Maybes ( Maybe(..) )
> import Outputable
> import UniqSupply
> import Util
>#endif
> import Type ( cloneTyVar, mkTyVarTy, applyTypeEnvToTy,
-> tyVarsOfType, TyVar, SigmaType(..)
+> tyVarsOfType, TyVar, SYN_IE(SigmaType)
> )
> import Literal ( Literal ) -- for Eq Literal
> import CoreSyn
> import Id ( getIdInfo, Id )
> import IdInfo
> import Outputable
-> import SimplEnv ( SwitchChecker(..) )
+> import SimplEnv ( SYN_IE(SwitchChecker) )
> import UniqSupply
> import Util
> 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
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 * (,)-}
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
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-} )
--- /dev/null
+\begin{code}
+interface HsLoop_1_3 1
+__exports__
+HsBinds HsBinds
+HsBinds nullBinds (..)
+HsBinds MonoBinds
+HsBinds Sig
+HsBinds nullMonoBinds (..)
+HsExpr HsExpr
+\end{code}
-- 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()
module HsTypes (
PolyType(..), MonoType(..),
- Context(..), ClassAssertion(..)
+ SYN_IE(Context), SYN_IE(ClassAssertion)
#ifdef COMPILING_GHC
, pprParendPolyType
import Outputable ( interppSP, ifnotPprForUser )
import Pretty
-import Type ( Kind )
import Util ( thenCmp, cmpList, isIn, panic# )
#endif {- COMPILING_GHC -}
\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}
| CoreDoStrictness
| CoreDoSpecialising
| CoreDoDeforest
- | CoreDoAutoCostCentres
| CoreDoFoldrBuildWorkerWrapper
| CoreDoFoldrBuildWWAnal
\end{code}
%************************************************************************
\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)
\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="
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}
"-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)
%************************************************************************
\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
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
#include "HsVersions.h"
module ErrUtils (
- Error(..), Warning(..), Message(..),
+ SYN_IE(Error), SYN_IE(Warning), SYN_IE(Message),
addErrLoc,
addShortErrLocLine, addShortWarnLocLine,
dontAddErrLoc,
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
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 >>
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(..),
)
import Name ( origName, nameOf, moduleOf,
exportFlagOn, nameExportFlag, ExportFlag(..),
- isExported, getExportFlag,
isLexSym, isLocallyDefined, isWiredInName,
RdrName(..){-instance Outputable-},
OrigName(..){-instance Ord-},
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
-> IO ()
ifaceExportList
:: Maybe Handle
+ -> (Name -> ExportFlag)
-> RenamedHsModule
-> IO ()
ifaceFixities
= 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(" :: "),
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)
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
\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, _)
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
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" >>
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}
%************************************************************************
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}
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
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}
StixReg(..), CodeSegment(..)
)
import UniqSupply ( returnUs, thenUs, mapUs, mapAndUnzipUs,
- mapAccumLUs, UniqSM(..)
+ mapAccumLUs, SYN_IE(UniqSM)
)
import Unpretty ( uppPStr )
import Util ( panic, assertPanic )
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}
--- /dev/null
+\begin{code}
+interface NcgLoop_1_3 1
+__exports__
+MachMisc underscorePrefix (..)
+MachMisc fmtAsmLbl (..)
+\end{code}
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}
)
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}
CodeSegment, StixReg
)
import StixMacro ( macroCode, heapCheck )
-import UniqSupply ( returnUs, thenUs, UniqSM(..) )
+import UniqSupply ( returnUs, thenUs, SYN_IE(UniqSM) )
import Util ( panic )
\end{code}
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
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 )
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
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}
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
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}
hsnewid(yytext, yyleng);
RETURN(isconstr(yytext) ? CONSYM : VARSYM);
}
+<Code,GlaExt,UserPragma>{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);
+ }
<Code,GlaExt,UserPragma>{Mod}"."{Id} {
BOOLEAN is_constr = hsnewqid(yytext, yyleng);
RETURN(is_constr ? QCONID : QVARID);
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
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
= [ aBSENT_ERROR_ID
, augmentId
, buildId
- , copyableId
+-- , copyableId
, eRROR_ID
, foldlId
, foldrId
- , forkId
+-- , forkId
, iRREFUT_PAT_ERROR_ID
, integerMinusOneId
, integerPlusOneId
, 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
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)
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 )
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
--- /dev/null
+\begin{code}
+interface PrelLoop_1_3 1
+__exports__
+Name mkWiredInName (..)
+Type mkSigmaTy (..)
+Type mkFunTys (..)
+IdUtils primOpNameInfo (..)
+\end{code}
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:
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}
%************************************************************************
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
\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,
%************************************************************************
\begin{code}
+{- OUT:
--------------------------------------------------------------------
-- seqId :: "seq", used w/ GRIP, etc., is really quite similar to
-- dangerousEval
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))
= 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")
= 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
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
-}
\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-}
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
\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}
%************************************************************************
\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}
%************************************************************************
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
= 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
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}
mkLiftTy,
mkListTy,
mkPrimIoTy,
+ mkStateTy,
mkStateTransformerTy,
mkTupleTy,
nilDataCon,
primIoTyCon,
+ primIoDataCon,
realWorldStateTy,
return2GMPsTyCon,
returnIntAndGMPTyCon,
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 )
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
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
%* *
%************************************************************************
-@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}
%************************************************************************
%************************************************************************
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}
overheadCostCentre, dontCareCostCentre,
mkUserCC, mkAutoCC, mkDictCC, mkAllCafsCC, mkAllDictsCC,
- cafifyCC, unCafifyCC, dupifyCC,
+ cafifyCC, dupifyCC,
isCafCC, isDictCC, isDupdCC,
- setToAbleCostCentre,
+ isSccCountCostCentre,
+ sccAbleCostCentre,
ccFromThisModule,
ccMentionsId,
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(..) )
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
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)
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
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
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}
= 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
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"
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 "")
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
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.
= 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
+++ /dev/null
-%
-% (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}
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 )
((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
----------
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')
= 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
= 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)
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')
= 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')
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')
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}
%************************************************************************
\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}
%************************************************************************
-> 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
\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}
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
#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
module ReadPrefix ( rdModule ) where
IMP_Ubiq()
+IMPORT_1_3(IO(hPutStr, stderr))
import UgenAll -- all Yacc parser gumpff...
import PrefixSyn -- and various syntaxen.
%************************************************************************
\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
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) ->
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}
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 ->
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-}
)
DCOLON { ITdcolon }
DOTDOT { ITdotdot }
EQUAL { ITequal }
+ FORALL { ITforall }
INFIX { ITinfix }
INFIXL { ITinfixl }
INFIXR { ITinfixr }
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 }
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] }
| 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) }
| 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 }
| 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) }
| 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]
--------------------------------------------------------------------------
}
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,
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}
| ITinfixl
| ITinfixr
| ITinfix
+ | ITforall
| ITbang -- magic symbols
| ITvbar
| ITdcolon
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
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
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 "<module>." on the front...
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)
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
,("fixities__", ITfixities)
,("declarations__", ITdeclarations)
,("pragmas__", ITpragmas)
+ ,("forall__", ITforall)
,("data", ITdata)
,("type", ITtype)
module Rename ( renameModule ) where
-import PreludeGlaST ( thenPrimIO, newVar, MutableVar(..) )
+import PreludeGlaST ( thenPrimIO )
IMP_Ubiq()
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 )
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
-}
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
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 ...
| 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
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)
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}
import UniqFM ( lookupUFM, ufmToList{-ToDo:rm-} )
import UniqSet ( emptyUniqSet, unitUniqSet,
unionUniqSets, unionManyUniqSets,
- UniqSet(..)
+ SYN_IE(UniqSet)
)
import Util ( Ord3(..), removeDups, panic )
\end{code}
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-}
)
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
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)
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 )
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(..)
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-}
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 )
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}
*********************************************************
\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)
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)
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
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
= 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)
\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
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
\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))))
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
{-
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) ->
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
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)]) $
\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}
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
| 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.
--- /dev/null
+\begin{code}
+interface RnLoop_1_3 1
+__exports__
+Outputable Outputable (..)
+\end{code}
#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,
setExtraRn, getExtraRn, getRnEnv,
getModuleRn, pushSrcLocRn, getSrcLocRn,
getSourceRn, getOccurrenceUpRn,
- getImplicitUpRn, ImplicitEnv(..), emptyImplicitEnv,
+ getImplicitUpRn, SYN_IE(ImplicitEnv), emptyImplicitEnv,
rnGetUnique, rnGetUniques,
newLocalNames,
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
isRnLocal, isRnWired, isRnTyCon, isRnClass,
isRnTyConOrClass, isRnConstr, isRnField,
isRnClassOp, RenamedFixityDecl(..) )
-import RnUtils ( RnEnv(..), extendLocalRnEnv,
+import RnUtils ( SYN_IE(RnEnv), extendLocalRnEnv,
lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
qualNameErr, dupNamesErr
)
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
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 ->
\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}
*********************************************************
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 )
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(..) )
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 )
(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!-})
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) ->
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
-- 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
\ 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) ->
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 $
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
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))
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)
-----------------------
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
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)
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(..),
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.
= 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)
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)
-- 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
-- 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_`
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 ->
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)
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)
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))
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 ->
#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,
) 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 )
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
= 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
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 = ...";
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}
*********************************************************
IMP_Ubiq(){-uitous-}
-import CoreSyn ( CoreBinding(..) )
+import CoreSyn ( SYN_IE(CoreBinding) )
import Util ( panic{-ToDo:rm-} )
--import Util
import FreeVars
import Id ( emptyIdSet, unionIdSets, unionManyIdSets,
- elementOfIdSet, IdSet(..)
+ elementOfIdSet, SYN_IE(IdSet), GenId
)
import Util ( nOfThem, panic, zipEqual )
\end{code}
\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}
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}
IMP_Ubiq(){-uitous-}
-import CoreSyn ( CoreBinding(..) )
+import CoreSyn ( SYN_IE(CoreBinding) )
+import UniqSupply ( UniqSupply )
import Util ( panic{-ToDo:rm?-} )
--import Type ( cloneTyVarFromTemplate, mkTyVarTy,
--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,
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-} )
(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}
%************************************************************************
--
| 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:
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(..) )
)
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
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)
(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}
{- LATER: to end of file:
-import Maybes ( Maybe(..) )
import SATMonad
import Util
\end{code}
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
nullIdEnv, addOneToIdEnv, growIdEnvList,
unionManyIdSets, minusIdSet, mkIdSet,
idSetToList,
- lookupIdEnv, IdEnv(..)
+ lookupIdEnv, SYN_IE(IdEnv)
)
import Pretty ( ppStr, ppBesides, ppChar, ppInt )
import SrcLoc ( mkUnknownSrcLoc )
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
-- any harm, and not floating it may pin something important. For
-- example
--
--- x = let v = Nil
+-- x = let v = []
-- w = 1:v
-- in ...
--
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-} )
import Id ( idType, toplevelishId, idWantsToBeINLINEd,
unfoldingUnfriendlyId,
nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
- lookupIdEnv, IdEnv(..),
+ lookupIdEnv, SYN_IE(IdEnv),
GenId{-instance Outputable-}
)
import IdInfo ( mkUnfolding )
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 )
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
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-}
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 )
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
type OutDefault = CoreCaseDefault
type OutArg = CoreArg
-\end{code}
-
-\begin{code}
type SwitchChecker = SimplifierSwitch -> SwitchResult
\end{code}
#include "HsVersions.h"
module SimplMonad (
- SmplM(..),
+ SYN_IE(SmplM),
initSmpl, returnSmpl, thenSmpl, thenSmpl_,
mapSmpl, mapAndUnzipSmpl,
) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(Ix)
IMPORT_DELOOPER(SmplLoop) -- well, cheating sort of
| 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)
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}
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
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
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
import ConFold ( completePrim )
+import CostCentre ( isSccCountCostCentre, cmpCostCentre )
import CoreSyn
import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
unTagBinders, squashableDictishCcExpr,
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
--- /dev/null
+\begin{code}
+interface SmplLoop_1_3 1
+__exports__
+SimplUtils simplIdWantsToBeINLINEd (..)
+Simplify simplExpr (..)
+Simplify simplBind (..)
+MagicUFs MagicUnfoldingFun
+\end{code}
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 )
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)
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, [])
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
\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
module SimplStg ( stg2stg ) where
IMP_Ubiq(){-uitous-}
+IMPORT_1_3(IO(hPutStr,stderr))
import StgSyn
import StgUtils
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 )
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
IMP_Ubiq(){-uitous-}
import StgSyn
-import UniqSupply ( UniqSM(..) )
+import UniqSupply ( SYN_IE(UniqSM) )
import Util ( panic )
\end{code}
import StgSyn
-import FiniteMap ( emptyFM, plusFM_C, unitFM, fmToList )
+import FiniteMap ( emptyFM, plusFM_C, unitFM, fmToList, FiniteMap )
\end{code}
\begin{code}
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 )
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
>
> {- 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
> 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))
#include "HsVersions.h"
module SpecEnv (
- SpecEnv(..), MatchEnv,
+ SYN_IE(SpecEnv), MatchEnv,
nullSpecEnv, isNullSpecEnv,
addOneToSpecEnv, lookupSpecEnv,
specEnvToList
import MatchEnv
import Type ( matchTys, isTyVarTy )
-import Usage ( UVar(..) )
+import Usage ( SYN_IE(UVar) )
\end{code}
\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
module SpecUtils (
specialiseCallTys,
- ConstraintVector(..),
+ SYN_IE(ConstraintVector),
getIdOverloading,
mkConstraintVector,
isUnboxedSpecialisation,
) 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-} )
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
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 )
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)"
= 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
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
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
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
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
\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}
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-} )
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
module StgSyn (
GenStgArg(..),
- GenStgLiveVars(..),
+ SYN_IE(GenStgLiveVars),
GenStgBinding(..), GenStgExpr(..), GenStgRhs(..),
GenStgCaseAlts(..), GenStgCaseDefault(..),
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-}
)
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}
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
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
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
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-} )
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-} )
maybeAppDataTyConExpandingDicts
)
import UniqSupply ( returnUs, thenUs, thenMaybeUs,
- getUniques, UniqSM(..)
+ getUniques, SYN_IE(UniqSM)
)
import Util ( zipWithEqual, assertPanic, panic )
\end{code}
module GenSpecEtc (
TcSigInfo(..),
genBinds,
- checkSigTyVars, checkSigTyVarsGivenGlobals
+ checkSigTyVars
) where
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
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}
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
-- 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
:: 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
-- 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)
-- 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.
-> 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
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 )
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,
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
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 )
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
= 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
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}
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-}
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 )
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
)
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(..),
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 )
-- 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) ->
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}
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,
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,
enumFromToClassOpKey, enumFromThenToClassOpKey,
thenMClassOpKey, zeroClassOpKey
)
---import Name ( Name ) -- Instance
import Outputable ( interpp'SP )
import PprType ( GenType, GenTyVar ) -- Instances
import Maybes ( maybeToBool )
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}
-- 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.
-- 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
-- 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
) 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(..) )
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
= 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] [] $
(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)
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
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)
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
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
= 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
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))
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
= 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)
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
-- 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:
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
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 )
| otherwise -- odd name...
= case name of
- WiredInId _ | opt_CompilingPrelude
+ WiredInId _ | opt_CompilingGhcInternals
-> tcInterfaceSigs sigs
_ -> tcAddSrcLoc src_loc $
failTc (ifaceSigNameErr name)
module TcInstDcls (
tcInstDecls1,
tcInstDecls2,
- processInstBinds,
- newMethodId
+ processInstBinds
) where
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 )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags,
concatBag, foldBag, bagToList )
-import CmdLineOpts ( opt_GlasgowExts,
+import CmdLineOpts ( opt_GlasgowExts, opt_CompilingGhcInternals,
opt_OmitDefaultInstanceMethods,
opt_SpecialiseOverloaded
)
)
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 )
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) ->
-- 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)
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
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) (
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.
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)
-> 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.
\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
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,
\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
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
--
-- 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) ->
= 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)
-- 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
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 )
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 )
--- /dev/null
+\begin{code}
+interface TcLoop_1_3 1
+__exports__
+Outputable Outputable (..)
+\end{code}
--- /dev/null
+\begin{code}
+interface TcMLoop_1_3 1
+__exports__
+Outputable Outputable (..)
+\end{code}
= 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',
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 )
%************************************************************************
-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}
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 )
\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
(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 ->
(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' ->
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 ()
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)
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 )
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,
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
#include "HsVersions.h"
module TcSimplify (
- tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals,
+ tcSimplify, tcSimplifyAndCheck,
tcSimplifyTop, tcSimplifyThetas, tcSimplifyCheckThetas, tcSimplifyRank2,
bindInstsOfLocalFuns
) where
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 )
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.
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 )
)
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-}
)
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}
tcInstTyVars,
tcInstSigTyVars,
- tcInstType, tcInstSigType, tcInstTcType,
+ tcInstType, tcInstSigType, tcInstTcType, tcInstSigTcType,
tcInstTheta, tcInstId,
zonkTcTyVars,
-- 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
)
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 )
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)
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
)
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}
#include "HsVersions.h"
module Class (
- GenClass(..), Class(..),
+ GenClass(..), SYN_IE(Class),
mkClass,
classKey, classOps, classSelIds,
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
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
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 )
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}
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:",
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
(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]
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
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
\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 "-}"]
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
= 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}
\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
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:
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
= case (lookupUFM_Directly uvenv u) of
Just xx -> (nenv, xx)
Nothing ->
- _trace "nmbrUVar: lookup failed" $
+ trace "nmbrUVar: lookup failed" $
(nenv, u)
\end{code}
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,
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
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-}
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
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
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 )
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
+++ /dev/null
-
-\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}
--- /dev/null
+\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}
#include "HsVersions.h"
module TyVar (
- GenTyVar(..), TyVar(..),
- mkTyVar,
+ GenTyVar(..), SYN_IE(TyVar),
+ mkTyVar, mkSysTyVar,
tyVarKind, -- TyVar -> Kind
cloneTyVar,
-- 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,
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
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 )
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
#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,
#endif
isPrimType, isUnboxedType, typePrimRep,
- RhoType(..), SigmaType(..), ThetaType(..),
+ SYN_IE(RhoType), SYN_IE(SigmaType), SYN_IE(ThetaType),
mkDictTy,
mkRhoTy, splitRhoTy, mkTheta,
mkSigmaTy, splitSigmaTy,
-- 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 )
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
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}
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
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
#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,
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
)
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
= 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}
) 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}
\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
#ifdef COMPILING_GHC
, bagToFM
- , FiniteSet(..), emptySet, mkSet, isEmptySet
+ , SYN_IE(FiniteSet), emptySet, mkSet, isEmptySet
, elementOf, setToList, union, minusSet
#endif
) where
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"...
{-# 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
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
CHK_Ubiq() -- debugging consistency check
+import Unique (Unique) -- only for specialising
+
#endif
\end{code}
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}
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 ' '
#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}
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
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\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
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}
--- /dev/null
+\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}
#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 )
%************************************************************************
\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}
%************************************************************************
--
-- 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
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)
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
#include "HsVersions.h"
module UniqSet (
- UniqSet(..), -- abstract type: NOT
+ SYN_IE(UniqSet), -- abstract type: NOT
mkUniqSet, uniqSetToList, emptyUniqSet, unitUniqSet,
addOneToUniqSet,
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
| 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}
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)
projects / ghc-hetmet.git / commitdiff