# define FAST_STRING _PackedString
# define SLIT(x) (_packCString (A# x#))
# define _CMP_STRING_ cmpPString
+ /* cmpPString defined in utils/Util.lhs */
# define _NULL_ _nullPS
# define _NIL_ _nilPS
# define _CONS_ _consPS
# -----------------------------------------------------------------------------
-# $Id: Makefile,v 1.4 1996/12/18 18:42:48 dnt Exp $
+# $Id: Makefile,v 1.5 1996/12/19 09:10:03 simonpj Exp $
TOP = ../..
FlexSuffixRules = YES
INCLUDEDIRS = $(foreach dir,$(DIRS),-i$(dir))
SRCS = \
$(foreach dir,$(DIRS),$(wildcard $(dir)/*.lhs)) \
- $(UGNHS) rename/ParseIface.hs
+ $(UGNHS) rename/ParseIface.hs \
+ main/LoopHack.hc
+
+# LoopHack.lhc is an SLPJ addition to fix a profiling problem. See comments
+# inside it.
+
LOOPS = $(patsubst %.lhi, %.hi, $(wildcard */*.lhi))
HCS = $(patsubst %.hs, %.hc, $(patsubst %.lhs, %.hc, $(SRCS)))
OBJS = \
$(patsubst %.hc, %.o, $(HCS)) rename/ParseIface.o \
- parser/hsclink.o parser/hschooks.o libhsp.a
+ parser/hsclink.o parser/hschooks.o libhsp.a \
+ main/LoopHack.o
+
+main/LoopHack.hc : main/LoopHack.lhc
+ $(RM) $@
+ $(GHC_UNLIT) $< $@ || ( $(RM) $@ && exit 1 )
+ @chmod 444 $@
+
+main/LoopHack.o : main/LoopHack.hc
+ $(HC) -v -c $(HC_OPTS) $<
# -----------------------------------------------------------------------------
# options for the Haskell compiler
all :: hsc libhsp.a
hsc : $(OBJS)
- $(HC) $(HC_OPTS) -o $@ $^
+# $(HC) -no-link-chk "-pgml time /projects/pacsoft/ghc/src/pureatria/purelink-1.2.2-solaris2/purelink gcc" $(HC_OPTS) -o $@ $^
+ $(HC) -no-link-chk "-pgml time gcc -B/projects/unsupported/gnu/sparc-sunos5/bin/g" $(HC_OPTS) -o $@ $^
+# $(HC) -no-link-chk "-pgml time gcc" $(HC_OPTS) -o $@ $^
parser/hschooks.o : parser/hschooks.c
@$(RM) $@
rename/ParseIface.hs : rename/ParseIface.y
@$(RM) rename/ParseIface.hs rename/ParseIface.hinfo
- happy -g rename/ParseIface.y
+ happy +RTS -K2m -RTS -g rename/ParseIface.y
@chmod 444 rename/ParseIface.hs
# ----------------------------------------------------------------------------
IMP_Ubiq(){-uitous-}
-import CgCompInfo ( mAX_Vanilla_REG, mAX_Float_REG,
+import Constants ( mAX_Vanilla_REG, mAX_Float_REG,
mAX_Double_REG, lIVENESS_R1, lIVENESS_R2,
lIVENESS_R3, lIVENESS_R4, lIVENESS_R5,
lIVENESS_R6, lIVENESS_R7, lIVENESS_R8
\end{code}
C ``static'' or not...
+From the point of view of the code generator, a name is
+externally visible if it should be given put in the .o file's
+symbol table; that is, made static.
+
\begin{code}
externallyVisibleCLabel (TyConLabel tc _) = True
externallyVisibleCLabel (CaseLabel _ _) = False
externallyVisibleCLabel (AsmTempLabel _) = False
externallyVisibleCLabel (RtsLabel _) = True
-externallyVisibleCLabel (IdLabel (CLabelId id) _)
- | isDataCon id = True
- | is_ConstMethodId id = True -- These are here to ensure splitting works
- | isDictFunId id = True -- when these values have not been exported
- | is_DefaultMethodId id = True
- | is_SuperDictSelId id = True
- | otherwise = externallyVisibleId id
- where
- is_ConstMethodId id = maybeToBool (isConstMethodId_maybe id)
- is_DefaultMethodId id = maybeToBool (isDefaultMethodId_maybe id)
- is_SuperDictSelId id = maybeToBool (isSuperDictSelId_maybe id)
+externallyVisibleCLabel (IdLabel (CLabelId id) _) = externallyVisibleId id
\end{code}
OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
char_to_c '<' = ppPStr SLIT("Zl")
char_to_c '-' = ppPStr SLIT("Zm")
char_to_c '!' = ppPStr SLIT("Zn")
- char_to_c '.' = ppPStr SLIT("Zo")
+ char_to_c '.' = ppPStr SLIT("_")
char_to_c '+' = ppPStr SLIT("Zp")
char_to_c '\'' = ppPStr SLIT("Zq")
char_to_c '*' = ppPStr SLIT("Zt")
import AbsCUtils ( getAmodeRep, nonemptyAbsC,
mixedPtrLocn, mixedTypeLocn
)
-import CgCompInfo ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
+import Constants ( spARelToInt, spBRelToInt, mIN_UPD_SIZE )
import CLabel ( externallyVisibleCLabel, mkErrorStdEntryLabel,
isReadOnly, needsCDecl, pprCLabel,
CLabel{-instance Ord-}
IMP_Ubiq(){-uitous-}
-import Name ( Name{-instance Eq/Outputable-} )
+import Name ( Name{-instance Eq/Outputable-}, nameUnique )
import Type ( SYN_IE(Type) )
\end{code}
instance NamedThing FieldLabel where
getName (FieldLabel n _ _) = n
+
+instance Uniquable FieldLabel where
+ uniqueOf (FieldLabel n _ _) = nameUnique n
\end{code}
mkUserId,
mkUserLocal,
mkWorkerId,
-
- -- MANGLING
- unsafeGenId2Id,
+ mkPrimitiveId,
+ setIdVisibility,
-- DESTRUCTION (excluding pragmatic info)
idPrimRep,
recordSelectorFieldLabel,
-- PREDICATES
+ wantIdSigInIface,
cmpEqDataCon,
cmpId,
cmpId_withSpecDataCon,
externallyVisibleId,
idHasNoFreeTyVars,
idWantsToBeINLINEd,
+ idMustBeINLINEd,
isBottomingId,
isConstMethodId,
isConstMethodId_maybe,
isDefaultMethodId_maybe,
isDictFunId,
isImportedId,
- isMethodSelId,
+ isRecordSelector,
+ isMethodSelId_maybe,
isNullaryDataCon,
isSpecPragmaId,
isSuperDictSelId_maybe,
+ isPrimitiveId_maybe,
isSysLocalId,
- isTopLevId,
isTupleCon,
isWorkerId,
isWrapperId,
addIdSpecialisation,
-- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
+ addIdUnfolding,
addIdArity,
addIdDemandInfo,
addIdStrictness,
import Class ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClassOp )
import IdInfo
import Maybes ( maybeToBool )
-import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
- isLocallyDefinedName,
- mkTupleDataConName, mkCompoundName, mkCompoundName2,
- isLexSym, isLexSpecialSym,
- isLocallyDefined, changeUnique,
- getOccName, origName, moduleOf,
- isExported, ExportFlag(..),
- RdrName(..), Name
+import Name ( nameUnique, mkLocalName, mkSysLocalName, isLocalName,
+ mkCompoundName, mkInstDeclName, mkWiredInIdName, mkGlobalName,
+ isLocallyDefinedName, occNameString, modAndOcc,
+ isLocallyDefined, changeUnique, isWiredInName,
+ nameString, getOccString, setNameVisibility,
+ isExported, ExportFlag(..), DefnInfo, Provenance,
+ OccName(..), Name
)
+import PrelMods ( pREL_TUP, pREL_BASE )
+import Lex ( mkTupNameStr )
import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} )
import PragmaInfo ( PragmaInfo(..) )
import PprEnv -- ( SYN_IE(NmbrM), NmbrEnv(..) )
-import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
+import PprType ( getTypeString, specMaybeTysSuffix,
nmbrType, nmbrTyVar,
GenType, GenTyVar
)
import Pretty
import MatchEnv ( MatchEnv )
import SrcLoc ( mkBuiltinSrcLoc )
-import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
+import TysWiredIn ( tupleTyCon )
+import TyCon ( TyCon, tyConDataCons )
import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
applyTyCon, instantiateTy, mkForAllTys,
tyVarsOfType, applyTypeEnvToTy, typePrimRep,
GenType, SYN_IE(ThetaType), SYN_IE(TauType), SYN_IE(Type)
)
import TyVar ( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) )
+import Usage ( SYN_IE(UVar) )
import UniqFM
import UniqSet -- practically all of it
import Unique ( getBuiltinUniques, pprUnique, showUnique,
- incrUnique,
+ incrUnique,
Unique{-instance Ord3-}
)
-import Util ( mapAccumL, nOfThem, zipEqual,
+import Util ( mapAccumL, nOfThem, zipEqual, assoc,
panic, panic#, pprPanic, assertPanic
)
\end{code}
-- eg specialise-me, inline-me
IdInfo -- Properties of this Id deduced by compiler
-type Id = GenId Type
+type Id = GenId Type
data StrictnessMark = MarkedStrict | NotMarkedStrict
| SysLocalId Bool -- Local name; made up by the compiler
-- as for LocalId
+ | PrimitiveId PrimOp -- The Id for a primitive operation
+
| SpecPragmaId -- Local name; introduced by the compiler
(Maybe Id) -- for explicit specid in pragma
Bool -- as for LocalId
| ImportedId -- Global name (Imported or Implicit); Id imported from an interface
- | TopLevId -- Global name (LocalDef); Top-level in the orig source pgm
- -- (not moved there by transformations).
-
- -- a TopLevId's type may contain free type variables, if
- -- the monomorphism restriction applies.
-
---------------- Data constructors
| DataConId ConTag
-- The "a" is irrelevant. As it is too painful to
-- actually do comparisons that way, we kindly supply
-- a Unique for that purpose.
- Module -- module where instance came from
-- see below
| ConstMethodId -- A method which depends only on the type of the
-- we may specialise to a type w/ free tyvars
-- (i.e., in one of the "Maybe Type" dudes).
+-- Scheduled for deletion: SLPJ Nov 96
+-- Nobody seems to depend on knowing this.
| WorkerId -- A "worker" for some other Id
Id -- Id for which this is a worker
their @IdInfo@).
%----------------------------------------------------------------------
-\item[@TopLevId@:] These are values defined at the top-level in this
-module; i.e., those which {\em might} be exported (hence, a
-@Name@). It does {\em not} include those which are moved to the
-top-level through program transformations.
-
-We also guarantee that @TopLevIds@ will {\em stay} at top-level.
-Theoretically, they could be floated inwards, but there's no known
-advantage in doing so. This way, we can keep them with the same
-@Unique@ throughout (no cloning), and, in general, we don't have to be
-so paranoid about them.
-
-In particular, we had the following problem generating an interface:
-We have to ``stitch together'' info (1)~from the typechecker-produced
-global-values list (GVE) and (2)~from the STG code [which @Ids@ have
-what arities]. If the @Uniques@ on the @TopLevIds@ can {\em change}
-between (1) and (2), you're sunk!
-
-%----------------------------------------------------------------------
\item[@MethodSelId@:] A selector from a dictionary; it may select either
a method or a dictionary for one of the class's superclasses.
%----------------------------------------------------------------------
\item
-@DataCons@ @TupleCons@, @Importeds@, @TopLevIds@, @SuperDictSelIds@,
+@DataCons@ @TupleCons@, @Importeds@, @SuperDictSelIds@,
@MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
properties:
\begin{itemize}
%************************************************************************
\begin{code}
-unsafeGenId2Id :: GenId ty -> Id
-unsafeGenId2Id (Id u n ty d p i) = Id u n (panic "unsafeGenId2Id:ty") d p i
-
-isDataCon id = is_data (unsafeGenId2Id id)
- where
- is_data (Id _ _ _ (DataConId _ _ _ _ _ _ _) _ _) = True
- is_data (Id _ _ _ (TupleConId _) _ _) = True
- is_data (Id _ _ _ (SpecId unspec _ _) _ _) = is_data unspec
- is_data other = False
+isDataCon (Id _ _ _ (DataConId _ _ _ _ _ _ _) _ _) = True
+isDataCon (Id _ _ _ (TupleConId _) _ _) = True
+isDataCon (Id _ _ _ (SpecId unspec _ _) _ _) = isDataCon unspec
+isDataCon other = False
-
-isTupleCon id = is_tuple (unsafeGenId2Id id)
- where
- is_tuple (Id _ _ _ (TupleConId _) _ _) = True
- is_tuple (Id _ _ _ (SpecId unspec _ _) _ _) = is_tuple unspec
- is_tuple other = False
+isTupleCon (Id _ _ _ (TupleConId _) _ _) = True
+isTupleCon (Id _ _ _ (SpecId unspec _ _) _ _) = isTupleCon unspec
+isTupleCon other = False
{-LATER:
isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _) _ _)
chk (TupleConId _) = True
chk (RecordSelId _) = True
chk ImportedId = True
- chk TopLevId = True -- NB: see notes
chk (SuperDictSelId _ _) = True
chk (MethodSelId _ _) = True
chk (DefaultMethodId _ _ _) = True
- chk (DictFunId _ _ _) = True
+ chk (DictFunId _ _) = True
chk (ConstMethodId _ _ _ _) = True
chk (SpecId unspec _ _) = toplevelishId unspec
-- depends what the unspecialised thing is
chk (LocalId _) = False
chk (SysLocalId _) = False
chk (SpecPragmaId _ _) = False
+ chk (PrimitiveId _) = True
idHasNoFreeTyVars (Id _ _ _ details _ info)
= chk details
chk (TupleConId _) = True
chk (RecordSelId _) = True
chk ImportedId = True
- chk TopLevId = True
chk (SuperDictSelId _ _) = True
chk (MethodSelId _ _) = True
chk (DefaultMethodId _ _ _) = True
- chk (DictFunId _ _ _) = True
+ chk (DictFunId _ _) = True
chk (ConstMethodId _ _ _ _) = True
chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr
chk (SpecId _ _ no_free_tvs) = no_free_tvs
chk (LocalId no_free_tvs) = no_free_tvs
chk (SysLocalId no_free_tvs) = no_free_tvs
chk (SpecPragmaId _ no_free_tvs) = no_free_tvs
+ chk (PrimitiveId _) = True
+
+-- wantIdSigInIface decides whether to put an Id's type signature and
+-- IdInfo in an interface file
+wantIdSigInIface
+ :: Bool -- True <=> the thing is mentioned somewhere else in the
+ -- interface file
+ -> Bool -- True <=> omit anything that doesn't *have* to go
+ -> Id
+ -> Bool
+
+wantIdSigInIface mentioned_already omit_iface_prags (Id _ name _ details _ _)
+ = chk details
+ where
+ chk (LocalId _) = isExported name &&
+ not (isWiredInName name) -- User-declared thing!
+ chk ImportedId = False -- Never put imports in interface file
+ chk (PrimitiveId _) = False -- Ditto, for primitives
+
+ -- This group is Ids that are implied by their type or class decl;
+ -- remember that all type and class decls appear in the interface file
+ chk (DataConId _ _ _ _ _ _ _) = False
+ chk (TupleConId _) = False -- Ditto
+ chk (RecordSelId _) = False -- Ditto
+ chk (SuperDictSelId _ _) = False -- Ditto
+ chk (MethodSelId _ _) = False -- Ditto
+ chk (ConstMethodId _ _ _ _) = False -- Scheduled for nuking
+ chk (DefaultMethodId _ _ _) = False -- Hmm. No, for now
+
+ -- DictFunIds are more interesting, they may have IdInfo we can't
+ -- get from the instance declaration. We emit them if we're gung ho.
+ -- No need to check the export flag; instance decls are always exposed
+ chk (DictFunId _ _) = not omit_iface_prags
+
+ -- This group are only called out by being mentioned somewhere else
+ chk (WorkerId unwrkr) = mentioned_already
+ chk (SpecId _ _ _) = mentioned_already
+ chk (InstId _) = mentioned_already
+ chk (SysLocalId _) = mentioned_already
+ chk (SpecPragmaId _ _) = mentioned_already
\end{code}
\begin{code}
-isTopLevId (Id _ _ _ TopLevId _ _) = True
-isTopLevId other = False
-
isImportedId (Id _ _ _ ImportedId _ _) = True
isImportedId other = False
-isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (getInfo info)
+isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (strictnessInfo info)
isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True
isSysLocalId other = False
isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _) _ _) = True
isSpecPragmaId other = False
-isMethodSelId (Id _ _ _ (MethodSelId _ _) _ _) = True
-isMethodSelId _ = False
+isMethodSelId_maybe (Id _ _ _ (MethodSelId cls op) _ _) = Just (cls,op)
+isMethodSelId_maybe _ = Nothing
isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True
isDefaultMethodId other = False
= Just (cls, clsop, err)
isDefaultMethodId_maybe other = Nothing
-isDictFunId (Id _ _ _ (DictFunId _ _ _) _ _) = True
-isDictFunId other = False
+isDictFunId (Id _ _ _ (DictFunId _ _) _ _) = True
+isDictFunId other = False
isConstMethodId (Id _ _ _ (ConstMethodId _ _ _ _) _ _) = True
isConstMethodId other = False
isWorkerId other = False
isWrapperId id = workerExists (getIdStrictness id)
-\end{code}
-
-\begin{code}
-{-LATER:
-pprIdInUnfolding :: IdSet -> Id -> Pretty
-
-pprIdInUnfolding in_scopes v
- = let
- v_ty = idType v
- in
- -- local vars first:
- if v `elementOfUniqSet` in_scopes then
- pprUnique (idUnique v)
-
- -- ubiquitous Ids with special syntax:
- else if v == nilDataCon then
- ppPStr SLIT("_NIL_")
- else if isTupleCon v then
- ppBeside (ppPStr SLIT("_TUP_")) (ppInt (dataConArity v))
-
- -- ones to think about:
- else
- let
- (Id _ _ _ v_details _ _) = v
- in
- case v_details of
- -- these ones must have been exported by their original module
- ImportedId -> pp_full_name
-
- -- these ones' exportedness checked later...
- TopLevId -> pp_full_name
- DataConId _ _ _ _ _ _ _ -> pp_full_name
-
- RecordSelId lbl -> ppr sty lbl
-
- -- class-ish things: class already recorded as "mentioned"
- SuperDictSelId c sc
- -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
- MethodSelId c o
- -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
- DefaultMethodId c o _
- -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
-
- -- instance-ish things: should we try to figure out
- -- *exactly* which extra instances have to be exported? (ToDo)
- DictFunId c t _
- -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
- ConstMethodId c t o _
- -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
-
- -- specialisations and workers
- SpecId unspec ty_maybes _
- -> let
- pp = pprIdInUnfolding in_scopes unspec
- in
- ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
- ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
- ppRbrack]
-
- WorkerId unwrkr
- -> let
- pp = pprIdInUnfolding in_scopes unwrkr
- in
- ppBeside (ppPStr SLIT("_WRKR_ ")) pp
-
- -- anything else? we're nae interested
- other_id -> panic "pprIdInUnfolding:mystery Id"
- where
- ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
-
- pp_full_name
- = let
- (OrigName m_str n_str) = origName "Id:ppr_Unfolding" v
-
- pp_n =
- if isLexSym n_str && not (isLexSpecialSym n_str) then
- ppBesides [ppLparen, ppPStr n_str, ppRparen]
- else
- ppPStr n_str
- in
- if isPreludeDefined v then
- pp_n
- else
- ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
-
- pp_class :: Class -> Pretty
- pp_class_op :: ClassOp -> Pretty
- pp_type :: Type -> Pretty
- pp_ty_maybe :: Maybe Type -> Pretty
-
- pp_class clas = ppr ppr_Unfolding clas
- pp_class_op op = ppr ppr_Unfolding op
-
- pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
- pp_ty_maybe Nothing = ppPStr SLIT("_N_")
- pp_ty_maybe (Just t) = pp_type t
--}
-\end{code}
-
-@whatsMentionedInId@ ferrets out the types/classes/instances on which
-this @Id@ depends. If this Id is to appear in an interface, then
-those entities had Jolly Well be in scope. Someone else up the
-call-tree decides that.
-
-\begin{code}
-{-LATER:
-whatsMentionedInId
- :: IdSet -- Ids known to be in scope
- -> Id -- Id being processed
- -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc.
-
-whatsMentionedInId in_scopes v
- = let
- v_ty = idType v
-
- (tycons, clss)
- = getMentionedTyConsAndClassesFromType v_ty
-
- result0 id_bag = (id_bag, tycons, clss)
-
- result1 ids tcs cs
- = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
- tcs `unionBags` tycons,
- cs `unionBags` clss)
- in
- -- local vars first:
- if v `elementOfUniqSet` in_scopes then
- result0 emptyBag -- v not added to "mentioned"
-
- -- ones to think about:
- else
- let
- (Id _ _ _ v_details _ _) = v
- in
- case v_details of
- -- specialisations and workers
- SpecId unspec ty_maybes _
- -> let
- (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
- in
- result1 ids2 tcs2 cs2
-
- WorkerId unwrkr
- -> let
- (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
- in
- result1 ids2 tcs2 cs2
-
- anything_else -> result0 (unitBag v) -- v is added to "mentioned"
--}
+isPrimitiveId_maybe (Id _ _ _ (PrimitiveId primop) _ _) = Just primop
+isPrimitiveId_maybe other = Nothing
\end{code}
Tell them who my wrapper function is.
\end{code}
@externallyVisibleId@: is it true that another module might be
-able to ``see'' this Id?
+able to ``see'' this Id in a code generation sense. That
+is, another .o file might refer to this Id.
-We need the @toplevelishId@ check as well as @isExported@ for when we
-compile instance declarations in the prelude. @DictFunIds@ are
-``exported'' if either their class or tycon is exported, but, in
-compiling the prelude, the compiler may not recognise that as true.
+In tidyCorePgm (SimplCore.lhs) we carefully set each top level thing's
+local-ness precisely so that the test here would be easy
\begin{code}
externallyVisibleId :: Id -> Bool
-
-externallyVisibleId id@(Id _ _ _ details _ _)
- = if isLocallyDefined id then
- 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
- True
- -- if visible here, it must be visible elsewhere, too.
-\end{code}
-
-\begin{code}
-idWantsToBeINLINEd :: Id -> Bool
-
-idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True
-idWantsToBeINLINEd _ = False
-
-addInlinePragma :: Id -> Id
-addInlinePragma (Id u sn ty details _ info)
- = Id u sn ty details IWantToBeINLINEd info
-\end{code}
-
-For @unlocaliseId@: See the brief commentary in
-\tr{simplStg/SimplStg.lhs}.
-
-\begin{code}
-{-LATER:
-unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
-
-unlocaliseId mod (Id u fn ty info TopLevId)
- = Just (Id u (unlocaliseFullName fn) ty info TopLevId)
-
-unlocaliseId mod (Id u sn ty info (LocalId no_ftvs))
- = --false?: ASSERT(no_ftvs)
- let
- full_name = unlocaliseShortName mod u sn
- in
- Just (Id u full_name ty info TopLevId)
-
-unlocaliseId mod (Id u sn ty info (SysLocalId no_ftvs))
- = --false?: on PreludeGlaST: ASSERT(no_ftvs)
- let
- full_name = unlocaliseShortName mod u sn
- in
- Just (Id u full_name ty info TopLevId)
-
-unlocaliseId mod (Id u n ty info (SpecId unspec ty_maybes no_ftvs))
- = case unlocalise_parent mod u unspec of
- Nothing -> Nothing
- Just xx -> Just (Id u n ty info (SpecId xx ty_maybes no_ftvs))
-
-unlocaliseId mod (Id u n ty info (WorkerId unwrkr))
- = case unlocalise_parent mod u unwrkr of
- Nothing -> Nothing
- Just xx -> Just (Id u n ty info (WorkerId xx))
-
-unlocaliseId mod (Id u name ty info (InstId no_ftvs))
- = Just (Id u full_name ty info TopLevId)
- -- type might be wrong, but it hardly matters
- -- at this stage (just before printing C) ToDo
- where
- name = nameOf (origName "Id.unlocaliseId" name)
- full_name = mkFullName mod name InventedInThisModule ExportAll mkGeneratedSrcLoc
-
-unlocaliseId mod other_id = Nothing
-
---------------------
--- we have to be Very Careful for workers/specs of
--- local functions!
-
-unlocalise_parent mod uniq (Id _ sn ty info (LocalId no_ftvs))
- = --false?: ASSERT(no_ftvs)
- let
- full_name = unlocaliseShortName mod uniq sn
- in
- Just (Id uniq full_name ty info TopLevId)
-
-unlocalise_parent mod uniq (Id _ sn ty info (SysLocalId no_ftvs))
- = --false?: ASSERT(no_ftvs)
- let
- full_name = unlocaliseShortName mod uniq sn
- in
- Just (Id uniq full_name ty info TopLevId)
-
-unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
- -- we're OK otherwise
--}
+externallyVisibleId id@(Id _ name _ _ _ _) = not (isLocalName name)
+ -- not local => global => externally visible
\end{code}
CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@:
idPrimRep i = typePrimRep (idType i)
\end{code}
-\begin{code}
-{-LATER:
-getInstIdModule (Id _ _ _ (DictFunId _ _ mod)) = mod
-getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ mod)) = mod
-getInstIdModule other = panic "Id:getInstIdModule"
--}
-\end{code}
-
%************************************************************************
%* *
\subsection[Id-overloading]{Functions related to overloading}
%************************************************************************
\begin{code}
-mkSuperDictSelId u c sc ty info
- = mk_classy_id (SuperDictSelId c sc) SLIT("sdsel") (Left (origName "mkSuperDictSelId" sc)) u c ty info
-
-mkMethodSelId u rec_c op ty info
- = mk_classy_id (MethodSelId rec_c op) SLIT("meth") (Right (classOpString op)) u rec_c ty info
-
-mkDefaultMethodId u rec_c op gen ty info
- = mk_classy_id (DefaultMethodId rec_c op gen) SLIT("defm") (Right (classOpString op)) u rec_c ty info
-
-mk_classy_id details str op_str u rec_c ty info
- = Id u n ty details NoPragmaInfo info
+mkSuperDictSelId u clas sc ty
+ = addStandardIdInfo $
+ Id u name ty details NoPragmaInfo noIdInfo
where
- cname = getName rec_c -- we get other info out of here
- cname_orig = origName "mk_classy_id" cname
- cmod = moduleOf cname_orig
-
- n = mkCompoundName u cmod str [Left cname_orig, op_str] cname
-
-mkDictFunId u c ity full_ty from_here locn mod info
- = Id u n full_ty (DictFunId c ity mod) NoPragmaInfo info
+ name = mkCompoundName name_fn u (getName clas)
+ details = SuperDictSelId clas sc
+ name_fn clas_str = SLIT("scsel_") _APPEND_ clas_str _APPEND_ mod _APPEND_ occNameString occ
+ (mod,occ) = modAndOcc sc
+
+ -- For method selectors the clean thing to do is
+ -- to give the method selector the same name as the class op itself.
+mkMethodSelId op_name rec_c op ty
+ = addStandardIdInfo $
+ Id (uniqueOf op_name) op_name ty (MethodSelId rec_c op) NoPragmaInfo noIdInfo
+
+mkDefaultMethodId op_name uniq rec_c op gen ty
+ = Id uniq dm_name ty details NoPragmaInfo noIdInfo
where
- n = mkCompoundName2 u mod SLIT("dfun") (Left (origName "mkDictFunId" c) : renum_type_string full_ty ity) from_here locn
+ dm_name = mkCompoundName name_fn uniq op_name
+ details = DefaultMethodId rec_c op gen
+ name_fn op_str = SLIT("dm_") _APPEND_ op_str
-mkConstMethodId u c op ity full_ty from_here locn mod info
- = Id u n full_ty (ConstMethodId c ity op mod) NoPragmaInfo info
+mkDictFunId dfun_name full_ty clas ity
+ = Id (nameUnique dfun_name) dfun_name full_ty details NoPragmaInfo noIdInfo
where
- n = mkCompoundName2 u mod SLIT("const") (Left (origName "mkConstMethodId" c) : Right (classOpString op) : renum_type_string full_ty ity) from_here locn
+ details = DictFunId clas ity
-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)
- )
+mkConstMethodId uniq clas op ity full_ty from_here locn mod info
+ = Id uniq name full_ty details NoPragmaInfo info
+ where
+ name = mkInstDeclName uniq mod (VarOcc occ_name) locn from_here
+ details = ConstMethodId clas ity op mod
+ occ_name = classOpString op _APPEND_
+ SLIT("_cm_") _APPEND_ renum_type_string full_ty ity
mkWorkerId u unwrkr ty info
- = Id u n ty (WorkerId unwrkr) NoPragmaInfo info
+ = Id u name ty details NoPragmaInfo info
where
- unwrkr_name = getName unwrkr
- unwrkr_orig = origName "mkWorkerId" unwrkr_name
- umod = moduleOf unwrkr_orig
-
- n = mkCompoundName u umod SLIT("wrk") [Left unwrkr_orig] unwrkr_name
+ name = mkCompoundName name_fn u (getName unwrkr)
+ details = WorkerId unwrkr
+ name_fn wkr_str = wkr_str _APPEND_ SLIT("_wrk")
-mkInstId u ty name = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
+mkInstId u ty name
+ = Id u (changeUnique name u) ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo
{-LATER:
getConstMethodId clas op ty
ppStr "The info above, however ugly, should indicate what else you need to import."
])
-}
+
+
+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)
+ )
\end{code}
%************************************************************************
\begin{code}
mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info
-{-LATER:
-updateIdType :: Id -> Type -> Id
-updateIdType (Id u n _ info details) ty = Id u n ty info details
--}
+mkPrimitiveId n ty primop
+ = addStandardIdInfo $
+ Id (nameUnique n) n ty (PrimitiveId primop) NoPragmaInfo noIdInfo
\end{code}
\begin{code}
-- SysLocal: for an Id being created by the compiler out of thin air...
-- UserLocal: an Id with a name the user might recognize...
-mkSysLocal, mkUserLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
+mkSysLocal :: FAST_STRING -> Unique -> MyTy a b -> SrcLoc -> MyId a b
+mkUserLocal :: OccName -> Unique -> MyTy a b -> SrcLoc -> MyId a b
mkSysLocal str uniq ty loc
- = Id uniq (mkLocalName uniq str True{-emph uniq-} loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
+ = Id uniq (mkSysLocalName uniq str loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
-mkUserLocal str uniq ty loc
- = Id uniq (mkLocalName uniq str False{-emph name-} loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
+mkUserLocal occ uniq ty loc
+ = Id uniq (mkLocalName uniq occ loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
--- mkUserId builds a local or top-level Id, depending on the name given
mkUserId :: Name -> MyTy a b -> PragmaInfo -> MyId a b
mkUserId name ty pragma_info
- | isLocalName name
= Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo
- | otherwise
- = Id (nameUnique name) name ty
- (if isLocallyDefinedName name then TopLevId else ImportedId)
- pragma_info noIdInfo
\end{code}
{-LATER:
-- for a SpecPragmaId being created by the compiler out of thin air...
-mkSpecPragmaId :: FAST_STRING -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
+mkSpecPragmaId :: OccName -> Unique -> Type -> Maybe Id -> SrcLoc -> Id
mkSpecPragmaId str uniq ty specid loc
= Id uniq (mkShortName str loc) ty noIdInfo (SpecPragmaId specid (no_free_tvs ty))
loc = getSrcLoc id
-}
-mkIdWithNewUniq :: Id -> Unique -> Id
+-- See notes with setNameVisibility (Name.lhs)
+setIdVisibility :: Module -> Id -> Id
+setIdVisibility mod (Id uniq name ty details prag info)
+ = Id uniq (setNameVisibility mod name) ty details prag info
+mkIdWithNewUniq :: Id -> Unique -> Id
mkIdWithNewUniq (Id _ n ty details prag info) u
= Id u (changeUnique n u) ty details prag info
\end{code}
selectIdInfoForSpecId :: Id -> IdInfo
selectIdInfoForSpecId unspec
= ASSERT(not (maybeToBool (isSpecId_maybe unspec)))
- noIdInfo `addInfo_UF` getIdUnfolding unspec
+ noIdInfo `addUnfoldInfo` getIdUnfolding unspec
-}
\end{code}
getIdArity :: Id -> ArityInfo
getIdArity id@(Id _ _ _ _ _ id_info)
= --ASSERT( not (isDataCon id))
- getInfo id_info
+ arityInfo id_info
dataConArity, dataConNumFields :: DataCon -> Int
dataConArity id@(Id _ _ _ _ _ id_info)
= ASSERT(isDataCon id)
- case (arityMaybe (getInfo id_info)) of
- Just i -> i
- Nothing -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
+ case arityInfo id_info of
+ ArityExactly a -> a
+ other -> pprPanic "dataConArity:Nothing:" (pprId PprDebug id)
dataConNumFields id
= ASSERT(isDataCon id)
isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience
-addIdArity :: Id -> Int -> Id
+addIdArity :: Id -> ArityInfo -> Id
addIdArity (Id u n ty details pinfo info) arity
- = Id u n ty details pinfo (info `addInfo` (mkArityInfo arity))
+ = Id u n ty details pinfo (info `addArityInfo` arity)
\end{code}
%************************************************************************
mkDataCon :: Name
-> [StrictnessMark] -> [FieldLabel]
-> [TyVar] -> ThetaType -> [TauType] -> TyCon
---ToDo: -> SpecEnv
-> Id
-- can get the tag and all the pieces of the type from the Type
mkDataCon n stricts fields tvs ctxt args_tys tycon
= ASSERT(length stricts == length args_tys)
- data_con
+ addStandardIdInfo data_con
where
-- NB: data_con self-recursion; should be OK as tags are not
-- looked at until late in the game.
data_con
= Id (nameUnique n)
n
- type_of_constructor
+ data_con_ty
(DataConId data_con_tag stricts fields tvs ctxt args_tys tycon)
IWantToBeINLINEd -- Always inline constructors if possible
- datacon_info
-
- data_con_tag = position_within fIRST_TAG data_con_family
+ noIdInfo
+ data_con_tag = assoc "mkDataCon" (data_con_family `zip` [fIRST_TAG..]) data_con
data_con_family = tyConDataCons tycon
- position_within :: Int -> [Id] -> Int
-
- position_within acc (c:cs)
- = if c == data_con then acc else position_within (acc+1) cs
-#ifdef DEBUG
- position_within acc []
- = panic "mkDataCon: con not found in family"
-#endif
-
- type_of_constructor
+ data_con_ty
= mkSigmaTy tvs ctxt
(mkFunTys args_tys (applyTyCon tycon (mkTyVarTys tvs)))
- datacon_info = noIdInfo `addInfo_UF` unfolding
- `addInfo` mkArityInfo arity
---ToDo: `addInfo` specenv
-
- arity = length ctxt + length args_tys
-
- unfolding
- = noInfo_UF
-{- LATER:
- = -- if arity == 0
- -- then noIdInfo
- -- else -- do some business...
- let
- (tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
- tyvar_tys = mkTyVarTys tyvars
- in
- case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
-
- mkUnfolding EssentialUnfolding -- for data constructors
- (mkLam tyvars (dict_vars ++ vars) plain_Con)
- }
- mk_uf_bits tvs ctxt arg_tys tycon
- = let
- (inst_env, tyvars, tyvar_tys)
- = instantiateTyVarTemplates tvs
- (map uniqueOf tvs)
- in
- -- the "context" and "arg_tys" have TyVarTemplates in them, so
- -- we instantiate those types to have the right TyVars in them
- -- instead.
- case (map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
- of { inst_dict_tys ->
- case (map (instantiateTauTy inst_env) arg_tys) of { inst_arg_tys ->
-
- -- We can only have **ONE** call to mkTemplateLocals here;
- -- otherwise, we get two blobs of locals w/ mixed-up Uniques
- -- (Mega-Sigh) [ToDo]
- case (mkTemplateLocals (inst_dict_tys ++ inst_arg_tys)) of { all_vars ->
-
- case (splitAt (length ctxt) all_vars) of { (dict_vars, vars) ->
-
- (tyvars, dict_vars, vars)
- }}}}
- where
- -- these are really dubious Types, but they are only to make the
- -- binders for the lambdas for tossed-away dicts.
- ctxt_ty (clas, ty) = mkDictTy clas ty
--}
-\end{code}
-
-\begin{code}
-mkTupleCon :: Arity -> Id
-
-mkTupleCon arity
- = Id unique n ty (TupleConId arity) NoPragmaInfo tuplecon_info
+mkTupleCon :: Arity -> Name -> Type -> Id
+mkTupleCon arity name ty
+ = addStandardIdInfo tuple_id
where
- n = mkTupleDataConName arity
- unique = uniqueOf n
- ty = mkSigmaTy tyvars []
- (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
- tycon = mkTupleTyCon arity
- tyvars = take arity alphaTyVars
- tyvar_tys = mkTyVarTys tyvars
-
- tuplecon_info
- = noIdInfo `addInfo_UF` unfolding
- `addInfo` mkArityInfo arity
---LATER:? `addInfo` panic "Id:mkTupleCon:pcGenerateTupleSpecs arity ty"
-
- unfolding
- = noInfo_UF
-{- LATER:
- = -- if arity == 0
- -- then noIdInfo
- -- else -- do some business...
- let
- (tyvars, dict_vars, vars) = mk_uf_bits arity
- tyvar_tys = mkTyVarTys tyvars
- in
- case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
- mkUnfolding
- EssentialUnfolding -- data constructors
- (mkLam tyvars (dict_vars ++ vars) plain_Con) }
-
- mk_uf_bits arity
- = case (mkTemplateLocals tyvar_tys) of { vars ->
- (tyvars, [], vars) }
- where
- tyvar_tmpls = take arity alphaTyVars
- (_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
--}
+ tuple_id = Id (nameUnique name) name ty
+ (TupleConId arity)
+ IWantToBeINLINEd -- Always inline constructors if possible
+ noIdInfo
fIRST_TAG :: ConTag
fIRST_TAG = 1 -- Tags allocated from here for real constructors
dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
dataConTyCon (Id _ _ _ (DataConId _ _ _ _ _ _ tycon) _ _) = tycon
-dataConTyCon (Id _ _ _ (TupleConId a) _ _) = mkTupleTyCon a
+dataConTyCon (Id _ _ _ (TupleConId a) _ _) = tupleTyCon a
dataConSig :: DataCon -> ([TyVar], ThetaType, [TauType], TyCon)
-- will panic if not a DataCon
= (tyvars, theta_ty, arg_tys, tycon)
dataConSig (Id _ _ _ (TupleConId arity) _ _)
- = (tyvars, [], tyvar_tys, mkTupleTyCon arity)
+ = (tyvars, [], tyvar_tys, tupleTyCon arity)
where
tyvars = take arity alphaTyVars
tyvar_tys = mkTyVarTys tyvars
\begin{code}
mkRecordSelId field_label selector_ty
- = Id (nameUnique name)
+ = addStandardIdInfo $ -- Record selectors have a standard unfolding
+ Id (nameUnique name)
name
selector_ty
(RecordSelId field_label)
recordSelectorFieldLabel :: Id -> FieldLabel
recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl
+
+isRecordSelector (Id _ _ _ (RecordSelId lbl) _ _) = True
+isRecordSelector other = False
\end{code}
%* *
%************************************************************************
-@getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
-and generates an @Unfolding@. The @Ids@ and @TyVars@ don't really
-have to be new, because we are only producing a template.
+\begin{code}
+getIdUnfolding :: Id -> Unfolding
-ToDo: what if @DataConId@'s type has a context (haven't thought about it
---WDP)?
+getIdUnfolding (Id _ _ _ _ _ info) = unfoldInfo info
-Note: @getDataConUnfolding@ is a ``poor man's'' version---it is NOT
-EXPORTED. It just returns the binders (@TyVars@ and @Ids@) [in the
-example above: a, b, and x, y, z], which is enough (in the important
-\tr{DsExpr} case). (The middle set of @Ids@ is binders for any
-dictionaries, in the even of an overloaded data-constructor---none at
-present.)
+addIdUnfolding :: Id -> Unfolding -> Id
+addIdUnfolding id@(Id u n ty details prag info) unfolding
+ = Id u n ty details prag (info `addUnfoldInfo` unfolding)
+\end{code}
+
+The inline pragma tells us to be very keen to inline this Id, but it's still
+OK not to if optimisation is switched off.
\begin{code}
-getIdUnfolding :: Id -> Unfolding
+idWantsToBeINLINEd :: Id -> Bool
-getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info
+idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True
+idWantsToBeINLINEd _ = False
-{-LATER:
-addIdUnfolding :: Id -> Unfolding -> Id
-addIdUnfolding id@(Id u n ty info details) unfold_details
- = ASSERT(
- case (isLocallyDefined id, unfold_details) of
- (_, NoUnfolding) -> True
- (True, IWantToBeINLINEd _) -> True
- (False, IWantToBeINLINEd _) -> False -- v bad
- (False, _) -> True
- _ -> False -- v bad
- )
- Id u n ty (info `addInfo_UF` unfold_details) details
--}
+addInlinePragma :: Id -> Id
+addInlinePragma (Id u sn ty details _ info)
+ = Id u sn ty details IWantToBeINLINEd info
\end{code}
-In generating selector functions (take a dictionary, give back one
-component...), we need to what out for the nothing-to-select cases (in
-which case the ``selector'' is just an identity function):
-\begin{verbatim}
-class Eq a => Foo a { } # the superdict selector for "Eq"
-class Foo a { op :: Complex b => c -> b -> a }
- # the method selector for "op";
- # note local polymorphism...
-\end{verbatim}
+The predicate @idMustBeINLINEd@ says that this Id absolutely must be inlined.
+It's only true for primitives, because we don't want to make a closure for each of them.
+
+\begin{code}
+idMustBeINLINEd (Id _ _ _ (PrimitiveId primop) _ _) = True
+idMustBeINLINEd other = False
+\end{code}
+
%************************************************************************
%* *
\begin{code}
getIdDemandInfo :: Id -> DemandInfo
-getIdDemandInfo (Id _ _ _ _ _ info) = getInfo info
+getIdDemandInfo (Id _ _ _ _ _ info) = demandInfo info
addIdDemandInfo :: Id -> DemandInfo -> Id
addIdDemandInfo (Id u n ty details prags info) demand_info
- = Id u n ty details prags (info `addInfo` demand_info)
+ = Id u n ty details prags (info `addDemandInfo` demand_info)
\end{code}
\begin{code}
getIdUpdateInfo :: Id -> UpdateInfo
-getIdUpdateInfo (Id _ _ _ _ _ info) = getInfo info
+getIdUpdateInfo (Id _ _ _ _ _ info) = updateInfo info
addIdUpdateInfo :: Id -> UpdateInfo -> Id
addIdUpdateInfo (Id u n ty details prags info) upd_info
- = Id u n ty details prags (info `addInfo` upd_info)
+ = Id u n ty details prags (info `addUpdateInfo` upd_info)
\end{code}
\begin{code}
{- LATER:
getIdArgUsageInfo :: Id -> ArgUsageInfo
-getIdArgUsageInfo (Id u n ty info details) = getInfo info
+getIdArgUsageInfo (Id u n ty info details) = argUsageInfo info
addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
addIdArgUsageInfo (Id u n ty info details) au_info
- = Id u n ty (info `addInfo` au_info) details
+ = Id u n ty (info `addArgusageInfo` au_info) details
-}
\end{code}
\begin{code}
{- LATER:
getIdFBTypeInfo :: Id -> FBTypeInfo
-getIdFBTypeInfo (Id u n ty info details) = getInfo info
+getIdFBTypeInfo (Id u n ty info details) = fbTypeInfo info
addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
addIdFBTypeInfo (Id u n ty info details) upd_info
- = Id u n ty (info `addInfo` upd_info) details
+ = Id u n ty (info `addFBTypeInfo` upd_info) details
-}
\end{code}
\begin{code}
getIdSpecialisation :: Id -> SpecEnv
-getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info
+getIdSpecialisation (Id _ _ _ _ _ info) = specInfo info
addIdSpecialisation :: Id -> SpecEnv -> Id
addIdSpecialisation (Id u n ty details prags info) spec_info
- = Id u n ty details prags (info `addInfo` spec_info)
+ = Id u n ty details prags (info `addSpecInfo` spec_info)
\end{code}
Strictness: we snaffle the info out of the IdInfo.
\begin{code}
-getIdStrictness :: Id -> StrictnessInfo
-
-getIdStrictness (Id _ _ _ _ _ info) = getInfo info
+getIdStrictness :: Id -> StrictnessInfo Id
-addIdStrictness :: Id -> StrictnessInfo -> Id
+getIdStrictness (Id _ _ _ _ _ info) = strictnessInfo info
+addIdStrictness :: Id -> StrictnessInfo Id -> Id
addIdStrictness (Id u n ty details prags info) strict_info
- = Id u n ty details prags (info `addInfo` strict_info)
+ = Id u n ty details prags (info `addStrictnessInfo` strict_info)
\end{code}
%************************************************************************
#include "HsVersions.h"
module IdInfo (
- IdInfo, -- abstract
+ IdInfo, -- Abstract
+
noIdInfo,
- boringIdInfo,
ppIdInfo,
applySubstToIdInfo, apply_to_IdInfo, -- not for general use, please
- OptIdInfo(..), -- class; for convenience only
- -- all the *Infos herein are instances of it
-
- -- component "id infos"; also abstract:
- SrcLoc,
- getSrcLocIdInfo,
-
- ArityInfo,
- mkArityInfo, unknownArity, arityMaybe,
+ ArityInfo(..),
+ exactArity, atLeastArity, unknownArity,
+ arityInfo, addArityInfo, ppArityInfo,
DemandInfo,
- mkDemandInfo,
- willBeDemanded,
-
- StrictnessInfo(..), -- non-abstract
- Demand(..), -- non-abstract
+ noDemandInfo, mkDemandInfo, demandInfo, ppDemandInfo, addDemandInfo, willBeDemanded,
+ StrictnessInfo(..), -- Non-abstract
+ Demand(..), -- Non-abstract
wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum,
- indicatesWorker, nonAbsentArgs,
- mkStrictnessInfo, mkBottomStrictnessInfo,
- getWrapperArgTypeCategories,
- getWorkerId,
+
+ getWorkerId_maybe,
workerExists,
- bottomIsGuaranteed,
+ mkStrictnessInfo, mkBottomStrictnessInfo, noStrictnessInfo, bottomIsGuaranteed,
+ strictnessInfo, ppStrictnessInfo, addStrictnessInfo,
- mkUnfolding,
- noInfo_UF, getInfo_UF, addInfo_UF, -- to avoid instance virus
+ unfoldInfo, addUnfoldInfo,
- UpdateInfo,
- mkUpdateInfo,
- SYN_IE(UpdateSpec),
- updateInfoMaybe,
+ specInfo, addSpecInfo,
- DeforestInfo(..),
+ UpdateInfo, SYN_IE(UpdateSpec),
+ mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, addUpdateInfo,
- ArgUsageInfo,
- ArgUsage(..),
- SYN_IE(ArgUsageType),
- mkArgUsageInfo,
- getArgUsage,
+ DeforestInfo(..),
+ deforestInfo, ppDeforestInfo, addDeforestInfo,
- FBTypeInfo,
- FBType(..),
- FBConsum(..),
- FBProd(..),
- mkFBTypeInfo,
- getFBType
+ ArgUsageInfo, ArgUsage(..), SYN_IE(ArgUsageType),
+ mkArgUsageInfo, argUsageInfo, addArgUsageInfo, getArgUsage,
+ FBTypeInfo, FBType(..), FBConsum(..), FBProd(..),
+ fbTypeInfo, ppFBTypeInfo, addFBTypeInfo, mkFBTypeInfo, getFBType
) where
IMP_Ubiq()
-- *not* importing much of anything else,
-- except from the very general "utils".
+import Type ( eqSimpleTy, splitFunTyExpandingDicts )
import CmdLineOpts ( opt_OmitInterfacePragmas )
+
+import Demand
import Maybes ( firstJust )
import Outputable ( ifPprInterface, Outputable(..){-instances-} )
import PprStyle ( PprStyle(..) )
import Pretty
-import SrcLoc ( mkUnknownSrcLoc )
-import Type ( eqSimpleTy, splitFunTyExpandingDicts )
import Unique ( pprUnique )
import Util ( mapAccumL, panic, assertPanic, pprPanic )
applySubstToTy = panic "IdInfo.applySubstToTy"
showTypeCategory = panic "IdInfo.showTypeCategory"
-mkFormSummary = panic "IdInfo.mkFormSummary"
-isWrapperFor = panic "IdInfo.isWrapperFor"
-pprCoreUnfolding = panic "IdInfo.pprCoreUnfolding"
\end{code}
An @IdInfo@ gives {\em optional} information about an @Id@. If
DemandInfo -- Whether or not it is definitely
-- demanded
- SpecEnv -- Specialisations of this function which exist
+ SpecEnv
+ -- Specialisations of this function which exist
- StrictnessInfo -- Strictness properties, notably
+ (StrictnessInfo Id)
+ -- Strictness properties, notably
-- how to conjure up "worker" functions
- Unfolding -- Its unfolding; for locally-defined
+ Unfolding
+ -- Its unfolding; for locally-defined
-- things, this can *only* be NoUnfolding
UpdateInfo -- Which args should be updated
ArgUsageInfo -- how this Id uses its arguments
FBTypeInfo -- the Foldr/Build W/W property of this function.
-
- SrcLoc -- Source location of definition
-
- -- ToDo: SrcLoc is in FullNames too (could rm?) but it
- -- is needed here too for things like ConstMethodIds and the
- -- like, which don't have full-names of their own Mind you,
- -- perhaps the Name for a constant method could give the
- -- class/type involved?
\end{code}
\begin{code}
-noIdInfo = IdInfo noInfo noInfo noInfo noInfo noInfo_UF
- noInfo noInfo noInfo noInfo mkUnknownSrcLoc
-
--- "boring" means: nothing to put in interface
-boringIdInfo (IdInfo UnknownArity
- UnknownDemand
- specenv
- strictness
- unfolding
- NoUpdateInfo
- Don'tDeforest
- _ {- arg_usage: currently no interface effect -}
- _ {- no f/b w/w -}
- _ {- src_loc: no effect on interfaces-}
- )
- | isNullSpecEnv specenv
- && boring_strictness strictness
- && boring_unfolding unfolding
- = True
- where
- boring_strictness NoStrictnessInfo = True
- boring_strictness BottomGuaranteed = False
- boring_strictness (StrictnessInfo wrap_args _) = all_present_WwLazies wrap_args
-
- boring_unfolding NoUnfolding = True
- boring_unfolding _ = False
-
-boringIdInfo _ = False
-
-pp_NONE = ppPStr SLIT("_N_")
+noIdInfo = IdInfo UnknownArity UnknownDemand nullSpecEnv NoStrictnessInfo noUnfolding
+ NoUpdateInfo Don'tDeforest NoArgUsageInfo NoFBTypeInfo
\end{code}
Simply turgid. But BE CAREFUL: don't @apply_to_Id@ if that @Id@
nasty loop, friends...)
\begin{code}
apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold
- update deforest arg_usage fb_ww srcloc)
+ update deforest arg_usage fb_ww)
| isNullSpecEnv spec
= idinfo
| otherwise
-- apply_wrap wrap `thenLft` \ new_wrap ->
in
IdInfo arity demand new_spec strictness unfold
- update deforest arg_usage fb_ww srcloc
+ update deforest arg_usage fb_ww
where
apply_spec (SpecEnv is)
= SpecEnv (map do_one is)
Variant of the same thing for the typechecker.
\begin{code}
applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold
- update deforest arg_usage fb_ww srcloc)
+ update deforest arg_usage fb_ww)
= panic "IdInfo:applySubstToIdInfo"
{- LATER:
case (apply_spec s0 spec) of { (s1, new_spec) ->
- (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww srcloc) }
+ (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww) }
where
apply_spec s0 (SpecEnv is)
= case (mapAccumL do_one s0 is) of { (s1, new_is) ->
\begin{code}
ppIdInfo :: PprStyle
- -> Id -- The Id for which we're printing this IdInfo
-> Bool -- True <=> print specialisations, please
- -> (Id -> Id) -- to look up "better Ids" w/ better IdInfos;
- -> IdEnv Unfolding
- -- inlining info for top-level fns in this module
- -> IdInfo -- see MkIface notes
+ -> IdInfo
-> Pretty
-ppIdInfo sty for_this_id specs_please better_id_fn inline_env
- i@(IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype srcloc)
- | boringIdInfo i
- = ppPStr SLIT("_NI_")
-
- | otherwise
- = let
- stuff = ppCat [
+ppIdInfo sty specs_please
+ (IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype)
+ = ppCat [
-- order is important!:
- ppInfo sty better_id_fn arity,
- ppInfo sty better_id_fn update,
- ppInfo sty better_id_fn deforest,
-
- pp_strictness sty (Just for_this_id)
- better_id_fn inline_env strictness,
+ ppArityInfo sty arity,
+ ppUpdateInfo sty update,
+ ppDeforestInfo sty deforest,
- if bottomIsGuaranteed strictness
- then pp_NONE
- else pp_unfolding sty for_this_id inline_env unfold,
+ ppStrictnessInfo sty strictness,
if specs_please
- then pp_NONE -- ToDo -- sty (not (isDataCon for_this_id))
+ then ppNil -- ToDo -- sty (not (isDataCon for_this_id))
-- better_id_fn inline_env (mEnvToList specenv)
- else pp_NONE,
+ else ppNil,
-- DemandInfo needn't be printed since it has no effect on interfaces
- ppInfo sty better_id_fn demand,
- ppInfo sty better_id_fn fbtype
- ]
- in
- case sty of
- PprInterface -> if opt_OmitInterfacePragmas
- then ppNil
- else stuff
- _ -> stuff
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[OptIdInfo-class]{The @OptIdInfo@ class (keeps things tidier)}
-%* *
-%************************************************************************
-
-\begin{code}
-class OptIdInfo a where
- noInfo :: a
- getInfo :: IdInfo -> a
- addInfo :: IdInfo -> a -> IdInfo
- -- By default, "addInfo" will not overwrite
- -- "info" with "non-info"; look at any instance
- -- to see an example.
- ppInfo :: PprStyle -> (Id -> Id) -> a -> Pretty
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[srcloc-IdInfo]{Source-location info in an @IdInfo@}
-%* *
-%************************************************************************
-
-Not used much, but...
-\begin{code}
-getSrcLocIdInfo (IdInfo _ _ _ _ _ _ _ _ _ src_loc) = src_loc
+ ppDemandInfo sty demand,
+ ppFBTypeInfo sty fbtype
+ ]
\end{code}
%************************************************************************
\begin{code}
data ArityInfo
- = UnknownArity -- no idea
- | ArityExactly Int -- arity is exactly this
+ = UnknownArity -- No idea
+ | ArityExactly Int -- Arity is exactly this
+ | ArityAtLeast Int -- Arity is this or greater
\end{code}
\begin{code}
-mkArityInfo = ArityExactly
+exactArity = ArityExactly
+atLeastArity = ArityAtLeast
unknownArity = UnknownArity
-arityMaybe :: ArityInfo -> Maybe Int
+arityInfo (IdInfo arity _ _ _ _ _ _ _ _) = arity
-arityMaybe UnknownArity = Nothing
-arityMaybe (ArityExactly i) = Just i
-\end{code}
+addArityInfo id_info UnknownArity = id_info
+addArityInfo (IdInfo _ a c d e f g h i) arity = IdInfo arity a c d e f g h i
-\begin{code}
-instance OptIdInfo ArityInfo where
- noInfo = UnknownArity
-
- getInfo (IdInfo arity _ _ _ _ _ _ _ _ _) = arity
-
- addInfo id_info UnknownArity = id_info
- addInfo (IdInfo _ a c d e f g h i j) arity = IdInfo arity a c d e f g h i j
-
- ppInfo sty _ UnknownArity = ifPprInterface sty pp_NONE
- ppInfo sty _ (ArityExactly arity) = ppCat [ppPStr SLIT("_A_"), ppInt arity]
+ppArityInfo sty UnknownArity = ppNil
+ppArityInfo sty (ArityExactly arity) = ppCat [ppPStr SLIT("_A_"), ppInt arity]
+ppArityInfo sty (ArityAtLeast arity) = ppCat [ppPStr SLIT("_A>_"), ppInt arity]
\end{code}
%************************************************************************
\end{code}
\begin{code}
+noDemandInfo = UnknownDemand
+
mkDemandInfo :: Demand -> DemandInfo
mkDemandInfo demand = DemandedAsPer demand
\end{code}
\begin{code}
-instance OptIdInfo DemandInfo where
- noInfo = UnknownDemand
-
- getInfo (IdInfo _ demand _ _ _ _ _ _ _ _) = demand
+demandInfo (IdInfo _ demand _ _ _ _ _ _ _) = demand
-{- DELETED! If this line is in, there is no way to
- nuke a DemandInfo, and we have to be able to do that
- when floating let-bindings around
- addInfo id_info UnknownDemand = id_info
--}
- addInfo (IdInfo a _ c d e f g h i j) demand = IdInfo a demand c d e f g h i j
+addDemandInfo (IdInfo a _ c d e f g h i) demand = IdInfo a demand c d e f g h i
- ppInfo PprInterface _ _ = ppNil
- ppInfo sty _ UnknownDemand = ppStr "{-# L #-}"
- ppInfo sty _ (DemandedAsPer info)
- = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"]
+ppDemandInfo PprInterface _ = ppNil
+ppDemandInfo sty UnknownDemand = ppStr "{-# L #-}"
+ppDemandInfo sty (DemandedAsPer info) = ppCat [ppStr "{-#", ppStr (showList [info] ""), ppStr "#-}"]
\end{code}
%************************************************************************
See SpecEnv.lhs
\begin{code}
-instance OptIdInfo SpecEnv where
- noInfo = nullSpecEnv
+specInfo (IdInfo _ _ spec _ _ _ _ _ _) = spec
- getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
-
- addInfo id_info spec | isNullSpecEnv spec = id_info
- addInfo (IdInfo a b _ d e f g h i j) spec = IdInfo a b spec d e f g h i j
-
- ppInfo sty better_id_fn spec = panic "IdInfo:ppSpecs"
--- = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
+addSpecInfo id_info spec | isNullSpecEnv spec = id_info
+addSpecInfo (IdInfo a b _ d e f g h i) spec = IdInfo a b spec d e f g h i
\end{code}
%************************************************************************
it exists); i.e. its calling convention.
\begin{code}
-data StrictnessInfo
+data StrictnessInfo bdee
= NoStrictnessInfo
| BottomGuaranteed -- This Id guarantees never to return;
-- Useful for "error" and other disguised
-- variants thereof.
- | StrictnessInfo [Demand] -- the main stuff; see below.
- (Maybe Id) -- worker's Id, if applicable.
-\end{code}
-
-This type is also actually used in the strictness analyser:
-\begin{code}
-data Demand
- = WwLazy -- Argument is lazy as far as we know
- MaybeAbsent -- (does not imply worker's existence [etc]).
- -- If MaybeAbsent == True, then it is
- -- *definitely* lazy. (NB: Absence implies
- -- a worker...)
-
- | WwStrict -- Argument is strict but that's all we know
- -- (does not imply worker's existence or any
- -- calling-convention magic)
-
- | WwUnpack -- Argument is strict & a single-constructor
- [Demand] -- type; its constituent parts (whose StrictInfos
- -- are in the list) should be passed
- -- as arguments to the worker.
-
- | WwPrim -- Argument is of primitive type, therefore
- -- strict; doesn't imply existence of a worker;
- -- argument should be passed as is to worker.
-
- | WwEnum -- Argument is strict & an enumeration type;
- -- an Int# representing the tag (start counting
- -- at zero) should be passed to the worker.
- deriving (Eq, Ord)
- -- we need Eq/Ord to cross-chk update infos in interfaces
-
-type MaybeAbsent = Bool -- True <=> not even used
-
--- versions that don't worry about Absence:
-wwLazy = WwLazy False
-wwStrict = WwStrict
-wwUnpack xs = WwUnpack xs
-wwPrim = WwPrim
-wwEnum = WwEnum
+ | StrictnessInfo [Demand] -- The main stuff; see below.
+ (Maybe bdee) -- Worker's Id, if applicable.
+ -- (It may not be applicable because the strictness info
+ -- might say just "SSS" or something; so there's no w/w split.)
\end{code}
\begin{code}
-mkStrictnessInfo :: [Demand] -> Maybe Id -> StrictnessInfo
+mkStrictnessInfo :: [Demand] -> Maybe bdee -> StrictnessInfo bdee
-mkStrictnessInfo [] _ = NoStrictnessInfo
-mkStrictnessInfo xs wrkr = StrictnessInfo xs wrkr
+mkStrictnessInfo xs wrkr
+ | all is_lazy xs = NoStrictnessInfo -- Uninteresting
+ | otherwise = StrictnessInfo xs wrkr
+ where
+ is_lazy (WwLazy False) = True -- NB "Absent" args do *not* count!
+ is_lazy _ = False -- (as they imply a worker)
+noStrictnessInfo = NoStrictnessInfo
mkBottomStrictnessInfo = BottomGuaranteed
bottomIsGuaranteed BottomGuaranteed = True
bottomIsGuaranteed other = False
-getWrapperArgTypeCategories
- :: Type -- wrapper's type
- -> StrictnessInfo -- strictness info about its args
- -> Maybe String
-
-getWrapperArgTypeCategories _ NoStrictnessInfo = Nothing
-getWrapperArgTypeCategories _ BottomGuaranteed
- = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing -- wrong
-getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
-
-getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
- = Just (mkWrapperArgTypeCategories ty arg_info)
-
-workerExists :: StrictnessInfo -> Bool
-workerExists (StrictnessInfo _ (Just worker_id)) = True
-workerExists other = False
-
-getWorkerId :: StrictnessInfo -> Id
-
-getWorkerId (StrictnessInfo _ (Just worker_id)) = worker_id
-#ifdef DEBUG
-getWorkerId junk = pprPanic "getWorkerId: " (ppInfo PprDebug (\x->x) junk)
-#endif
-\end{code}
-
-\begin{code}
-isStrict :: Demand -> Bool
+strictnessInfo (IdInfo _ _ _ strict _ _ _ _ _) = strict
-isStrict WwStrict = True
-isStrict (WwUnpack _) = True
-isStrict WwPrim = True
-isStrict WwEnum = True
-isStrict _ = False
+addStrictnessInfo id_info NoStrictnessInfo = id_info
+addStrictnessInfo (IdInfo a b d _ e f g h i) strict = IdInfo a b d strict e f g h i
-nonAbsentArgs :: [Demand] -> Int
+ppStrictnessInfo sty NoStrictnessInfo = ppNil
+ppStrictnessInfo sty BottomGuaranteed = ppPStr SLIT("_S_ _!_")
-nonAbsentArgs cmpts
- = foldr tick_non 0 cmpts
+ppStrictnessInfo sty (StrictnessInfo wrapper_args wrkr_maybe)
+ = ppCat [ppPStr SLIT("_S_"), ppStr (showList wrapper_args ""), pp_wrkr]
where
- tick_non (WwLazy True) acc = acc
- tick_non other acc = acc + 1
-
-all_present_WwLazies :: [Demand] -> Bool
-all_present_WwLazies infos
- = and (map is_L infos)
- where
- is_L (WwLazy False) = True -- False <=> "Absent" args do *not* count!
- is_L _ = False -- (as they imply a worker)
+ pp_wrkr = case wrkr_maybe of
+ Nothing -> ppNil
+ Just wrkr -> ppr sty wrkr
\end{code}
-WDP 95/04: It is no longer enough to look at a list of @Demands@ for
-an ``Unpack'' or an ``Absent'' and declare a worker. We also have to
-check that @mAX_WORKER_ARGS@ hasn't been exceeded. Therefore,
-@indicatesWorker@ mirrors the process used in @mk_ww_arg_processing@
-in \tr{WwLib.lhs}. A worker is ``indicated'' when we hit an Unpack
-or an Absent {\em that we accept}.
-\begin{code}
-indicatesWorker :: [Demand] -> Bool
-
-indicatesWorker dems
- = fake_mk_ww (mAX_WORKER_ARGS - nonAbsentArgs dems) dems
- where
- fake_mk_ww _ [] = False
- fake_mk_ww _ (WwLazy True : _) = True -- we accepted an Absent
- fake_mk_ww extra_args (WwUnpack cmpnts : dems)
- | extra_args_now > 0 = True -- we accepted an Unpack
- where
- extra_args_now = extra_args + 1 - nonAbsentArgs cmpnts
-
- fake_mk_ww extra_args (_ : dems)
- = fake_mk_ww extra_args dems
-\end{code}
\begin{code}
-mkWrapperArgTypeCategories
- :: Type -- wrapper's type
- -> [Demand] -- info about its arguments
- -> String -- a string saying lots about the args
-
-mkWrapperArgTypeCategories wrapper_ty wrap_info
- = case (splitFunTyExpandingDicts wrapper_ty) of { (arg_tys,_) ->
- map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) }
- where
- -- ToDo: this needs FIXING UP (it was a hack anyway...)
- do_one (WwPrim, _) = 'P'
- do_one (WwEnum, _) = 'E'
- do_one (WwStrict, arg_ty_char) = arg_ty_char
- do_one (WwUnpack _, arg_ty_char)
- = if arg_ty_char `elem` "CIJFDTS"
- then toLower arg_ty_char
- else if arg_ty_char == '+' then 't'
- else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
- do_one (other_wrap_info, _) = '-'
-\end{code}
-
-Whether a worker exists depends on whether the worker has an
-absent argument, a @WwUnpack@ argument, (or @WwEnum@ ToDo???) arguments.
-
-If a @WwUnpack@ argument is for an {\em abstract} type (or one that
-will be abstract outside this module), which might happen for an
-imported function, then we can't (or don't want to...) unpack the arg
-as the worker requires. Hence we have to give up altogether, and call
-the wrapper only; so under these circumstances we return \tr{False}.
-
-\begin{code}
-#ifdef REALLY_HASKELL_1_3
-instance Read Demand where
-#else
-instance Text Demand where
-#endif
- readList str = read_em [{-acc-}] str
- where
- read_em acc [] = [(reverse acc, "")]
- -- lower case indicates absence...
- read_em acc ('L' : xs) = read_em (WwLazy False : acc) xs
- read_em acc ('A' : xs) = read_em (WwLazy True : acc) xs
- read_em acc ('S' : xs) = read_em (WwStrict : acc) xs
- read_em acc ('P' : xs) = read_em (WwPrim : acc) xs
- read_em acc ('E' : xs) = read_em (WwEnum : acc) xs
-
- read_em acc (')' : xs) = [(reverse acc, xs)]
- read_em acc ( 'U' : '(' : xs)
- = case (read_em [] xs) of
- [(stuff, rest)] -> read_em (WwUnpack stuff : acc) rest
- _ -> panic ("Text.Demand:"++str++"::"++xs)
-
- read_em acc other = panic ("IdInfo.readem:"++other)
-
-#ifdef REALLY_HASKELL_1_3
-instance Show Demand where
-#endif
- showList wrap_args rest = (concat (map show1 wrap_args)) ++ rest
- where
- show1 (WwLazy False) = "L"
- show1 (WwLazy True) = "A"
- show1 WwStrict = "S"
- show1 WwPrim = "P"
- show1 WwEnum = "E"
- show1 (WwUnpack args)= "U(" ++ (concat (map show1 args)) ++ ")"
-
-instance Outputable Demand where
- ppr sty si = ppStr (showList [si] "")
-
-instance OptIdInfo StrictnessInfo where
- noInfo = NoStrictnessInfo
-
- getInfo (IdInfo _ _ _ strict _ _ _ _ _ _) = strict
-
- addInfo id_info NoStrictnessInfo = id_info
- addInfo (IdInfo a b d _ e f g h i j) strict = IdInfo a b d strict e f g h i j
+workerExists :: StrictnessInfo bdee -> Bool
+workerExists (StrictnessInfo _ (Just worker_id)) = True
+workerExists other = False
- ppInfo sty better_id_fn strictness_info
- = pp_strictness sty Nothing better_id_fn nullIdEnv strictness_info
+getWorkerId_maybe :: StrictnessInfo bdee -> Maybe bdee
+getWorkerId_maybe (StrictnessInfo _ maybe_worker_id) = maybe_worker_id
+getWorkerId_maybe other = Nothing
\end{code}
-We'll omit the worker info if the thing has an explicit unfolding
-already.
-\begin{code}
-pp_strictness sty _ _ _ NoStrictnessInfo = ifPprInterface sty pp_NONE
-
-pp_strictness sty _ _ _ BottomGuaranteed = ppPStr SLIT("_S_ _!_")
-
-pp_strictness sty for_this_id_maybe better_id_fn inline_env
- info@(StrictnessInfo wrapper_args wrkr_maybe)
- = let
- (have_wrkr, wrkr_id) = case wrkr_maybe of
- Nothing -> (False, panic "ppInfo(Strictness)")
- Just xx -> (True, xx)
-
- wrkr_to_print = better_id_fn wrkr_id
- wrkr_info = getIdInfo wrkr_to_print
-
- -- if we aren't going to be able to *read* the strictness info
- -- in TcPragmas, we need not even print it.
- wrapper_args_to_use
- = if not (indicatesWorker wrapper_args) then
- wrapper_args -- no worker/wrappering in any case
- else
- case for_this_id_maybe of
- Nothing -> wrapper_args
- Just id -> if externallyVisibleId id
- && (unfoldingUnfriendlyId id || not have_wrkr) then
- -- pprTrace "IdInfo: unworker-ising:" (ppCat [ppr PprDebug have_wrkr, ppr PprDebug id]) $
- map un_workerise wrapper_args
- else
- wrapper_args
-
- id_is_worker
- = case for_this_id_maybe of
- Nothing -> False
- Just id -> isWorkerId id
-
- am_printing_iface = case sty of { PprInterface -> True ; _ -> False }
-
- pp_basic_info
- = ppBesides [ppStr "_S_ \"",
- ppStr (showList wrapper_args_to_use ""), ppStr "\""]
-
- pp_with_worker
- = ppBesides [ ppSP, ppChar '{',
- ppIdInfo sty wrkr_to_print True{-wrkr specs, yes!-} better_id_fn inline_env wrkr_info,
- ppChar '}' ]
- in
- if all_present_WwLazies wrapper_args_to_use then -- too boring
- ifPprInterface sty pp_NONE
-
- else if id_is_worker && am_printing_iface then
- pp_NONE -- we don't put worker strictness in interfaces
- -- (it can be deduced)
-
- else if not (indicatesWorker wrapper_args_to_use)
- || not have_wrkr
- || boringIdInfo wrkr_info then
- ppBeside pp_basic_info ppNil
- else
- ppBeside pp_basic_info pp_with_worker
- where
- un_workerise (WwLazy _) = WwLazy False -- avoid absence
- un_workerise (WwUnpack _) = WwStrict
- un_workerise other = other
-\end{code}
%************************************************************************
%* *
%************************************************************************
\begin{code}
-mkUnfolding guide expr
- = CoreUnfolding (SimpleUnfolding (mkFormSummary expr)
- guide
- (occurAnalyseGlobalExpr expr))
-\end{code}
-
-\begin{code}
-noInfo_UF = NoUnfolding
-
-getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _) = unfolding
-
-addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfolding = id_info
-addInfo_UF (IdInfo a b d e _ f g h i j) uf = IdInfo a b d e uf f g h i j
-\end{code}
-
-\begin{code}
-pp_unfolding sty for_this_id inline_env uf_details
- = case (lookupIdEnv inline_env for_this_id) of
- Nothing -> pp uf_details
- Just dt -> pp dt
- where
- pp NoUnfolding = pp_NONE
-
- pp (MagicUnfolding tag _)
- = ppCat [ppPStr SLIT("_MF_"), pprUnique tag]
-
- pp (CoreUnfolding (SimpleUnfolding _ guide template))
- = let
- untagged = unTagBinders template
- in
- if untagged `isWrapperFor` for_this_id
- then -- pprTrace "IdInfo:isWrapperFor:" (ppAbove (ppr PprDebug for_this_id) (ppr PprDebug untagged))
- pp_NONE
- else ppCat [ppPStr SLIT("_F_"), ppr sty guide, pprCoreUnfolding untagged]
+unfoldInfo (IdInfo _ _ _ _ unfolding _ _ _ _) = unfolding
+addUnfoldInfo (IdInfo a b d e _ f g h i) uf = IdInfo a b d e uf f g h i
\end{code}
%************************************************************************
ok_digit c | c >= '0' && c <= '2' = ord c - ord '0'
| otherwise = panic "IdInfo: not a digit while reading update pragma"
-instance OptIdInfo UpdateInfo where
- noInfo = NoUpdateInfo
-
- getInfo (IdInfo _ _ _ _ _ update _ _ _ _) = update
+updateInfo (IdInfo _ _ _ _ _ update _ _ _) = update
- addInfo id_info NoUpdateInfo = id_info
- addInfo (IdInfo a b d e f _ g h i j) upd_info = IdInfo a b d e f upd_info g h i j
+addUpdateInfo id_info NoUpdateInfo = id_info
+addUpdateInfo (IdInfo a b d e f _ g h i) upd_info = IdInfo a b d e f upd_info g h i
- ppInfo sty better_id_fn NoUpdateInfo = ifPprInterface sty pp_NONE
- ppInfo sty better_id_fn (SomeUpdateInfo []) = ifPprInterface sty pp_NONE
- ppInfo sty better_id_fn (SomeUpdateInfo spec)
- = ppBeside (ppPStr SLIT("_U_ ")) (ppBesides (map ppInt spec))
+ppUpdateInfo sty NoUpdateInfo = ppNil
+ppUpdateInfo sty (SomeUpdateInfo []) = ppNil
+ppUpdateInfo sty (SomeUpdateInfo spec) = ppBeside (ppPStr SLIT("_U_ ")) (ppBesides (map ppInt spec))
\end{code}
%************************************************************************
\end{code}
\begin{code}
-instance OptIdInfo DeforestInfo where
- noInfo = Don'tDeforest
+deforestInfo (IdInfo _ _ _ _ _ _ deforest _ _) = deforest
- getInfo (IdInfo _ _ _ _ _ _ deforest _ _ _) = deforest
+addDeforestInfo id_info Don'tDeforest = id_info
+addDeforestInfo (IdInfo a b d e f g _ h i) deforest = IdInfo a b d e f g deforest h i
- addInfo id_info Don'tDeforest = id_info
- addInfo (IdInfo a b d e f g _ h i j) deforest =
- IdInfo a b d e f g deforest h i j
-
- ppInfo sty better_id_fn Don'tDeforest
- = ifPprInterface sty pp_NONE
- ppInfo sty better_id_fn DoDeforest
- = ppPStr SLIT("_DEFOREST_")
+ppDeforestInfo sty Don'tDeforest = ppNil
+ppDeforestInfo sty DoDeforest = ppPStr SLIT("_DEFOREST_")
\end{code}
%************************************************************************
\end{code}
\begin{code}
-mkArgUsageInfo = SomeArgUsageInfo
+mkArgUsageInfo [] = NoArgUsageInfo
+mkArgUsageInfo au = SomeArgUsageInfo au
getArgUsage :: ArgUsageInfo -> ArgUsageType
-getArgUsage NoArgUsageInfo = []
+getArgUsage NoArgUsageInfo = []
getArgUsage (SomeArgUsageInfo u) = u
\end{code}
\begin{code}
-instance OptIdInfo ArgUsageInfo where
- noInfo = NoArgUsageInfo
-
- getInfo (IdInfo _ _ _ _ _ _ _ au _ _) = au
+argUsageInfo (IdInfo _ _ _ _ _ _ _ au _) = au
- addInfo id_info NoArgUsageInfo = id_info
- addInfo (IdInfo a b d e f g h _ i j) au_info = IdInfo a b d e f g h au_info i j
-
- ppInfo sty better_id_fn NoArgUsageInfo = ifPprInterface sty pp_NONE
- ppInfo sty better_id_fn (SomeArgUsageInfo []) = ifPprInterface sty pp_NONE
- ppInfo sty better_id_fn (SomeArgUsageInfo aut)
- = ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut)
+addArgUsageInfo id_info NoArgUsageInfo = id_info
+addArgUsageInfo (IdInfo a b d e f g h _ i) au_info = IdInfo a b d e f g h au_info i
+ppArgUsageInfo sty NoArgUsageInfo = ppNil
+ppArgUsageInfo sty (SomeArgUsageInfo aut) = ppBeside (ppPStr SLIT("_L_ ")) (ppArgUsageType aut)
ppArgUsage (ArgUsage n) = ppInt n
ppArgUsage (UnknownArgUsage) = ppChar '-'
ppIntersperse ppComma (map ppArgUsage aut),
ppChar '"' ]
\end{code}
+
%************************************************************************
%* *
\subsection[FBType-IdInfo]{Type of an expression through Foldr/build's eyes}
data FBTypeInfo
= NoFBTypeInfo
| SomeFBTypeInfo FBType
- -- ??? deriving (Eq, Ord)
data FBType = FBType [FBConsum] FBProd deriving (Eq)
\end{code}
\begin{code}
-instance OptIdInfo FBTypeInfo where
- noInfo = NoFBTypeInfo
-
- getInfo (IdInfo _ _ _ _ _ _ _ _ fb _) = fb
+fbTypeInfo (IdInfo _ _ _ _ _ _ _ _ fb) = fb
- addInfo id_info NoFBTypeInfo = id_info
- addInfo (IdInfo a b d e f g h i _ j) fb_info = IdInfo a b d e f g h i fb_info j
+addFBTypeInfo id_info NoFBTypeInfo = id_info
+addFBTypeInfo (IdInfo a b d e f g h i _) fb_info = IdInfo a b d e f g h i fb_info
- ppInfo PprInterface _ NoFBTypeInfo = ppNil
- ppInfo sty _ NoFBTypeInfo = ifPprInterface sty pp_NONE
- ppInfo sty _ (SomeFBTypeInfo (FBType cons prod))
+ppFBTypeInfo sty NoFBTypeInfo = ppNil
+ppFBTypeInfo sty (SomeFBTypeInfo (FBType cons prod))
= ppBeside (ppPStr SLIT("_F_ ")) (ppFBType cons prod)
---ppFBType (FBType n) = ppBesides [ppInt n]
---ppFBType (UnknownFBType) = ppBesides [ppStr "-"]
---
-
ppFBType cons prod = ppBesides
([ ppChar '"' ] ++ map ppCons cons ++ [ ppChar '-', ppProd prod, ppChar '"' ])
where
import BinderInfo ( BinderInfo )
import CoreSyn ( CoreExpr(..), GenCoreExpr, GenCoreArg )
import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
- SimpleUnfolding(..), FormSummary(..) )
+ SimpleUnfolding(..), FormSummary(..), noUnfolding )
import CoreUtils ( unTagBinders )
import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId,
unfoldingUnfriendlyId, getIdInfo, nmbrId,
import Usage ( GenUsage )
import Util ( Ord3(..) )
import WwLib ( mAX_WORKER_ARGS )
+import StdIdInfo ( addStandardIdInfo ) -- Used in Id, but StdIdInfo needs lots of stuff from Id
+
+addStandardIdInfo :: Id -> Id
nullSpecEnv :: SpecEnv
isNullSpecEnv :: SpecEnv -> Bool
-occurAnalyseGlobalExpr :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique
+-- occurAnalyseGlobalExpr :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique
+-- unTagBinders :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), a) b c d -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) b c d
+
externallyVisibleId :: Id -> Bool
isDataCon :: GenId ty -> Bool
isWorkerId :: GenId ty -> Bool
lookupIdEnv :: UniqFM b -> GenId a -> Maybe b
mAX_WORKER_ARGS :: Int
nmbrId :: Id -> NmbrEnv -> (NmbrEnv, Id)
-pprParendGenType :: (Eq a, Outputable a, Eq b, Outputable b) => PprStyle -> GenType a b -> Int -> Bool -> PrettyRep
-unTagBinders :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), a) b c d -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) b c d
-
+pprParendGenType :: (Eq a, Outputable a, Eq b, Outputable b) => PprStyle -> GenType a b -> Int -> Bool -> PrettyRep
mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun
type IdEnv a = UniqFM a
data MagicUnfoldingFun
data FormSummary = VarForm | ValueForm | BottomForm | OtherForm
-data Unfolding
- = NoUnfolding
- | CoreUnfolding SimpleUnfolding
- | MagicUnfolding Unique MagicUnfoldingFun
+-- data Unfolding
+-- = NoUnfolding
+-- | CoreUnfolding SimpleUnfolding
+-- | MagicUnfolding Unique MagicUnfoldingFun
+data Unfolding
+noUnfolding :: Unfolding
-data SimpleUnfolding = SimpleUnfolding FormSummary UnfoldingGuidance (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique)
+-- data SimpleUnfolding = SimpleUnfolding FormSummary UnfoldingGuidance (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique)
data UnfoldingGuidance
\begin{code}
#include "HsVersions.h"
-module IdUtils ( primOpNameInfo, primOpId ) where
+module IdUtils ( primOpName ) where
IMP_Ubiq()
IMPORT_DELOOPER(PrelLoop) -- here for paranoia checking
IMPORT_DELOOPER(IdLoop) (SpecEnv)
import CoreSyn
-import CoreUnfold ( UnfoldingGuidance(..), Unfolding )
-import Id ( mkImported, mkTemplateLocals )
+import CoreUnfold ( UnfoldingGuidance(..), Unfolding, mkUnfolding )
+import Id ( mkPrimitiveId, mkTemplateLocals )
import IdInfo -- quite a few things
-import Name ( mkPrimitiveName, OrigName(..) )
-import PrelMods ( gHC_BUILTINS )
+import StdIdInfo
+import Name ( mkWiredInIdName )
import PrimOp ( primOpInfo, tagOf_PrimOp, primOp_str,
PrimOpInfo(..), PrimOpResultInfo(..) )
-import RnHsSyn ( RnName(..) )
+import PrelMods ( gHC__ )
import Type ( mkForAllTys, mkFunTy, mkFunTys, mkTyVarTy, applyTyCon )
import TysWiredIn ( boolTy )
import Unique ( mkPrimOpIdUnique )
\end{code}
\begin{code}
-primOpNameInfo :: PrimOp -> (FAST_STRING, RnName)
-primOpId :: PrimOp -> Id
-
-primOpNameInfo op = (primOp_str op, WiredInId (primOpId op))
-
-primOpId op
+primOpName :: PrimOp -> Name
+primOpName op
= case (primOpInfo op) of
Dyadic str ty ->
- mk_prim_Id op str [] [ty,ty] (dyadic_fun_ty ty) 2
+ mk_prim_name op str [] [ty,ty] (dyadic_fun_ty ty) 2
Monadic str ty ->
- mk_prim_Id op str [] [ty] (monadic_fun_ty ty) 1
+ mk_prim_name op str [] [ty] (monadic_fun_ty ty) 1
Compare str ty ->
- mk_prim_Id op str [] [ty,ty] (compare_fun_ty ty) 2
+ mk_prim_name op str [] [ty,ty] (compare_fun_ty ty) 2
Coercing str ty1 ty2 ->
- mk_prim_Id op str [] [ty1] (ty1 `mkFunTy` ty2) 1
+ mk_prim_name op str [] [ty1] (ty1 `mkFunTy` ty2) 1
PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
- mk_prim_Id op str
+ mk_prim_name op str
tyvars
arg_tys
(mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys)))
(length arg_tys) -- arity
AlgResult str tyvars arg_tys tycon res_tys ->
- mk_prim_Id op str
+ mk_prim_name op str
tyvars
arg_tys
(mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon tycon res_tys)))
(length arg_tys) -- arity
where
- mk_prim_Id prim_op name tyvar_tmpls arg_tys ty arity
- = mkImported (mkPrimitiveName key (OrigName gHC_BUILTINS name)) ty
- (noIdInfo `addInfo` (mkArityInfo arity)
- `addInfo_UF` (mkUnfolding UnfoldAlways
- (mk_prim_unfold prim_op tyvar_tmpls arg_tys)))
+ mk_prim_name prim_op occ_name tyvar_tmpls arg_tys ty arity
+ = name
where
- key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
+ key = mkPrimOpIdUnique (IBOX(tagOf_PrimOp prim_op))
+ name = mkWiredInIdName key gHC__ occ_name the_id
+ the_id = mkPrimitiveId name ty prim_op
\end{code}
-
\begin{code}
dyadic_fun_ty ty = mkFunTys [ty, ty] ty
monadic_fun_ty ty = ty `mkFunTy` ty
compare_fun_ty ty = mkFunTys [ty, ty] boolTy
\end{code}
-
-The functions to make common unfoldings are tedious.
-
-\begin{code}
-mk_prim_unfold :: PrimOp -> [TyVar] -> [Type] -> CoreExpr{-template-}
-
-mk_prim_unfold prim_op tyvars arg_tys
- = let
- vars = mkTemplateLocals arg_tys
- in
- mkLam tyvars vars $
- Prim prim_op
- ([TyArg (mkTyVarTy tv) | tv <- tyvars] ++ [VarArg v | v <- vars])
-\end{code}
-
#include "HsVersions.h"
module Name (
+ -- The Module type
SYN_IE(Module),
+ pprModule, moduleString,
- OrigName(..), -- glorified pair
- qualToOrigName, -- a Qual to an OrigName
-
- RdrName(..),
- preludeQual,
- moduleNamePair,
- isUnqual,
- isQual,
- isRdrLexCon, isRdrLexConOrSpecial,
- appendRdr,
- showRdr,
- cmpRdr,
-
- Name,
- Provenance,
- mkLocalName, isLocalName,
- mkTopLevName, mkImportedName, oddlyImportedName,
- mkImplicitName, isImplicitName,
- mkPrimitiveName, mkWiredInName,
- mkCompoundName, mkCompoundName2,
-
- mkFunTyConName, mkTupleDataConName, mkTupleTyConName,
- mkTupNameStr,
-
- NamedThing(..), -- class
- ExportFlag(..),
- isExported{-overloaded-}, exportFlagOn{-not-},
-
- nameUnique, changeUnique,
- nameOccName,
--- nameOrigName, : not exported
- nameExportFlag,
- nameSrcLoc,
- nameImpLocs,
- nameImportFlag,
- isLocallyDefinedName, isWiredInName,
-
- origName, moduleOf, nameOf,
- getOccName, getExportFlag,
- getSrcLoc, getImpLocs,
- isLocallyDefined,
- getLocalName,
-
- isSymLexeme, pprSym, pprNonSym,
- isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym,
- isLexConId, isLexConSym, isLexVarId, isLexVarSym
- ) where
+ -- The OccName type
+ OccName(..),
+ pprOccName, pprSymOcc, pprNonSymOcc, occNameString, occNameFlavour, isTvOcc,
+ quoteInText, parenInCode,
-IMP_Ubiq()
-IMPORT_1_3(Char(isUpper,isLower))
+ -- The Name type
+ Name, -- Abstract
+ mkLocalName, mkSysLocalName,
-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, SrcLoc )
-import Unique ( funTyConKey, mkTupleDataConUnique, mkTupleTyConUnique,
- pprUnique, Unique
- )
-import Util ( thenCmp, _CMP_STRING_, nOfThem, panic, assertPanic{-, pprTrace ToDo:rm-} )
-
-#ifdef REALLY_HASKELL_1_3
-ord = fromEnum :: Char -> Int
-#endif
-\end{code}
+ mkCompoundName, mkGlobalName, mkInstDeclName,
-%************************************************************************
-%* *
-\subsection[RdrName]{The @RdrName@ datatype; names read from files}
-%* *
-%************************************************************************
-
-\begin{code}
-type Module = FAST_STRING
+ mkWiredInIdName, mkWiredInTyConName,
+ maybeWiredInIdName, maybeWiredInTyConName,
+ isWiredInName,
-data OrigName = OrigName Module FAST_STRING
+ nameUnique, changeUnique, setNameProvenance, setNameVisibility,
+ nameOccName, nameString,
+ isExportedName, nameSrcLoc,
+ isLocallyDefinedName,
-qualToOrigName (Qual m n) = OrigName m n
+ isLocalName,
-data RdrName
- = Unqual FAST_STRING
- | Qual Module FAST_STRING
+ pprNameProvenance,
-preludeQual n = Qual pRELUDE n
+ -- Sets of Names
+ NameSet(..),
+ emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets,
+ minusNameSet, elemNameSet, nameSetToList, addListToNameSet,
-moduleNamePair (Qual m n) = (m, n) -- we make *no* claim whether this
- -- constitutes an original name or
- -- an occurrence name, or anything else
-
-isUnqual (Unqual _) = True
-isUnqual (Qual _ _) = False
+ -- Misc
+ DefnInfo(..),
+ Provenance(..), pprProvenance,
+ ExportFlag(..),
-isQual (Unqual _) = False
-isQual (Qual _ _) = True
+ -- Class NamedThing and overloaded friends
+ NamedThing(..),
+ modAndOcc, isExported,
+ getSrcLoc, isLocallyDefined, getOccString,
-isRdrLexCon (Unqual n) = isLexCon n
-isRdrLexCon (Qual m n) = isLexCon n
+ pprSym, pprNonSym
+ ) where
-isRdrLexConOrSpecial (Unqual n) = isLexCon n || isLexSpecialSym n
-isRdrLexConOrSpecial (Qual m n) = isLexCon n || isLexSpecialSym n
+IMP_Ubiq()
+import TyLoop ( GenId, Id(..), TyCon ) -- Used inside Names
+import CStrings ( identToC, modnameToC, cSEP )
+import CmdLineOpts ( opt_OmitInterfacePragmas, opt_EnsureSplittableC )
-appendRdr (Unqual n) str = Unqual (n _APPEND_ str)
-appendRdr (Qual m n) str = Qual m (n _APPEND_ str)
+import Outputable ( Outputable(..) )
+import PprStyle ( PprStyle(..), codeStyle, ifaceStyle )
+import PrelMods ( gHC__ )
+import Pretty
+import Lex ( isLexSym, isLexConId )
+import SrcLoc ( noSrcLoc, SrcLoc )
+import Unique ( pprUnique, showUnique, Unique )
+import UniqSet ( UniqSet(..), emptyUniqSet, unitUniqSet, unionUniqSets, uniqSetToList,
+ unionManyUniqSets, minusUniqSet, mkUniqSet, elementOfUniqSet, addListToUniqSet )
+import UniqFM ( UniqFM )
+import Util ( cmpPString, panic, assertPanic {-, pprTrace ToDo:rm-} )
+\end{code}
-cmpRdr (Unqual n1) (Unqual n2) = _CMP_STRING_ n1 n2
-cmpRdr (Unqual n1) (Qual m2 n2) = LT_
-cmpRdr (Qual m1 n1) (Unqual n2) = GT_
-cmpRdr (Qual m1 n1) (Qual m2 n2) = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2
- -- always compare module-names *second*
-cmpOrig (OrigName m1 n1) (OrigName m2 n2)
- = _CMP_STRING_ n1 n2 `thenCmp` _CMP_STRING_ m1 m2 -- again; module-names *second*
+%************************************************************************
+%* *
+\subsection[Name-pieces-datatypes]{The @Module@, @OccName@ datatypes}
+%* *
+%************************************************************************
-instance Eq RdrName where
+\begin{code}
+type Module = FAST_STRING
+
+data OccName = VarOcc FAST_STRING -- Variables and data constructors
+ | TvOcc FAST_STRING -- Type variables
+ | TCOcc FAST_STRING -- Type constructors and classes
+
+moduleString :: Module -> String
+moduleString mod = _UNPK_ mod
+
+pprModule :: PprStyle -> Module -> Pretty
+pprModule sty m = ppPStr m
+
+pprOccName :: PprStyle -> OccName -> Pretty
+pprOccName PprDebug n = ppCat [ppPStr (occNameString n), ppBracket (ppStr (occNameFlavour n))]
+pprOccName sty n = if codeStyle sty
+ then identToC (occNameString n)
+ else ppPStr (occNameString n)
+
+occNameString :: OccName -> FAST_STRING
+occNameString (VarOcc s) = s
+occNameString (TvOcc s) = s
+occNameString (TCOcc s) = s
+
+-- occNameFlavour is used only to generate good error messages, so it doesn't matter
+-- that the VarOcc case isn't mega-efficient. We could have different Occ constructors for
+-- data constructors and values, but that makes everything else a bit more complicated.
+occNameFlavour :: OccName -> String
+occNameFlavour (VarOcc s) | isLexConId s = "data constructor"
+ | otherwise = "value"
+occNameFlavour (TvOcc s) = "type variable"
+occNameFlavour (TCOcc s) = "type constructor or class"
+
+isTvOcc :: OccName -> Bool
+isTvOcc (TvOcc s) = True
+isTvOcc other = False
+
+instance Eq OccName where
a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
-instance Ord RdrName where
+instance Ord OccName where
a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
-instance Ord3 RdrName where
- cmp = cmpRdr
-
-instance NamedThing RdrName where
- -- We're sorta faking it here
- getName (Unqual n)
- = Local u n True locn
- where
- u = panic "NamedThing.RdrName:Unique1"
- locn = panic "NamedThing.RdrName:locn"
-
- getName rdr_name@(Qual m n)
- = Global u m (Left n) prov ex [rdr_name]
- where
- u = panic "NamedThing.RdrName:Unique"
- prov = panic "NamedThing.RdrName:Provenance"
- ex = panic "NamedThing.RdrName:ExportFlag"
-
-instance Outputable RdrName where
- ppr sty (Unqual n) = pp_name sty n
- ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n)
-
-pp_mod 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)
+instance Ord3 OccName where
+ cmp = cmpOcc
-pp_name sty n = (if codeStyle sty then identToC else ppPStr) n
+(VarOcc s1) `cmpOcc` (VarOcc s2) = s1 `_CMP_STRING_` s2
+(VarOcc s1) `cmpOcc` other2 = LT_
-pp_name2 sty pieces
- = ppIntersperse sep (map pp_piece pieces)
- where
- sep = if codeStyle sty then ppPStr cSEP else ppChar '.'
+(TvOcc s1) `cmpOcc` (VarOcc s2) = GT_
+(TvOcc s1) `cmpOcc` (TvOcc s2) = s1 `_CMP_STRING_` s2
+(TvOcc s1) `cmpOcc` other = LT_
- pp_piece (Left (OrigName m n)) = ppBeside (pp_mod sty m) (pp_name sty n)
- pp_piece (Right n) = pp_name sty n
+(TCOcc s1) `cmpOcc` (TCOcc s2) = s1 `_CMP_STRING_` s2
+(TCOcc s1) `cmpOcc` other = GT_
-showRdr sty rdr = ppShow 100 (ppr sty rdr)
+instance Outputable OccName where
+ ppr = pprOccName
+\end{code}
--------------------------
-instance Eq OrigName where
- a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
- a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
-instance Ord OrigName where
- a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
- a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
- a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
- a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
+\begin{code}
+parenInCode, quoteInText :: OccName -> Bool
+parenInCode occ = isLexSym (occNameString occ)
-instance Ord3 OrigName where
- cmp = cmpOrig
+quoteInText occ = not (isLexSym (occNameString occ))
+
+-- print `vars`, (op) correctly
+pprSymOcc, pprNonSymOcc :: PprStyle -> OccName -> Pretty
-instance NamedThing OrigName where -- faking it
- getName (OrigName m n) = getName (Qual m n)
+pprSymOcc sty var
+ = if quoteInText var
+ then ppQuote (pprOccName sty var)
+ else pprOccName sty var
-instance Outputable OrigName where -- ditto
- ppr sty (OrigName m n) = ppr sty (Qual m n)
+pprNonSymOcc sty var
+ = if parenInCode var
+ then ppParens (pprOccName sty var)
+ else pprOccName sty var
\end{code}
%************************************************************************
%* *
-\subsection[Name-datatype]{The @Name@ datatype}
+\subsection[Name-datatype]{The @Name@ datatype, and name construction}
%* *
%************************************************************************
-
+
\begin{code}
data Name
= Local Unique
- FAST_STRING
- Bool -- True <=> emphasize Unique when
- -- printing; this is just an esthetic thing...
+ OccName
SrcLoc
| Global Unique
- Module -- original name
- (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);
- -- first may be *un*qual.
+ Module -- The defining module
+ OccName -- Its name in that module
+ DefnInfo -- How it is defined
+ Provenance -- How it was brought into scope
+\end{code}
+
+Things with a @Global@ name are given C static labels, so they finally
+appear in the .o file's symbol table. They appear in the symbol table
+in the form M.n. If originally-local things have this property they
+must be made @Global@ first.
+
+\begin{code}
+data DefnInfo = VanillaDefn
+ | WiredInTyCon TyCon -- There's a wired-in version
+ | WiredInId Id -- ...ditto...
data Provenance
- = LocalDef SrcLoc -- locally defined; give its source location
-
- | Imported ExportFlag -- how it was imported
- SrcLoc -- *original* source location
- [SrcLoc] -- any import source location(s)
-
- | Implicit
- | Primitive -- really and truly primitive thing (not
- -- definable in Haskell)
- | WiredIn Bool -- something defined in Haskell; True <=>
- -- definition is in the module in question;
- -- this probably comes from the -fcompiling-prelude=...
- -- flag.
+ = LocalDef ExportFlag SrcLoc -- Locally defined
+ | Imported Module SrcLoc -- Directly imported from M; gives locn of import statement
+ | Implicit -- Implicitly imported
+\end{code}
+
+Something is "Exported" if it may be mentioned by another module without
+warning. The crucial thing about Exported things is that they must
+never be dropped as dead code, even if they aren't used in this module.
+Furthermore, being Exported means that we can't see all call sites of the thing.
+
+Exported things include:
+ - explicitly exported Ids, including data constructors, class method selectors
+ - dfuns from instance decls
+
+Being Exported is *not* the same as finally appearing in the .o file's
+symbol table. For example, a local Id may be mentioned in an Exported
+Id's unfolding in the interface file, in which case the local Id goes
+out too.
+
+\begin{code}
+data ExportFlag = Exported | NotExported
\end{code}
\begin{code}
+mkLocalName :: Unique -> OccName -> SrcLoc -> Name
mkLocalName = Local
-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
+mkGlobalName :: Unique -> Module -> OccName -> DefnInfo -> Provenance -> Name
+mkGlobalName = Global
+
+mkSysLocalName :: Unique -> FAST_STRING -> SrcLoc -> Name
+mkSysLocalName uniq str loc = Local uniq (VarOcc str) loc
-mkImplicitName :: Unique -> OrigName -> Name
-mkImplicitName u (OrigName m n) = Global u m (Left n) Implicit NotExported []
+mkWiredInIdName :: Unique -> Module -> FAST_STRING -> Id -> Name
+mkWiredInIdName uniq mod occ id
+ = Global uniq mod (VarOcc occ) (WiredInId id) Implicit
-mkPrimitiveName :: Unique -> OrigName -> Name
-mkPrimitiveName u (OrigName m n) = Global u m (Left n) Primitive NotExported []
+mkWiredInTyConName :: Unique -> Module -> FAST_STRING -> TyCon -> Name
+mkWiredInTyConName uniq mod occ tycon
+ = Global uniq mod (TCOcc occ) (WiredInTyCon tycon) Implicit
-mkWiredInName :: Unique -> OrigName -> ExportFlag -> Name
-mkWiredInName u (OrigName m n) exp
- = Global u m (Left n) (WiredIn from_here) exp []
+
+mkCompoundName :: (FAST_STRING -> FAST_STRING) -- Occurrence-name modifier
+ -> Unique -- New unique
+ -> Name -- Base name (must be a Global)
+ -> Name -- Result is always a value name
+
+mkCompoundName str_fn uniq (Global _ mod occ defn prov)
+ = Global uniq mod new_occ defn prov
+ where
+ new_occ = VarOcc (str_fn (occNameString occ)) -- Always a VarOcc
+
+mkCompoundName str_fn uniq (Local _ occ loc)
+ = Local uniq (VarOcc (str_fn (occNameString occ))) loc
+
+ -- Rather a wierd one that's used for names generated for instance decls
+mkInstDeclName :: Unique -> Module -> OccName -> SrcLoc -> Bool -> Name
+mkInstDeclName uniq mod occ loc from_here
+ = Global uniq mod occ VanillaDefn prov
where
- from_here
- = case maybe_CompilingGhcInternals of
- Nothing -> False
- Just mod -> mod == _UNPK_ m
-
-mkCompoundName :: Unique
- -> Module
- -> FAST_STRING -- indicates what kind of compound thing it is (e.g., "sdsel")
- -> [Either OrigName FAST_STRING] -- "dot" these names together
- -> Name -- from which we get provenance, etc....
- -> Name -- result!
-
-mkCompoundName u m str ns (Local _ _ _ locn) -- these arise for workers...
- = Local u str True{-emph uniq-} locn
-
-mkCompoundName u m str ns (Global _ _ _ prov exp _)
- = Global u m (Right (Right str : ns)) prov exp []
-
-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
- -> Module
- -> FAST_STRING -- indicates what kind of compound thing it is
- -> [Either OrigName FAST_STRING] -- "dot" these names together
- -> Bool -- True <=> defined in this module
- -> SrcLoc
- -> Name -- result!
-
-mkCompoundName2 u m str ns from_here locn
- = 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)) ExportAll
-mkTupleTyConName arity
- = mkWiredInName (mkTupleTyConUnique arity) (OrigName pRELUDE (mkTupNameStr arity)) ExportAll
-
-mkTupNameStr 0 = SLIT("()")
-mkTupNameStr 1 = panic "Name.mkTupNameStr: 1 ???"
-mkTupNameStr 2 = _PK_ "(,)" -- not strictly necessary
-mkTupNameStr 3 = _PK_ "(,,)" -- ditto
-mkTupNameStr 4 = _PK_ "(,,,)" -- ditto
-mkTupNameStr n
- = _PK_ ("(" ++ nOfThem (n-1) ',' ++ ")")
-
- -- ToDo: what about module ???
- -- ToDo: exported when compiling builtin ???
-
-isLocalName (Local _ _ _ _) = True
-isLocalName _ = False
-
--- things the compiler "knows about" are in some sense
+ prov | from_here = LocalDef Exported loc
+ | otherwise = Implicit
+
+
+setNameProvenance :: Name -> Provenance -> Name -- Globals only
+setNameProvenance (Global uniq mod occ def _) prov = Global uniq mod occ def prov
+
+-- When we renumber/rename things, we need to be
+-- able to change a Name's Unique to match the cached
+-- one in the thing it's the name of. If you know what I mean.
+changeUnique (Local _ n l) u = Local u n l
+changeUnique (Global _ mod occ def prov) u = Global u mod occ def prov
+
+setNameVisibility :: Module -> Name -> Name
+-- setNameVisibility is applied to top-level names in the final program
+-- The "visibility" here concerns whether the .o file's symbol table
+-- mentions the thing; if so, it needs a module name in its symbol,
+-- otherwise we just use its unique. The Global things are "visible"
+-- and the local ones are not
+
+setNameVisibility _ (Global uniq mod occ def (LocalDef NotExported loc))
+ | not all_toplev_ids_visible
+ = Local uniq occ loc
+
+setNameVisibility mod (Local uniq occ loc)
+ | all_toplev_ids_visible
+ = Global uniq mod
+ (VarOcc (showUnique uniq)) -- It's local name must be unique!
+ VanillaDefn (LocalDef NotExported loc)
+
+setNameVisibility mod name = name
+
+all_toplev_ids_visible = not opt_OmitInterfacePragmas || -- Pragmas can make them visible
+ opt_EnsureSplittableC -- Splitting requires visiblilty
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Predicates and selectors}
+%* *
+%************************************************************************
+
+\begin{code}
+nameUnique :: Name -> Unique
+nameModAndOcc :: Name -> (Module, OccName) -- Globals only
+nameOccName :: Name -> OccName
+nameString :: Name -> FAST_STRING -- A.b form
+nameSrcLoc :: Name -> SrcLoc
+isLocallyDefinedName :: Name -> Bool
+isExportedName :: Name -> Bool
+isWiredInName :: Name -> Bool
+isLocalName :: Name -> Bool
+
+
+
+nameUnique (Local u _ _) = u
+nameUnique (Global u _ _ _ _) = u
+
+nameOccName (Local _ occ _) = occ
+nameOccName (Global _ _ occ _ _) = occ
+
+nameModAndOcc (Global _ mod occ _ _) = (mod,occ)
+
+nameString (Local _ occ _) = occNameString occ
+nameString (Global _ mod occ _ _) = mod _APPEND_ SLIT(".") _APPEND_ occNameString occ
+
+isExportedName (Global _ _ _ _ (LocalDef Exported _)) = True
+isExportedName other = False
+
+nameSrcLoc (Local _ _ loc) = loc
+nameSrcLoc (Global _ _ _ _ (LocalDef _ loc)) = loc
+nameSrcLoc (Global _ _ _ _ (Imported _ loc)) = loc
+nameSrcLoc other = noSrcLoc
+
+isLocallyDefinedName (Local _ _ _) = True
+isLocallyDefinedName (Global _ _ _ _ (LocalDef _ _)) = True
+isLocallyDefinedName other = False
+
+-- Things the compiler "knows about" are in some sense
-- "imported". When we are compiling the module where
-- the entities are defined, we need to be able to pick
-- them out, often in combination with isLocallyDefined.
-oddlyImportedName (Global _ _ _ Primitive _ _) = True
-oddlyImportedName (Global _ _ _ (WiredIn _) _ _) = True
-oddlyImportedName _ = False
+isWiredInName (Global _ _ _ (WiredInTyCon _) _) = True
+isWiredInName (Global _ _ _ (WiredInId _) _) = True
+isWiredInName _ = False
+
+maybeWiredInIdName :: Name -> Maybe Id
+maybeWiredInIdName (Global _ _ _ (WiredInId id) _) = Just id
+maybeWiredInIdName other = Nothing
+
+maybeWiredInTyConName :: Name -> Maybe TyCon
+maybeWiredInTyConName (Global _ _ _ (WiredInTyCon tc) _) = Just tc
+maybeWiredInTyConName other = Nothing
-isImplicitName (Global _ _ _ Implicit _ _) = True
-isImplicitName _ = False
+
+isLocalName (Local _ _ _) = True
+isLocalName _ = False
\end{code}
+
%************************************************************************
%* *
\subsection[Name-instances]{Instance declarations}
\begin{code}
cmpName n1 n2 = c n1 n2
where
- c (Local u1 _ _ _) (Local u2 _ _ _) = cmp u1 u2
- c (Local _ _ _ _) _ = LT_
- c (Global u1 _ _ _ _ _) (Global u2 _ _ _ _ _) = cmp u1 u2
- c (Global _ _ _ _ _ _) _ = GT_
+ c (Local u1 _ _) (Local u2 _ _) = cmp u1 u2
+ c (Local _ _ _) _ = LT_
+ c (Global u1 _ _ _ _) (Global u2 _ _ _ _) = cmp u1 u2
+ c (Global _ _ _ _ _) _ = GT_
\end{code}
\begin{code}
getName n = n
\end{code}
-\begin{code}
-nameUnique (Local u _ _ _) = u
-nameUnique (Global u _ _ _ _ _) = u
--- when we renumber/rename things, we need to be
--- able to change a Name's Unique to match the cached
--- one in the thing it's the name of. If you know what I mean.
-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 (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 (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
-
-nameSrcLoc (Local _ _ _ loc) = loc
-nameSrcLoc (Global _ _ _ (LocalDef loc) _ _) = loc
-nameSrcLoc (Global _ _ _ (Imported _ loc _) _ _) = loc
-nameSrcLoc (Global _ _ _ Implicit _ _) = mkUnknownSrcLoc
-nameSrcLoc (Global _ _ _ Primitive _ _) = mkBuiltinSrcLoc
-nameSrcLoc (Global _ _ _ (WiredIn _) _ _) = mkBuiltinSrcLoc
-
-nameImpLocs (Global _ _ _ (Imported _ _ locs) _ _) = locs
-nameImpLocs _ = []
-
-nameImportFlag (Local _ _ _ _) = NotExported
-nameImportFlag (Global _ _ _ (LocalDef _) _ _) = ExportAll
-nameImportFlag (Global _ _ _ (Imported exp _ _) _ _) = exp
-nameImportFlag (Global _ _ _ Implicit _ _) = ExportAll
-nameImportFlag (Global _ _ _ Primitive _ _) = ExportAll
-nameImportFlag (Global _ _ _ (WiredIn _) _ _) = ExportAll
-
-isLocallyDefinedName (Local _ _ _ _) = True
-isLocallyDefinedName (Global _ _ _ (LocalDef _) _ _) = True
-isLocallyDefinedName (Global _ _ _ (Imported _ _ _) _ _) = False
-isLocallyDefinedName (Global _ _ _ Implicit _ _) = False
-isLocallyDefinedName (Global _ _ _ Primitive _ _) = False
-isLocallyDefinedName (Global _ _ _ (WiredIn from_here) _ _) = from_here
-
-isWiredInName (Global _ _ _ (WiredIn _) _ _) = True
-isWiredInName _ = False
-\end{code}
+
+%************************************************************************
+%* *
+\subsection{Pretty printing}
+%* *
+%************************************************************************
\begin{code}
instance Outputable Name where
- ppr sty (Local u n emph_uniq _)
- | codeStyle sty = pprUnique u
- | emph_uniq = ppBesides [pprUnique u, ppStr "{-", ppPStr n, ppStr "-}"]
- | otherwise = ppBesides [ppPStr n, ppStr "{-", pprUnique u, ppStr "-}"]
-
- 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]
-
-pp_exp NotExported = ppNil
-pp_exp ExportAll = ppPStr SLIT("/EXP(..)")
-pp_exp ExportAbs = ppPStr SLIT("/EXP")
-
-pp_prov Implicit = ppPStr SLIT("/IMPLICIT")
-pp_prov Primitive = ppPStr SLIT("/PRIMITIVE")
-pp_prov (WiredIn _) = ppPStr SLIT("/WIREDIN")
-pp_prov _ = ppNil
+ ppr sty (Local u n _) | codeStyle sty ||
+ ifaceStyle sty = pprUnique u
+ | otherwise = ppBesides [ppPStr (occNameString n), ppPStr SLIT("_"), pprUnique u]
+
+ ppr sty (Global u m n _ _) = ppBesides [pp_name, pp_uniq sty u]
+ where
+ pp_name | codeStyle sty = identToC qual_name
+ | otherwise = ppPStr qual_name
+ qual_name = m _APPEND_ SLIT(".") _APPEND_ occNameString n
+
+pp_uniq PprDebug uniq = ppBesides [ppStr "{-", pprUnique uniq, ppStr "-}"]
+pp_uniq other uniq = ppNil
+
+-- pprNameProvenance is used in error messages to say where a name came from
+pprNameProvenance :: PprStyle -> Name -> Pretty
+pprNameProvenance sty (Local _ _ loc) = pprProvenance sty (LocalDef NotExported loc)
+pprNameProvenance sty (Global _ _ _ _ prov) = pprProvenance sty prov
+
+pprProvenance :: PprStyle -> Provenance -> Pretty
+pprProvenance sty (Imported mod loc)
+ = ppSep [ppStr "Imported from", pprModule sty mod, ppStr "at", ppr sty loc]
+pprProvenance sty (LocalDef _ loc)
+ = ppSep [ppStr "Defined at", ppr sty loc]
+pprProvenance sty Implicit
+ = panic "pprNameProvenance: Implicit"
\end{code}
+
%************************************************************************
%* *
-\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
+\subsection[Sets of names}
%* *
%************************************************************************
-The export flag @ExportAll@ means `export all there is', so there are
-times when it is attached to a class or data type which has no
-ops/constructors (if the class/type was imported abstractly). In
-fact, @ExportAll@ is attached to everything except to classes/types
-which are being {\em exported} abstractly, regardless of how they were
-imported.
-
\begin{code}
-data ExportFlag
- = ExportAll -- export with all constructors/methods
- | ExportAbs -- export abstractly (tycons/classes only)
- | NotExported
+type NameSet = UniqSet Name
+emptyNameSet :: NameSet
+unitNameSet :: Name -> NameSet
+addListToNameSet :: NameSet -> [Name] -> NameSet
+mkNameSet :: [Name] -> NameSet
+unionNameSets :: NameSet -> NameSet -> NameSet
+unionManyNameSets :: [NameSet] -> NameSet
+minusNameSet :: NameSet -> NameSet -> NameSet
+elemNameSet :: Name -> NameSet -> Bool
+nameSetToList :: NameSet -> [Name]
+
+emptyNameSet = emptyUniqSet
+unitNameSet = unitUniqSet
+mkNameSet = mkUniqSet
+addListToNameSet = addListToUniqSet
+unionNameSets = unionUniqSets
+unionManyNameSets = unionManyUniqSets
+minusNameSet = minusUniqSet
+elemNameSet = elementOfUniqSet
+nameSetToList = uniqSetToList
+\end{code}
-exportFlagOn NotExported = False
-exportFlagOn _ = True
--- Be very wary about using "isExported"; perhaps you
--- really mean "externallyVisibleId"?
-
-isExported a = exportFlagOn (getExportFlag a)
-\end{code}
%************************************************************************
%* *
\begin{code}
class NamedThing a where
- getName :: a -> Name
+ getOccName :: a -> OccName -- Even RdrNames can do this!
+ getName :: a -> Name
+
+ getOccName n = nameOccName (getName n) -- Default method
\end{code}
\begin{code}
-origName :: NamedThing a => String -> a -> OrigName
-moduleOf :: OrigName -> Module
-nameOf :: OrigName -> FAST_STRING
-
-getOccName :: NamedThing a => a -> RdrName
-getLocalName :: NamedThing a => a -> FAST_STRING
-getExportFlag :: NamedThing a => a -> ExportFlag
+modAndOcc :: NamedThing a => a -> (Module, OccName)
getSrcLoc :: NamedThing a => a -> SrcLoc
-getImpLocs :: NamedThing a => a -> [SrcLoc]
isLocallyDefined :: NamedThing a => a -> Bool
+isExported :: NamedThing a => a -> Bool
+getOccString :: NamedThing a => a -> String
-origName str n = nameOrigName str (getName n)
-
-moduleOf (OrigName m n) = m
-nameOf (OrigName m n) = n
-
-getLocalName n
- = case (getName n) of
- 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
+modAndOcc = nameModAndOcc . getName
+isExported = isExportedName . getName
getSrcLoc = nameSrcLoc . getName
-getImpLocs = nameImpLocs . getName
isLocallyDefined = isLocallyDefinedName . getName
+pprSym sty = pprSymOcc sty . getOccName
+pprNonSym sty = pprNonSymOcc sty . getOccName
+getOccString x = _UNPK_ (occNameString (getOccName x))
\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)@.
-
-\begin{code}
-isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
- isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool
-
-isLexCon cs = isLexConId cs || isLexConSym cs
-isLexVar cs = isLexVarId cs || isLexVarSym cs
-
-isLexId cs = isLexConId cs || isLexVarId cs
-isLexSym cs = isLexConSym cs || isLexVarSym cs
-
--------------
-
-isLexConId cs
- | _NULL_ cs = False
- | otherwise = isUpper c || isUpperISO c
- where
- c = _HEAD_ cs
-
-isLexVarId cs
- | _NULL_ cs = False
- | otherwise = isLower c || isLowerISO c
- where
- c = _HEAD_ cs
-
-isLexConSym cs
- | _NULL_ cs = False
- | otherwise = c == ':'
--- || c == '(' -- (), (,), (,,), ...
- || cs == SLIT("->")
--- || cs == SLIT("[]")
- where
- c = _HEAD_ cs
-
-isLexVarSym cs
- | _NULL_ cs = False
- | otherwise = isSymbolASCII c
- || isSymbolISO c
--- || c == '(' -- (), (,), (,,), ...
--- || cs == SLIT("[]")
- where
- c = _HEAD_ cs
-
-isLexSpecialSym cs
- | _NULL_ cs = False
- | otherwise = c == '(' -- (), (,), (,,), ...
- || cs == SLIT("[]")
- where
- c = _HEAD_ cs
-
--------------
-isSymbolASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-"
-isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
-isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
-isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
-\end{code}
-
-And one ``higher-level'' interface to those:
-
-\begin{code}
-isSymLexeme :: NamedThing a => a -> Bool
-
-isSymLexeme v
- = let str = getLocalName v in isLexSym str
-
--- print `vars`, (op) correctly
-pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
-
-pprSym sty var
- = let
- str = getLocalName var
- in
- if isLexSym str && not (isLexSpecialSym str)
- then ppr sty var
- else ppBesides [ppChar '`', ppr sty var, ppChar '`']
-
-pprNonSym sty var
- = if isSymLexeme var
- then ppParens (ppr sty var)
- else ppr sty var
-\end{code}
initPprEnv,
pCon, pLit, pMajBndr, pMinBndr, pOcc, pPrim, pSCC, pStyle,
- pTy, pTyVar, pUVar, pUse,
+ pTy, pTyVarB, pTyVarO, pUVar, pUse,
NmbrEnv(..),
SYN_IE(NmbrM), initNmbr,
(PrimOp -> Pretty)
(CostCentre -> Pretty)
- (tyvar -> Pretty) -- to print tyvars
+ (tyvar -> Pretty) -- to print tyvar binders
+ (tyvar -> Pretty) -- to print tyvar occurrences
+
(uvar -> Pretty) -- to print usage vars
(bndr -> Pretty) -- to print "major" val_bdrs
-> Maybe (PrimOp -> Pretty)
-> Maybe (CostCentre -> Pretty)
-> Maybe (tyvar -> Pretty)
+ -> Maybe (tyvar -> Pretty)
-> Maybe (uvar -> Pretty)
-> Maybe (bndr -> Pretty)
-> Maybe (bndr -> Pretty)
-- you can specify all the printers individually; if
-- you don't specify one, you get bottom
-initPprEnv sty l d p c tv uv maj_bndr min_bndr occ ty use
+initPprEnv sty l d p c tvb tvo uv maj_bndr min_bndr occ ty use
= PE sty
(demaybe l)
(demaybe d)
(demaybe p)
(demaybe c)
- (demaybe tv)
+ (demaybe tvb)
+ (demaybe tvo)
(demaybe uv)
(demaybe maj_bndr)
(demaybe min_bndr)
\end{code}
\begin{code}
-pStyle (PE s _ _ _ _ _ _ _ _ _ _ _) = s
-pLit (PE _ pp _ _ _ _ _ _ _ _ _ _) = pp
-pCon (PE _ _ pp _ _ _ _ _ _ _ _ _) = pp
-pPrim (PE _ _ _ pp _ _ _ _ _ _ _ _) = pp
-pSCC (PE _ _ _ _ pp _ _ _ _ _ _ _) = pp
-
-pTyVar (PE _ _ _ _ _ pp _ _ _ _ _ _) = pp
-pUVar (PE _ _ _ _ _ _ pp _ _ _ _ _) = pp
-
-pMajBndr (PE _ _ _ _ _ _ _ pp _ _ _ _) = pp
-pMinBndr (PE _ _ _ _ _ _ _ _ pp _ _ _) = pp
-pOcc (PE _ _ _ _ _ _ _ _ _ pp _ _) = pp
-
-pTy (PE _ _ _ _ _ _ _ _ _ _ pp _) = pp
-pUse (PE _ _ _ _ _ _ _ _ _ _ _ pp) = pp
+pStyle (PE s _ _ _ _ _ _ _ _ _ _ _ _) = s
+pLit (PE _ pp _ _ _ _ _ _ _ _ _ _ _) = pp
+pCon (PE _ _ pp _ _ _ _ _ _ _ _ _ _) = pp
+pPrim (PE _ _ _ pp _ _ _ _ _ _ _ _ _) = pp
+pSCC (PE _ _ _ _ pp _ _ _ _ _ _ _ _) = pp
+
+pTyVarB (PE _ _ _ _ _ pp _ _ _ _ _ _ _) = pp
+pTyVarO (PE _ _ _ _ _ _ pp _ _ _ _ _ _) = pp
+pUVar (PE _ _ _ _ _ _ _ pp _ _ _ _ _) = pp
+
+pMajBndr (PE _ _ _ _ _ _ _ _ pp _ _ _ _) = pp
+pMinBndr (PE _ _ _ _ _ _ _ _ _ pp _ _ _) = pp
+pOcc (PE _ _ _ _ _ _ _ _ _ _ pp _ _) = pp
+
+pTy (PE _ _ _ _ _ _ _ _ _ _ _ pp _) = pp
+pUse (PE _ _ _ _ _ _ _ _ _ _ _ _ pp) = pp
\end{code}
We tend to {\em renumber} everything before printing, so that
#include "HsVersions.h"
module SrcLoc (
- SrcLoc, -- abstract
+ SrcLoc, -- Abstract
+
+ mkSrcLoc,
+ noSrcLoc, isNoSrcLoc, -- "I'm sorry, I haven't a clue"
- mkSrcLoc, mkSrcLoc2, -- the usual
- mkUnknownSrcLoc, -- "I'm sorry, I haven't a clue"
mkIfaceSrcLoc, -- Unknown place in an interface
-- (this one can die eventually ToDo)
- mkBuiltinSrcLoc, -- something wired into the compiler
- mkGeneratedSrcLoc, -- code generated within the compiler
- unpackSrcLoc
+
+ mkBuiltinSrcLoc, -- Something wired into the compiler
+
+ mkGeneratedSrcLoc -- Code generated within the compiler
) where
IMP_Ubiq()
this is the obvious stuff:
\begin{code}
data SrcLoc
- = SrcLoc FAST_STRING -- source file name
- FAST_STRING -- line number in source file
- | SrcLoc2 FAST_STRING -- same, but w/ an Int line#
+ = NoSrcLoc
+
+ | SrcLoc FAST_STRING -- A precise location
FAST_INT
+
+ | UnhelpfulSrcLoc FAST_STRING -- Just a general indication
\end{code}
Note that an entity might be imported via more than one route, and
Things to make 'em:
\begin{code}
-mkSrcLoc = SrcLoc
-mkSrcLoc2 x IBOX(y) = SrcLoc2 x y
-mkUnknownSrcLoc = SrcLoc SLIT("<unknown>") SLIT("<unknown>")
-mkIfaceSrcLoc = SrcLoc SLIT("<an interface file>") SLIT("<unknown>")
-mkBuiltinSrcLoc = SrcLoc SLIT("<built-into-the-compiler>") SLIT("<none>")
-mkGeneratedSrcLoc = SrcLoc SLIT("<compiler-generated-code>") SLIT("<none>")
-
-unpackSrcLoc (SrcLoc src_file src_line) = (src_file, src_line)
-unpackSrcLoc (SrcLoc2 src_file src_line) = (src_file, _PK_ (show IBOX(src_line)))
+noSrcLoc = NoSrcLoc
+mkSrcLoc x IBOX(y) = SrcLoc x y
+
+mkIfaceSrcLoc = UnhelpfulSrcLoc SLIT("<an interface file>")
+mkBuiltinSrcLoc = UnhelpfulSrcLoc SLIT("<built-into-the-compiler>")
+mkGeneratedSrcLoc = UnhelpfulSrcLoc SLIT("<compiler-generated-code>")
+
+isNoSrcLoc NoSrcLoc = True
+isNoSrcLoc other = False
\end{code}
%************************************************************************
\begin{code}
instance Outputable SrcLoc where
ppr PprForUser (SrcLoc src_file src_line)
- = ppBesides [ ppChar '"', ppPStr src_file, ppStr "\", line ", ppPStr src_line ]
+ = ppBesides [ ppPStr src_file, ppStr ": ", ppStr (show IBOX(src_line)) ]
ppr sty (SrcLoc src_file src_line)
- = ppBesides [ppPStr SLIT("{-# LINE "), ppPStr src_line, ppSP,
+ = ppBesides [ppPStr SLIT("{-# LINE "), ppStr (show IBOX(src_line)), ppSP,
ppChar '"', ppPStr src_file, ppPStr SLIT("\" #-}")]
- ppr sty (SrcLoc2 src_file src_line)
- = ppr sty (SrcLoc src_file (_PK_ (show IBOX(src_line))))
+ ppr sty (UnhelpfulSrcLoc s) = ppPStr s
+
+ ppr sty NoSrcLoc = ppStr "<NoSrcLoc>"
\end{code}
getUnique, getUniques, -- basic ops
SYN_IE(UniqSM), -- type: unique supply monad
- initUs, thenUs, returnUs,
+ initUs, thenUs, returnUs, fixUs,
mapUs, mapAndUnzipUs, mapAndUnzip3Us,
thenMaybeUs, mapAccumLUs,
@thenUs@ is where we split the @UniqSupply@.
\begin{code}
+fixUs :: (a -> UniqSM a) -> UniqSM a
+fixUs m us
+ = r where r = m r us
+
thenUs :: UniqSM a -> (a -> UniqSM b) -> UniqSM b
thenUs expr cont us
foreignObjTyConKey,
forkIdKey,
fractionalClassKey,
+ fromEnumClassOpKey,
fromIntClassOpKey,
fromIntegerClassOpKey,
fromRationalClassOpKey,
, parAtRelIdKey
, parGlobalIdKey
, parLocalIdKey
+ , unboundKey
) where
import PreludeGlaST
geClassOpKey = mkPreludeMiscIdUnique 61
zeroClassOpKey = mkPreludeMiscIdUnique 62
thenMClassOpKey = mkPreludeMiscIdUnique 63 -- (>>=)
+unboundKey = mkPreludeMiscIdUnique 64 -- Just a place holder for unbound
+ -- variables produced by the renamer
+fromEnumClassOpKey = mkPreludeMiscIdUnique 65
\end{code}
GenId{-instance NamedThing-}
)
import Maybes ( catMaybes )
-import Name ( isLocallyDefined, oddlyImportedName, Name{-instance NamedThing-} )
+import Name ( isLocallyDefined, isWiredInName, Name{-instance NamedThing-} )
#ifdef DEBUG
import PprAbsC ( pprAmode )
#endif
getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo)
getCAddrModeAndInfo id
- | not (isLocallyDefined name) || oddlyImportedName name
- {- Why the "oddlyImported"?
+ | not (isLocallyDefined name) || isWiredInName name
+ {- Why the "isWiredInName"?
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
bindNewToReg, bindArgsToRegs,
stableAmodeIdInfo, heapIdInfo, CgIdInfo
)
-import CgCompInfo ( spARelToInt, spBRelToInt )
+import Constants ( spARelToInt, spBRelToInt )
import CgUpdate ( pushUpdateFrame )
import CgHeapery ( allocDynClosure, heapCheck
, heapCheckOnly, fetchAndReschedule, yield -- HWL
getSpARelOffset, getSpBRelOffset,
getHpRelOffset
)
-import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel,
+import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel, mkFastEntryLabel,
mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel,
mkErrorStdEntryLabel, mkRednCountsLabel
)
-- If f is not top-level, then f is one of the free variables too,
-- hence "payload_ids" isn't the same as "arg_ids".
--
- vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyIdSet
+ stg_args = map StgVarArg args
+ vap_entry_rhs = StgApp (StgVarArg fun) stg_args emptyIdSet
-- Empty live vars
arg_ids_w_info = [(name,mkLFArgument) | name <- args]
payload_ids | fun_in_payload = fun : args -- Sigh; needed for mkClosureLFInfo
| otherwise = args
- vap_lf_info = mkClosureLFInfo False {-not top level-} payload_ids
- upd_flag [] vap_entry_rhs
+ vap_lf_info = mkVapLFInfo payload_ids upd_flag fun stg_args fun_in_payload
-- It's not top level, even if we're currently compiling a top-level
-- function, because any VAP *use* of this function will be for a
-- local thunk, thus
= getEntryConvention id lf_info
(map idPrimRep all_args) `thenFC` \ entry_conv ->
let
- is_concurrent = opt_ForConcurrent
-
- stg_arity = length all_args
-
-- Arg mapping for standard (slow) entry point; all args on stack
(spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
= mkVirtStkOffsets
mkIntCLit spA_stk_args, -- # passed on A stk
mkIntCLit spB_stk_args, -- B stk (rest in regs)
CString (_PK_ (map (showTypeCategory . idType) all_args)),
- CString (_PK_ (show_wrapper_name wrapper_maybe)),
- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
+ CString SLIT(""), CString SLIT("")
+
+-- Nuked for now; see comment at end of file
+-- CString (_PK_ (show_wrapper_name wrapper_maybe)),
+-- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
+
] `thenC`
-- Bind args to regs/stack as appropriate, and
CCodeBlock fast_label fast_abs_c
)
where
+ is_concurrent = opt_ForConcurrent
+ stg_arity = length all_args
lf_info = closureLFInfo closure_info
cl_descr mod_name = closureDescription mod_name id all_args body
-- Manufacture labels
id = closureId closure_info
+ fast_label = mkFastEntryLabel id stg_arity
+ stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
- fast_label = fastLabelFromCI closure_info
-
- stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
-
+{- OLD... see note at end of file
wrapper_maybe = get_ultimate_wrapper Nothing id
where
get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain"
= case (getWrapperArgTypeCategories (idType xx) (getIdStrictness xx)) of
Nothing -> ""
Just str -> str
+-}
\end{code}
For lexically scoped profiling we have to load the cost centre from
in
(use_cc, blame_cc)
\end{code}
+
+
+
+========================================================================
+OLD CODE THAT EMITTED INFORMATON FOR QUANTITATIVE ANALYSIS
+
+It's pretty wierd, so I've nuked it for now. SLPJ Nov 96
+
+\begin{pseudocode}
+getWrapperArgTypeCategories
+ :: Type -- wrapper's type
+ -> StrictnessInfo bdee -- strictness info about its args
+ -> Maybe String
+
+getWrapperArgTypeCategories _ NoStrictnessInfo = Nothing
+getWrapperArgTypeCategories _ BottomGuaranteed
+ = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing -- wrong
+getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
+
+getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
+ = Just (mkWrapperArgTypeCategories ty arg_info)
+
+mkWrapperArgTypeCategories
+ :: Type -- wrapper's type
+ -> [Demand] -- info about its arguments
+ -> String -- a string saying lots about the args
+
+mkWrapperArgTypeCategories wrapper_ty wrap_info
+ = case (splitFunTyExpandingDicts wrapper_ty) of { (arg_tys,_) ->
+ map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) }
+ where
+ -- ToDo: this needs FIXING UP (it was a hack anyway...)
+ do_one (WwPrim, _) = 'P'
+ do_one (WwEnum, _) = 'E'
+ do_one (WwStrict, arg_ty_char) = arg_ty_char
+ do_one (WwUnpack _, arg_ty_char)
+ = if arg_ty_char `elem` "CIJFDTS"
+ then toLower arg_ty_char
+ else if arg_ty_char == '+' then 't'
+ else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
+ do_one (other_wrap_info, _) = '-'
+\end{pseudocode}
+
#include "HsVersions.h"
module CgCompInfo (
- uNFOLDING_USE_THRESHOLD,
- uNFOLDING_CREATION_THRESHOLD,
- uNFOLDING_OVERRIDE_THRESHOLD,
+-- uNFOLDING_USE_THRESHOLD,
+-- uNFOLDING_CREATION_THRESHOLD,
+-- uNFOLDING_OVERRIDE_THRESHOLD,
+ iNTERFACE_UNFOLD_THRESHOLD,
uNFOLDING_CHEAP_OP_COST,
uNFOLDING_DEAR_OP_COST,
uNFOLDING_NOREP_LIT_COST,
All pretty arbitrary:
\begin{code}
-uNFOLDING_USE_THRESHOLD = ( 3 :: Int)
-uNFOLDING_CREATION_THRESHOLD = (30 :: Int)
-uNFOLDING_OVERRIDE_THRESHOLD = ( 8 :: Int)
+-- uNFOLDING_USE_THRESHOLD = ( 3 :: Int)
+-- uNFOLDING_CREATION_THRESHOLD = (30 :: Int)
+-- uNFOLDING_OVERRIDE_THRESHOLD = ( 8 :: Int)
+
+iNTERFACE_UNFOLD_THRESHOLD = (30 :: Int)
uNFOLDING_CHEAP_OP_COST = ( 1 :: Int)
uNFOLDING_DEAR_OP_COST = ( 4 :: Int)
uNFOLDING_NOREP_LIT_COST = ( 4 :: Int)
heapIdInfo, CgIdInfo
)
import CgClosure ( cgTopRhsClosure )
-import CgCompInfo ( mAX_INTLIKE, mIN_INTLIKE )
+import Constants ( mAX_INTLIKE, mIN_INTLIKE )
import CgHeapery ( allocDynClosure )
import CgRetConv ( dataReturnConvAlg, DataReturnConvention(..) )
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
= cgTopRhsClosure name top_cc NoStgBinderInfo [] body lf_info
where
body = StgCon con args emptyIdSet{-emptyLiveVarSet-}
- lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant [] body
+ lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant []
\end{code}
OK, so now we have the general case.
import CgMonad
import AbsCUtils ( mkAbsCStmts, mkAbstractCs, magicIdPrimRep )
-import CgCompInfo ( uF_UPDATEE )
+import Constants ( uF_UPDATEE )
import CgHeapery ( heapCheck, allocDynClosure )
import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg,
CtrlReturnConvention(..),
emptyIdSet,
GenId{-instance NamedThing-}
)
-import Name ( nameOf, origName )
+import Name ( getOccString )
import PrelInfo ( maybeIntLikeTyCon )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import TyCon ( tyConDataCons, mkSpecTyCon )
body_code))
entry_addr = CLbl entry_label CodePtrRep
- con_descr = _UNPK_ (nameOf (origName "con_descr" data_con))
+ con_descr = getOccString data_con
closure_code = CClosureInfoAndCode closure_info body Nothing
stdUpd con_descr
phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
- con_descr = _UNPK_ (nameOf (origName "con_descr2" data_con))
+ con_descr = getOccString data_con
con_arity = dataConNumFields data_con
IMP_Ubiq(){-uitous-}
IMPORT_DELOOPER(CgLoop2) -- here for paranoia-checking
+import Constants ( mAX_SPEC_SELECTEE_SIZE )
import StgSyn
import CgMonad
import AbsCSyn
import AbsCUtils ( mkAbsCStmts, mkAbstractCs )
-import CgBindery ( getArgAmodes, CgIdInfo )
+import CgBindery ( getArgAmodes, getCAddrModeAndInfo, CgIdInfo )
import CgCase ( cgCase, saveVolatileVarsAndRegs )
import CgClosure ( cgRhsClosure )
import CgCon ( buildDynCon, cgReturnDataCon )
mkDynamicAlgReturnCode, mkPrimReturnCode
)
import CLabel ( mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
-import ClosureInfo ( mkClosureLFInfo )
+import ClosureInfo ( mkClosureLFInfo, mkSelectorLFInfo, mkVapLFInfo, lfArity_maybe,
+ layOutDynCon )
import CostCentre ( sccAbleCostCentre, isDictCC, isSccCountCostCentre )
-import HeapOffs ( SYN_IE(VirtualSpBOffset) )
-import Id ( mkIdSet, unionIdSets, GenId{-instance Outputable-} )
+import HeapOffs ( SYN_IE(VirtualSpBOffset), intOffsetIntoGoods )
+import Id ( dataConTyCon, idPrimRep, getIdArity,
+ mkIdSet, unionIdSets, GenId{-instance Outputable-}
+ )
+import IdInfo ( ArityInfo(..) )
+import Name ( isLocallyDefined )
import PprStyle ( PprStyle(..) )
import PrimOp ( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..),
getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
)
import PrimRep ( getPrimRepSize, PrimRep(..) )
-import TyCon ( tyConDataCons )
-import Util ( panic, pprPanic, assertPanic )
+import TyCon ( tyConDataCons, maybeTyConSingleCon )
+import Maybes ( assocMaybe, maybeToBool )
+import Util ( panic, isIn, pprPanic, assertPanic )
\end{code}
This module provides the support code for @StgToAbstractC@ to deal
%********************************************************
\subsection[non-top-level-bindings]{Converting non-top-level bindings}
-@cgBinding@ is only used for let/letrec, not for unboxed bindings.
-So the kind should always be @PtrRep@.
-
We rely on the support code in @CgCon@ (to do constructors) and
in @CgClosure@ (to do closures).
zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
cgRhs name (StgRhsClosure cc bi fvs upd_flag args body)
- = cgRhsClosure name cc bi fvs args body lf_info
+ = mkRhsLFInfo fvs upd_flag args body `thenFC` \ lf_info ->
+ cgRhsClosure name cc bi fvs args body lf_info
+\end{code}
+
+mkRhsLFInfo looks for two special forms of the right-hand side:
+ a) selector thunks.
+ b) VAP thunks
+
+If neither happens, it just calls mkClosureLFInfo. You might think
+that mkClosureLFInfo should do all this, but
+ (a) it seems wrong for the latter to look at the structure
+ of an expression
+ (b) mkRhsLFInfo has to be in the monad since it looks up in
+ the environment, and it's very tiresome for mkClosureLFInfo to
+ be. Apart from anything else it would make a loop between
+ CgBindery and ClosureInfo.
+
+Selectors
+~~~~~~~~~
+We look at the body of the closure to see if it's a selector---turgid,
+but nothing deep. We are looking for a closure of {\em exactly} the
+form:
+\begin{verbatim}
+... = [the_fv] \ u [] ->
+ case the_fv of
+ con a_1 ... a_n -> a_i
+\end{verbatim}
+
+\begin{code}
+mkRhsLFInfo [the_fv] -- Just one free var
+ Updatable -- Updatable thunk
+ [] -- A thunk
+ (StgCase (StgApp (StgVarArg scrutinee) [{-no args-}] _)
+ _ _ _ -- ignore live vars and uniq...
+ (StgAlgAlts case_ty
+ [(con, params, use_mask,
+ (StgApp (StgVarArg selectee) [{-no args-}] _))]
+ StgNoDefault))
+ | the_fv == scrutinee -- Scrutinee is the only free variable
+ && maybeToBool maybe_offset -- Selectee is a component of the tuple
+ && maybeToBool offset_into_int_maybe
+ && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
+ = -- ASSERT(is_single_constructor) -- Should be true, but causes error for SpecTyCon
+ returnFC (mkSelectorLFInfo scrutinee con offset_into_int)
where
- lf_info = mkClosureLFInfo False{-not top level-} fvs upd_flag args body
+ (_, params_w_offsets) = layOutDynCon con idPrimRep params
+ maybe_offset = assocMaybe params_w_offsets selectee
+ Just the_offset = maybe_offset
+ offset_into_int_maybe = intOffsetIntoGoods the_offset
+ Just offset_into_int = offset_into_int_maybe
+ is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
+ tycon = dataConTyCon con
\end{code}
+
+Vap thunks
+~~~~~~~~~~
+Same kind of thing, looking for vector-apply thunks, of the form:
+
+ x = [...] \ .. [] -> f a1 .. an
+
+where f has arity n. We rely on the arity info inside the Id being correct.
+
+\begin{code}
+mkRhsLFInfo fvs
+ upd_flag
+ [] -- No args; a thunk
+ (StgApp (StgVarArg fun_id) args _)
+ | isLocallyDefined fun_id -- Must be defined in this module
+ = -- Get the arity of the fun_id. We could find out from the
+ -- looking in the Id, but it's more certain just to look in the code
+ -- generator's environment.
+
+----------------------------------------------
+-- Sadly, looking in the environment, as suggested above,
+-- causes a black hole (because cgRhsClosure depends on the LFInfo
+-- returned here to determine its control flow.
+-- So I wimped out and went back to looking at the arity inside the Id.
+-- That means beefing up Core2Stg to propagate it. Sigh.
+-- getCAddrModeAndInfo fun_id `thenFC` \ (_, fun_lf_info) ->
+-- let arity_maybe = lfArity_maybe fun_lf_info
+----------------------------------------------
+
+ let
+ arity_maybe = case getIdArity fun_id of
+ ArityExactly n -> Just n
+ other -> Nothing
+ in
+ returnFC (case arity_maybe of
+ Just arity
+ | arity > 0 && -- It'd better be a function!
+ arity == length args -- Saturated application
+ -> -- Ha! A VAP thunk
+ mkVapLFInfo fvs upd_flag fun_id args store_fun_in_vap
+
+ other -> mkClosureLFInfo False{-not top level-} fvs upd_flag []
+ )
+
+ where
+ -- If the function is a free variable then it must be stored
+ -- in the thunk too; if it isn't a free variable it must be
+ -- because it's constant, so it doesn't need to be stored in the thunk
+ store_fun_in_vap = fun_id `is_elem` fvs
+ is_elem = isIn "mkClosureLFInfo"
+\end{code}
+
+The default case
+~~~~~~~~~~~~~~~~
+\begin{code}
+mkRhsLFInfo fvs upd_flag args body
+ = returnFC (mkClosureLFInfo False{-not top level-} fvs upd_flag args)
+\end{code}
+
+
+%********************************************************
+%* *
+%* Let-no-escape bindings
+%* *
+%********************************************************
\begin{code}
cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
= cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot binder rhs
import AbsCUtils ( mkAbstractCs, getAmodeRep,
amodeCanSurviveGC
)
-import CgCompInfo ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
+import Constants ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
mAX_Vanilla_REG, mAX_Float_REG,
mAX_Double_REG
)
import CgMonad
import AbsCSyn
-import CgCompInfo ( sTD_UF_SIZE, sCC_STD_UF_SIZE )
+import Constants ( sTD_UF_SIZE, sCC_STD_UF_SIZE )
import CgStackery ( allocUpdateFrame )
import CmdLineOpts ( opt_SccProfilingOn )
import Util ( assertPanic )
EntryConvention(..),
- mkClosureLFInfo, mkConLFInfo,
+ mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo, mkVapLFInfo,
mkLFImported, mkLFArgument, mkLFLetNoEscape,
closureSize, closureHdrSize,
mkVirtHeapOffsets,
nodeMustPointToIt, getEntryConvention,
- blackHoleOnEntry,
+ blackHoleOnEntry, lfArity_maybe,
staticClosureRequired,
slowFunEntryCodeRequired, funInfoTableRequired,
stdVapRequired, noUpdVapRequired,
- closureId, infoTableLabelFromCI,
+ closureId, infoTableLabelFromCI, fastLabelFromCI,
closureLabelFromCI,
- entryLabelFromCI, fastLabelFromCI,
+ entryLabelFromCI,
closureLFInfo, closureSMRep, closureUpdReqd,
closureSingleEntry, closureSemiTag, closureType,
closureReturnsUnboxedType, getStandardFormThunkInfo,
import StgSyn
import CgMonad
-import CgCompInfo ( mAX_SPEC_SELECTEE_SIZE,
- mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject,
+import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject,
mAX_SPEC_ALL_PTRS, mAX_SPEC_MIXED_FIELDS,
mAX_SPEC_ALL_NONPTRS,
oTHER_TAG
)
import CmdLineOpts ( opt_SccProfilingOn, opt_ForConcurrent )
import HeapOffs ( intOff, addOff, totHdrSize, varHdrSize,
- intOffsetIntoGoods,
SYN_IE(VirtualHeapOffset)
)
-import Id ( idType, idPrimRep, getIdArity,
+import Id ( idType, getIdArity,
externallyVisibleId,
dataConTag, fIRST_TAG,
- isDataCon, isNullaryDataCon, dataConTyCon,
+ isDataCon, isNullaryDataCon, dataConTyCon, dataConArity,
isTupleCon, SYN_IE(DataCon),
GenId{-instance Eq-}
)
-import IdInfo ( arityMaybe )
-import Maybes ( assocMaybe, maybeToBool )
-import Name ( isLocallyDefined, nameOf, origName )
+import IdInfo ( ArityInfo(..) )
+import Maybes ( maybeToBool )
+import Name ( getOccString )
import PprStyle ( PprStyle(..) )
import PprType ( getTyDescription, GenType{-instance Outputable-} )
---import Pretty--ToDo:rm
+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, splitFunTyExpandingDictsAndPeeking,
+import TyCon ( TyCon{-instance NamedThing-} )
+import Type ( isPrimType, expandTy, splitForAllTy, splitFunTyExpandingDictsAndPeeking,
mkFunTys, maybeAppSpecDataTyConExpandingDicts
)
import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic )
mkLFImported :: Id -> LambdaFormInfo
mkLFImported id
- = case arityMaybe (getIdArity id) of
- Nothing -> LFImported
- Just 0 -> LFThunk True{-top-lev-} True{-no fvs-}
- True{-updatable-} NonStandardThunk
- Just n -> LFReEntrant True n True -- n > 0
+ = case getIdArity id of
+ ArityExactly 0 -> LFThunk True{-top-lev-} True{-no fvs-}
+ True{-updatable-} NonStandardThunk
+ ArityExactly n -> LFReEntrant True n True -- n > 0
+ other -> LFImported -- Not sure of exact arity
\end{code}
%************************************************************************
-> [Id] -- Free vars
-> UpdateFlag -- Update flag
-> [Id] -- Args
- -> StgExpr -- Body of closure: passed so we
- -- can look for selector thunks!
-> LambdaFormInfo
-mkClosureLFInfo top fvs upd_flag args@(_:_) body -- Non-empty args
+mkClosureLFInfo top fvs upd_flag args@(_:_) -- Non-empty args
= LFReEntrant top (length args) (null fvs)
-mkClosureLFInfo top fvs ReEntrant [] body
+mkClosureLFInfo top fvs ReEntrant []
= LFReEntrant top 0 (null fvs)
-\end{code}
-
-OK, this is where we look at the body of the closure to see if it's a
-selector---turgid, but nothing deep. We are looking for a closure of
-{\em exactly} the form:
-\begin{verbatim}
-... = [the_fv] \ u [] ->
- case the_fv of
- con a_1 ... a_n -> a_i
-\end{verbatim}
-Here we go:
-\begin{code}
-mkClosureLFInfo False -- don't bother if at top-level
- [the_fv] -- just one...
- Updatable
- [] -- no args (a thunk)
- (StgCase (StgApp (StgVarArg scrutinee) [{-no args-}] _)
- _ _ _ -- ignore live vars and uniq...
- (StgAlgAlts case_ty
- [(con, params, use_mask,
- (StgApp (StgVarArg selectee) [{-no args-}] _))]
- StgNoDefault))
- | the_fv == scrutinee -- Scrutinee is the only free variable
- && maybeToBool maybe_offset -- Selectee is a component of the tuple
- && maybeToBool offset_into_int_maybe
- && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
- =
- -- ASSERT(is_single_constructor) -- Should be true, by causes error for SpecTyCon
- LFThunk False False True (SelectorThunk scrutinee con offset_into_int)
- where
- (_, params_w_offsets) = layOutDynCon con idPrimRep params
- maybe_offset = assocMaybe params_w_offsets selectee
- Just the_offset = maybe_offset
- offset_into_int_maybe = intOffsetIntoGoods the_offset
- Just offset_into_int = offset_into_int_maybe
- is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
- tycon = dataConTyCon con
-\end{code}
-
-Same kind of thing, looking for vector-apply thunks, of the form:
- x = [...] \ .. [] -> f a1 .. an
-
-where f has arity n. We rely on the arity info inside the Id being correct.
-
-\begin{code}
-mkClosureLFInfo top_level
- fvs
- upd_flag
- [] -- No args; a thunk
- (StgApp (StgVarArg fun_id) args _)
- | not top_level -- A top-level thunk would require a static
- -- vap_info table, which we don't generate just
- -- now; so top-level thunks are never standard
- -- form.
- && isLocallyDefined fun_id -- Must be defined in this module
- && maybeToBool arity_maybe -- A known function with known arity
- && fun_arity > 0 -- It'd better be a function!
- && fun_arity == length args -- Saturated application
- = LFThunk top_level (null fvs) (isUpdatable upd_flag) (VapThunk fun_id args store_fun_in_vap)
- where
- arity_maybe = arityMaybe (getIdArity fun_id)
- Just fun_arity = arity_maybe
-
- -- If the function is a free variable then it must be stored
- -- in the thunk too; if it isn't a free variable it must be
- -- because it's constant, so it doesn't need to be stored in the thunk
- store_fun_in_vap = fun_id `is_elem` fvs
-
- is_elem = isIn "mkClosureLFInfo"
-\end{code}
-
-Finally, the general updatable-thing case:
-\begin{code}
-mkClosureLFInfo top fvs upd_flag [] body
+mkClosureLFInfo top fvs upd_flag []
= LFThunk top (null fvs) (isUpdatable upd_flag) NonStandardThunk
isUpdatable ReEntrant = False
mkConLFInfo con
= -- the isNullaryDataCon will do this: ASSERT(isDataCon con)
(if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon con)
+
+mkSelectorLFInfo scrutinee con offset
+ = LFThunk False False True (SelectorThunk scrutinee con offset)
+
+mkVapLFInfo fvs upd_flag fun_id args fun_in_vap
+ = LFThunk False (null fvs) (isUpdatable upd_flag) (VapThunk fun_id args fun_in_vap)
\end{code}
_ -> False
\end{code}
+@lfArity@ extracts the arity of a function from its LFInfo
+
+\begin{code}
+lfArity_maybe (LFReEntrant _ arity _) = Just arity
+lfArity_maybe (LFCon con _) = Just (dataConArity con)
+lfArity_maybe (LFTuple con _) = Just (dataConArity con)
+lfArity_maybe other = Nothing
+\end{code}
+
%************************************************************************
%* *
\subsection[ClosureInfo-misc-funs]{Misc functions about @ClosureInfo@, etc.}
-- ToDo: need anything like this in Type.lhs?
fun_result_ty arity id
= let
- (_, de_foralld_ty) = splitForAllTy (idType id)
- (arg_tys, res_ty) = splitFunTyExpandingDictsAndPeeking de_foralld_ty
+ (arg_tys, res_ty) = splitFunTyExpandingDictsAndPeeking (idType id)
in
- 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)])) $
+-- 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}
Label generation.
\begin{code}
-infoTableLabelFromCI :: ClosureInfo -> CLabel
+fastLabelFromCI :: ClosureInfo -> CLabel
+fastLabelFromCI (MkClosureInfo id lf_info _)
+ = case lfArity_maybe lf_info of
+ Just arity -> mkFastEntryLabel id arity
+ other -> pprPanic "fastLabelFromCI" (ppr PprDebug id)
+infoTableLabelFromCI :: ClosureInfo -> CLabel
infoTableLabelFromCI (MkClosureInfo id lf_info rep)
= case lf_info of
LFCon con _ -> mkConInfoPtr con rep
= mkVapEntryLabel fun_id is_updatable
thunkEntryLabel thunk_id _ is_updatable
= mkStdEntryLabel thunk_id
-
-fastLabelFromCI :: ClosureInfo -> CLabel
-fastLabelFromCI (MkClosureInfo id _ _) = mkFastEntryLabel id fun_arity
- where
- arity_maybe = arityMaybe (getIdArity id)
- fun_arity = case arity_maybe of
- Just x -> x
- _ -> panic "fastLabelFromCI:no arity:" --(ppr PprShowAll id)
\end{code}
\begin{code}
closureTypeDescr :: ClosureInfo -> String
closureTypeDescr (MkClosureInfo id lf _)
- = if (isDataCon id) then -- DataCon has function types
- _UNPK_ (nameOf (origName "closureTypeDescr" (dataConTyCon id))) -- We want the TyCon not the ->
+ = if (isDataCon id) then -- DataCon has function types
+ getOccString (dataConTyCon id) -- We want the TyCon not the ->
else
getTyDescription (idType id)
\end{code}
= let
doing_profiling = opt_SccProfilingOn
compiling_prelude = opt_CompilingGhcInternals
- maybe_split = if maybeToBool (opt_EnsureSplittableC)
+ maybe_split = if opt_EnsureSplittableC
then CSplitMarker
else AbsCNop
= ASSERT(null fvs) -- There should be no free variables
forkStatics (cgTopRhsClosure name cc bi args body lf_info)
where
- lf_info = mkClosureLFInfo True{-top level-} [{-no fvs-}] upd_flag args body
+ lf_info = mkClosureLFInfo True{-top level-} [{-no fvs-}] upd_flag args
\end{code}
nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv),
GenId{-instances-}
)
-import Name ( isLocallyDefined, getSrcLoc )
+import Name ( isLocallyDefined, getSrcLoc, getOccString )
import TyCon ( isBoxedTyCon, TyCon{-instance-} )
import Type ( maybeAppDataTyConExpandingDicts, eqTy )
import TysPrim ( statePrimTyCon )
type LiftM a
= IdEnv (Id, Id) -- lifted Ids are mapped to:
-- * lifted Id with the same Unique
- -- (top-level bindings must keep their
- -- unique (see TopLevId in Id.lhs))
+ -- (top-level bindings must keep their unique
-- * unlifted version with a new Unique
-> UniqSupply -- unique supply
-> a -- result
= ASSERT (isUnboxedButNotState unlifted_ty)
(lifted_id, unlifted_id)
where
- id_name = panic "CoreLift.mkLiftedId:id_name" --LATER: getOccName id
+ id_name = _PK_ (getOccString id) -- yuk!
lifted_id = updateIdType id lifted_ty
unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id)
| Prim PrimOp [GenCoreArg val_occ tyvar uvar]
-- saturated primitive operation;
+
-- comment on Cons applies here, too.
\end{code}
module CoreUnfold (
SimpleUnfolding(..), Unfolding(..), UnfoldingGuidance(..), -- types
+ UfExpr, RdrName, -- For closure (delete in 1.3)
FormSummary(..), mkFormSummary, whnfOrBottom, exprSmallEnoughToDup,
- smallEnoughToInline, couldBeSmallEnoughToInline,
+ noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate,
- mkSimpleUnfolding,
- mkMagicUnfolding,
- calcUnfoldingGuidance,
- mentionedInUnfolding
+ smallEnoughToInline, couldBeSmallEnoughToInline, certainlySmallEnoughToInline,
+ okToInline,
+
+ calcUnfoldingGuidance
) where
IMP_Ubiq()
IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
import Bag ( emptyBag, unitBag, unionBags, Bag )
-import CgCompInfo ( uNFOLDING_CHEAP_OP_COST,
+
+import CmdLineOpts ( opt_UnfoldingCreationThreshold,
+ opt_UnfoldingUseThreshold,
+ opt_UnfoldingConDiscount
+ )
+import Constants ( uNFOLDING_CHEAP_OP_COST,
uNFOLDING_DEAR_OP_COST,
uNFOLDING_NOREP_LIT_COST
)
+import BinderInfo ( BinderInfo(..), FunOrArg, DuplicationDanger, InsideSCC, isDupDanger )
import CoreSyn
+import CoreUtils ( unTagBinders )
+import HsCore ( UfExpr )
+import RdrHsSyn ( RdrName )
+import OccurAnal ( occurAnalyseGlobalExpr )
import CoreUtils ( coreExprType )
import CostCentre ( ccMentionsId )
import Id ( idType, getIdArity, isBottomingId,
SYN_IE(IdSet), GenId{-instances-} )
import PrimOp ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) )
-import IdInfo ( arityMaybe, bottomIsGuaranteed )
+import IdInfo ( ArityInfo(..), bottomIsGuaranteed )
import Literal ( isNoRepLit, isLitLitLit )
import Pretty
import TyCon ( tyConFamilySize )
import Usage ( SYN_IE(UVar) )
import Util ( isIn, panic, assertPanic )
-whatsMentionedInId = panic "whatsMentionedInId (CoreUnfold)"
-getMentionedTyConsAndClassesFromType = panic "getMentionedTyConsAndClassesFromType (CoreUnfold)"
\end{code}
%************************************************************************
\begin{code}
data Unfolding
= NoUnfolding
+
| CoreUnfolding SimpleUnfolding
+
| MagicUnfolding
- Unique -- of the Id whose magic unfolding this is
+ Unique -- Unique of the Id whose magic unfolding this is
MagicUnfoldingFun
data SimpleUnfolding
- = SimpleUnfolding FormSummary -- Tells whether the template is a WHNF or bottom
- UnfoldingGuidance -- Tells about the *size* of the template.
- TemplateOutExpr -- The template
+ = SimpleUnfolding -- An unfolding with redundant cached information
+ FormSummary -- Tells whether the template is a WHNF or bottom
+ UnfoldingGuidance -- Tells about the *size* of the template.
+ SimplifiableCoreExpr -- Template
-type TemplateOutExpr = GenCoreExpr (Id, BinderInfo) Id TyVar UVar
- -- An OutExpr with occurrence info attached. This is used as
- -- a template in GeneralForms.
+noUnfolding = NoUnfolding
-mkSimpleUnfolding form guidance template
- = SimpleUnfolding form guidance template
+mkUnfolding inline_me expr
+ = CoreUnfolding (SimpleUnfolding
+ (mkFormSummary expr)
+ (calcUnfoldingGuidance inline_me opt_UnfoldingCreationThreshold expr)
+ (occurAnalyseGlobalExpr expr))
mkMagicUnfolding :: Unique -> Unfolding
mkMagicUnfolding tag = MagicUnfolding tag (mkMagicUnfoldingFun tag)
+getUnfoldingTemplate :: Unfolding -> CoreExpr
+getUnfoldingTemplate (CoreUnfolding (SimpleUnfolding _ _ expr))
+ = unTagBinders expr
+getUnfoldingTemplate other = panic "getUnfoldingTemplate"
+
data UnfoldingGuidance
= UnfoldNever
go n (Var f) | isBottomingId f = BottomForm
go 0 (Var f) = VarForm
- go n (Var f) = case (arityMaybe (getIdArity f)) of
- Just arity | n < arity -> ValueForm
+ go n (Var f) = case getIdArity f of
+ ArityExactly a | n < a -> ValueForm
+ ArityAtLeast a | n < a -> ValueForm
other -> OtherForm
whnfOrBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
\begin{code}
calcUnfoldingGuidance
- :: Bool -- True <=> OK if _scc_s appear in expr
+ :: Bool -- True <=> there's an INLINE pragma on this thing
-> Int -- bomb out if size gets bigger than this
-> CoreExpr -- expression to look at
-> UnfoldingGuidance
-calcUnfoldingGuidance scc_s_OK bOMB_OUT_SIZE expr
+calcUnfoldingGuidance True bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so
+
+calcUnfoldingGuidance False bOMB_OUT_SIZE expr
= let
(use_binders, ty_binders, val_binders, body) = collectBinders expr
in
- case (sizeExpr scc_s_OK bOMB_OUT_SIZE val_binders body) of
+ case (sizeExpr bOMB_OUT_SIZE val_binders body) of
Nothing -> UnfoldNever
\end{code}
\begin{code}
-sizeExpr :: Bool -- True <=> _scc_s OK
- -> Int -- Bomb out if it gets bigger than this
+sizeExpr :: Int -- Bomb out if it gets bigger than this
-> [Id] -- Arguments; we're interested in which of these
-- get case'd
-> CoreExpr
[Id] -- Subset of args which are cased
)
-sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
+sizeExpr bOMB_OUT_SIZE args expr
= size_up expr
where
size_up (Var v) = sizeOne
size_up (App fun arg) = size_up fun `addSize` size_up_arg arg
size_up (Lit lit) = if isNoRepLit lit
- then sizeN uNFOLDING_NOREP_LIT_COST
- else sizeOne
+ then sizeN uNFOLDING_NOREP_LIT_COST
+ else sizeOne
- size_up (SCC _ (Con _ _)) = Nothing -- **** HACK *****
- size_up (SCC lbl body)
- = if scc_s_OK then size_up body else Nothing
+-- I don't understand this hack so I'm removing it! SLPJ Nov 96
+-- size_up (SCC _ (Con _ _)) = Nothing -- **** HACK *****
+ size_up (SCC lbl body) = size_up body -- SCCs cost nothing
size_up (Coerce _ _ body) = size_up body -- Coercions cost nothing
size_up (Con con args) = -- 1 + # of val args
number of constructors in the type being scrutinized].
\begin{code}
-smallEnoughToInline :: Int -> Int -- Constructor discount and size threshold
- -> [Bool] -- Evaluated-ness of value arguments
- -> UnfoldingGuidance
- -> Bool -- True => unfold it
-
-smallEnoughToInline con_discount size_threshold _ UnfoldAlways = True
-smallEnoughToInline con_discount size_threshold _ UnfoldNever = False
-smallEnoughToInline con_discount size_threshold arg_is_evald_s
- (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size)
- = n_vals_wanted <= length arg_is_evald_s &&
- discounted_size <= size_threshold
+smallEnoughToInline :: [Bool] -- Evaluated-ness of value arguments
+ -> UnfoldingGuidance
+ -> Bool -- True => unfold it
+smallEnoughToInline _ UnfoldAlways = True
+smallEnoughToInline _ UnfoldNever = False
+smallEnoughToInline arg_is_evald_s
+ (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size)
+ = enough_args n_vals_wanted arg_is_evald_s &&
+ discounted_size <= opt_UnfoldingUseThreshold
where
+ enough_args 0 evals = True
+ enough_args n [] = False
+ enough_args n (e:es) = enough_args (n-1) es
+ -- NB: don't take the length of arg_is_evald_s because when
+ -- called from couldBeSmallEnoughToInline it is infinite!
+
discounted_size = size - sum (zipWith arg_discount discount_vec arg_is_evald_s)
arg_discount no_of_constrs is_evald
- | is_evald = 1 + no_of_constrs * con_discount
+ | is_evald = 1 + no_of_constrs * opt_UnfoldingConDiscount
| otherwise = 1
\end{code}
Just the same as smallEnoughToInline, except that it has no actual arguments.
\begin{code}
-couldBeSmallEnoughToInline :: Int -> Int -- Constructor discount and size threshold
- -> UnfoldingGuidance
- -> Bool -- True => unfold it
-
-couldBeSmallEnoughToInline con_discount size_threshold guidance
- = smallEnoughToInline con_discount size_threshold (repeat True) guidance
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[unfoldings-for-ifaces]{Processing unfoldings for interfaces}
-%* *
-%************************************************************************
-
-Of course, the main thing we do to unfoldings-for-interfaces is {\em
-print} them. But, while we're at it, we collect info about
-``mentioned'' Ids, etc., etc.---we're going to need this stuff anyway.
-
-%************************************************************************
-%* *
-\subsubsection{Monad stuff for the unfolding-generation game}
-%* *
-%************************************************************************
-
-\begin{code}
-type UnfoldM bndr thing
- = IdSet -- in-scope Ids (passed downwards only)
- -> (bndr -> Id) -- to extract an Id from a binder (down only)
-
- -> (Bag Id, -- mentioned global vars (ditto)
- Bag TyCon, -- ditto, tycons
- Bag Class, -- ditto, classes
- Bool) -- True <=> mentions something litlit-ish
-
- -> (thing, (Bag Id, Bag TyCon, Bag Class, Bool)) -- accumulated...
-\end{code}
-
-A little stuff for in-scopery:
-\begin{code}
-no_in_scopes :: IdSet
-add1 :: IdSet -> Id -> IdSet
-add_some :: IdSet -> [Id] -> IdSet
-
-no_in_scopes = emptyUniqSet
-in_scopes `add1` x = addOneToUniqSet in_scopes x
-in_scopes `add_some` xs = in_scopes `unionUniqSets` mkUniqSet xs
-\end{code}
-
-The can-see-inside-monad functions are the usual sorts of things.
-
-\begin{code}
-thenUf :: UnfoldM bndr a -> (a -> UnfoldM bndr b) -> UnfoldM bndr b
-thenUf m k in_scopes get_id mentioneds
- = case m in_scopes get_id mentioneds of { (v, mentioneds1) ->
- k v in_scopes get_id mentioneds1 }
-
-thenUf_ :: UnfoldM bndr a -> UnfoldM bndr b -> UnfoldM bndr b
-thenUf_ m k in_scopes get_id mentioneds
- = case m in_scopes get_id mentioneds of { (_, mentioneds1) ->
- k in_scopes get_id mentioneds1 }
-
-mapUf :: (a -> UnfoldM bndr b) -> [a] -> UnfoldM bndr [b]
-mapUf f [] = returnUf []
-mapUf f (x:xs)
- = f x `thenUf` \ r ->
- mapUf f xs `thenUf` \ rs ->
- returnUf (r:rs)
-
-returnUf :: a -> UnfoldM bndr a
-returnUf v in_scopes get_id mentioneds = (v, mentioneds)
-
-addInScopesUf :: [Id] -> UnfoldM bndr a -> UnfoldM bndr a
-addInScopesUf more_in_scopes m in_scopes get_id mentioneds
- = m (in_scopes `add_some` more_in_scopes) get_id mentioneds
-
-getInScopesUf :: UnfoldM bndr IdSet
-getInScopesUf in_scopes get_id mentioneds = (in_scopes, mentioneds)
-
-extractIdsUf :: [bndr] -> UnfoldM bndr [Id]
-extractIdsUf binders in_scopes get_id mentioneds
- = (map get_id binders, mentioneds)
-
-consider_Id :: Id -> UnfoldM bndr ()
-consider_Id var in_scopes get_id (ids, tcs, clss, has_litlit)
- = let
- (ids2, tcs2, clss2) = whatsMentionedInId in_scopes var
- in
- ((), (ids `unionBags` ids2,
- tcs `unionBags` tcs2,
- clss `unionBags`clss2,
- has_litlit))
-\end{code}
-
-\begin{code}
-addToMentionedIdsUf :: Id -> UnfoldM bndr ()
-addToMentionedTyConsUf :: Bag TyCon -> UnfoldM bndr ()
-addToMentionedClassesUf :: Bag Class -> UnfoldM bndr ()
-litlit_oops :: UnfoldM bndr ()
-
-addToMentionedIdsUf add_me in_scopes get_id (ids, tcs, clss, has_litlit)
- = ((), (ids `unionBags` unitBag add_me, tcs, clss, has_litlit))
-
-addToMentionedTyConsUf add_mes in_scopes get_id (ids, tcs, clss, has_litlit)
- = ((), (ids, tcs `unionBags` add_mes, clss, has_litlit))
-
-addToMentionedClassesUf add_mes in_scopes get_id (ids, tcs, clss, has_litlit)
- = ((), (ids, tcs, clss `unionBags` add_mes, has_litlit))
-
-litlit_oops in_scopes get_id (ids, tcs, clss, _)
- = ((), (ids, tcs, clss, True))
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsubsection{Gathering up info for an interface-unfolding}
-%* *
-%************************************************************************
-
-\begin{code}
-{-
-mentionedInUnfolding
- :: (bndr -> Id) -- so we can get Ids out of binders
- -> GenCoreExpr bndr Id -- input expression
- -> (Bag Id, Bag TyCon, Bag Class,
- -- what we found mentioned in the expr
- Bool -- True <=> mentions a ``litlit''-ish thing
- -- (the guy on the other side of an interface
- -- may not be able to handle it)
- )
--}
-
-mentionedInUnfolding get_id expr
- = case (ment_expr expr no_in_scopes get_id (emptyBag, emptyBag, emptyBag, False)) of
- (_, (ids_bag, tcs_bag, clss_bag, has_litlit)) ->
- (ids_bag, tcs_bag, clss_bag, has_litlit)
-\end{code}
-
-\begin{code}
---ment_expr :: GenCoreExpr bndr Id -> UnfoldM bndr ()
-
-ment_expr (Var v) = consider_Id v
-ment_expr (Lit l) = consider_lit l
-
-ment_expr expr@(Lam _ _)
- = let
- (uvars, tyvars, args, body) = collectBinders expr
- in
- extractIdsUf args `thenUf` \ bs_ids ->
- addInScopesUf bs_ids (
- -- this considering is just to extract any mentioned types/classes
- mapUf consider_Id bs_ids `thenUf_`
- ment_expr body
- )
-
-ment_expr (App fun arg)
- = ment_expr fun `thenUf_`
- ment_arg arg
-
-ment_expr (Con c as)
- = consider_Id c `thenUf_`
- mapUf ment_arg as `thenUf_`
- returnUf ()
-
-ment_expr (Prim op as)
- = ment_op op `thenUf_`
- mapUf ment_arg as `thenUf_`
- returnUf ()
- where
- ment_op (CCallOp str is_asm may_gc arg_tys res_ty)
- = mapUf ment_ty arg_tys `thenUf_`
- ment_ty res_ty
- ment_op other_op = returnUf ()
-
-ment_expr (Case scrutinee alts)
- = ment_expr scrutinee `thenUf_`
- ment_alts alts
-
-ment_expr (Let (NonRec bind rhs) body)
- = ment_expr rhs `thenUf_`
- extractIdsUf [bind] `thenUf` \ bi@[bind_id] ->
- addInScopesUf bi (
- ment_expr body `thenUf_`
- consider_Id bind_id )
-
-ment_expr (Let (Rec pairs) body)
- = let
- binders = map fst pairs
- rhss = map snd pairs
- in
- extractIdsUf binders `thenUf` \ binder_ids ->
- addInScopesUf binder_ids (
- mapUf ment_expr rhss `thenUf_`
- mapUf consider_Id binder_ids `thenUf_`
- ment_expr body )
-
-ment_expr (SCC cc expr)
- = (case (ccMentionsId cc) of
- Just id -> consider_Id id
- Nothing -> returnUf ()
- )
- `thenUf_` ment_expr expr
-
-ment_expr (Coerce _ _ _) = panic "ment_expr:Coerce"
-
--------------
-ment_ty ty
- = let
- (tycons, clss) = getMentionedTyConsAndClassesFromType ty
- in
- addToMentionedTyConsUf tycons `thenUf_`
- addToMentionedClassesUf clss
-
--------------
+couldBeSmallEnoughToInline :: UnfoldingGuidance -> Bool
+couldBeSmallEnoughToInline guidance = smallEnoughToInline (repeat True) guidance
-ment_alts alg_alts@(AlgAlts alts deflt)
- = mapUf ment_alt alts `thenUf_`
- ment_deflt deflt
- where
- ment_alt alt@(con, params, rhs)
- = consider_Id con `thenUf_`
- extractIdsUf params `thenUf` \ param_ids ->
- addInScopesUf param_ids (
- -- "consider" them so we can chk out their types...
- mapUf consider_Id param_ids `thenUf_`
- ment_expr rhs )
-
-ment_alts (PrimAlts alts deflt)
- = mapUf ment_alt alts `thenUf_`
- ment_deflt deflt
- where
- ment_alt alt@(lit, rhs) = ment_expr rhs
-
-----------------
-ment_deflt NoDefault
- = returnUf ()
-
-ment_deflt d@(BindDefault b rhs)
- = extractIdsUf [b] `thenUf` \ bi@[b_id] ->
- addInScopesUf bi (
- consider_Id b_id `thenUf_`
- ment_expr rhs )
-
------------
-ment_arg (VarArg v) = consider_Id v
-ment_arg (LitArg l) = consider_lit l
-ment_arg (TyArg ty) = ment_ty ty
-ment_arg (UsageArg _) = returnUf ()
-
------------
-consider_lit lit
- | isLitLitLit lit = litlit_oops `thenUf_` returnUf ()
- | otherwise = returnUf ()
+certainlySmallEnoughToInline :: UnfoldingGuidance -> Bool
+certainlySmallEnoughToInline guidance = smallEnoughToInline (repeat False) guidance
\end{code}
-%************************************************************************
-%* *
-\subsubsection{Printing unfoldings in interfaces}
-%* *
-%************************************************************************
-
-Printing Core-expression unfoldings is sufficiently delicate that we
-give it its own function.
-\begin{code}
-{- OLD:
-pprCoreUnfolding
- :: CoreExpr
- -> Pretty
-
-pprCoreUnfolding expr
- = let
- (_, renamed) = instCoreExpr uniqSupply_u expr
- -- We rename every unfolding with a "steady" unique supply,
- -- so that the names won't constantly change.
- -- One place we *MUST NOT* use a splittable UniqueSupply!
- in
- ppr_uf_Expr emptyUniqSet renamed
-
-ppr_Unfolding = PprUnfolding (panic "CoreUnfold:ppr_Unfolding")
-\end{code}
+Predicates
+~~~~~~~~~~
\begin{code}
-ppr_uf_Expr in_scopes (Var v) = pprIdInUnfolding in_scopes v
-ppr_uf_Expr in_scopes (Lit l) = ppr ppr_Unfolding l
-
-ppr_uf_Expr in_scopes (Con c as)
- = ppBesides [ppPStr SLIT("_!_ "), pprIdInUnfolding no_in_scopes c, ppSP,
- ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack,
- ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack]
-ppr_uf_Expr in_scopes (Prim op as)
- = ppBesides [ppPStr SLIT("_#_ "), ppr ppr_Unfolding op, ppSP,
- ppLbrack, ppIntersperse pp'SP{-'-} (map (pprParendUniType ppr_Unfolding) ts), ppRbrack,
- ppSP, ppLbrack, ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) as), ppRbrack]
-
-ppr_uf_Expr in_scopes (Lam binder body)
- = ppCat [ppChar '\\', ppr_uf_Binder binder,
- ppPStr SLIT("->"), ppr_uf_Expr (in_scopes `add1` binder) body]
-
-ppr_uf_Expr in_scopes (CoTyLam tyvar expr)
- = ppCat [ppPStr SLIT("_/\\_"), interppSP ppr_Unfolding (tyvar:tyvars), ppStr "->",
- ppr_uf_Expr in_scopes body]
- where
- (tyvars, body) = collect_tyvars expr
-
- collect_tyvars (CoTyLam tyv e) = ( tyv:tyvs, e_after )
- where (tyvs, e_after) = collect_tyvars e
- collect_tyvars other_e = ( [], other_e )
-
-ppr_uf_Expr in_scopes expr@(App fun_expr atom)
- = let
- (fun, args) = collect_args expr []
- in
- ppCat [ppPStr SLIT("_APP_ "), ppr_uf_Expr in_scopes fun, ppLbrack,
- ppIntersperse pp'SP{-'-} (map (ppr_uf_Atom in_scopes) args), ppRbrack]
- where
- collect_args (App fun arg) args = collect_args fun (arg:args)
- collect_args fun args = (fun, args)
-
-ppr_uf_Expr in_scopes (CoTyApp expr ty)
- = ppCat [ppPStr SLIT("_TYAPP_ "), ppr_uf_Expr in_scopes expr,
- ppChar '{', pprParendUniType ppr_Unfolding ty, ppChar '}']
-
-ppr_uf_Expr in_scopes (Case scrutinee alts)
- = ppCat [ppPStr SLIT("case"), ppr_uf_Expr in_scopes scrutinee, ppStr "of {",
- pp_alts alts, ppChar '}']
- where
- pp_alts (AlgAlts alts deflt)
- = ppCat [ppPStr SLIT("_ALG_"), ppCat (map pp_alg alts), pp_deflt deflt]
- pp_alts (PrimAlts alts deflt)
- = ppCat [ppPStr SLIT("_PRIM_"), ppCat (map pp_prim alts), pp_deflt deflt]
-
- pp_alg (con, params, rhs)
- = ppBesides [pprIdInUnfolding no_in_scopes con, ppSP,
- ppIntersperse ppSP (map ppr_uf_Binder params),
- ppPStr SLIT(" -> "), ppr_uf_Expr (in_scopes `add_some` params) rhs, ppSemi]
-
- pp_prim (lit, rhs)
- = ppBesides [ppr ppr_Unfolding lit,
- ppPStr SLIT(" -> "), ppr_uf_Expr in_scopes rhs, ppSemi]
-
- pp_deflt NoDefault = ppPStr SLIT("_NO_DEFLT_")
- pp_deflt (BindDefault binder rhs)
- = ppBesides [ppr_uf_Binder binder, ppPStr SLIT(" -> "),
- ppr_uf_Expr (in_scopes `add1` binder) rhs]
-
-ppr_uf_Expr in_scopes (Let (NonRec binder rhs) body)
- = ppBesides [ppStr "let {", ppr_uf_Binder binder, ppPStr SLIT(" = "), ppr_uf_Expr in_scopes rhs,
- ppStr "} in ", ppr_uf_Expr (in_scopes `add1` binder) body]
-
-ppr_uf_Expr in_scopes (Let (Rec pairs) body)
- = ppBesides [ppStr "_LETREC_ {", ppIntersperse sep (map pp_pair pairs),
- ppStr "} in ", ppr_uf_Expr new_in_scopes body]
- where
- sep = ppBeside ppSemi ppSP
- new_in_scopes = in_scopes `add_some` map fst pairs
-
- pp_pair (b, rhs) = ppCat [ppr_uf_Binder b, ppEquals, ppr_uf_Expr new_in_scopes rhs]
-
-ppr_uf_Expr in_scopes (SCC cc body)
- = ASSERT(not (noCostCentreAttached cc))
- ASSERT(not (currentOrSubsumedCosts cc))
- ppBesides [ppStr "_scc_ { ", ppStr (showCostCentre ppr_Unfolding False{-not as string-} cc), ppStr " } ", ppr_uf_Expr in_scopes body]
-
-ppr_uf_Expr in_scopes (Coerce _ _ _) = panic "ppr_uf_Expr:Coerce"
+okToInline
+ :: FormSummary -- What the thing to be inlined is like
+ -> BinderInfo -- How the thing to be inlined occurs
+ -> Bool -- True => it's small enough to inline
+ -> Bool -- True => yes, inline it
+
+-- Always inline bottoms
+okToInline BottomForm occ_info small_enough
+ = True -- Unless one of the type args is unboxed??
+ -- This used to be checked for, but I can't
+ -- see why so I've left it out.
+
+-- A WHNF can be inlined if it occurs once, or is small
+okToInline form occ_info small_enough
+ | is_whnf_form form
+ = small_enough || one_occ
+ where
+ one_occ = case occ_info of
+ OneOcc _ _ _ n_alts _ -> n_alts <= 1
+ other -> False
+
+ is_whnf_form VarForm = True
+ is_whnf_form ValueForm = True
+ is_whnf_form other = False
+
+-- A non-WHNF can be inlined if it doesn't occur inside a lambda,
+-- and occurs exactly once or
+-- occurs once in each branch of a case and is small
+okToInline OtherForm (OneOcc _ dup_danger _ n_alts _) small_enough
+ = not (isDupDanger dup_danger) && (n_alts <= 1 || small_enough)
+
+okToInline form any_occ small_enough = False
\end{code}
-\begin{code}
-ppr_uf_Binder :: Id -> Pretty
-ppr_uf_Binder v
- = ppBesides [ppLparen, pprIdInUnfolding (unitUniqSet v) v, ppPStr SLIT(" :: "),
- ppr ppr_Unfolding (idType v), ppRparen]
-
-ppr_uf_Atom in_scopes (LitArg l) = ppr ppr_Unfolding l
-ppr_uf_Atom in_scopes (VarArg v) = pprIdInUnfolding in_scopes v
-END OLD -}
-\end{code}
, maybeErrorApp
, nonErrorRHSs
, squashableDictishCcExpr
-{-
- coreExprArity,
- isWrapperFor,
-
--} ) where
+ ) where
IMP_Ubiq()
IMPORT_DELOOPER(IdLoop) -- for pananoia-checking purposes
import CoreSyn
import CostCentre ( isDictCC, CostCentre, noCostCentre )
-import Id ( idType, mkSysLocal, getIdArity, isBottomingId,
+import Id ( idType, mkSysLocal, isBottomingId,
toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
dataConRepType,
addOneToIdEnv, growIdEnvList, lookupIdEnv,
isNullIdEnv, SYN_IE(IdEnv),
GenId{-instances-}
)
-import IdInfo ( arityMaybe )
import Literal ( literalType, isNoRepLit, Literal(..) )
import Maybes ( catMaybes, maybeToBool )
import PprCore
import Pretty ( ppAboves, ppStr )
import PrelVals ( augmentId, buildId )
import PrimOp ( primOpType, PrimOp(..) )
-import SrcLoc ( mkUnknownSrcLoc )
+import SrcLoc ( noSrcLoc )
import TyVar ( cloneTyVar,
isNullTyVarEnv, addOneToTyVarEnv, SYN_IE(TyVarEnv)
)
in
getUnique `thenUs` \ uniq ->
let
- new_var = mkSysLocal SLIT("a") uniq e_ty mkUnknownSrcLoc
+ new_var = mkSysLocal SLIT("a") uniq e_ty noSrcLoc
in
returnUs (VarArg new_var, Just (NonRec new_var other_expr))
\end{code}
argToExpr (LitArg lit) = Lit lit
\end{code}
-\begin{code}
-{-LATER:
-coreExprArity
- :: (Id -> Maybe (GenCoreExpr bndr Id))
- -> GenCoreExpr bndr Id
- -> Int
-coreExprArity f (Lam _ expr) = coreExprArity f expr + 1
-coreExprArity f (CoTyLam _ expr) = coreExprArity f expr
-coreExprArity f (App expr arg) = max (coreExprArity f expr - 1) 0
-coreExprArity f (CoTyApp expr _) = coreExprArity f expr
-coreExprArity f (Var v) = max further info
- where
- further
- = case f v of
- Nothing -> 0
- Just expr -> coreExprArity f expr
- info = case (arityMaybe (getIdArity v)) of
- Nothing -> 0
- Just arity -> arity
-coreExprArity f _ = 0
-\end{code}
-
-@isWrapperFor@: we want to see exactly:
-\begin{verbatim}
-/\ ... \ args -> case <arg> of ... -> case <arg> of ... -> wrkr <stuff>
-\end{verbatim}
-
-Probably a little too HACKY [WDP].
-
-\begin{code}
-isWrapperFor :: CoreExpr -> Id -> Bool
-
-expr `isWrapperFor` var
- = case (collectBinders expr) of { (_, _, args, body) -> -- lambdas off the front
- unravel_casing args body
- --NO, THANKS: && not (null args)
- }
- where
- var's_worker = getWorkerId (getIdStrictness var)
-
- is_elem = isIn "isWrapperFor"
-
- --------------
- unravel_casing case_ables (Case scrut alts)
- = case (collectArgs scrut) of { (fun, _, _, vargs) ->
- case fun of
- Var scrut_var -> let
- answer =
- scrut_var /= var && all (doesn't_mention var) vargs
- && scrut_var `is_elem` case_ables
- && unravel_alts case_ables alts
- in
- answer
-
- _ -> False
- }
-
- unravel_casing case_ables other_expr
- = case (collectArgs other_expr) of { (fun, _, _, vargs) ->
- case fun of
- Var wrkr -> let
- answer =
- -- DOESN'T WORK: wrkr == var's_worker
- wrkr /= var
- && isWorkerId wrkr
- && all (doesn't_mention var) vargs
- && all (only_from case_ables) vargs
- in
- answer
-
- _ -> False
- }
-
- --------------
- unravel_alts case_ables (AlgAlts [(_,params,rhs)] NoDefault)
- = unravel_casing (params ++ case_ables) rhs
- unravel_alts case_ables other = False
-
- -------------------------
- doesn't_mention var (ValArg (VarArg v)) = v /= var
- doesn't_mention var other = True
-
- -------------------------
- only_from case_ables (ValArg (VarArg v)) = v `is_elem` case_ables
- only_from case_ables other = True
--}
-\end{code}
-
All the following functions operate on binders, perform a uniform
transformation on them; ie. the function @(\ x -> (x,False))@
annotates all binders with False.
freeVars,
-- cheap and cheerful variant...
- addTopBindsFVs,
+ addTopBindsFVs, addExprFVs,
freeVarsOf, freeTyVarsOf,
SYN_IE(FVCoreExpr), SYN_IE(FVCoreBinding),
elementOfIdSet, minusIdSet, unionManyIdSets,
SYN_IE(IdSet)
)
-import IdInfo ( arityMaybe )
+import IdInfo ( ArityInfo(..) )
import PrimOp ( PrimOp(..) )
import Type ( tyVarsOfType )
import TyVar ( emptyTyVarSet, unitTyVarSet, minusTyVarSet,
where
leakiness
| isBottomingId v = lEAK_FREE_BIG -- Hack
- | otherwise = case arityMaybe (getIdArity v) of
- Nothing -> lEAK_FREE_0
- Just arity -> LeakFree arity
+ | otherwise = case getIdArity v of
+ UnknownArity -> lEAK_FREE_0
+ ArityAtLeast arity -> LeakFree arity
+ ArityExactly arity -> LeakFree arity
fvExpr id_cands tyvar_cands (Lit k)
= (FVInfo noFreeIds noFreeTyVars lEAK_FREE_0, AnnLit k)
#include "HsVersions.h"
module PprCore (
- pprCoreExpr,
+ pprCoreExpr, pprIfaceUnfolding,
pprCoreBinding,
pprBigCoreBinder,
pprTypedCoreBinder
)
import IdInfo ( ppIdInfo, StrictnessInfo(..) )
import Literal ( Literal{-instances-} )
-import Name ( isSymLexeme )
+import Name ( OccName, parenInCode )
import Outputable -- quite a few things
import PprEnv
-import PprType ( pprParendGenType, GenType{-instances-}, GenTyVar{-instance-} )
+import PprType ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} )
import PprStyle ( PprStyle(..) )
import Pretty
import PrimOp ( PrimOp{-instances-} )
pprCoreBinding :: PprStyle -> CoreBinding -> Pretty
pprGenCoreBinding
- :: (Eq tyvar, Outputable tyvar,
+ :: (Eq tyvar, Outputable tyvar,
Eq uvar, Outputable uvar,
Outputable bndr,
Outputable occ)
-> Pretty
pprGenCoreBinding sty pbdr1 pbdr2 pocc bind
- = ppr_bind (init_ppr_env sty pbdr1 pbdr2 pocc) bind
+ = ppr_bind (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) bind
-init_ppr_env sty pbdr1 pbdr2 pocc
+init_ppr_env sty tvbndr pbdr1 pbdr2 pocc
= initPprEnv sty
(Just (ppr sty)) -- literals
(Just (ppr sty)) -- data cons
(Just (ppr sty)) -- primops
(Just (\ cc -> ppStr (showCostCentre sty True cc)))
- (Just (ppr sty)) -- tyvars
+ (Just tvbndr) -- tyvar binders
+ (Just (ppr sty)) -- tyvar occs
(Just (ppr sty)) -- usage vars
(Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
(Just (pprParendGenType sty)) -- types
pprCoreExpr = pprGenCoreExpr
pprGenCoreExpr, pprParendCoreExpr
- :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
+ :: (Eq tyvar, Outputable tyvar,
+ Eq uvar, Outputable uvar,
Outputable bndr,
Outputable occ)
=> PprStyle
-> Pretty
pprGenCoreExpr sty pbdr1 pbdr2 pocc expr
- = ppr_expr (init_ppr_env sty pbdr1 pbdr2 pocc) expr
+ = ppr_expr (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) expr
pprParendCoreExpr sty pbdr1 pbdr2 pocc expr
= let
in
parenify (pprGenCoreExpr sty pbdr1 pbdr2 pocc expr)
+-- Printer for unfoldings in interfaces
+pprIfaceUnfolding :: CoreExpr -> Pretty
+pprIfaceUnfolding = ppr_expr env
+ where
+ env = init_ppr_env PprInterface (pprTyVarBndr PprInterface)
+ (pprTypedCoreBinder PprInterface)
+ (pprTypedCoreBinder PprInterface)
+ (ppr PprInterface)
+
ppr_core_arg sty pocc arg
- = ppr_arg (init_ppr_env sty pocc pocc pocc) arg
+ = ppr_arg (init_ppr_env sty (ppr sty) pocc pocc pocc) arg
ppr_core_alts sty pbdr1 pbdr2 pocc alts
- = ppr_alts (init_ppr_env sty pbdr1 pbdr2 pocc) alts
+ = ppr_alts (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) alts
ppr_core_default sty pbdr1 pbdr2 pocc deflt
- = ppr_default (init_ppr_env sty pbdr1 pbdr2 pocc) deflt
+ = ppr_default (init_ppr_env sty (ppr sty) pbdr1 pbdr2 pocc) deflt
\end{code}
%************************************************************************
4 (ppr_expr pe expr)
ppr_bind pe (Rec binds)
- = ppAboves [ ppStr "{- Rec -}",
- ppAboves (map ppr_pair binds),
- ppStr "{- end Rec -}" ]
+ = ppAboves (map ppr_pair binds)
where
ppr_pair (val_bdr, expr)
= ppHang (ppCat [pMajBndr pe val_bdr, ppEquals])
- 4 (ppr_expr pe expr)
+ 4 (ppr_expr pe expr `ppBeside` ppSemi)
\end{code}
\begin{code}
= let
(uvars, tyvars, vars, body) = collectBinders expr
in
- ppHang (ppCat [pp_vars SLIT("_/u\\_") (pUVar pe) uvars,
- pp_vars SLIT("_/\\_") (pTyVar pe) tyvars,
- pp_vars SLIT("\\") (pMinBndr pe) vars])
+ ppHang (ppCat [pp_vars SLIT("/u\\") (pUVar pe) uvars,
+ pp_vars SLIT("/\\") (pTyVarB pe) tyvars,
+ pp_vars SLIT("\\") (pMinBndr pe) vars])
4 (ppr_expr pe body)
where
pp_vars lam pp [] = ppNil
ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
in
ppSep
- [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {", ppr_alt alts],
- ppBeside (ppr_rhs alts) (ppStr "}")]
+ [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_expr pe expr), ppStr "of {", ppr_alt alts],
+ ppBeside (ppr_rhs alts) (ppStr ";}")]
| otherwise -- default "case" printing
= ppSep
- [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_parend_expr pe expr), ppStr "of {"],
+ [ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_expr pe expr), ppStr "of {"],
ppNest 2 (ppr_alts pe alts),
ppStr "}"]
-- general case (recursive case, too)
ppr_expr pe (Let bind expr)
- = ppSep [ppHang (ppStr "let {") 2 (ppr_bind pe bind),
+ = ppSep [ppHang (ppStr keyword) 2 (ppr_bind pe bind),
ppHang (ppStr "} in ") 2 (ppr_expr pe expr)]
+ where
+ keyword = case bind of
+ Rec _ -> "letrec {"
+ NonRec _ _ -> "let {"
ppr_expr pe (SCC cc expr)
= ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc],
ppr_parend_expr pe expr ]
ppr_expr pe (Coerce c ty expr)
- = ppSep [ppCat [ppPStr SLIT("_coerce_"), pp_coerce c],
- pTy pe ty, ppr_parend_expr pe expr ]
+ = ppSep [pp_coerce c, pTy pe ty, ppr_parend_expr pe expr ]
where
- pp_coerce (CoerceIn v) = ppBeside (ppStr "{-in-}") (ppr (pStyle pe) v)
- pp_coerce (CoerceOut v) = ppBeside (ppStr "{-out-}") (ppr (pStyle pe) v)
+ pp_coerce (CoerceIn v) = ppBeside (ppStr "_coerce_in_") (ppr (pStyle pe) v)
+ pp_coerce (CoerceOut v) = ppBeside (ppStr "_coerce_out_") (ppr (pStyle pe) v)
only_one_alt (AlgAlts [] (BindDefault _ _)) = True
only_one_alt (AlgAlts (_:[]) NoDefault) = True
only_one_alt (PrimAlts (_:[]) NoDefault) = True
only_one_alt _ = False
-ppr_alt_con con pp_con
- = if isSymLexeme con then ppParens pp_con else pp_con
+ppr_alt_con con pp_con = if parenInCode (getOccName con) then ppParens pp_con else pp_con
\end{code}
\begin{code}
ppInterleave ppSP (map (pMinBndr pe) params),
ppStr "->"]
)
- 4 (ppr_expr pe expr)
+ 4 (ppr_expr pe expr `ppBeside` ppSemi)
ppr_alts pe (PrimAlts alts deflt)
= ppAboves [ ppAboves (map ppr_alt alts), ppr_default pe deflt ]
where
ppr_alt (lit, expr)
= ppHang (ppCat [pLit pe lit, ppStr "->"])
- 4 (ppr_expr pe expr)
+ 4 (ppr_expr pe expr `ppBeside` ppSemi)
\end{code}
\begin{code}
ppr_default pe (BindDefault val_bdr expr)
= ppHang (ppCat [pMinBndr pe val_bdr, ppStr "->"])
- 4 (ppr_expr pe expr)
+ 4 (ppr_expr pe expr `ppBeside` ppSemi)
\end{code}
\begin{code}
pragmas =
ifnotPprForUser sty
- (ppIdInfo sty binder False{-no specs, thanks-} id nullIdEnv
- (getIdInfo binder))
+ (ppIdInfo sty False{-no specs, thanks-} (getIdInfo binder))
pprBabyCoreBinder sty binder
= ppCat [ppr sty binder, pp_strictness]
-- ppStr ("{- " ++ (showList xx "") ++ " -}")
pprTypedCoreBinder sty binder
- = ppBesides [ppLparen, ppCat [ppr sty binder,
- ppStr "::", ppr sty (idType binder)],
- ppRparen]
+ = ppBesides [ppr sty binder, ppStr "::", pprParendGenType sty (idType binder)]
\end{code}
%==============================================
\begin{code}
+dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (CoreMonoBind var core_expr)
+ = doSccAuto auto_scc [var] core_expr `thenDs` \ sccd_core_expr ->
+ returnDs [(binder_subst var, mkLam tyvars dicts sccd_core_expr)]
+
dsMonoBinds auto_scc is_rec tyvars dicts binder_subst (VarMonoBind var expr)
= dsExpr expr `thenDs` \ core_expr ->
doSccAuto auto_scc [var] core_expr `thenDs` \ sccd_core_expr ->
import DsUtils
import CoreUtils ( coreExprType )
-import Id ( dataConArgTys, mkTupleCon )
+import Id ( dataConArgTys )
import Maybes ( maybeToBool )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instances-} )
import Pretty
import PrelVals ( packStringForCId )
import PrimOp ( PrimOp(..) )
-import Type ( isPrimType, maybeAppDataTyConExpandingDicts, eqTy, maybeBoxedPrimType )
-import TysPrim ( byteArrayPrimTy, realWorldTy, realWorldStatePrimTy )
+import Type ( isPrimType, maybeAppDataTyConExpandingDicts, maybeAppTyCon,
+ eqTy, maybeBoxedPrimType )
+import TysPrim ( byteArrayPrimTy, realWorldTy, realWorldStatePrimTy,
+ byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
import TysWiredIn ( getStatePairingConInfo,
- realWorldStateTy, stateDataCon,
+ realWorldStateTy, stateDataCon, pairDataCon, unitDataCon,
stringTy
)
import Util ( pprPanic, pprError, panic )
-- oops: we can't see the data constructors!!!
= can't_see_datacons_error "argument" arg_ty
- -- Byte-arrays, both mutable and otherwise
- -- (HACKy method -- but we really don't want the TyCons wired-in...) [WDP 94/10]
+ -- Byte-arrays, both mutable and otherwise; hack warning
| is_data_type &&
length data_con_arg_tys == 2 &&
- not (isPrimType data_con_arg_ty1) &&
- isPrimType data_con_arg_ty2
+ maybeToBool maybe_arg2_tycon &&
+ (arg2_tycon == byteArrayPrimTyCon ||
+ arg2_tycon == mutableByteArrayPrimTyCon)
-- and, of course, it is an instance of CCallable
--- ( tycon == byteArrayTyCon ||
--- tycon == mutableByteArrayTyCon )
= newSysLocalsDs data_con_arg_tys `thenDs` \ vars@[ixs_var, arr_cts_var] ->
returnDs (Var arr_cts_var,
\ body -> Case arg (AlgAlts [(the_data_con,vars,body)]
data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys
(data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
+ maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2
+ Just (arg2_tycon,_) = maybe_arg2_tycon
+
can't_see_datacons_error thing ty
= pprError "ERROR: Can't see the data constructor(s) for _ccall_/_casm_ "
(ppBesides [ppStr thing, ppStr "; type: ", ppr PprForUser ty])
\begin{code}
-tuple_con_2 = mkTupleCon 2 -- out here to avoid CAF (sigh)
-covar_tuple_con_0 = Var (mkTupleCon 0) -- ditto
-
boxResult :: Type -- Type of desired result
-> DsM (Type, -- Type of the result of the ccall itself
CoreExpr -> CoreExpr) -- Wrapper for the ccall
mkConDs stateDataCon [TyArg realWorldTy, VarArg (Var prim_state_id)] `thenDs` \ new_state ->
mkConDs the_data_con (map TyArg tycon_arg_tys ++ [VarArg (Var prim_result_id)]) `thenDs` \ the_result ->
- mkConDs tuple_con_2
+ mkConDs pairDataCon
[TyArg result_ty, TyArg realWorldStateTy, VarArg the_result, VarArg new_state]
`thenDs` \ the_pair ->
let
mkConDs stateDataCon [TyArg realWorldTy, VarArg (Var prim_state_id)]
`thenDs` \ new_state ->
- mkConDs tuple_con_2
- [TyArg result_ty, TyArg realWorldStateTy, VarArg covar_tuple_con_0, VarArg new_state]
+ mkConDs pairDataCon
+ [TyArg result_ty, TyArg realWorldStateTy, VarArg (Var unitDataCon), VarArg new_state]
`thenDs` \ the_pair ->
let
import HsSyn ( failureFreePat,
HsExpr(..), OutPat(..), HsLit(..), ArithSeqInfo(..),
- Stmt(..), Match(..), Qualifier, HsBinds, PolyType,
+ Stmt(..), Match(..), Qualifier, HsBinds, HsType,
GRHSsAndBinds
)
import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds),
)
import Match ( matchWrapper )
-import CoreUnfold ( Unfolding )
import CoreUtils ( coreExprType, substCoreExpr, argToExpr,
mkCoreIfThenElse, unTagBinders )
import CostCentre ( mkUserCC )
import FieldLabel ( fieldLabelType, FieldLabel )
-import Id ( mkTupleCon, idType, nullIdEnv, addOneToIdEnv,
- getIdUnfolding, dataConArgTys, dataConFieldLabels,
+import Id ( idType, nullIdEnv, addOneToIdEnv,
+ dataConArgTys, dataConFieldLabels,
recordSelectorFieldLabel
)
import Literal ( mkMachInt, Literal(..) )
-import MagicUFs ( MagicUnfoldingFun )
import Name ( Name{--O only-} )
import PprStyle ( PprStyle(..) )
import PprType ( GenType )
maybeBoxedPrimType
)
import TysPrim ( voidTy )
-import TysWiredIn ( mkTupleTy, nilDataCon, consDataCon,
+import TysWiredIn ( mkTupleTy, tupleCon, nilDataCon, consDataCon,
charDataCon, charTy
)
import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} )
dsExpr (ExplicitTuple expr_list)
= mapDs dsExpr expr_list `thenDs` \ core_exprs ->
- mkConDs (mkTupleCon (length expr_list))
+ mkConDs (tupleCon (length expr_list))
(map (TyArg . coreExprType) core_exprs ++ map VarArg core_exprs)
-- Two cases, one for ordinary constructors and one for newtype constructors
1 -> returnDs (head core_d_and_ms) -- just a single Id
_ -> -- tuple 'em up
- mkConDs (mkTupleCon num_of_d_and_ms)
+ mkConDs (tupleCon num_of_d_and_ms)
(map (TyArg . coreExprType) core_d_and_ms ++ map VarArg core_d_and_ms)
)
where
where
num_of_d_and_ms = length dicts + length methods
dicts_and_methods = dicts ++ methods
- tuple_ty = mkTupleTy num_of_d_and_ms (map idType dicts_and_methods)
- tuple_con = mkTupleCon num_of_d_and_ms
+ tuple_ty = mkTupleTy num_of_d_and_ms (map idType dicts_and_methods)
+ tuple_con = tupleCon num_of_d_and_ms
#ifdef DEBUG
-- HsSyn constructs that just shouldn't be here:
collectTypedMonoBinders (PatMonoBind pat _ _) = collectTypedPatBinders pat
collectTypedMonoBinders (FunMonoBind f _ _ _) = [f]
collectTypedMonoBinders (VarMonoBind v _) = [v]
+collectTypedMonoBinders (CoreMonoBind v _) = [v]
collectTypedMonoBinders (AndMonoBinds bs1 bs2)
= collectTypedMonoBinders bs1 ++ collectTypedMonoBinders bs2
deListComp expr quals list `thenDs` \ core_rest ->
returnDs ( mkCoreIfThenElse core_filt core_rest list )
+-- [e | let B, qs] = let B in [e | qs]
deListComp expr (LetQual binds : quals) list
- = panic "deListComp:LetQual"
+ = dsBinds False binds `thenDs` \ core_binds ->
+ deListComp expr quals list `thenDs` \ core_rest ->
+ returnDs (mkCoLetsAny core_binds core_rest)
deListComp expr ((GeneratorQual pat list1):quals) core_list2 -- rule A' above
= dsExpr list1 `thenDs` \ core_list1 ->
import PprType ( GenType, GenTyVar )
import PprStyle ( PprStyle(..) )
import Pretty
-import SrcLoc ( unpackSrcLoc, mkUnknownSrcLoc, SrcLoc )
+import SrcLoc ( noSrcLoc, SrcLoc )
import TcHsSyn ( SYN_IE(TypecheckedPat) )
import TyVar ( nullTyVarEnv, cloneTyVar, GenTyVar{-instance Eq-} )
import Unique ( Unique{-instances-} )
-> (a, DsWarnings)
initDs init_us env mod_name action
- = action init_us mkUnknownSrcLoc module_and_group env emptyBag
+ = action init_us noSrcLoc module_and_group env emptyBag
where
module_and_group = (mod_name, grp_name)
grp_name = case opt_SccGroup of
uniqSMtoDsM u_action us loc mod_and_grp env warns
= (u_action us, warns)
-getSrcLocDs :: DsM (String, String)
+getSrcLocDs :: DsM SrcLoc
getSrcLocDs us loc mod_and_grp env warns
- = case (unpackSrcLoc loc) of { (x,y) ->
- ((_UNPK_ x, _UNPK_ y), warns) }
+ = (loc, warns)
putSrcLocDs :: SrcLoc -> DsM a -> DsM a
putSrcLocDs new_loc expr us old_loc mod_and_grp env warns
IMPORT_DELOOPER(DsLoop) ( match, matchSimply )
import HsSyn ( HsExpr(..), OutPat(..), HsLit(..),
- Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
+ Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo )
import TcHsSyn ( SYN_IE(TypecheckedPat) )
import DsHsSyn ( outPatType )
import CoreSyn
import CoreUtils ( coreExprType, mkCoreIfThenElse )
import PprStyle ( PprStyle(..) )
import PrelVals ( iRREFUT_PAT_ERROR_ID, voidId )
-import Pretty ( ppShow )
-import Id ( idType, dataConArgTys, mkTupleCon,
+import Pretty ( ppShow, ppBesides, ppStr )
+import Id ( idType, dataConArgTys,
-- pprId{-ToDo:rm-},
SYN_IE(DataCon), SYN_IE(DictVar), SYN_IE(Id), GenId )
import Literal ( Literal(..) )
-import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons )
+import TyCon ( isNewTyCon, tyConDataCons )
import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTy,
mkTheta, isUnboxedType, applyTyCon, getAppTyCon
)
import TysPrim ( voidTy )
+import TysWiredIn ( tupleTyCon, unitDataCon, tupleCon )
import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, SYN_IE(UniqSet) )
import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} )
import Usage ( SYN_IE(UVar) )
+import SrcLoc ( SrcLoc {- instance Outputable -} )
--import PprCore{-ToDo:rm-}
--import PprType--ToDo:rm
--import Pretty--ToDo:rm
-> DsM CoreExpr
mkErrorAppDs err_id ty msg
- = getSrcLocDs `thenDs` \ (file, line) ->
+ = getSrcLocDs `thenDs` \ src_loc ->
let
- full_msg = file ++ "|" ++ line ++ "|" ++msg
+ full_msg = ppShow 80 (ppBesides [ppr PprForUser src_loc, ppStr ": ", ppStr msg])
msg_lit = NoRepStr (_PK_ full_msg)
in
returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit])
tuple_var_ty
= mkForAllTys tyvars $
mkRhoTy theta $
- applyTyCon (mkTupleTyCon no_of_binders)
+ applyTyCon (tupleTyCon no_of_binders)
(map idType locals)
where
theta = mkTheta (map idType dicts)
\begin{code}
mkTupleExpr :: [Id] -> CoreExpr
-mkTupleExpr [] = Con (mkTupleCon 0) []
+mkTupleExpr [] = Con unitDataCon []
mkTupleExpr [id] = Var id
-mkTupleExpr ids = mkCon (mkTupleCon (length ids))
+mkTupleExpr ids = mkCon (tupleCon (length ids))
[{-usages-}]
(map idType ids)
[ VarArg i | i <- ids ]
expr
mkTupleSelector expr vars the_var
- = Case expr (AlgAlts [(mkTupleCon arity, vars, Var the_var)]
+ = Case expr (AlgAlts [(tupleCon arity, vars, Var the_var)]
NoDefault)
where
arity = length vars
import MatchLit ( matchLiterals )
import FieldLabel ( FieldLabel {- Eq instance -} )
-import Id ( idType, mkTupleCon, dataConFieldLabels,
+import Id ( idType, dataConFieldLabels,
dataConArgTys, recordSelectorFieldLabel,
GenId{-instance-}
)
)
import TysWiredIn ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
charTy, charDataCon, intTy, intDataCon,
- floatTy, floatDataCon, doubleTy,
+ floatTy, floatDataCon, doubleTy, tupleCon,
doubleDataCon, stringTy, addrTy,
addrDataCon, wordTy, wordDataCon
)
where
arity = length pats
tuple_ConPat
- = ConPat (mkTupleCon arity)
+ = ConPat (tupleCon arity)
(mkTupleTy arity (map outPatType pats))
pats
IMPORT_DELOOPER(DsLoop) -- break match-ish and dsExpr-ish loops
import HsSyn ( HsLit(..), OutPat(..), HsExpr(..),
- Match, HsBinds, Stmt, Qualifier, PolyType, ArithSeqInfo )
+ Match, HsBinds, Stmt, Qualifier, HsType, ArithSeqInfo )
import TcHsSyn ( SYN_IE(TypecheckedHsExpr), SYN_IE(TypecheckedHsBinds),
SYN_IE(TypecheckedPat)
)
> TyVarTemplate
> )
> import Digraph ( dfs )
-> import Id ( idType, toplevelishId, updateIdType,
+> import Id ( idType, updateIdType,
> getIdInfo, replaceIdInfo, eqId, Id
> )
> import IdInfo
> newDefId type_of_f `thenUs` \f' ->
> let
> f = replaceIdInfo f'
-> (addInfo (getIdInfo f') DoDeforest)
+> (addDeforestInfo (getIdInfo f') DoDeforest)
> in
> loop ((f,e,val_args,ty_args):ls) e1
> `thenUs` \res@(ls',bs,bls,e') ->
> import CmdLineOpts ( SwitchResult, switchIsOn )
> import CoreUnfold ( Unfolding(..) )
> import CoreUtils ( mkValLam, unTagBinders, coreExprType )
-> import Id ( applyTypeEnvToId, getIdUnfolding, isTopLevId, Id,
+> import Id ( applyTypeEnvToId, getIdUnfolding, Id,
> isInstId_maybe
> )
> import Inst -- Inst(..)
> import Pretty
> import PrimOp ( PrimOp ) -- for Eq PrimOp
> import UniqSupply
-> import SrcLoc ( mkUnknownSrcLoc )
+> import SrcLoc ( noSrcLoc )
> import Util
-----------------------------------------------------------------------------
> newDefId :: Type -> UniqSM Id
> newDefId t =
> getUnique `thenUs` \u ->
-> returnUs (mkSysLocal SLIT("def") u t mkUnknownSrcLoc)
+> returnUs (mkSysLocal SLIT("def") u t noSrcLoc)
> newTmpId :: Type -> UniqSM Id
> newTmpId t =
> getUnique `thenUs` \u ->
-> returnUs (mkSysLocal SLIT("tmp") u t mkUnknownSrcLoc)
+> returnUs (mkSysLocal SLIT("tmp") u t noSrcLoc)
-----------------------------------------------------------------------------
Check whether an Id was given a `DEFOREST' annotation by the programmer.
> deforestable :: Id -> Bool
> deforestable id =
-> case getInfo (getIdInfo id) of
+> case getDeforestInfo (getIdInfo id) of
> DoDeforest -> True
> Don'tDeforest -> False
> (vs,es) = unzip bs
> vs' = map mkDeforestable vs
> s = zip vs (map (Var . DefArgVar) vs')
-> mkDeforestable v = replaceIdInfo v (addInfo (getIdInfo v) DoDeforest)
+> mkDeforestable v = replaceIdInfo v (addDeforestInfo (getIdInfo v) DoDeforest)
> convAtom :: DefAtom -> UniqSM DefAtom
>
Match, GRHSsAndBinds )
import HsPat ( collectPatBinders, InPat )
import HsPragmas ( GenPragmas, ClassOpPragmas )
-import HsTypes ( PolyType )
+import HsTypes ( HsType )
+import CoreSyn ( SYN_IE(CoreExpr) )
--others:
import Id ( SYN_IE(DictVar), SYN_IE(Id), GenId )
-import Name ( pprNonSym )
+import Name ( pprNonSym, getOccName, OccName )
import Outputable ( interpp'SP, ifnotPprForUser,
Outputable(..){-instance * (,)-}
)
+import PprCore ( GenCoreExpr {- instance Outputable -} )
+import PprType ( GenTyVar {- instance Outputable -} )
import Pretty
+import Bag
import SrcLoc ( SrcLoc{-instances-} )
---import TyVar ( GenTyVar{-instances-} )
+import TyVar ( GenTyVar{-instances-} )
+import Unique ( Unique {- instance Eq -} )
\end{code}
%************************************************************************
| BindWith -- Bind with a type signature.
-- These appear only on typechecker input
- -- (PolyType [in Sigs] can't appear on output)
+ -- (HsType [in Sigs] can't appear on output)
(Bind tyvar uvar id pat)
[Sig id]
\begin{code}
data Sig name
= Sig name -- a bog-std type signature
- (PolyType name)
- (GenPragmas name) -- only interface ones have pragmas
+ (HsType name)
SrcLoc
| ClassOpSig name -- class-op sigs have different pragmas
- (PolyType name)
+ (HsType name)
(ClassOpPragmas name) -- only interface ones have pragmas
SrcLoc
| SpecSig name -- specialise a function or datatype ...
- (PolyType name) -- ... to these types
+ (HsType name) -- ... to these types
(Maybe name) -- ... maybe using this as the code for it
SrcLoc
| InlineSig name -- INLINE f
SrcLoc
- -- ToDo: strictly speaking, could omit based on -DOMIT_DEFORESTER
| DeforestSig name -- Deforest using this function definition
SrcLoc
\begin{code}
instance (NamedThing name, Outputable name) => Outputable (Sig name) where
- ppr sty (Sig var ty pragmas _)
+ ppr sty (Sig var ty _)
= ppHang (ppCat [pprNonSym sty var, ppPStr SLIT("::")])
- 4 (ppHang (ppr sty ty)
- 4 (ifnotPprForUser sty (ppr sty pragmas)))
+ 4 (ppr sty ty)
ppr sty (ClassOpSig var ty pragmas _)
- = ppHang (ppCat [pprNonSym sty var, ppPStr SLIT("::")])
+ = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")])
4 (ppHang (ppr sty ty)
4 (ifnotPprForUser sty (ppr sty pragmas)))
Bool -- True => infix declaration
[Match tyvar uvar id pat] -- must have at least one Match
SrcLoc
+
| VarMonoBind id -- TRANSLATION
(HsExpr tyvar uvar id pat)
+
+ | CoreMonoBind id -- TRANSLATION
+ CoreExpr -- No zonking; this is a final CoreExpr with Ids and Types!
\end{code}
\begin{code}
ppr sty (VarMonoBind name expr)
= ppHang (ppCat [pprNonSym sty name, ppEquals]) 4 (ppr sty expr)
+
+ ppr sty (CoreMonoBind name expr)
+ = ppHang (ppCat [pprNonSym sty name, ppEquals]) 4 (ppr sty expr)
\end{code}
%************************************************************************
it should return @[x, y, f, a, b]@ (remember, order important).
\begin{code}
-collectTopLevelBinders :: HsBinds tyvar uvar name (InPat name) -> [name]
-collectTopLevelBinders EmptyBinds = []
-collectTopLevelBinders (SingleBind b) = collectBinders b
-collectTopLevelBinders (BindWith b _) = collectBinders b
-collectTopLevelBinders (ThenBinds b1 b2)
- = collectTopLevelBinders b1 ++ collectTopLevelBinders b2
-
-collectBinders :: Bind tyvar uvar name (InPat name) -> [name]
-collectBinders EmptyBind = []
+collectTopBinders :: HsBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
+collectTopBinders EmptyBinds = emptyBag
+collectTopBinders (SingleBind b) = collectBinders b
+collectTopBinders (BindWith b _) = collectBinders b
+collectTopBinders (ThenBinds b1 b2)
+ = collectTopBinders b1 `unionBags` collectTopBinders b2
+
+collectBinders :: Bind tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
+collectBinders EmptyBind = emptyBag
collectBinders (NonRecBind monobinds) = collectMonoBinders monobinds
collectBinders (RecBind monobinds) = collectMonoBinders monobinds
-collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> [name]
-collectMonoBinders EmptyMonoBinds = []
-collectMonoBinders (PatMonoBind pat grhss_w_binds _) = collectPatBinders pat
-collectMonoBinders (FunMonoBind f _ matches _) = [f]
-collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders"
+collectMonoBinders :: MonoBinds tyvar uvar name (InPat name) -> Bag (name,SrcLoc)
+collectMonoBinders EmptyMonoBinds = emptyBag
+collectMonoBinders (PatMonoBind pat grhss_w_binds loc) = listToBag (map (\v->(v,loc)) (collectPatBinders pat))
+collectMonoBinders (FunMonoBind f _ matches loc) = unitBag (f,loc)
+collectMonoBinders (VarMonoBind v expr) = error "collectMonoBinders"
+collectMonoBinders (CoreMonoBind v expr) = error "collectMonoBinders"
collectMonoBinders (AndMonoBinds bs1 bs2)
- = collectMonoBinders bs1 ++ collectMonoBinders bs2
-
--- We'd like the binders -- and where they came from --
--- so we can make new ones with equally-useful origin info.
-
-collectMonoBindersAndLocs
- :: MonoBinds tyvar uvar name (InPat name) -> [(name, SrcLoc)]
-
-collectMonoBindersAndLocs EmptyMonoBinds = []
-
-collectMonoBindersAndLocs (AndMonoBinds bs1 bs2)
- = collectMonoBindersAndLocs bs1 ++ collectMonoBindersAndLocs bs2
-
-collectMonoBindersAndLocs (PatMonoBind pat grhss_w_binds locn)
- = collectPatBinders pat `zip` repeat locn
-
-collectMonoBindersAndLocs (FunMonoBind f _ matches locn) = [(f, locn)]
-
-#ifdef DEBUG
-collectMonoBindersAndLocs (VarMonoBind v expr)
- = trace "collectMonoBindersAndLocs:VarMonoBind" []
- -- ToDo: this is dubious, i.e., wrong, but harmless?
-#endif
+ = collectMonoBinders bs1 `unionBags` collectMonoBinders bs2
\end{code}
%************************************************************************
We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
-@TyVars@ as well. Currently trying the former.
+@TyVars@ as well. Currently trying the former... MEGA SIGH.
\begin{code}
#include "HsVersions.h"
module HsCore (
- UnfoldingCoreExpr(..), UnfoldingCoreAlts(..),
- UnfoldingCoreDefault(..), UnfoldingCoreBinding(..),
- UnfoldingCoreAtom(..), UfId(..), SYN_IE(UnfoldingType),
- UnfoldingPrimOp(..), UfCostCentre(..)
+ UfExpr(..), UfAlts(..), UfBinder(..), UfCoercion(..),
+ UfDefault(..), UfBinding(..),
+ UfArg(..), UfPrimOp(..)
) where
IMP_Ubiq()
-- friends:
-import HsTypes ( MonoType, PolyType )
+import HsTypes ( HsType, pprParendHsType )
import PrimOp ( PrimOp, tagOf_PrimOp )
+import Kind ( Kind {- instance Outputable -} )
+import Type ( GenType {- instance Outputable -} )
-- others:
import Literal ( Literal )
%************************************************************************
\begin{code}
-data UnfoldingCoreExpr name
- = UfVar (UfId name)
+data UfExpr name
+ = UfVar name
| UfLit Literal
- | UfCon name -- must be a "BoringUfId"...
- [UnfoldingType name]
- [UnfoldingCoreAtom name]
- | UfPrim (UnfoldingPrimOp name)
- [UnfoldingType name]
- [UnfoldingCoreAtom name]
- | UfLam (UfBinder name)
- (UnfoldingCoreExpr name)
- | UfApp (UnfoldingCoreExpr name)
- (UnfoldingCoreAtom name)
- | UfCase (UnfoldingCoreExpr name)
- (UnfoldingCoreAlts name)
- | UfLet (UnfoldingCoreBinding name)
- (UnfoldingCoreExpr name)
- | UfSCC (UfCostCentre name)
- (UnfoldingCoreExpr name)
-
-data UnfoldingPrimOp name
+ | UfCon name [UfArg name]
+ | UfPrim (UfPrimOp name) [UfArg name]
+ | UfLam (UfBinder name) (UfExpr name)
+ | UfApp (UfExpr name) (UfArg name)
+ | UfCase (UfExpr name) (UfAlts name)
+ | UfLet (UfBinding name) (UfExpr name)
+ | UfSCC CostCentre (UfExpr name)
+ | UfCoerce (UfCoercion name) (HsType name) (UfExpr name)
+
+data UfPrimOp name
= UfCCallOp FAST_STRING -- callee
Bool -- True <=> casm, rather than ccall
Bool -- True <=> might cause GC
- [UnfoldingType name] -- arg types, incl state token
+ [HsType name] -- arg types, incl state token
-- (which will be first)
- (UnfoldingType name) -- return type
- | UfOtherOp PrimOp
-
-data UnfoldingCoreAlts name
- = UfCoAlgAlts [(name, [UfBinder name], UnfoldingCoreExpr name)]
- (UnfoldingCoreDefault name)
- | UfCoPrimAlts [(Literal, UnfoldingCoreExpr name)]
- (UnfoldingCoreDefault name)
-
-data UnfoldingCoreDefault name
- = UfCoNoDefault
- | UfCoBindDefault (UfBinder name)
- (UnfoldingCoreExpr name)
-
-data UnfoldingCoreBinding name
- = UfCoNonRec (UfBinder name)
- (UnfoldingCoreExpr name)
- | UfCoRec [(UfBinder name, UnfoldingCoreExpr name)]
-
-data UnfoldingCoreAtom name
- = UfCoVarAtom (UfId name)
- | UfCoLitAtom Literal
-
-data UfCostCentre name
- = UfPreludeDictsCC
- Bool -- True <=> is dupd
- | UfAllDictsCC FAST_STRING -- module and group
- FAST_STRING
- Bool -- True <=> is dupd
- | UfUserCC FAST_STRING
- FAST_STRING FAST_STRING -- module and group
- Bool -- True <=> is dupd
- Bool -- True <=> is CAF
- | UfAutoCC (UfId name)
- FAST_STRING FAST_STRING -- module and group
- Bool Bool -- as above
- | UfDictCC (UfId name)
- FAST_STRING FAST_STRING -- module and group
- Bool Bool -- as above
-
-type UfBinder name = (name, UnfoldingType name)
-
-data UfId name
- = BoringUfId name
- | SuperDictSelUfId name name -- class and superclass
- | ClassOpUfId name name -- class and class op
- | DictFunUfId name -- class and type
- (UnfoldingType name)
- | ConstMethodUfId name name -- class, class op, and type
- (UnfoldingType name)
- | DefaultMethodUfId name name -- class and class op
- | SpecUfId (UfId name) -- its unspecialised "parent"
- [Maybe (MonoType name)]
- | WorkerUfId (UfId name) -- its non-working "parent"
- -- more to come?
-
-type UnfoldingType name = PolyType name
+ (HsType name) -- return type
+
+ | UfOtherOp name
+
+data UfCoercion name = UfIn name | UfOut name
+
+data UfAlts name
+ = UfAlgAlts [(name, [UfBinder name], UfExpr name)]
+ (UfDefault name)
+ | UfPrimAlts [(Literal, UfExpr name)]
+ (UfDefault name)
+
+data UfDefault name
+ = UfNoDefault
+ | UfBindDefault (UfBinder name)
+ (UfExpr name)
+
+data UfBinding name
+ = UfNonRec (UfBinder name)
+ (UfExpr name)
+ | UfRec [(UfBinder name, UfExpr name)]
+
+data UfBinder name
+ = UfValBinder name (HsType name)
+ | UfTyBinder name Kind
+ | UfUsageBinder name
+
+data UfArg name
+ = UfVarArg name
+ | UfLitArg Literal
+ | UfTyArg (HsType name)
+ | UfUsageArg name
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-instance Outputable name => Outputable (UnfoldingCoreExpr name) where
- ppr sty (UfVar v) = pprUfId sty v
+instance Outputable name => Outputable (UfExpr name) where
+ ppr sty (UfVar v) = ppr sty v
ppr sty (UfLit l) = ppr sty l
- ppr sty (UfCon c tys as)
- = ppCat [ppStr "(UfCon", ppr sty c, ppr sty tys, ppr sty as, ppStr ")"]
- ppr sty (UfPrim o tys as)
- = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty tys, ppr sty as, ppStr ")"]
+ ppr sty (UfCon c as)
+ = ppCat [ppStr "(UfCon", ppr sty c, ppr sty as, ppStr ")"]
+ ppr sty (UfPrim o as)
+ = ppCat [ppStr "(UfPrim", ppr sty o, ppr sty as, ppStr ")"]
- ppr sty (UfLam bs body)
- = ppCat [ppChar '\\', ppr sty bs, ppStr "->", ppr sty body]
+ ppr sty (UfLam b body)
+ = ppCat [ppChar '\\', ppr sty b, ppStr "->", ppr sty body]
- ppr sty (UfApp fun arg)
- = ppCat [ppStr "(UfApp", ppr sty fun, ppr sty arg, ppStr ")"]
+ ppr sty (UfApp fun (UfTyArg ty))
+ = ppCat [ppr sty fun, ppStr "@", pprParendHsType sty ty]
+
+ ppr sty (UfApp fun (UfLitArg lit))
+ = ppCat [ppr sty fun, ppr sty lit]
+
+ ppr sty (UfApp fun (UfVarArg var))
+ = ppCat [ppr sty fun, ppr sty var]
ppr sty (UfCase scrut alts)
= ppCat [ppStr "case", ppr sty scrut, ppStr "of {", pp_alts alts, ppStr "}"]
where
- pp_alts (UfCoAlgAlts alts deflt)
+ pp_alts (UfAlgAlts alts deflt)
= ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
where
pp_alt (c,bs,rhs) = ppCat [ppr sty c, ppr sty bs, ppStr "->", ppr sty rhs]
- pp_alts (UfCoPrimAlts alts deflt)
+ pp_alts (UfPrimAlts alts deflt)
= ppCat [ppInterleave ppSemi (map pp_alt alts), pp_deflt deflt]
where
pp_alt (l,rhs) = ppCat [ppr sty l, ppStr "->", ppr sty rhs]
- pp_deflt UfCoNoDefault = ppNil
- pp_deflt (UfCoBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs]
+ pp_deflt UfNoDefault = ppNil
+ pp_deflt (UfBindDefault b rhs) = ppCat [ppr sty b, ppStr "->", ppr sty rhs]
- ppr sty (UfLet (UfCoNonRec b rhs) body)
+ ppr sty (UfLet (UfNonRec b rhs) body)
= ppCat [ppStr "let", ppr sty b, ppEquals, ppr sty rhs, ppStr "in", ppr sty body]
- ppr sty (UfLet (UfCoRec pairs) body)
+ ppr sty (UfLet (UfRec pairs) body)
= ppCat [ppStr "letrec {", ppInterleave ppSemi (map pp_pair pairs), ppStr "} in", ppr sty body]
where
pp_pair (b,rhs) = ppCat [ppr sty b, ppEquals, ppr sty rhs]
ppr sty (UfSCC uf_cc body)
= ppCat [ppStr "_scc_ <cost-centre[ToDo]>", ppr sty body]
-instance Outputable name => Outputable (UnfoldingPrimOp name) where
+instance Outputable name => Outputable (UfPrimOp name) where
ppr sty (UfCCallOp str is_casm can_gc arg_tys result_ty)
= let
before = ppStr (if is_casm then "_casm_ ``" else "_ccall_ ")
after = if is_casm then ppStr "'' " else ppSP
in
ppBesides [before, ppPStr str, after,
- ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
+ ppLbrack, ppr sty arg_tys, ppRbrack, ppSP, ppr sty result_ty]
+
ppr sty (UfOtherOp op)
= ppr sty op
-instance Outputable name => Outputable (UnfoldingCoreAtom name) where
- ppr sty (UfCoVarAtom v) = pprUfId sty v
- ppr sty (UfCoLitAtom l) = ppr sty l
-
-pprUfId sty (BoringUfId v) = ppr sty v
-pprUfId sty (SuperDictSelUfId c sc)
- = ppBesides [ppStr "({-superdict-}", ppr sty c, ppSP, ppr sty sc, ppStr ")"]
-pprUfId sty (ClassOpUfId c op)
- = ppBesides [ppStr "({-method-}", ppr sty c, ppSP, ppr sty op, ppStr ")"]
-pprUfId sty (DictFunUfId c ty)
- = ppBesides [ppStr "({-dfun-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
-pprUfId sty (ConstMethodUfId c op ty)
- = ppBesides [ppStr "({-constm-}", ppr sty c, ppSP, ppr sty op, ppSP, ppr sty ty, ppStr ")"]
-pprUfId sty (DefaultMethodUfId c ty)
- = ppBesides [ppStr "({-defm-}", ppr sty c, ppSP, ppr sty ty, ppStr ")"]
-
-pprUfId sty (SpecUfId unspec ty_maybes)
- = ppBesides [ppStr "({-spec-} ", pprUfId sty unspec,
- ppInterleave ppSP (map pp_ty_maybe ty_maybes), ppStr ")"]
- where
- pp_ty_maybe Nothing = ppStr "_N_"
- pp_ty_maybe (Just t) = ppr sty t
-
-pprUfId sty (WorkerUfId unwrkr)
- = ppBesides [ppStr "({-wrkr-}", pprUfId sty unwrkr, ppStr ")"]
+instance Outputable name => Outputable (UfArg name) where
+ ppr sty (UfVarArg v) = ppr sty v
+ ppr sty (UfLitArg l) = ppr sty l
+ ppr sty (UfTyArg ty) = pprParendHsType sty ty
+ ppr sty (UfUsageArg name) = ppr sty name
+
+instance Outputable name => Outputable (UfBinder name) where
+ ppr sty (UfValBinder name ty) = ppCat [ppr sty name, ppStr "::", ppr sty ty]
+ ppr sty (UfTyBinder name kind) = ppCat [ppr sty name, ppStr "::", ppr sty kind]
+ ppr sty (UfUsageBinder name) = ppr sty name
\end{code}
IMP_Ubiq()
-- friends:
-IMPORT_DELOOPER(HsLoop) ( nullMonoBinds, MonoBinds, Sig )
+import HsBinds ( HsBinds, MonoBinds, Sig, nullMonoBinds )
import HsPragmas ( DataPragmas, ClassPragmas,
InstancePragmas, ClassOpPragmas
)
import HsTypes
+import IdInfo
+import SpecEnv ( SpecEnv )
+import HsCore ( UfExpr )
-- others:
-import Name ( pprSym, pprNonSym )
+import Name ( pprSym, pprNonSym, getOccName, OccName )
import Outputable ( interppSP, interpp'SP,
Outputable(..){-instance * []-}
)
import Pretty
import SrcLoc ( SrcLoc )
---import Util ( panic#{-ToDo:rm eventually-} )
+import PprStyle ( PprStyle(..) )
\end{code}
+
+%************************************************************************
+%* *
+\subsection[HsDecl]{Declarations}
+%* *
+%************************************************************************
+
+\begin{code}
+data HsDecl tyvar uvar name pat
+ = TyD (TyDecl name)
+ | ClD (ClassDecl tyvar uvar name pat)
+ | InstD (InstDecl tyvar uvar name pat)
+ | DefD (DefaultDecl name)
+ | ValD (HsBinds tyvar uvar name pat)
+ | SigD (IfaceSig name)
+\end{code}
+
+\begin{code}
+hsDeclName (TyD (TyData _ name _ _ _ _ _)) = name
+hsDeclName (TyD (TyNew _ name _ _ _ _ _)) = name
+hsDeclName (TyD (TySynonym name _ _ _)) = name
+hsDeclName (ClD (ClassDecl _ name _ _ _ _ _)) = name
+hsDeclName (SigD (IfaceSig name _ _ _)) = name
+-- Others don't make sense
+\end{code}
+
+\begin{code}
+instance (NamedThing name, Outputable name, Outputable pat,
+ Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
+ => Outputable (HsDecl tyvar uvar name pat) where
+
+ ppr sty (TyD td) = ppr sty td
+ ppr sty (ClD cd) = ppr sty cd
+ ppr sty (SigD sig) = ppr sty sig
+ ppr sty (ValD binds) = ppr sty binds
+ ppr sty (DefD def) = ppr sty def
+ ppr sty (InstD inst) = ppr sty inst
+\end{code}
+
+
%************************************************************************
%* *
\subsection[FixityDecl]{A fixity declaration}
%************************************************************************
\begin{code}
-data FixityDecl name
- = InfixL name Int
- | InfixR name Int
- | InfixN name Int
+data FixityDecl name = FixityDecl name Fixity SrcLoc
+
+instance Outputable name => Outputable (FixityDecl name) where
+ ppr sty (FixityDecl name fixity loc) = ppSep [ppr sty fixity, ppr sty name]
\end{code}
+It's convenient to keep the source location in the @Fixity@; it makes error reporting
+in the renamer easier.
+
\begin{code}
-instance (NamedThing name, Outputable name)
- => Outputable (FixityDecl name) where
- ppr sty (InfixL var prec) = print_it sty "l" prec var
- ppr sty (InfixR var prec) = print_it sty "r" prec var
- ppr sty (InfixN var prec) = print_it sty "" prec var
+data Fixity = Fixity Int FixityDirection
+data FixityDirection = InfixL | InfixR | InfixN
+ deriving(Eq)
-print_it sty suff prec var
- = ppBesides [ppStr "infix", ppStr suff, ppSP, ppInt prec, ppSP, pprSym sty var]
+instance Outputable Fixity where
+ ppr sty (Fixity prec dir) = ppBesides [ppr sty dir, ppSP, ppInt prec]
+
+instance Outputable FixityDirection where
+ ppr sty InfixL = ppStr "infixl"
+ ppr sty InfixR = ppStr "infixr"
+ ppr sty InfixN = ppStr "infix"
+
+instance Eq Fixity where -- Used to determine if two fixities conflict
+ (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
\end{code}
+
%************************************************************************
%* *
\subsection[TyDecl]{@data@, @newtype@ or @type@ (synonym) type declaration}
data TyDecl name
= TyData (Context name) -- context
name -- type constructor
- [name] -- type variables
+ [HsTyVar name] -- type variables
[ConDecl name] -- data constructors (empty if abstract)
(Maybe [name]) -- derivings; Nothing => not specified
-- (i.e., derive default); Just [] => derive
| TyNew (Context name) -- context
name -- type constructor
- [name] -- type variables
- [ConDecl name] -- data constructor (empty if abstract)
+ [HsTyVar name] -- type variables
+ (ConDecl name) -- data constructor
(Maybe [name]) -- derivings; as above
(DataPragmas name)
SrcLoc
| TySynonym name -- type constructor
- [name] -- type variables
- (MonoType name) -- synonym expansion
+ [HsTyVar name] -- type variables
+ (HsType name) -- synonym expansion
SrcLoc
\end{code}
ppr sty (TySynonym tycon tyvars mono_ty src_loc)
= ppHang (pp_decl_head sty SLIT("type") ppNil tycon tyvars)
- 4 (ppCat [ppEquals, ppr sty mono_ty])
+ 4 (ppr sty mono_ty)
ppr sty (TyData context tycon tyvars condecls derivings pragmas src_loc)
= pp_tydecl sty
- (pp_decl_head sty SLIT("data") (pprContext sty context) tycon tyvars)
+ (pp_decl_head sty SLIT("data") (pp_context_and_arrow sty context) tycon tyvars)
(pp_condecls sty condecls)
derivings
ppr sty (TyNew context tycon tyvars condecl derivings pragmas src_loc)
= pp_tydecl sty
- (pp_decl_head sty SLIT("newtype") (pprContext sty context) tycon tyvars)
- (pp_condecls sty condecl)
+ (pp_decl_head sty SLIT("newtype") (pp_context_and_arrow sty context) tycon tyvars)
+ (ppr sty condecl)
derivings
pp_decl_head sty str pp_context tycon tyvars
- = ppCat [ppPStr str, pp_context, ppr sty tycon, interppSP sty tyvars]
+ = ppCat [ppPStr str, pp_context, ppr sty (getOccName tycon),
+ interppSP sty tyvars, ppPStr SLIT("=")]
-pp_condecls sty [] = ppNil -- abstract datatype
+pp_condecls sty [] = ppNil -- Curious!
pp_condecls sty (c:cs)
- = ppSep (ppBeside (ppStr "= ") (ppr sty c)
- : map (\ x -> ppBeside (ppStr "| ") (ppr sty x)) cs)
+ = ppSep (ppr sty c : map (\ c -> ppBeside (ppStr "| ") (ppr sty c)) cs)
pp_tydecl sty pp_head pp_decl_rhs derivings
= ppHang pp_head 4 (ppSep [
pp_decl_rhs,
- case derivings of
- Nothing -> ppNil
- Just ds -> ppBeside (ppPStr SLIT("deriving "))
- (ppParens (ppInterleave ppComma (map (ppr sty) ds)))])
+ case (derivings, sty) of
+ (Nothing,_) -> ppNil
+ (_,PprInterface) -> ppNil -- No derivings in interfaces
+ (Just ds,_) -> ppCat [ppPStr SLIT("deriving"), ppParens (interpp'SP sty ds)]
+ ])
+
+pp_context_and_arrow :: Outputable name => PprStyle -> Context name -> Pretty
+pp_context_and_arrow sty [] = ppNil
+pp_context_and_arrow sty theta = ppCat [pprContext sty theta, ppPStr SLIT("=>")]
\end{code}
A type for recording what types a datatype should be specialised to.
\begin{code}
data SpecDataSig name
= SpecDataSig name -- tycon to specialise
- (MonoType name)
+ (HsType name)
SrcLoc
instance (NamedThing name, Outputable name)
SrcLoc
| NewConDecl name -- newtype con decl
- (MonoType name)
+ (HsType name)
SrcLoc
data BangType name
- = Banged (PolyType name) -- PolyType: to allow Haskell extensions
- | Unbanged (PolyType name) -- (MonoType only needed for straight Haskell)
+ = Banged (HsType name) -- HsType: to allow Haskell extensions
+ | Unbanged (HsType name) -- (MonoType only needed for straight Haskell)
\end{code}
\begin{code}
instance (NamedThing name, Outputable name) => Outputable (ConDecl name) where
ppr sty (ConDecl con tys _)
- = ppCat [pprNonSym sty con, ppInterleave ppNil (map (ppr_bang sty) tys)]
+ = ppCat [ppr sty (getOccName con), ppInterleave ppNil (map (ppr_bang sty) tys)]
+
+ -- We print ConOpDecls in prefix form in interface files
+ ppr PprInterface (ConOpDecl ty1 op ty2 _)
+ = ppCat [ppr PprInterface (getOccName op), ppr_bang PprInterface ty1, ppr_bang PprInterface ty2]
ppr sty (ConOpDecl ty1 op ty2 _)
- = ppCat [ppr_bang sty ty1, pprSym sty op, ppr_bang sty ty2]
+ = ppCat [ppr_bang sty ty1, ppr sty (getOccName op), ppr_bang sty ty2]
+
ppr sty (NewConDecl con ty _)
- = ppCat [pprNonSym sty con, pprParendMonoType sty ty]
+ = ppCat [ppr sty (getOccName con), pprParendHsType sty ty]
ppr sty (RecConDecl con fields _)
- = ppCat [pprNonSym sty con, ppChar '{',
- ppInterleave pp'SP (map pp_field fields), ppChar '}']
+ = ppCat [ppr sty (getOccName con),
+ ppCurlies (ppInterleave pp'SP (map pp_field fields))
+ ]
where
pp_field (n, ty) = ppCat [ppr sty n, ppPStr SLIT("::"), ppr_bang sty ty]
-ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendPolyType sty ty)
-ppr_bang sty (Unbanged ty) = pprParendPolyType sty ty
+ppr_bang sty (Banged ty) = ppBeside (ppChar '!') (pprParendHsType sty ty)
+ppr_bang sty (Unbanged ty) = pprParendHsType sty ty
\end{code}
%************************************************************************
data ClassDecl tyvar uvar name pat
= ClassDecl (Context name) -- context...
name -- name of the class
- name -- the class type variable
+ (HsTyVar name) -- the class type variable
[Sig name] -- methods' signatures
(MonoBinds tyvar uvar name pat) -- default methods
(ClassPragmas name)
=> Outputable (ClassDecl tyvar uvar name pat) where
ppr sty (ClassDecl context clas tyvar sigs methods pragmas src_loc)
- = let
- top_matter = ppCat [ppStr "class", pprContext sty context,
- ppr sty clas, ppr sty tyvar]
- in
- if null sigs && nullMonoBinds methods then
- ppAbove top_matter (ppNest 4 (ppr sty pragmas))
- else
- ppAboves [ppCat [top_matter, ppStr "where"],
- ppNest 4 (ppAboves (map (ppr sty) sigs)),
- ppNest 4 (ppr sty methods),
- ppNest 4 (ppr sty pragmas) ]
+ | null sigs -- No "where" part
+ = top_matter
+
+ | iface_style -- All on one line (for now at least)
+ = ppCat [top_matter, ppStr "where",
+ ppCurlies (ppInterleave (ppPStr SLIT("; ")) pp_sigs)]
+
+ | otherwise -- Laid out
+ = ppSep [ppCat [top_matter, ppStr "where {"],
+ ppNest 4 ((ppIntersperse ppSemi pp_sigs `ppAbove` pp_methods)
+ `ppBeside` ppStr "}")]
+ where
+ top_matter = ppCat [ppStr "class", pp_context_and_arrow sty context,
+ ppr sty (getOccName clas), ppr sty tyvar]
+ pp_sigs = map (ppr sty) sigs
+ pp_methods = ppr sty methods
+ iface_style = case sty of {PprInterface -> True; other -> False}
\end{code}
%************************************************************************
\begin{code}
data InstDecl tyvar uvar name pat
- = InstDecl name -- Class
-
- (PolyType name) -- Context => Instance-type
+ = InstDecl (HsType name) -- Context => Class Instance-type
-- Using a polytype means that the renamer conveniently
-- figures out the quantified type variables for us.
(MonoBinds tyvar uvar name pat)
- Bool -- True <=> This instance decl is from the
- -- module being compiled; False <=> It is from
- -- an imported interface.
+ [Sig name] -- User-supplied pragmatic info
- Module -- The name of the module where the instance decl
- -- originally came from
+ (Maybe name) -- Name for the dictionary function
- [Sig name] -- actually user-supplied pragmatic info
- (InstancePragmas name) -- interface-supplied pragmatic info
SrcLoc
\end{code}
Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
=> Outputable (InstDecl tyvar uvar name pat) where
- ppr sty (InstDecl clas ty binds from_here modname uprags pragmas src_loc)
- = let
- (context, inst_ty)
- = case ty of
- HsPreForAllTy c t -> (c, t)
- HsForAllTy _ c t -> (c, t)
-
- top_matter = ppCat [ppStr "instance", pprContext sty context,
- ppr sty clas, pprParendMonoType sty inst_ty]
- in
- if nullMonoBinds binds && null uprags then
- ppAbove top_matter (ppNest 4 (ppr sty pragmas))
- else
- ppAboves [ppCat [top_matter, ppStr "where"],
- if null uprags then ppNil else ppNest 4 (ppr sty uprags),
- ppNest 4 (ppr sty binds),
- ppNest 4 (ppr sty pragmas) ]
+ ppr sty (InstDecl inst_ty binds uprags dfun_name src_loc)
+ | case sty of { PprInterface -> True; other -> False} ||
+ nullMonoBinds binds && null uprags
+ = ppCat [ppStr "instance", ppr sty inst_ty]
+
+ | otherwise
+ = ppAboves [ppCat [ppStr "instance", ppr sty inst_ty, ppStr "where"],
+ ppNest 4 (ppr sty uprags),
+ ppNest 4 (ppr sty binds) ]
\end{code}
A type for recording what instances the user wants to specialise;
\begin{code}
data SpecInstSig name
= SpecInstSig name -- class
- (MonoType name) -- type to specialise to
+ (HsType name) -- type to specialise to
SrcLoc
instance (NamedThing name, Outputable name)
\begin{code}
data DefaultDecl name
- = DefaultDecl [MonoType name]
+ = DefaultDecl [HsType name]
SrcLoc
instance (NamedThing name, Outputable name)
ppr sty (DefaultDecl tys src_loc)
= ppBeside (ppPStr SLIT("default ")) (ppParens (interpp'SP sty tys))
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Signatures in interface files}
+%* *
+%************************************************************************
+
+\begin{code}
+data IfaceSig name
+ = IfaceSig name
+ (HsType name)
+ [HsIdInfo name]
+ SrcLoc
+
+instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where
+ ppr sty (IfaceSig var ty _ _)
+ = ppHang (ppCat [ppr sty (getOccName var), ppPStr SLIT("::")])
+ 4 (ppr sty ty)
+
+data HsIdInfo name
+ = HsArity ArityInfo
+ | HsStrictness (StrictnessInfo name)
+ | HsUnfold (UfExpr name)
+ | HsUpdate UpdateInfo
+ | HsDeforest DeforestInfo
+ | HsArgUsage ArgUsageInfo
+ | HsFBType FBTypeInfo
+ -- ToDo: specialisations
+\end{code}
import HsBinds ( HsBinds )
import HsLit ( HsLit )
import HsMatches ( pprMatches, pprMatch, Match )
-import HsTypes ( PolyType )
+import HsTypes ( HsType )
-- others:
import Id ( SYN_IE(DictVar), GenId, SYN_IE(Id) )
| ExprWithTySig -- signature binding
(HsExpr tyvar uvar id pat)
- (PolyType id)
+ (HsType id)
| ArithSeqIn -- arithmetic sequence
(ArithSeqInfo tyvar uvar id pat)
| ArithSeqOut
-> HsRecordBinds tyvar uvar id pat -> Pretty
pp_rbinds sty thing rbinds
- = ppHang thing 4
- (ppBesides [ppChar '{', ppInterleave ppComma (map (pp_rbind sty) rbinds), ppChar '}'])
+ = ppHang thing
+ 4 (ppCurlies (ppIntersperse pp'SP (map (pp_rbind sty) rbinds)))
where
pp_rbind PprForUser (v, _, True) = ppr PprForUser v
pp_rbind sty (v, e, _) = ppCat [ppr sty v, ppStr "=", ppr sty e]
\subsection{Imported and exported entities}
%* *
%************************************************************************
+
\begin{code}
data IE name
= IEVar name
\end{code}
\begin{code}
+ieName :: IE name -> name
+ieName (IEVar n) = n
+ieName (IEThingAbs n) = n
+ieName (IEThingWith n _) = n
+ieName (IEThingAll n) = n
+\end{code}
+
+\begin{code}
instance (NamedThing name, Outputable name) => Outputable (IE name) where
ppr sty (IEVar var) = pprNonSym sty var
ppr sty (IEThingAbs thing) = ppr sty thing
ppr sty (IEModuleContents mod)
= ppBeside (ppPStr SLIT("module ")) (ppPStr mod)
\end{code}
+
= ppParens (interpp'SP sty pats)
pprInPat sty (RecPatIn con rpats)
- = ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}']
+ = ppCat [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))]
where
pp_rpat PprForUser (v, _, True) = ppr PprForUser v
pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppStr "=", ppr sty p]
\end{code}
\begin{code}
-instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar,
- NamedThing id, Outputable id)
+instance (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar, Outputable id)
=> Outputable (OutPat tyvar uvar id) where
ppr = pprOutPat
\end{code}
\begin{code}
pprOutPat sty (WildPat ty) = ppChar '_'
-pprOutPat sty (VarPat var) = pprNonSym sty var
+pprOutPat sty (VarPat var) = ppr sty var
pprOutPat sty (LazyPat pat) = ppBesides [ppChar '~', ppr sty pat]
pprOutPat sty (AsPat name pat)
= ppBesides [ppLparen, ppr sty name, ppChar '@', ppr sty pat, ppRparen]
= ppParens (interpp'SP sty pats)
pprOutPat sty (RecPat con ty rpats)
- = ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}']
+ = ppBesides [ppr sty con, ppCurlies (ppIntersperse pp'SP (map (pp_rpat sty) rpats))]
where
pp_rpat PprForUser (v, _, True) = ppr PprForUser v
pp_rpat sty (v, p, _) = ppCat [ppr sty v, ppStr "=", ppr sty p]
IMP_Ubiq()
-- friends:
-import HsCore ( UnfoldingCoreExpr )
-import HsTypes ( MonoType )
+import HsTypes ( HsType )
-- others:
import IdInfo
import Pretty
\end{code}
+All the pragma stuff has changed. Here are some placeholders!
+
+\begin{code}
+data GenPragmas name = NoGenPragmas
+data DataPragmas name = NoDataPragmas
+data InstancePragmas name = NoInstancePragmas
+data ClassOpPragmas name = NoClassOpPragmas
+data ClassPragmas name = NoClassPragmas
+
+noClassPragmas = NoClassPragmas
+isNoClassPragmas NoClassPragmas = True
+
+noDataPragmas = NoDataPragmas
+isNoDataPragmas NoDataPragmas = True
+
+noGenPragmas = NoGenPragmas
+isNoGenPragmas NoGenPragmas = True
+
+noInstancePragmas = NoInstancePragmas
+isNoInstancePragmas NoInstancePragmas = True
+
+noClassOpPragmas = NoClassOpPragmas
+isNoClassOpPragmas NoClassOpPragmas = True
+
+instance Outputable name => Outputable (ClassPragmas name) where
+ ppr sty NoClassPragmas = ppNil
+
+instance Outputable name => Outputable (ClassOpPragmas name) where
+ ppr sty NoClassOpPragmas = ppNil
+
+instance Outputable name => Outputable (InstancePragmas name) where
+ ppr sty NoInstancePragmas = ppNil
+
+instance Outputable name => Outputable (GenPragmas name) where
+ ppr sty NoGenPragmas = ppNil
+\end{code}
+
+========================= OLD CODE SCEDULED FOR DELETION SLPJ Nov 96 ==============
+
+\begin{code}
+{- COMMENTED OUT
+
Certain pragmas expect to be pinned onto certain constructs.
Pragma types may be parameterised, just as with any other
\begin{code}
data DataPragmas name
= NoDataPragmas
- | DataPragmas [[Maybe (MonoType name)]] -- types to which specialised
+ | DataPragmas [[Maybe (HsType name)]] -- types to which specialised
noDataPragmas = NoDataPragmas
-
isNoDataPragmas NoDataPragmas = True
-isNoDataPragmas _ = False
\end{code}
These are {\em general} things you can know about any value:
DeforestInfo -- deforest info
(ImpStrictness name) -- strictness, worker-wrapper
(ImpUnfolding name) -- unfolding (maybe)
- [([Maybe (MonoType name)], -- Specialisations: types to which spec'd;
+ [([Maybe (HsType name)], -- Specialisations: types to which spec'd;
Int, -- # dicts to ignore
GenPragmas name)] -- Gen info about the spec'd version
| SpecialisedInstancePragma
(GenPragmas name) -- for its "dfun"
- [([Maybe (MonoType name)], -- specialised instance; type...
+ [([Maybe (HsType name)], -- specialised instance; type...
Int, -- #dicts to ignore
InstancePragmas name)] -- (no SpecialisedInstancePragma please!)
pp_arity (Just i) = ppBeside (ppStr "ARITY=") (ppInt i)
pp_upd Nothing = ppNil
- pp_upd (Just u) = ppInfo sty id u
+ pp_upd (Just u) = ppUpdateInfo sty u
pp_str NoImpStrictness = ppNil
pp_str (ImpStrictness is_bot demands wrkr_prags)
pp_MaB Nothing = ppStr "_N_"
pp_MaB (Just x) = ppr sty x
\end{code}
+
+
+\begin{code}
+-}
+\end{code}
-- friends:
import HsBinds
-import HsDecls
+import HsDecls ( HsDecl(..), TyDecl(..), InstDecl(..), ClassDecl(..),
+ DefaultDecl(..),
+ FixityDecl(..), Fixity(..), FixityDirection(..),
+ ConDecl(..), BangType(..),
+ IfaceSig(..), HsIdInfo, SpecDataSig(..), SpecInstSig(..),
+ hsDeclName
+ )
import HsExpr
import HsImpExp
import HsLit
import HsTypes
import HsPragmas ( ClassPragmas, ClassOpPragmas,
DataPragmas, GenPragmas, InstancePragmas )
+import HsCore
+
-- others:
import FiniteMap ( FiniteMap )
import Outputable ( ifPprShowAll, ifnotPprForUser, interpp'SP, Outputable(..) )
-- info to TyDecls/etc; so this list is
-- often empty, downstream.
[FixityDecl name]
- [TyDecl name]
- [SpecDataSig name] -- user pragmas that modify TyDecls
- [ClassDecl tyvar uvar name pat]
- [InstDecl tyvar uvar name pat]
- [SpecInstSig name] -- user pragmas that modify InstDecls
- [DefaultDecl name]
- (HsBinds tyvar uvar name pat) -- the main stuff, includes source sigs
- [Sig name] -- interface sigs
+ [HsDecl tyvar uvar name pat] -- Type, class, value, and interface signature decls
SrcLoc
\end{code}
=> Outputable (HsModule tyvar uvar name pat) where
ppr sty (HsModule name iface_version exports imports fixities
- typedecls typesigs classdecls instdecls instsigs
- defdecls binds sigs src_loc)
+ decls src_loc)
= ppAboves [
ifPprShowAll sty (ppr sty src_loc),
ifnotPprForUser sty (pp_iface_version iface_version),
],
pp_nonnull imports,
pp_nonnull fixities,
- pp_nonnull typedecls,
- pp_nonnull typesigs,
- pp_nonnull classdecls,
- pp_nonnull instdecls,
- pp_nonnull instsigs,
- pp_nonnull defdecls,
- ppr sty binds,
- pp_nonnull sigs
+ pp_nonnull decls
]
where
pp_nonnull [] = ppNil
#include "HsVersions.h"
module HsTypes (
- PolyType(..), MonoType(..),
+ HsType(..), HsTyVar(..),
SYN_IE(Context), SYN_IE(ClassAssertion)
-#ifdef COMPILING_GHC
- , pprParendPolyType
- , pprParendMonoType, pprContext
- , extractMonoTyNames, extractCtxtTyNames
- , cmpPolyType, cmpMonoType, cmpContext
-#endif
+ , mkHsForAllTy
+ , getTyVarName, replaceTyVarName
+ , pprParendHsType
+ , pprContext
+ , cmpHsType, cmpContext
) where
-#ifdef COMPILING_GHC
IMP_Ubiq()
import Outputable ( interppSP, ifnotPprForUser )
+import Kind ( Kind {- instance Outputable -} )
import Pretty
import Util ( thenCmp, cmpList, isIn, panic# )
-
-#endif {- COMPILING_GHC -}
\end{code}
This is the syntax for types as seen in type signatures.
\begin{code}
-data PolyType name
+type Context name = [ClassAssertion name]
+
+type ClassAssertion name = (name, HsType name)
+ -- The type is usually a type variable, but it
+ -- doesn't have to be when reading interface files
+
+data HsType name
= HsPreForAllTy (Context name)
- (MonoType name)
+ (HsType name)
-- The renamer turns HsPreForAllTys into HsForAllTys when they
-- occur in signatures, to make the binding of variables
-- non-COMPILING_GHC code, because you probably want to do the
-- same thing.
- | HsForAllTy [name]
+ | HsForAllTy [HsTyVar name]
(Context name)
- (MonoType name)
+ (HsType name)
-type Context name = [ClassAssertion name]
-
-type ClassAssertion name = (name, name)
-
-data MonoType name
- = MonoTyVar name -- Type variable
+ | MonoTyVar name -- Type variable
| MonoTyApp name -- Type constructor or variable
- [MonoType name]
+ [HsType name]
-- We *could* have a "MonoTyCon name" equiv to "MonoTyApp name []"
-- (for efficiency, what?) WDP 96/02/18
- | MonoFunTy (MonoType name) -- function type
- (MonoType name)
+ | MonoFunTy (HsType name) -- function type
+ (HsType name)
- | MonoListTy (MonoType name) -- list type
- | MonoTupleTy [MonoType name] -- tuple type (length gives arity)
+ | MonoListTy name -- The list TyCon name
+ (HsType name) -- Element type
+
+ | MonoTupleTy name -- The tuple TyCon name
+ [HsType name] -- Element types (length gives arity)
-#ifdef COMPILING_GHC
-- these next two are only used in unfoldings in interfaces
| MonoDictTy name -- Class
- (MonoType name)
+ (HsType name)
+
+mkHsForAllTy [] [] ty = ty
+mkHsForAllTy tvs ctxt ty = HsForAllTy tvs ctxt ty
- | MonoForAllTy [(name, Kind)]
- (MonoType name)
+data HsTyVar name
+ = UserTyVar name
+ | IfaceTyVar name Kind
-- *** NOTA BENE *** A "monotype" in a pragma can have
-- for-alls in it, (mostly to do with dictionaries). These
-- must be explicitly Kinded.
-#endif {- COMPILING_GHC -}
+getTyVarName (UserTyVar n) = n
+getTyVarName (IfaceTyVar n _) = n
+
+replaceTyVarName :: HsTyVar name1 -> name2 -> HsTyVar name2
+replaceTyVarName (UserTyVar n) n' = UserTyVar n'
+replaceTyVarName (IfaceTyVar n k) n' = IfaceTyVar n' k
\end{code}
-This is used in various places:
+
+%************************************************************************
+%* *
+\subsection{Pretty printing}
+%* *
+%************************************************************************
+
\begin{code}
-#ifdef COMPILING_GHC
-pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty
-pprContext sty [] = ppNil
-pprContext sty [(clas, ty)] = ppCat [ppr sty clas, ppr sty ty, ppStr "=>"]
+instance (Outputable name) => Outputable (HsType name) where
+ ppr = pprHsType
+
+instance (Outputable name) => Outputable (HsTyVar name) where
+ ppr sty (UserTyVar name) = ppr sty name
+ ppr sty (IfaceTyVar name kind) = ppCat [ppr sty name, ppStr "::", ppr sty kind]
+
+
+ppr_forall sty ctxt_prec [] [] ty
+ = ppr_mono_ty sty ctxt_prec ty
+ppr_forall sty ctxt_prec tvs ctxt ty
+ = ppSep [ppStr "_forall_", ppBracket (interppSP sty tvs),
+ pprContext sty ctxt, ppStr "=>",
+ pprHsType sty ty]
+
+pprContext :: (Outputable name) => PprStyle -> (Context name) -> Pretty
+pprContext sty [] = ppNil
pprContext sty context
- = ppBesides [ppLparen,
- ppInterleave ppComma (map pp_assert context),
- ppRparen, ppStr " =>"]
+ = ppCat [ppCurlies (ppIntersperse pp'SP (map ppr_assert context))]
where
- pp_assert (clas, ty)
- = ppCat [ppr sty clas, ppr sty ty]
+ ppr_assert (clas, ty) = ppCat [ppr sty clas, ppr sty ty]
\end{code}
\begin{code}
-instance (Outputable name) => Outputable (PolyType name) where
- ppr sty (HsPreForAllTy ctxt ty)
- = print_it sty ppNil ctxt ty
- ppr sty (HsForAllTy [] ctxt ty)
- = print_it sty ppNil ctxt ty
- ppr sty (HsForAllTy tvs ctxt ty)
- = print_it sty
- (ppBesides [ppStr "_forall_ ", interppSP sty tvs, ppStr " => "])
- ctxt ty
-
-print_it sty pp_forall ctxt ty
- = ppCat [ifnotPprForUser sty pp_forall, -- print foralls unless PprForUser
- pprContext sty ctxt, ppr sty ty]
-
-pprParendPolyType :: Outputable name => PprStyle -> PolyType name -> Pretty
-pprParendPolyType sty ty = ppr sty ty -- ToDo: more later
-
-instance (Outputable name) => Outputable (MonoType name) where
- ppr = pprMonoType
-
pREC_TOP = (0 :: Int)
pREC_FUN = (1 :: Int)
pREC_CON = (2 :: Int)
+maybeParen :: Bool -> Pretty -> Pretty
+maybeParen True p = ppParens p
+maybeParen False p = p
+
-- printing works more-or-less as for Types
-pprMonoType, pprParendMonoType :: (Outputable name) => PprStyle -> MonoType name -> Pretty
+pprHsType, pprParendHsType :: (Outputable name) => PprStyle -> HsType name -> Pretty
-pprMonoType sty ty = ppr_mono_ty sty pREC_TOP ty
-pprParendMonoType sty ty = ppr_mono_ty sty pREC_CON ty
+pprHsType sty ty = ppr_mono_ty sty pREC_TOP ty
+pprParendHsType sty ty = ppr_mono_ty sty pREC_CON ty
+
+ppr_mono_ty sty ctxt_prec (HsPreForAllTy ctxt ty) = ppr_forall sty ctxt_prec [] ctxt ty
+ppr_mono_ty sty ctxt_prec (HsForAllTy tvs ctxt ty) = ppr_forall sty ctxt_prec tvs ctxt ty
ppr_mono_ty sty ctxt_prec (MonoTyVar name) = ppr sty name
= let p1 = ppr_mono_ty sty pREC_FUN ty1
p2 = ppr_mono_ty sty pREC_TOP ty2
in
- if ctxt_prec < pREC_FUN then -- no parens needed
- ppSep [p1, ppBeside (ppStr "-> ") p2]
- else
- ppSep [ppBeside ppLparen p1, ppBesides [ppStr "-> ", p2, ppRparen]]
+ maybeParen (ctxt_prec >= pREC_FUN)
+ (ppSep [p1, ppBeside (ppStr "-> ") p2])
-ppr_mono_ty sty ctxt_prec (MonoTupleTy tys)
- = ppBesides [ppLparen, ppInterleave ppComma (map (ppr sty) tys), ppRparen]
+ppr_mono_ty sty ctxt_prec (MonoTupleTy _ tys)
+ = ppParens (ppInterleave ppComma (map (ppr sty) tys))
-ppr_mono_ty sty ctxt_prec (MonoListTy ty)
+ppr_mono_ty sty ctxt_prec (MonoListTy _ ty)
= ppBesides [ppLbrack, ppr_mono_ty sty pREC_TOP ty, ppRbrack]
ppr_mono_ty sty ctxt_prec (MonoTyApp tycon tys)
= let pp_tycon = ppr sty tycon in
if null tys then
pp_tycon
- else if ctxt_prec < pREC_CON then -- no parens needed
- ppCat [pp_tycon, ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys)]
- else
- ppBesides [ ppLparen, pp_tycon, ppSP,
- ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys), ppRparen ]
+ else
+ maybeParen (ctxt_prec >= pREC_CON)
+ (ppCat [pp_tycon, ppInterleave ppNil (map (ppr_mono_ty sty pREC_CON) tys)])
--- unfoldings only
ppr_mono_ty sty ctxt_prec (MonoDictTy clas ty)
- = ppBesides [ppStr "{{", ppr sty clas, ppSP, ppr_mono_ty sty ctxt_prec ty, ppStr "}}"]
-
-#endif {- COMPILING_GHC -}
+ = ppCurlies (ppCat [ppr sty clas, ppr_mono_ty sty pREC_CON ty])
+ -- Curlies are temporary
\end{code}
-\begin{code}
-#ifdef COMPILING_GHC
-
-extractCtxtTyNames :: Eq name => Context name -> [name]
-extractMonoTyNames :: Eq name => (name -> Bool) -> MonoType name -> [name]
-
-extractCtxtTyNames ctxt
- = foldr get [] ctxt
- where
- get (clas, tv) acc
- | tv `is_elem` acc = acc
- | otherwise = tv : acc
-
- is_elem = isIn "extractCtxtTyNames"
-extractMonoTyNames is_tyvar_name ty
- = get ty []
- where
- get (MonoTyApp con tys) acc = let
- rest = foldr get acc tys
- in
- if is_tyvar_name con && not (con `is_elem` rest)
- then con : rest
- else rest
- get (MonoListTy ty) acc = get ty acc
- get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc)
- get (MonoDictTy _ ty) acc = get ty acc
- get (MonoTupleTy tys) acc = foldr get acc tys
- get (MonoTyVar tv) acc
- | tv `is_elem` acc = acc
- | otherwise = tv : acc
-
- is_elem = isIn "extractMonoTyNames"
-
-#endif {- COMPILING_GHC -}
-\end{code}
+%************************************************************************
+%* *
+\subsection{Comparison}
+%* *
+%************************************************************************
We do define a specialised equality for these \tr{*Type} types; used
in checking interfaces. Most any other use is likely to be {\em
wrong}, so be careful!
-\begin{code}
-#ifdef COMPILING_GHC
-cmpPolyType :: (a -> a -> TAG_) -> PolyType a -> PolyType a -> TAG_
-cmpMonoType :: (a -> a -> TAG_) -> MonoType a -> MonoType a -> TAG_
+\begin{code}
+cmpHsTyVar :: (a -> a -> TAG_) -> HsTyVar a -> HsTyVar a -> TAG_
+cmpHsType :: (a -> a -> TAG_) -> HsType a -> HsType a -> TAG_
cmpContext :: (a -> a -> TAG_) -> Context a -> Context a -> TAG_
+cmpHsTyVar cmp (UserTyVar v1) (UserTyVar v2) = v1 `cmp` v2
+cmpHsTyVar cmp (IfaceTyVar v1 _) (IfaceTyVar v2 _) = v1 `cmp` v2
+cmpHsTyVar cmp (UserTyVar _) other = LT_
+cmpHsTyVar cmp other1 other2 = GT_
+
+
-- We assume that HsPreForAllTys have been smashed by now.
# ifdef DEBUG
-cmpPolyType _ (HsPreForAllTy _ _) _ = panic# "cmpPolyType:HsPreForAllTy:1st arg"
-cmpPolyType _ _ (HsPreForAllTy _ _) = panic# "cmpPolyType:HsPreForAllTy:2nd arg"
+cmpHsType _ (HsPreForAllTy _ _) _ = panic# "cmpHsType:HsPreForAllTy:1st arg"
+cmpHsType _ _ (HsPreForAllTy _ _) = panic# "cmpHsType:HsPreForAllTy:2nd arg"
# endif
-cmpPolyType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
- = cmpList cmp tvs1 tvs2 `thenCmp`
- cmpContext cmp c1 c2 `thenCmp`
- cmpMonoType cmp t1 t2
+cmpHsType cmp (HsForAllTy tvs1 c1 t1) (HsForAllTy tvs2 c2 t2)
+ = cmpList (cmpHsTyVar cmp) tvs1 tvs2 `thenCmp`
+ cmpContext cmp c1 c2 `thenCmp`
+ cmpHsType cmp t1 t2
------------
-cmpMonoType cmp (MonoTyVar n1) (MonoTyVar n2)
+cmpHsType cmp (MonoTyVar n1) (MonoTyVar n2)
= cmp n1 n2
-cmpMonoType cmp (MonoTupleTy tys1) (MonoTupleTy tys2)
- = cmpList (cmpMonoType cmp) tys1 tys2
-cmpMonoType cmp (MonoListTy ty1) (MonoListTy ty2)
- = cmpMonoType cmp ty1 ty2
+cmpHsType cmp (MonoTupleTy _ tys1) (MonoTupleTy _ tys2)
+ = cmpList (cmpHsType cmp) tys1 tys2
+cmpHsType cmp (MonoListTy _ ty1) (MonoListTy _ ty2)
+ = cmpHsType cmp ty1 ty2
-cmpMonoType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2)
+cmpHsType cmp (MonoTyApp tc1 tys1) (MonoTyApp tc2 tys2)
= cmp tc1 tc2 `thenCmp`
- cmpList (cmpMonoType cmp) tys1 tys2
+ cmpList (cmpHsType cmp) tys1 tys2
-cmpMonoType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
- = cmpMonoType cmp a1 a2 `thenCmp` cmpMonoType cmp b1 b2
+cmpHsType cmp (MonoFunTy a1 b1) (MonoFunTy a2 b2)
+ = cmpHsType cmp a1 a2 `thenCmp` cmpHsType cmp b1 b2
-cmpMonoType cmp (MonoDictTy c1 ty1) (MonoDictTy c2 ty2)
- = cmp c1 c2 `thenCmp` cmpMonoType cmp ty1 ty2
+cmpHsType cmp (MonoDictTy c1 ty1) (MonoDictTy c2 ty2)
+ = cmp c1 c2 `thenCmp` cmpHsType cmp ty1 ty2
-cmpMonoType cmp ty1 ty2 -- tags must be different
+cmpHsType cmp ty1 ty2 -- tags must be different
= let tag1 = tag ty1
tag2 = tag ty2
in
if tag1 _LT_ tag2 then LT_ else GT_
where
tag (MonoTyVar n1) = (ILIT(1) :: FAST_INT)
- tag (MonoTupleTy tys1) = ILIT(2)
- tag (MonoListTy ty1) = ILIT(3)
+ tag (MonoTupleTy _ tys1) = ILIT(2)
+ tag (MonoListTy _ ty1) = ILIT(3)
tag (MonoTyApp tc1 tys1) = ILIT(4)
tag (MonoFunTy a1 b1) = ILIT(5)
tag (MonoDictTy c1 ty1) = ILIT(7)
+ tag (HsForAllTy _ _ _) = ILIT(8)
+ tag (HsPreForAllTy _ _) = ILIT(9)
-------------------
cmpContext cmp a b
= cmpList cmp_ctxt a b
where
- cmp_ctxt (c1, tv1) (c2, tv2)
- = cmp c1 c2 `thenCmp` cmp tv1 tv2
-
-#endif {- COMPILING_GHC -}
+ cmp_ctxt (c1, ty1) (c2, ty2)
+ = cmp c1 c2 `thenCmp` cmpHsType cmp ty1 ty2
\end{code}
opt_AutoSccsOnExportedToplevs,
opt_AutoSccsOnIndividualCafs,
opt_CompilingGhcInternals,
- opt_UsingGhcInternals,
opt_D_dump_absC,
opt_D_dump_asm,
opt_D_dump_deforest,
opt_D_dump_stranal,
opt_D_dump_tc,
opt_D_show_passes,
+ opt_D_show_rn_trace,
opt_D_simplifier_stats,
opt_D_source_stats,
opt_D_verbose_core2core,
opt_IgnoreStrictnessPragmas,
opt_IrrefutableEverything,
opt_IrrefutableTuples,
- opt_NoImplicitPrelude,
+ opt_LiberateCaseThreshold,
opt_NumbersStrict,
opt_OmitBlackHoling,
opt_OmitDefaultInstanceMethods,
opt_ShowImportSpecs,
opt_ShowPragmaNameErrs,
opt_SigsRequired,
+ opt_SourceUnchanged,
opt_SpecialiseAll,
opt_SpecialiseImports,
opt_SpecialiseOverloaded,
opt_SpecialiseTrace,
opt_SpecialiseUnboxed,
opt_StgDoLetNoEscapes,
+
+ opt_InterfaceUnfoldThreshold,
opt_UnfoldingCreationThreshold,
- opt_UnfoldingOverrideThreshold,
+ opt_UnfoldingConDiscount,
opt_UnfoldingUseThreshold,
+
opt_Verbose,
opt_WarnNameShadowing
) where
CHK_Ubiq() -- debugging consistency check
-import CgCompInfo -- Default values for some flags
+import Constants -- Default values for some flags
import Maybes ( assocMaybe, firstJust, maybeToBool )
import Util ( startsWith, panic, panic#, assertPanic )
| MaxSimplifierIterations Int
- | SimplUnfoldingUseThreshold Int -- per-simplification variants
- | SimplUnfoldingConDiscount Int
- | SimplUnfoldingCreationThreshold Int
-
| KeepSpecPragmaIds -- We normally *toss* Ids we can do without
| KeepUnusedBindings
%************************************************************************
\begin{code}
-lookUp :: FAST_STRING -> Bool
-lookup_int :: String -> Maybe Int
-lookup_str :: String -> Maybe String
+lookUp :: FAST_STRING -> Bool
+lookup_int :: String -> Maybe Int
+lookup_def_int :: String -> Int -> Int
+lookup_str :: String -> Maybe String
lookUp sw = maybeToBool (assoc_opts sw)
Nothing -> Nothing
Just xx -> Just (read xx)
+lookup_def_int sw def = case (lookup_str sw) of
+ Nothing -> def -- Use default
+ Just xx -> read xx
+
assoc_opts = assocMaybe [ (a, True) | a <- argv ]
unpacked_opts = map _UNPK_ argv
\end{code}
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_CompilingGhcInternals = maybeToBool maybe_CompilingGhcInternals
+maybe_CompilingGhcInternals = lookup_str "-fcompiling-ghc-internals="
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_stranal = lookUp SLIT("-ddump-stranal")
opt_D_dump_tc = lookUp SLIT("-ddump-tc")
opt_D_show_passes = lookUp SLIT("-dshow-passes")
+opt_D_show_rn_trace = lookUp SLIT("-dshow-rn-trace")
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_DoCoreLinting = lookUp SLIT("-dcore-lint")
opt_DoSemiTagging = lookUp SLIT("-fsemi-tagging")
opt_DoTickyProfiling = lookUp SLIT("-fticky-ticky")
+opt_EnsureSplittableC = lookUp SLIT("-fglobalise-toplev-names")
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_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files
+opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas")
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_PprStyle_All = lookUp SLIT("-dppr-all")
opt_PprStyle_Debug = lookUp SLIT("-dppr-debug")
opt_PprStyle_User = lookUp SLIT("-dppr-user")
+opt_ProduceC = lookup_str "-C="
+opt_ProduceS = lookup_str "-S="
+opt_ProduceHi = lookup_str "-hifile=" -- the one to produce this time
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_SourceUnchanged = lookUp SLIT("-fsource-unchanged")
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_ProduceHi = lookup_str "-hifile=" -- the one to produce this time
-opt_HiMap = lookup_str "-himap=" -- file saying where to look for .hi files
-opt_EnsureSplittableC = lookup_str "-fglobalise-toplev-names="
-opt_UnfoldingUseThreshold = lookup_int "-funfolding-use-threshold"
-opt_UnfoldingCreationThreshold = lookup_int "-funfolding-creation-threshold"
-opt_UnfoldingOverrideThreshold = lookup_int "-funfolding-override-threshold"
opt_ReturnInRegsThreshold = lookup_int "-freturn-in-regs-threshold"
+opt_SccGroup = lookup_str "-G="
+opt_Verbose = lookUp SLIT("-v")
-opt_NoImplicitPrelude = lookUp SLIT("-fno-implicit-prelude")
-opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas")
+opt_InterfaceUnfoldThreshold = lookup_def_int "-funfolding-interface-threshold" iNTERFACE_UNFOLD_THRESHOLD
+opt_UnfoldingCreationThreshold = lookup_def_int "-funfolding-creation-threshold" uNFOLDING_CREATION_THRESHOLD
+opt_UnfoldingUseThreshold = lookup_def_int "-funfolding-use-threshold" uNFOLDING_USE_THRESHOLD
+opt_UnfoldingConDiscount = lookup_def_int "-funfolding-con-discount" uNFOLDING_CON_DISCOUNT_WEIGHT
+
+opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" lIBERATE_CASE_THRESHOLD
+opt_WarnNameShadowing = lookUp SLIT("-fwarn-name-shadowing")
+
+-- opt_UnfoldingUseThreshold = lookup_int "-funfolding-use-threshold"
+-- opt_UnfoldingOverrideThreshold = lookup_int "-funfolding-override-threshold"
\end{code}
\begin{code}
"-fno-let-from-strict-let" -> SIMPL_SW(SimplNoLetFromStrictLet)
o | starts_with_msi -> SIMPL_SW(MaxSimplifierIterations (read after_msi))
- | starts_with_suut -> SIMPL_SW(SimplUnfoldingUseThreshold (read after_suut))
- | starts_with_suct -> SIMPL_SW(SimplUnfoldingCreationThreshold (read after_suct))
- | starts_with_sucd -> SIMPL_SW(SimplUnfoldingConDiscount (read after_sucd))
where
- maybe_suut = startsWith "-fsimpl-uf-use-threshold" o
- maybe_suct = startsWith "-fsimpl-uf-creation-threshold" o
- maybe_sucd = startsWith "-fsimpl-uf-con-discount" o
maybe_msi = startsWith "-fmax-simplifier-iterations" o
- starts_with_suut = maybeToBool maybe_suut
- starts_with_suct = maybeToBool maybe_suct
- starts_with_sucd = maybeToBool maybe_sucd
starts_with_msi = maybeToBool maybe_msi
- (Just after_suut) = maybe_suut
- (Just after_suct) = maybe_suct
- (Just after_sucd) = maybe_sucd
(Just after_msi) = maybe_msi
_ -> -- NB: the driver is really supposed to handle bad options
tagOf_SimplSwitch EssentialUnfoldingsOnly = ILIT(19)
tagOf_SimplSwitch ShowSimplifierProgress = ILIT(20)
tagOf_SimplSwitch (MaxSimplifierIterations _) = ILIT(21)
-tagOf_SimplSwitch (SimplUnfoldingUseThreshold _) = ILIT(22)
-tagOf_SimplSwitch (SimplUnfoldingConDiscount _) = ILIT(23)
-tagOf_SimplSwitch (SimplUnfoldingCreationThreshold _) = ILIT(24)
tagOf_SimplSwitch KeepSpecPragmaIds = ILIT(25)
tagOf_SimplSwitch KeepUnusedBindings = ILIT(26)
tagOf_SimplSwitch SimplNoLetFromCase = ILIT(27)
}
where
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@(SimplUnfoldingConDiscount 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) SET_TO SwBool True -- I'm here, Mom!
Default settings for simplifier switches
\begin{code}
-defaultSimplSwitches = [SimplUnfoldingCreationThreshold uNFOLDING_CREATION_THRESHOLD,
- SimplUnfoldingUseThreshold uNFOLDING_USE_THRESHOLD,
- SimplUnfoldingConDiscount uNFOLDING_CON_DISCOUNT_WEIGHT,
- MaxSimplifierIterations 1
+defaultSimplSwitches = [MaxSimplifierIterations 1
]
\end{code}
import Bag ( bagToList )
import PprStyle ( PprStyle(..) )
import Pretty
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc{-instance-} )
+import SrcLoc ( noSrcLoc, SrcLoc{-instance-} )
\end{code}
\begin{code}
IMPORT_1_3(IO(hGetContents,stdin,stderr,hPutStr,hClose,openFile,IOMode(..)))
import HsSyn
+import RdrHsSyn ( RdrName )
import ReadPrefix ( rdModule )
import Rename ( renameModule )
+import RnMonad ( ExportEnv )
+
import MkIface -- several functions
import TcModule ( typecheckModule )
import Desugar ( deSugar, DsMatchContext, pprDsWarnings )
import SimplCore ( core2core )
import CoreToStg ( topCoreBindsToStg )
+import StgSyn ( collectFinalStgBinders )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
#if ! OMIT_NATIVE_CODEGEN
import CmdLineOpts
import ErrUtils ( pprBagOfErrors, ghcExit )
import Maybes ( maybeToBool, MaybeErr(..) )
-import RdrHsSyn ( getRawExportees )
import Specialise ( SpecialiseData(..) )
import StgSyn ( pprPlainStgBinding, GenStgBinding )
import TcInstUtil ( InstInfo )
import Pretty
import Id ( GenId ) -- instances
-import Name ( Name, RdrName ) -- instances
+import Name ( Name ) -- instances
import PprType ( GenType, GenTyVar ) -- instances
-import RnHsSyn ( RnName ) -- instances
import TyVar ( GenTyVar ) -- instances
import Unique ( Unique ) -- instances
\end{code}
doIt :: ([CoreToDo], [StgToDo]) -> String -> IO ()
doIt (core_cmds, stg_cmds) input_pgm
- = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.01, for Haskell 1.3" "" >>
+ = doDump opt_Verbose "Glasgow Haskell Compiler, version 2.02, for Haskell 1.3" "" >>
-- ******* READER
show_pass "Reader" >>
_scc_ "Renamer"
renameModule rn_uniqs rdr_module >>=
- \ (rn_mod, rn_env, import_names,
- export_stuff, usage_stuff,
- rn_errs_bag, rn_warns_bag) ->
+ \ (maybe_rn_stuff, rn_errs_bag, rn_warns_bag) ->
- if (not (isEmptyBag rn_errs_bag)) then
- hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_errs_bag))
- >> hPutStr stderr "\n" >>
- hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
- >> hPutStr stderr "\n" >>
- ghcExit 1
+ checkErrors rn_errs_bag rn_warns_bag >>
+ case maybe_rn_stuff of {
+ Nothing -> -- Hurrah! Renamer reckons that there's no need to
+ -- go any further
+ hPutStr stderr "No recompilation required!\n" >>
+ ghcExit 0 ;
+
+ -- Oh well, we've got to recompile for real
+ Just (rn_mod, iface_file_stuff, rn_name_supply, imported_modules) ->
- else -- No renaming errors ...
- (if (isEmptyBag rn_warns_bag) then
- return ()
- else
- hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle rn_warns_bag))
- >> hPutStr stderr "\n"
- ) >>
doDump opt_D_dump_rn "Renamer:"
(pp_show (ppr pprStyle rn_mod)) >>
-- (the iface file is produced incrementally, as we have
-- the information that we need...; we use "iface<blah>")
-- "endIface" finishes the job.
- let
- (usages_map, version_info, instance_modules) = usage_stuff
- in
- startIface mod_name >>= \ if_handle ->
- ifaceUsages if_handle usages_map >>
- ifaceVersions if_handle version_info >>
- ifaceExportList if_handle export_stuff rn_env >>
- ifaceFixities if_handle rn_mod >>
- ifaceInstanceModules if_handle instance_modules >>
+ startIface mod_name >>= \ if_handle ->
+ ifaceMain if_handle iface_file_stuff >>
+
-- ******* TYPECHECKER
show_pass "TypeCheck" >>
_scc_ "TypeCheck"
- case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_env rn_mod) of
+ case (case (typecheckModule tc_uniqs {-idinfo_fm-} rn_name_supply rn_mod) of
Succeeded (stuff, warns)
-> (emptyBag, warns, stuff)
Failed (errs, warns)
of { (tc_errs_bag, tc_warns_bag, tc_results) ->
- if (not (isEmptyBag tc_errs_bag)) then
- hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_errs_bag))
- >> hPutStr stderr "\n" >>
- hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag))
- >> hPutStr stderr "\n" >>
- ghcExit 1
-
- else ( -- No typechecking errors ...
-
- (if (isEmptyBag tc_warns_bag) then
- return ()
- else
- hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle tc_warns_bag))
- >> hPutStr stderr "\n"
- ) >>
+ checkErrors tc_errs_bag tc_warns_bag >>
case tc_results
of { (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds),
- interface_stuff@(_,local_tycons,_,_),
- pragma_tycon_specs, ddump_deriv) ->
+ local_tycons, inst_info, pragma_tycon_specs,
+ ddump_deriv) ->
doDump opt_D_dump_tc "Typechecked:"
(pp_show (ppAboves [
doDump opt_D_dump_deriv "Derived instances:"
(pp_show (ddump_deriv pprStyle)) >>
- -- OK, now do the interface stuff that relies on typechecker output:
- ifaceDecls if_handle interface_stuff >>
- ifaceInstances if_handle interface_stuff >>
+ -- Now (and alas only now) we have the derived-instance information
+ -- so we can put instance information in the interface file
+ ifaceInstances if_handle inst_info >>
-- ******* DESUGARER
- show_pass "DeSugar" >>
+ show_pass "DeSugar " >>
_scc_ "DeSugar"
let
(desugared,ds_warnings)
sm_uniqs local_data_tycons pragma_tycon_specs desugared
>>=
- \ (simplified, inlinings_env,
+ \ (simplified,
SpecData _ _ _ gen_tycons all_tycon_specs _ _ _) ->
doDump opt_D_dump_simpl "Simplified:" (pp_show (ppAboves
(pp_show (ppAboves (map (pprPlainStgBinding pprStyle) stg_binds2)))
>>
+ -- Dump type signatures into the interface file
+ let
+ final_ids = collectFinalStgBinders stg_binds2
+ in
+ ifaceDecls if_handle rn_mod final_ids simplified >>
+ endIface if_handle >>
-- We are definitely done w/ interface-file stuff at this point:
-- (See comments near call to "startIface".)
- endIface if_handle >>
+
-- ******* "ABSTRACT", THEN "FLAT", THEN *REAL* C!
show_pass "CodeGen" >>
_scc_ "CodeGen"
let
- abstractC = codeGen mod_name -- module name for CC labelling
+ abstractC = codeGen mod_name -- module name for CC labelling
cost_centre_info
- import_names -- import names for CC registering
- gen_tycons -- type constructors generated locally
- all_tycon_specs -- tycon specialisations
+ imported_modules -- import names for CC registering
+ gen_tycons -- type constructors generated locally
+ all_tycon_specs -- tycon specialisations
stg_binds2
flat_abstractC = flattenAbsC fl_uniqs abstractC
doOutput opt_ProduceC c_output_w >>
ghcExit 0
- } ) }
+ } } }
where
-------------------------------------------------------------
-- ****** printing styles and column width:
- pprCols = (80 :: Int) -- could make configurable
-
- (pprStyle, pprErrorsStyle)
- = if opt_PprStyle_All then
- (PprShowAll, PprShowAll)
- else if opt_PprStyle_Debug then
- (PprDebug, PprDebug)
- else if opt_PprStyle_User then
- (PprForUser, PprForUser)
- else -- defaults...
- (PprDebug, PprForUser)
-
- pp_show p = ppShow {-WAS:pprCols-}10000{-random-} p
-------------------------------------------------------------
-- ****** help functions:
else return ()
-ppSourceStats (HsModule name version exports imports fixities typedecls typesigs
- classdecls instdecls instsigs defdecls binds
- [{-no sigs-}] src_loc)
+pprCols = (80 :: Int) -- could make configurable
+
+(pprStyle, pprErrorsStyle)
+ | opt_PprStyle_All = (PprShowAll, PprShowAll)
+ | opt_PprStyle_Debug = (PprDebug, PprDebug)
+ | opt_PprStyle_User = (PprForUser, PprForUser)
+ | otherwise = (PprDebug, PprForUser)
+
+pp_show p = ppShow {-WAS:pprCols-}10000{-random-} p
+
+checkErrors errs_bag warns_bag
+ | not (isEmptyBag errs_bag)
+ = hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle errs_bag))
+ >> hPutStr stderr "\n" >>
+ hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle warns_bag))
+ >> hPutStr stderr "\n" >>
+ ghcExit 1
+
+ | not (isEmptyBag warns_bag)
+ = hPutStr stderr (ppShow pprCols (pprBagOfErrors pprErrorsStyle warns_bag)) >>
+ hPutStr stderr "\n"
+
+ | otherwise = return ()
+
+
+ppSourceStats (HsModule name version exports imports fixities decls src_loc)
= ppAboves (map pp_val
[("ExportAll ", export_all), -- 1 if no export list
("ExportDecls ", export_ds),
(" ImpPartial ", import_partial),
(" ImpHiding ", import_hiding),
("FixityDecls ", fixity_ds),
- ("DefaultDecls ", defalut_ds),
+ ("DefaultDecls ", default_ds),
("TypeDecls ", type_ds),
("DataDecls ", data_ds),
("NewTypeDecls ", newt_ds),
("FunBinds ", fn_bind_ds),
("InlineMeths ", method_inlines),
("InlineBinds ", bind_inlines),
- ("SpecialisedData ", data_specs),
- ("SpecialisedInsts ", inst_specs),
+-- ("SpecialisedData ", data_specs),
+-- ("SpecialisedInsts ", inst_specs),
("SpecialisedMeths ", method_specs),
("SpecialisedBinds ", bind_specs)
])
pp_val (str, 0) = ppNil
pp_val (str, n) = ppBesides [ppStr str, ppInt n]
- (export_decls, export_mods) = getRawExportees exports
- type_decls = filter is_type_decl typedecls
- data_decls = filter is_data_decl typedecls
- newt_decls = filter is_newt_decl typedecls
-
- export_ds = length export_decls
- export_ms = length export_mods
- export_all = if export_ds == 0 && export_ms == 0 then 1 else 0
-
- fixity_ds = length fixities
- defalut_ds = length defdecls
- type_ds = length type_decls
- data_ds = length data_decls
- newt_ds = length newt_decls
- class_ds = length classdecls
- inst_ds = length instdecls
+ fixity_ds = length fixities
+ type_decls = [d | TyD d@(TySynonym _ _ _ _) <- decls]
+ data_decls = [d | TyD d@(TyData _ _ _ _ _ _ _) <- decls]
+ newt_decls = [d | TyD d@(TyNew _ _ _ _ _ _ _) <- decls]
+ type_ds = length type_decls
+ data_ds = length data_decls
+ newt_ds = length newt_decls
+ class_decls = [d | ClD d <- decls]
+ class_ds = length class_decls
+ inst_decls = [d | InstD d <- decls]
+ inst_ds = length inst_decls
+ default_ds = length [() | DefD _ <- decls]
+ val_decls = [d | ValD d <- decls]
+
+ real_exports = case exports of { Nothing -> []; Just es -> es }
+ n_exports = length real_exports
+ export_ms = length [() | IEModuleContents _ <- real_exports]
+ export_ds = n_exports - export_ms
+ export_all = case exports of { Nothing -> 1; other -> 0 }
(val_bind_ds, fn_bind_ds, bind_tys, bind_specs, bind_inlines)
- = count_binds binds
+ = count_binds (foldr ThenBinds EmptyBinds val_decls)
(import_no, import_qual, import_as, import_all, import_partial, import_hiding)
= foldr add6 (0,0,0,0,0,0) (map import_info imports)
(data_constrs, data_derivs)
= foldr add2 (0,0) (map data_info (newt_decls ++ data_decls))
(class_method_ds, default_method_ds)
- = foldr add2 (0,0) (map class_info classdecls)
+ = foldr add2 (0,0) (map class_info class_decls)
(inst_method_ds, method_specs, method_inlines)
- = foldr add3 (0,0,0) (map inst_info instdecls)
+ = foldr add3 (0,0,0) (map inst_info inst_decls)
- data_specs = length typesigs
- inst_specs = length instsigs
count_binds EmptyBinds = (0,0,0,0,0)
count_binds (ThenBinds b1 b2) = count_binds b1 `add5` count_binds b2
count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs)
- sig_info (Sig _ _ _ _) = (1,0,0,0)
+ sig_info (Sig _ _ _) = (1,0,0,0)
sig_info (ClassOpSig _ _ _ _) = (0,1,0,0)
sig_info (SpecSig _ _ _ _) = (0,0,1,0)
sig_info (InlineSig _ _) = (0,0,0,1)
data_info (TyData _ _ _ constrs derivs _ _)
= (length constrs, case derivs of {Nothing -> 0; Just ds -> length ds})
data_info (TyNew _ _ _ constr derivs _ _)
- = (length constr, case derivs of {Nothing -> 0; Just ds -> length ds})
+ = (1, case derivs of {Nothing -> 0; Just ds -> length ds})
class_info (ClassDecl _ _ _ meth_sigs def_meths _ _)
= case count_sigs meth_sigs of
(_,classops,_,_) ->
(classops, addpr (count_monobinds def_meths))
- inst_info (InstDecl _ _ inst_meths _ _ inst_sigs _ _)
+ inst_info (InstDecl _ inst_meths inst_sigs _ _)
= case count_sigs inst_sigs of
(_,_,ss,is) ->
(addpr (count_monobinds inst_meths), ss, is)
- is_type_decl (TySynonym _ _ _ _) = True
- is_type_decl _ = False
- is_data_decl (TyData _ _ _ _ _ _ _) = True
- is_data_decl _ = False
- is_newt_decl (TyNew _ _ _ _ _ _ _) = True
- is_newt_decl _ = False
-
addpr (x,y) = x+y
add1 x1 y1 = x1+y1
add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
module MkIface (
startIface, endIface,
- ifaceUsages,
- ifaceVersions,
- ifaceExportList,
- ifaceFixities,
- ifaceInstanceModules,
- ifaceDecls,
- ifaceInstances,
- ifacePragmas
+ ifaceMain, ifaceInstances,
+ ifaceDecls
) where
IMP_Ubiq(){-uitous-}
IMPORT_1_3(IO(Handle,hPutStr,openFile,hClose,IOMode(..)))
-import Bag ( bagToList )
-import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) )
-import CmdLineOpts ( opt_ProduceHi )
-import FieldLabel ( FieldLabel{-instance NamedThing-} )
-import FiniteMap ( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap )
import HsSyn
+import RdrHsSyn ( RdrName(..) )
+import RnHsSyn ( SYN_IE(RenamedHsModule) )
+import RnMonad
+
+import TcInstUtil ( InstInfo(..) )
+
+import CmdLineOpts
import Id ( idType, dataConRawArgTys, dataConFieldLabels, isDataCon,
- dataConStrictMarks, StrictnessMark(..),
+ getIdInfo, idWantsToBeINLINEd, wantIdSigInIface,
+ dataConStrictMarks, StrictnessMark(..),
+ SYN_IE(IdSet), idSetToList, unionIdSets, unitIdSet, minusIdSet,
+ isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet,
GenId{-instance NamedThing/Outputable-}
)
-import Maybes ( maybeToBool )
-import Name ( origName, nameOf, moduleOf,
- exportFlagOn, nameExportFlag, ExportFlag(..),
- isLexSym, isLexCon, isLocallyDefined, isWiredInName,
- RdrName(..){-instance Outputable-},
- OrigName(..){-instance Ord-},
- Name{-instance NamedThing-}
+import IdInfo ( StrictnessInfo, ArityInfo, Unfolding,
+ arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo,
+ getWorkerId_maybe, bottomIsGuaranteed
)
-import ParseUtils ( UsagesMap(..), VersionsMap(..) )
+import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding), GenCoreExpr, GenCoreBinding(..) )
+import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..) )
+import FreeVars ( addExprFVs )
+import Name ( isLocallyDefined, isWiredInName, modAndOcc, getName, pprOccName,
+ OccName, occNameString, nameOccName, nameString, isExported, pprNonSym,
+ Name {-instance NamedThing-}, Provenance
+ )
+import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) )
+import Class ( GenClass(..){-instance NamedThing-}, GenClassOp, classOpLocalType )
+import FieldLabel ( FieldLabel{-instance NamedThing-} )
+import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy )
+import TyVar ( GenTyVar {- instance Eq -} )
+import Unique ( Unique {- instance Eq -} )
+
import PprEnv -- not sure how much...
import PprStyle ( PprStyle(..) )
-import PprType -- most of it (??)
---import PrelMods ( modulesWithBuiltins )
-import PrelInfo ( builtinValNamesMap, builtinTcNamesMap )
-import Pretty ( prettyToUn )
+import PprType
+import PprCore ( pprIfaceUnfolding )
+import Pretty
import Unpretty -- ditto
-import RnHsSyn ( isRnConstr, SYN_IE(RenamedHsModule), RnName(..) )
-import RnUtils ( SYN_IE(RnEnv) {-, pprRnEnv ToDo:rm-} )
-import TcModule ( SYN_IE(TcIfaceInfo) )
-import TcInstUtil ( InstInfo(..) )
-import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) )
-import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitForAllTy )
-import Util ( sortLt, removeDups, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}{-, pprTrace ToDo:rm-} )
-uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util
-ppr_ty ty = prettyToUn (pprType PprInterface ty)
-ppr_tyvar tv = prettyToUn (ppr PprInterface tv)
-ppr_name n
- = case (origName "ppr_name" n) of { OrigName m s ->
- uppBesides [uppPStr m, uppChar '.', uppPStr s] }
+
+import Bag ( bagToList )
+import Maybes ( catMaybes, maybeToBool )
+import FiniteMap ( emptyFM, addToFM, lookupFM, fmToList, eltsFM, FiniteMap )
+import UniqFM ( UniqFM, lookupUFM, listToUFM )
+import Util ( sortLt, zipWithEqual, zipWith3Equal, mapAccumL,
+ assertPanic, panic{-ToDo:rm-}, pprTrace )
+
\end{code}
We have a function @startIface@ to open the output file and put
\begin{code}
startIface :: Module
-> IO (Maybe Handle) -- Nothing <=> don't do an interface
-endIface :: Maybe Handle -> IO ()
-ifaceUsages
- :: Maybe Handle
- -> UsagesMap
- -> IO ()
-ifaceVersions
- :: Maybe Handle
- -> VersionsMap
- -> IO ()
-ifaceExportList
- :: Maybe Handle
- -> (Name -> ExportFlag, ([(Name,ExportFlag)], [(Name,ExportFlag)]))
- -> RnEnv
- -> IO ()
-ifaceFixities
- :: Maybe Handle
- -> RenamedHsModule
- -> IO ()
-ifaceInstanceModules
- :: Maybe Handle
- -> [Module]
- -> IO ()
-ifaceDecls :: Maybe Handle
- -> TcIfaceInfo -- info produced by typechecker, for interfaces
- -> IO ()
-ifaceInstances
- :: Maybe Handle
- -> TcIfaceInfo -- as above
- -> IO ()
-ifacePragmas
- :: Maybe Handle
+
+ifaceMain :: Maybe Handle
+ -> InterfaceDetails
-> IO ()
-ifacePragmas = panic "ifacePragmas" -- stub
+
+ifaceInstances :: Maybe Handle -> Bag InstInfo -> IO ()
+
+ifaceDecls :: Maybe Handle
+ -> RenamedHsModule
+ -> [Id] -- Ids used at code-gen time; they have better pragma info!
+ -> [CoreBinding] -- In dependency order, later depend on earlier
+ -> IO ()
+
+endIface :: Maybe Handle -> IO ()
\end{code}
\begin{code}
Nothing -> return Nothing -- not producing any .hi file
Just fn ->
openFile fn WriteMode >>= \ if_hdl ->
- hPutStr if_hdl ("{-# GHC_PRAGMA INTERFACE VERSION 20 #-}\ninterface "++ _UNPK_ mod) >>
+ hPutStr if_hdl ("{-# GHC_PRAGMA INTERFACE VERSION 20 #-}\n_interface_ "++ _UNPK_ mod ++ "\n") >>
return (Just if_hdl)
endIface Nothing = return ()
endIface (Just if_hdl) = hPutStr if_hdl "\n" >> hClose if_hdl
\end{code}
-\begin{code}
-ifaceUsages Nothing{-no iface handle-} _ = return ()
-ifaceUsages (Just if_hdl) usages
- | null usages_list
- = return ()
+\begin{code}
+ifaceMain Nothing iface_stuff = return ()
+ifaceMain (Just if_hdl)
+ (import_usages, ExportEnv avails fixities, instance_modules)
+ =
+ ifaceInstanceModules if_hdl instance_modules >>
+ ifaceUsages if_hdl import_usages >>
+ ifaceExports if_hdl avails >>
+ ifaceFixities if_hdl fixities >>
+ return ()
+
+ifaceDecls Nothing rn_mod final_ids simplified = return ()
+ifaceDecls (Just hdl)
+ (HsModule _ _ _ _ _ decls _)
+ final_ids binds
+ | null decls = return ()
+ -- You could have a module with just (re-)exports/instances in it
| otherwise
- = hPutStr if_hdl "\n__usages__\n" >>
- hPutStr if_hdl (uppShow 0 (uppAboves (map upp_uses usages_list)))
+ = hPutStr hdl "_declarations_\n" >>
+ ifaceTCDecls hdl decls >>
+ ifaceBinds hdl final_ids binds >>
+ return ()
+\end{code}
+
+\begin{code}
+ifaceUsages if_hdl import_usages
+ = hPutStr if_hdl "_usages_\n" >>
+ hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages)
where
- usages_list = fmToList usages -- NO: filter has_no_builtins (...)
+ upp_uses (m, mv, versions)
+ = uppBesides [upp_module m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
+ upp_import_versions (sort_versions versions), uppSemi]
--- has_no_builtins (m, _)
--- = m `notElem` modulesWithBuiltins
--- -- Don't *have* to do this; save gratuitous spillage in
--- -- every interface. Could be flag-controlled...
+ -- For imported versions we do print the version number
+ upp_import_versions nvs
+ = uppIntersperse uppSP [ uppCat [ppr_unqual_name n, uppInt v] | (n,v) <- nvs ]
- upp_uses (m, (mv, versions))
- = uppBesides [uppPStr m, uppSP, uppInt mv, uppPStr SLIT(" :: "),
- upp_versions (fmToList versions), uppSemi]
- upp_versions nvs
- = uppIntersperse uppSP [ uppCat [uppPStr n, uppInt v] | (n,v) <- nvs ]
-\end{code}
+ifaceInstanceModules if_hdl [] = return ()
+ifaceInstanceModules if_hdl imods
+ = hPutStr if_hdl "_instance_modules_\n" >>
+ hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods))) >>
+ hPutStr if_hdl "\n"
-\begin{code}
-ifaceVersions Nothing{-no iface handle-} _ = return ()
+ifaceExports if_hdl [] = return ()
+ifaceExports if_hdl avails
+ = hPutStr if_hdl "_exports_\n" >>
+ hPutCol if_hdl upp_avail (sortLt lt_avail avails)
-ifaceVersions (Just if_hdl) version_info
- | null version_list
- = return ()
- | otherwise
- = hPutStr if_hdl "\n__versions__\n" >>
- hPutStr if_hdl (uppShow 0 (upp_versions version_list))
- -- NB: when compiling Prelude.hs, this will spew out
- -- stuff for [], (), (,), etc. [i.e., builtins], which
- -- we'd rather it didn't. The version-mangling in
- -- the driver will ignore them.
+ifaceFixities if_hdl [] = return ()
+ifaceFixities if_hdl fixities
+ = hPutStr if_hdl "_fixities_\n" >>
+ hPutCol if_hdl upp_fixity fixities
+
+ifaceTCDecls if_hdl decls
+ = hPutCol if_hdl ppr_decl tc_decls_for_iface
where
- version_list = fmToList version_info
+ tc_decls_for_iface = sortLt lt_decl (filter for_iface decls)
+ for_iface decl@(ClD _) = for_iface_name (hsDeclName decl)
+ for_iface decl@(TyD _) = for_iface_name (hsDeclName decl)
+ for_iface other_decl = False
- upp_versions nvs
- = uppAboves [ uppPStr n | (n,v) <- nvs ]
-\end{code}
+ for_iface_name name = isLocallyDefined name &&
+ not (isWiredInName name)
-\begin{code}
-ifaceInstanceModules Nothing{-no iface handle-} _ = return ()
-ifaceInstanceModules (Just _) [] = return ()
+ lt_decl d1 d2 = hsDeclName d1 < hsDeclName d2
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Instance declarations}
+%* *
+%************************************************************************
-ifaceInstanceModules (Just if_hdl) imods
- = hPutStr if_hdl "\n__instance_modules__\n" >>
- hPutStr if_hdl (uppShow 0 (uppCat (map uppPStr imods)))
+
+\begin{code}
+ifaceInstances Nothing{-no iface handle-} _ = return ()
+
+ifaceInstances (Just if_hdl) inst_infos
+ | null togo_insts = return ()
+ | otherwise = hPutStr if_hdl "_instances_\n" >>
+ hPutCol if_hdl pp_inst (sortLt lt_inst togo_insts)
+ where
+ togo_insts = filter is_togo_inst (bagToList inst_infos)
+ is_togo_inst (InstInfo _ _ _ _ _ dfun_id _ _ _) = isLocallyDefined dfun_id
+
+ -------
+ lt_inst (InstInfo _ _ _ _ _ dfun_id1 _ _ _)
+ (InstInfo _ _ _ _ _ dfun_id2 _ _ _)
+ = getOccName dfun_id1 < getOccName dfun_id2
+ -- The dfuns are assigned names df1, df2, etc, in order of original textual
+ -- occurrence, and this makes as good a sort order as any
+
+ -------
+ pp_inst (InstInfo clas tvs ty theta _ dfun_id _ _ _)
+ = let
+ forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty)
+ renumbered_ty = renumber_ty forall_ty
+ in
+ uppBesides [uppPStr SLIT("instance "), ppr_ty renumbered_ty,
+ uppPStr SLIT(" = "), ppr_unqual_name dfun_id, uppSemi]
\end{code}
-Export list: grab the Names of things that are marked Exported, sort
-(so the interface file doesn't ``wobble'' from one compilation to the
-next...), and print. We work from the renamer's final ``RnEnv'',
-which has all the names we might possibly be interested in.
-(Note that the ``module X'' export items can cause a lot of grief.)
+
+%************************************************************************
+%* *
+\subsection{Printing values}
+%* *
+%************************************************************************
+
\begin{code}
-ifaceExportList Nothing{-no iface handle-} _ _ = return ()
-
-ifaceExportList (Just if_hdl)
- (export_fn, (dotdot_vals, dotdot_tcs))
- rn_env@((qual, unqual, tc_qual, tc_unqual), _)
- = let
- name_flag_pairs :: FiniteMap OrigName ExportFlag
- name_flag_pairs
- = foldr (from_wired True{-val-ish-})
- (foldr (from_wired False{-tycon-ish-})
- (foldr (from_dotdot True{-val-ish-})
- (foldr (from_dotdot False{-tycon-ish-})
- (foldr from_val
- (foldr from_val
- (foldr from_tc
- (foldr from_tc emptyFM{-init accum-}
- (eltsFM tc_unqual))
- (eltsFM tc_qual))
- (eltsFM unqual))
- (eltsFM qual))
- dotdot_tcs)
- dotdot_vals)
- (eltsFM builtinTcNamesMap))
- (eltsFM builtinValNamesMap)
-
- sorted_pairs = sortLt lexical_lt (fmToList name_flag_pairs)
-
- in
- --pprTrace "Exporting:" (pprRnEnv PprDebug rn_env) $
- hPutStr if_hdl "\n__exports__\n" >>
- hPutStr if_hdl (uppShow 0 (uppAboves (map upp_pair sorted_pairs)))
+ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added
+ -- by the STG passes. Sigh
+
+ -> IdSet -- Set of Ids that are needed by earlier interface
+ -- file emissions. If the Id isn't in this set, and isn't
+ -- exported, there's no need to emit anything
+ -> Id
+ -> CoreExpr -- The Id's right hand side
+ -> Maybe (Pretty, IdSet) -- The emitted stuff, plus a possibly-augmented set of needed Ids
+
+ifaceId get_idinfo needed_ids id rhs
+ | not (wantIdSigInIface (id `elementOfIdSet` needed_ids)
+ opt_OmitInterfacePragmas
+ id)
+ = Nothing -- Well, that was easy!
+
+ifaceId get_idinfo needed_ids id rhs
+ = Just (ppCat [sig_pretty, prag_pretty, ppSemi], new_needed_ids)
where
- from_val rn acc
- | fun_looking rn && exportFlagOn ef = addToFM acc on ef
- | otherwise = acc
- where
- ef = export_fn n -- NB: using the export fn!
- n = getName rn
- on = origName "from_val" n
-
- -- fun_looking: must avoid class ops and data constructors
- -- and record fieldnames
- fun_looking (RnName _) = True
- fun_looking (WiredInId i) = not (isDataCon i)
- fun_looking _ = False
-
- from_tc rn acc
- | exportFlagOn ef = addToFM acc on ef
- | otherwise = acc
- where
- ef = export_fn n -- NB: using the export fn!
- n = getName rn
- on = origName "from_tc" n
-
- from_dotdot is_valish (n,ef) acc
- | is_valish && isLexCon str = acc
- | exportFlagOn ef = addToFM acc on ef
- | otherwise = acc
- where
- on = origName "from_dotdot" n
- (OrigName _ str) = on
-
- from_wired is_val_ish rn acc
- | is_val_ish && not (fun_looking rn)
- = acc -- these things don't cause export-ery
- | exportFlagOn ef = addToFM acc on ef
- | otherwise = acc
- where
- n = getName rn
- ef = export_fn n
- on = origName "from_wired" n
-
- --------------
- lexical_lt (n1,_) (n2,_) = n1 < n2
-
- --------------
- upp_pair (OrigName m n, ef)
- = uppBesides [uppPStr m, uppSP, uppPStr n, uppSP, upp_export ef]
- where
- upp_export ExportAll = uppPStr SLIT("(..)")
- upp_export ExportAbs = uppNil
+ idinfo = get_idinfo id
+ ty_pretty = pprType PprInterface (initNmbr (nmbrType (idType id)))
+ sig_pretty = ppBesides [ppr PprInterface (getOccName id), ppPStr SLIT(" :: "), ty_pretty]
+
+ prag_pretty | opt_OmitInterfacePragmas = ppNil
+ | otherwise = ppCat [arity_pretty, strict_pretty, unfold_pretty]
+
+ ------------ Arity --------------
+ arity_pretty = ppArityInfo PprInterface (arityInfo idinfo)
+
+ ------------ Strictness --------------
+ strict_info = strictnessInfo idinfo
+ maybe_worker = getWorkerId_maybe strict_info
+ strict_pretty = ppStrictnessInfo PprInterface strict_info
+
+ ------------ Unfolding --------------
+ unfold_pretty | show_unfold = ppCat [ppStr "_U_", pprIfaceUnfolding rhs]
+ | otherwise = ppNil
+
+ show_unfold = not (maybeToBool maybe_worker) && -- Unfolding is implicit
+ not (bottomIsGuaranteed strict_info) && -- Ditto
+ case guidance of -- Small enough to show
+ UnfoldNever -> False
+ other -> True
+
+ guidance = calcUnfoldingGuidance (idWantsToBeINLINEd id)
+ opt_InterfaceUnfoldThreshold
+ rhs
+
+
+ ------------ Extra free Ids --------------
+ new_needed_ids = (needed_ids `minusIdSet` unitIdSet id) `unionIdSets`
+ extra_ids
+
+ extra_ids | opt_OmitInterfacePragmas = emptyIdSet
+ | otherwise = worker_ids `unionIdSets`
+ unfold_ids
+
+ worker_ids = case maybe_worker of
+ Just wkr -> unitIdSet wkr
+ Nothing -> emptyIdSet
+
+ unfold_ids | show_unfold = free_vars
+ | otherwise = emptyIdSet
+ where
+ (_,free_vars) = addExprFVs interesting emptyIdSet rhs
+ interesting bound id = not (id `elementOfIdSet` bound) &&
+ not (isDataCon id) &&
+ not (isWiredInName (getName id)) &&
+ isLocallyDefined id
\end{code}
\begin{code}
-ifaceFixities Nothing{-no iface handle-} _ = return ()
-
-ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
- = let
- pp_fixities = foldr go [] fixities
- in
- if null pp_fixities then
- return ()
- else
- hPutStr if_hdl "\n__fixities__\n" >>
- hPutStr if_hdl (uppShow 0 (uppAboves pp_fixities))
+ifaceBinds :: Handle
+ -> [Id] -- Ids used at code-gen time; they have better pragma info!
+ -> [CoreBinding] -- In dependency order, later depend on earlier
+ -> IO ()
+
+ifaceBinds hdl final_ids binds
+ = hPutStr hdl (uppShow 0 (prettyToUn (ppAboves pretties))) >>
+ hPutStr hdl "\n"
where
- go (InfixL v i) acc = (if isLocallyDefined v then (:) (print_fix "l" i v) else id) acc
- go (InfixR v i) acc = (if isLocallyDefined v then (:) (print_fix "r" i v) else id) acc
- go (InfixN v i) acc = (if isLocallyDefined v then (:) (print_fix "" i v) else id) acc
-
- print_fix suff prec var
- = uppBesides [uppPStr SLIT("infix"), uppStr suff, uppSP, uppInt prec, uppSP, ppr_name var, uppSemi]
+ final_id_map = listToUFM [(id,id) | id <- final_ids]
+ get_idinfo id = case lookupUFM final_id_map id of
+ Just id' -> getIdInfo id'
+ Nothing -> pprTrace "ifaceBinds not found:" (ppr PprDebug id) $
+ getIdInfo id
+
+ pretties = go emptyIdSet (reverse binds) -- Reverse so that later things will
+ -- provoke earlier ones to be emitted
+ go needed [] = if not (isEmptyIdSet needed) then
+ pprTrace "ifaceBinds: free vars:"
+ (ppSep (map (ppr PprDebug) (idSetToList needed))) $
+ []
+ else
+ []
+
+ go needed (NonRec id rhs : binds)
+ = case ifaceId get_idinfo needed id rhs of
+ Nothing -> go needed binds
+ Just (pretty, needed') -> pretty : go needed' binds
+
+ -- Recursive groups are a bit more of a pain. We may only need one to
+ -- start with, but it may call out the next one, and so on. So we
+ -- have to look for a fixed point.
+ go needed (Rec pairs : binds)
+ = pretties ++ go needed'' binds
+ where
+ (needed', pretties) = go_rec needed pairs
+ needed'' = needed' `minusIdSet` mkIdSet (map fst pairs)
+ -- Later ones may spuriously cause earlier ones to be "needed" again
+
+ go_rec :: IdSet -> [(Id,CoreExpr)] -> (IdSet, [Pretty])
+ go_rec needed pairs
+ | null pretties = (needed, [])
+ | otherwise = (final_needed, more_pretties ++ pretties)
+ where
+ reduced_pairs = [pair | (pair,Nothing) <- pairs `zip` maybes]
+ pretties = catMaybes maybes
+ (needed', maybes) = mapAccumL do_one needed pairs
+ (final_needed, more_pretties) = go_rec needed' reduced_pairs
+
+ do_one needed (id,rhs) = case ifaceId get_idinfo needed id rhs of
+ Nothing -> (needed, Nothing)
+ Just (pretty, needed') -> (needed', Just pretty)
\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 vals)
- ASSERT(all isLocallyDefined tycons)
- ASSERT(all isLocallyDefined classes)
- let
- nonwired_classes = filter non_wired classes
- nonwired_tycons = filter non_wired tycons
- nonwired_vals = filter non_wired vals
-
- lt_lexical a b = origName "lt_lexical" a < origName "lt_lexical" b
-
- sorted_classes = sortLt lt_lexical nonwired_classes
- sorted_tycons = sortLt lt_lexical nonwired_tycons
- 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 (re-)exports/instances in it
- return ()
- else
- hPutStr if_hdl "\n__declarations__\n" >>
- hPutStr if_hdl (uppShow 0 (uppAboves [
- uppAboves (map ppr_class sorted_classes),
- uppAboves (map ppr_tycon sorted_tycons),
- uppAboves [ppr_val v (idType v) | v <- sorted_vals]]))
-\end{code}
+%************************************************************************
+%* *
+\subsection{Random small things}
+%* *
+%************************************************************************
+
\begin{code}
-ifaceInstances Nothing{-no iface handle-} _ = return ()
+upp_avail NotAvailable = uppNil
+upp_avail (Avail name ns) = uppBesides [upp_module mod, uppSP,
+ upp_occname occ, uppSP,
+ upp_export ns]
+ where
+ (mod,occ) = modAndOcc name
-ifaceInstances (Just if_hdl) (_, _, _, insts)
- = let
- togo_insts = filter is_togo_inst (bagToList insts)
-
- sorted_insts = sortLt lt_inst togo_insts
- in
- if null togo_insts then
- return ()
- else
- hPutStr if_hdl "\n__instances__\n" >>
- hPutStr if_hdl (uppShow 0 (uppAboves (map pp_inst sorted_insts)))
- where
- is_togo_inst (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
- = from_here -- && ...
-
- -------
- lt_inst (InstInfo clas1 _ ty1 _ _ _ _ _ _ _ _ _)
- (InstInfo clas2 _ ty2 _ _ _ _ _ _ _ _ _)
- = let
- tycon1 = fst (getAppTyCon ty1)
- tycon2 = fst (getAppTyCon ty2)
- in
- case (origName "lt_inst" clas1 `cmp` origName "lt_inst" clas2) of
- LT_ -> True
- GT_ -> False
- EQ_ -> origName "lt_inst2" tycon1 < origName "lt_inst2" tycon2
-
- -------
- pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _)
- = let
- forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty)
- renumbered_ty = initNmbr (nmbrType forall_ty)
- in
- case (splitForAllTy renumbered_ty) of { (rtvs, rrho_ty) ->
- uppBesides [uppPStr SLIT("instance "), ppr_forall rtvs, ppr_ty rrho_ty, uppSemi] }
+upp_export [] = uppNil
+upp_export names = uppBesides [uppStr "(",
+ uppIntersperse uppSP (map (upp_occname . getOccName) names),
+ uppStr ")"]
+
+upp_fixity (occ, Fixity prec dir, prov) = uppBesides [upp_dir dir, uppSP,
+ uppInt prec, uppSP,
+ upp_occname occ, uppSemi]
+upp_dir InfixR = uppStr "infixr"
+upp_dir InfixL = uppStr "infixl"
+upp_dir InfixN = uppStr "infix"
+
+ppr_unqual_name :: NamedThing a => a -> Unpretty -- Just its occurrence name
+ppr_unqual_name name = upp_occname (getOccName name)
+
+ppr_name :: NamedThing a => a -> Unpretty -- Its full name
+ppr_name n = uppPStr (nameString (getName n))
+
+upp_occname :: OccName -> Unpretty
+upp_occname occ = uppPStr (occNameString occ)
+
+upp_module :: Module -> Unpretty
+upp_module mod = uppPStr mod
+
+uppSemid x = uppBeside (prettyToUn (ppr PprInterface x)) uppSemi -- micro util
+
+ppr_ty ty = prettyToUn (pprType PprInterface ty)
+ppr_tyvar tv = prettyToUn (ppr PprInterface tv)
+ppr_tyvar_bndr tv = prettyToUn (pprTyVarBndr PprInterface tv)
+
+ppr_decl decl = prettyToUn (ppr PprInterface decl) `uppBeside` uppSemi
+
+renumber_ty ty = initNmbr (nmbrType ty)
\end{code}
+
%************************************************************************
-%* *
-\subsection{Printing tycons, classes, ...}
-%* *
+%* *
+\subsection{Comparisons
+%* *
%************************************************************************
+
-\begin{code}
-ppr_class :: Class -> Unpretty
-
-ppr_class c
- = --pprTrace "ppr_class:" (ppr PprDebug c) $
- case (initNmbr (nmbrClass c)) of { -- renumber it!
- Class _ n tyvar super_classes sdsels ops sels defms insts links ->
-
- uppCat [uppPStr SLIT("class"), ppr_context tyvar super_classes,
- ppr_name n, ppr_tyvar tyvar,
- if null ops
- then uppSemi
- else uppCat [uppStr "where {", uppCat (map ppr_op ops), uppStr "};"]]
- }
- where
- ppr_context :: TyVar -> [Class] -> Unpretty
+The various sorts above simply prevent unnecessary "wobbling" when
+things change that don't have to. We therefore compare lexically, not
+by unique
- ppr_context tv [] = uppNil
--- ppr_context tv [sc] = uppBeside (ppr_assert tv sc) (uppPStr SLIT(" =>"))
- ppr_context tv super_classes
- = uppBesides [uppStr "{{",
- uppIntersperse upp'SP{-'-} (map (ppr_assert tv) super_classes),
- uppStr "}} =>"]
+\begin{code}
+lt_avail :: AvailInfo -> AvailInfo -> Bool
- ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = uppCat [ppr_name n, ppr_tyvar tv]
+NotAvailable `lt_avail` (Avail _ _) = True
+(Avail n1 _) `lt_avail` (Avail n2 _) = n1 `lt_name` n2
+any `lt_avail` NotAvailable = False
- clas_mod = moduleOf (origName "ppr_class" c)
+lt_name :: Name -> Name -> Bool
+n1 `lt_name` n2 = modAndOcc n1 < modAndOcc n2
- ppr_op (ClassOp o _ ty) = pp_sig (Qual clas_mod o) ty
-\end{code}
+lt_lexical :: NamedThing a => a -> a -> Bool
+lt_lexical a1 a2 = getName a1 `lt_name` getName a2
-\begin{code}
-ppr_val v ty -- renumber the type first!
- = --pprTrace "ppr_val:" (ppr PprDebug v) $
- pp_sig v (initNmbr (nmbrType ty))
+lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool
+lt_imp_vers (m1,_,_) (m2,_,_) = m1 < m2
-pp_sig op ty
- = case (splitForAllTy ty) of { (tvs, rho_ty) ->
- uppBesides [ppr_name op, uppPStr SLIT(" :: "), ppr_forall tvs, ppr_ty rho_ty, uppSemi] }
+sort_versions vs = sortLt lt_vers vs
-ppr_forall [] = uppNil
-ppr_forall tvs = uppBesides [ uppStr "__forall__ [", uppInterleave uppComma (map ppr_tyvar tvs), uppStr "] " ]
+lt_vers :: LocalVersion Name -> LocalVersion Name -> Bool
+lt_vers (n1,v1) (n2,v2) = n1 `lt_name` n2
\end{code}
+
\begin{code}
-ppr_tycon tycon
- = --pprTrace "ppr_tycon:" (ppr PprDebug tycon) $
- ppr_tc (initNmbr (nmbrTyCon tycon))
-
-------------------------
-ppr_tc (PrimTyCon _ n _ _)
- = uppCat [ uppStr "{- data", ppr_name n, uppStr " *built-in* -}" ]
-
-ppr_tc FunTyCon
- = uppCat [ uppStr "{- data", ppr_name FunTyCon, uppStr " *built-in* -}" ]
-
-ppr_tc (TupleTyCon _ n _)
- = uppCat [ uppStr "{- ", ppr_name n, uppStr "-}" ]
-
-ppr_tc (SynTyCon _ n _ _ tvs expand)
- = let
- pp_tyvars = map ppr_tyvar tvs
- in
- uppBesides [uppPStr SLIT("type "), ppr_name n, uppSP, uppIntersperse uppSP pp_tyvars,
- uppPStr SLIT(" = "), ppr_ty expand, uppSemi]
-
-ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new)
- = uppCat [pp_data_or_new,
- ppr_context ctxt,
- ppr_name n,
- uppIntersperse uppSP (map ppr_tyvar tvs),
- uppEquals, pp_condecls,
- uppSemi]
- -- NB: we do not print deriving info in interfaces
- where
- pp_data_or_new = case data_or_new of
- DataType -> uppPStr SLIT("data")
- NewType -> uppPStr SLIT("newtype")
-
- ppr_context [] = uppNil
--- ppr_context [(c,t)] = uppCat [ppr_name c, ppr_ty t, uppPStr SLIT("=>")]
- ppr_context cs
- = uppBesides[uppStr "{{",
- uppInterleave uppComma [uppCat [ppr_name c, ppr_ty t] | (c,t) <- cs],
- uppStr "}}", uppPStr SLIT(" =>")]
-
- pp_condecls
- = let
- (c:cs) = cons
- in
- uppCat ((ppr_con c) : (map ppr_next_con cs))
-
- ppr_next_con con = uppCat [uppChar '|', ppr_con con]
-
- ppr_con con
- = let
- con_arg_tys = dataConRawArgTys con
- labels = dataConFieldLabels con -- none if not a record
- strict_marks = dataConStrictMarks con
- in
- uppCat [ppr_name con, ppr_fields labels strict_marks con_arg_tys]
-
- ppr_fields labels strict_marks con_arg_tys
- = if null labels then -- not a record thingy
- uppIntersperse uppSP (zipWithEqual "ppr_fields" ppr_bang_ty strict_marks con_arg_tys)
- else
- uppCat [ uppChar '{',
- uppInterleave uppComma (zipWith3Equal "ppr_field" ppr_field labels strict_marks con_arg_tys),
- uppChar '}' ]
-
- ppr_bang_ty b t
- = uppBeside (case b of { MarkedStrict -> uppChar '!'; _ -> uppNil })
- (prettyToUn (pprParendType PprInterface t))
-
- ppr_field l b t
- = uppBesides [ppr_name l, uppPStr SLIT(" :: "),
- case b of { MarkedStrict -> uppChar '!'; _ -> uppNil },
- ppr_ty t]
+hPutCol :: Handle
+ -> (a -> Unpretty)
+ -> [a]
+ -> IO ()
+hPutCol hdl fmt xs = hPutStr hdl (uppShow 0 (uppAboves (map fmt xs))) >>
+ hPutStr hdl "\n"
\end{code}
import AbsCUtils ( getAmodeRep, mixedTypeLocn,
nonemptyAbsC, mkAbsCStmts, mkAbsCStmtList
)
-import CgCompInfo ( mIN_UPD_SIZE )
+import Constants ( mIN_UPD_SIZE )
import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI,
fastLabelFromCI, closureUpdReqd
)
import MachRegs
import AbsCSyn -- bits and bobs...
-import CgCompInfo ( mIN_MP_INT_SIZE )
+import Constants ( mIN_MP_INT_SIZE )
import Literal ( Literal(..) )
import OrdList ( OrdList )
import PrimOp ( PrimOp(..) )
import MachRegs
import AbsCSyn ( CStmtMacro(..), MagicId(..), mkIntCLit, CAddrMode )
-import CgCompInfo ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
+import Constants ( uF_RET, uF_SUA, uF_SUB, uF_UPDATEE,
sTD_UF_SIZE
)
import OrdList ( OrdList )
import AbsCSyn
import AbsCUtils ( getAmodeRep, mixedTypeLocn )
-import CgCompInfo ( spARelToInt, spBRelToInt )
+import Constants ( spARelToInt, spBRelToInt )
import CostCentre ( noCostCentreAttached )
import HeapOffs ( hpRelToInt, subOff )
import Literal ( Literal(..) )
# define PACK_BYTES _packCBytes
#endif
-import Name ( RdrName(..) )
-import SrcLoc ( mkSrcLoc2, mkUnknownSrcLoc, SrcLoc )
+import RdrHsSyn ( RdrName(..) )
+import SrcLoc ( mkSrcLoc, noSrcLoc, SrcLoc )
\end{code}
\begin{code}
initUgn :: UgnM a -> IO a
initUgn action
= let
- do_it = action (SLIT(""),SLIT(""),mkUnknownSrcLoc)
+ do_it = action (SLIT(""),SLIT(""),noSrcLoc)
in
#if __GLASGOW_HASKELL__ >= 200
primIOToIO do_it
mkSrcLocUgn ln action (file,mod,_)
= action loc (file,mod,loc)
where
- loc = mkSrcLoc2 file ln
+ loc = mkSrcLoc file ln
getSrcLocUgn :: UgnM SrcLoc
getSrcLocUgn stuff@(file,mod,loc) = returnUgn loc stuff
%{
/* These SHOULDNAE work in "Code" (sigh) */
%}
-<Code,GlaExt,UserPragma>{Id}"#" {
- if (! nonstandardFlag) {
+<GlaExt,UserPragma>{Id}"#" {
+ if (! nonstandardFlag) {
char errbuf[ERR_BUF_SIZE];
sprintf(errbuf, "Non-standard identifier (trailing `#'): %s\n", yytext);
hsperror(errbuf);
#include "HsVersions.h"
module PrelInfo (
-
-- finite maps for built-in things (for the renamer and typechecker):
- builtinNameInfo, builtinNameMaps,
- builtinValNamesMap, builtinTcNamesMap,
- builtinKeysMap,
+ builtinNames, builtinKeys, derivingOccurrences,
SYN_IE(BuiltinNames),
- SYN_IE(BuiltinKeys), SYN_IE(BuiltinIdInfos),
- maybeCharLikeTyCon, maybeIntLikeTyCon
+ maybeCharLikeTyCon, maybeIntLikeTyCon,
+
+ eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR, compare_RDR,
+ minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR,
+ enumFromThenTo_RDR, fromEnum_RDR,
+ range_RDR, index_RDR, inRange_RDR, readsPrec_RDR, readList_RDR,
+ showsPrec_RDR, showList_RDR, plus_RDR, times_RDR, ltTag_RDR, eqTag_RDR, gtTag_RDR,
+ eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR, eqH_Addr_RDR, ltH_Addr_RDR,
+ eqH_Float_RDR, ltH_Float_RDR, eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR, ltH_Int_RDR,
+ geH_RDR, leH_RDR, minusH_RDR, false_RDR, true_RDR, and_RDR, not_RDR, append_RDR,
+ map_RDR, compose_RDR, mkInt_RDR, error_RDR, showString_RDR, showParen_RDR, readParen_RDR,
+ lex_RDR, showSpace_RDR, showList___RDR, readList___RDR, negate_RDR,
+
+ numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, creturnableClass_RDR,
+ monadZeroClass_RDR, enumClass_RDR, evalClass_RDR, ordClass_RDR,
+
+ needsDataDeclCtxtClassKeys, cCallishClassKeys, isNoDictClass,
+ isNumericClass, isStandardClass, isCcallishClass
) where
IMP_Ubiq()
-IMPORT_DELOOPER(PrelLoop) ( primOpNameInfo )
-IMPORT_DELOOPER(IdLoop) ( SpecEnv )
+IMPORT_DELOOPER(PrelLoop) ( primOpName )
+-- IMPORT_DELOOPER(IdLoop) ( SpecEnv )
-- friends:
import PrelMods -- Prelude module names
import TysWiredIn
-- others:
-import FiniteMap ( FiniteMap, emptyFM, listToFM )
-import Id ( mkTupleCon, GenId, SYN_IE(Id) )
-import Maybes ( catMaybes )
-import Name ( origName, OrigName(..), Name )
-import RnHsSyn ( RnName(..) )
-import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon )
+import SpecEnv ( SpecEnv )
+import RdrHsSyn ( RdrName(..), varQual, tcQual, qual )
+import Id ( GenId, SYN_IE(Id) )
+import Name ( Name, OccName(..), DefnInfo(..), Provenance(..),
+ getName, mkGlobalName, modAndOcc )
+import Class ( Class(..), GenClass, classKey )
+import TyCon ( tyConDataCons, mkFunTyCon, TyCon )
import Type
-import UniqFM ( UniqFM, emptyUFM, listToUFM )
+import Bag
import Unique -- *Key stuff
-import Util ( nOfThem, panic )
+import UniqFM ( UniqFM, listToUFM )
+import Util ( isIn )
\end{code}
%************************************************************************
@Classes@, the other to look up values.
\begin{code}
-builtinNameInfo :: ( BuiltinNames, BuiltinKeys, BuiltinIdInfos )
-
-type BuiltinNames = (FiniteMap OrigName RnName, -- WiredIn Ids
- FiniteMap OrigName RnName) -- WiredIn TyCons
- -- Two maps because "[]" is in both...
-
-type BuiltinKeys = FiniteMap OrigName (Unique, Name -> RnName)
- -- Names with known uniques
-
-type BuiltinIdInfos = UniqFM IdInfo -- Info for known unique Ids
-
-builtinNameMaps = case builtinNameInfo of { (x,_,_) -> x }
-builtinKeysMap = case builtinNameInfo of { (_,x,_) -> x }
-builtinValNamesMap = fst builtinNameMaps
-builtinTcNamesMap = snd builtinNameMaps
-
-builtinNameInfo
- = ( (listToFM assoc_val_wired, listToFM assoc_tc_wired)
- , listToFM assoc_keys
- , listToUFM assoc_id_infos
- )
- where
- assoc_val_wired
- = concat [
- -- data constrs
- concat (map pcDataConWiredInInfo g_con_tycons),
- concat (map pcDataConWiredInInfo data_tycons),
-
- -- values
- map pcIdWiredInInfo wired_in_ids,
- primop_ids
- ]
- assoc_tc_wired
- = concat [
- -- tycons
- map pcTyConWiredInInfo prim_tycons,
- map pcTyConWiredInInfo g_tycons,
- map pcTyConWiredInInfo data_tycons
- ]
-
- assoc_keys
- = concat
- [
- id_keys,
- tysyn_keys,
- class_keys,
- class_op_keys
- ]
-
- id_keys = map id_key id_keys_infos
- id_key (str_mod, uniq, info) = (str_mod, (uniq, RnImplicit))
-
- assoc_id_infos = catMaybes (map assoc_info id_keys_infos)
- assoc_info (str_mod, uniq, Just info) = Just (uniq, info)
- assoc_info (str_mod, uniq, Nothing) = Nothing
+type BuiltinNames = Bag Name
+
+builtinNames :: BuiltinNames
+builtinNames
+ = -- Wired in TyCons
+ unionManyBags (map getTyConNames wired_in_tycons) `unionBags`
+
+ -- Wired in Ids
+ listToBag (map getName wired_in_ids) `unionBags`
+
+ -- PrimOps
+ listToBag (map (getName.primOpName) allThePrimOps) `unionBags`
+
+ -- Other names with magic keys
+ listToBag builtinKeys
+\end{code}
+
+
+\begin{code}
+getTyConNames :: TyCon -> Bag Name
+getTyConNames tycon
+ = getName tycon `consBag` listToBag (map getName (tyConDataCons tycon))
+ -- Synonyms return empty list of constructors
\end{code}
sense of them in interface pragmas. It's cool, though they all have
"non-standard" names, so they won't get past the parser in user code.
-The WiredIn TyCons and DataCons ...
+%************************************************************************
+%* *
+\subsection{Wired in TyCons}
+%* *
+%************************************************************************
+
+
\begin{code}
+wired_in_tycons = [mkFunTyCon] ++
+ prim_tycons ++
+ tuple_tycons ++
+ data_tycons
prim_tycons
= [ addrPrimTyCon
, wordPrimTyCon
]
-g_tycons
- = mkFunTyCon : g_con_tycons
-
-g_con_tycons
- = listTyCon : mkTupleTyCon 0 : [mkTupleTyCon i | i <- [2..37] ]
-
-min_nonprim_tycon_list -- used w/ HideMostBuiltinNames
- = [ boolTyCon
- , charTyCon
- , intTyCon
- , floatTyCon
- , doubleTyCon
- , integerTyCon
- , liftTyCon
- , return2GMPsTyCon -- ADR asked for these last two (WDP 94/11)
- , returnIntAndGMPTyCon
- ]
+tuple_tycons = unitTyCon : [tupleTyCon i | i <- [2..37] ]
data_tycons
- = [ addrTyCon
+ = [ listTyCon
+ , addrTyCon
, boolTyCon
, charTyCon
, doubleTyCon
, voidTyCon
, wordTyCon
]
+
+min_nonprim_tycon_list -- used w/ HideMostBuiltinNames
+ = [ boolTyCon
+ , charTyCon
+ , intTyCon
+ , floatTyCon
+ , doubleTyCon
+ , integerTyCon
+ , liftTyCon
+ , return2GMPsTyCon -- ADR asked for these last two (WDP 94/11)
+ , returnIntAndGMPTyCon
+ ]
\end{code}
+%************************************************************************
+%* *
+\subsection{Wired in Ids}
+%* *
+%************************************************************************
+
The WiredIn Ids ...
ToDo: Some of these should be moved to id_keys_infos!
+
\begin{code}
wired_in_ids
= [ aBSENT_ERROR_ID
, augmentId
, buildId
--- , copyableId
, eRROR_ID
, foldlId
, foldrId
--- , forkId
, iRREFUT_PAT_ERROR_ID
, integerMinusOneId
, integerPlusOneId
, nON_EXHAUSTIVE_GUARDS_ERROR_ID
, nO_DEFAULT_METHOD_ERROR_ID
, nO_EXPLICIT_METHOD_ERROR_ID
--- , noFollowId
, pAR_ERROR_ID
, pAT_ERROR_ID
, packStringForCId
--- , parAtAbsId
--- , parAtForNowId
--- , parAtId
--- , parAtRelId
--- , parGlobalId
--- , parId
--- , parLocalId
, rEC_CON_ERROR_ID
, rEC_UPD_ERROR_ID
, realWorldPrimId
, runSTId
--- , seqId
, tRACE_ID
, unpackCString2Id
, unpackCStringAppendId
, unpackCStringFoldrId
, unpackCStringId
, voidId
+
+-- , copyableId
+-- , forkId
+-- , noFollowId
+-- , parAtAbsId
+-- , parAtForNowId
+-- , parAtId
+-- , parAtRelId
+-- , parGlobalId
+-- , parId
+-- , parLocalId
+-- , seqId
]
+\end{code}
-pcTyConWiredInInfo :: TyCon -> (OrigName, RnName)
-pcTyConWiredInInfo tc = (origName "pcTyConWiredInInfo" tc, WiredInTyCon tc)
-pcDataConWiredInInfo :: TyCon -> [(OrigName, RnName)]
-pcDataConWiredInInfo tycon
- = [ (origName "pcDataConWiredInInfo" con, WiredInId con) | con <- tyConDataCons tycon ]
+%************************************************************************
+%* *
+\subsection{Built-in keys}
+%* *
+%************************************************************************
-pcIdWiredInInfo :: Id -> (OrigName, RnName)
-pcIdWiredInInfo id = (origName "pcIdWiredInInfo" id, WiredInId id)
-\end{code}
+Ids, Synonyms, Classes and ClassOps with builtin keys.
-WiredIn primitive numeric operations ...
\begin{code}
-primop_ids
- = map prim_fn allThePrimOps ++ map funny_fn funny_name_primops
- where
- prim_fn op = case (primOpNameInfo op) of (s,n) -> ((OrigName gHC_BUILTINS s),n)
- funny_fn (op,s) = case (primOpNameInfo op) of (_,n) -> ((OrigName gHC_BUILTINS s),n)
-
-funny_name_primops
- = [ (IntAddOp, SLIT("+#"))
- , (IntSubOp, SLIT("-#"))
- , (IntMulOp, SLIT("*#"))
- , (IntGtOp, SLIT(">#"))
- , (IntGeOp, SLIT(">=#"))
- , (IntEqOp, SLIT("==#"))
- , (IntNeOp, SLIT("/=#"))
- , (IntLtOp, SLIT("<#"))
- , (IntLeOp, SLIT("<=#"))
- , (DoubleAddOp, SLIT("+##"))
- , (DoubleSubOp, SLIT("-##"))
- , (DoubleMulOp, SLIT("*##"))
- , (DoubleDivOp, SLIT("/##"))
- , (DoublePowerOp, SLIT("**##"))
- , (DoubleGtOp, SLIT(">##"))
- , (DoubleGeOp, SLIT(">=##"))
- , (DoubleEqOp, SLIT("==##"))
- , (DoubleNeOp, SLIT("/=##"))
- , (DoubleLtOp, SLIT("<##"))
- , (DoubleLeOp, SLIT("<=##"))
+getKeyOrig :: (Module, OccName, Unique) -> Name
+getKeyOrig (mod, occ, uniq) = mkGlobalName uniq mod occ VanillaDefn Implicit
+
+builtinKeys :: [Name]
+builtinKeys
+ = map getKeyOrig
+ [
+ -- Type constructors (synonyms especially)
+ (iO_BASE, TCOcc SLIT("IO"), iOTyConKey)
+ , (pREL_BASE, TCOcc SLIT("Ordering"), orderingTyConKey)
+ , (pREL_NUM, TCOcc SLIT("Rational"), rationalTyConKey)
+ , (pREL_NUM, TCOcc SLIT("Ratio"), ratioTyConKey)
+
+
+ -- Classes. *Must* include:
+ -- classes that are grabbed by key (e.g., eqClassKey)
+ -- classes in "Class.standardClassKeys" (quite a few)
+ , (pREL_BASE, TCOcc SLIT("Eq"), eqClassKey) -- mentioned, derivable
+ , (pREL_BASE, TCOcc SLIT("Eval"), evalClassKey) -- mentioned
+ , (pREL_BASE, TCOcc SLIT("Ord"), ordClassKey) -- derivable
+ , (pREL_BASE, TCOcc SLIT("Bounded"), boundedClassKey) -- derivable
+ , (pREL_BASE, TCOcc SLIT("Num"), numClassKey) -- mentioned, numeric
+ , (pREL_BASE, TCOcc SLIT("Enum"), enumClassKey) -- derivable
+ , (pREL_BASE, TCOcc SLIT("Monad"), monadClassKey)
+ , (pREL_BASE, TCOcc SLIT("MonadZero"), monadZeroClassKey)
+ , (pREL_BASE, TCOcc SLIT("MonadPlus"), monadPlusClassKey)
+ , (pREL_BASE, TCOcc SLIT("Functor"), functorClassKey)
+ , (pREL_BASE, TCOcc SLIT("Show"), showClassKey) -- derivable
+ , (pREL_NUM, TCOcc SLIT("Real"), realClassKey) -- numeric
+ , (pREL_NUM, TCOcc SLIT("Integral"), integralClassKey) -- numeric
+ , (pREL_NUM, TCOcc SLIT("Fractional"), fractionalClassKey) -- numeric
+ , (pREL_NUM, TCOcc SLIT("Floating"), floatingClassKey) -- numeric
+ , (pREL_NUM, TCOcc SLIT("RealFrac"), realFracClassKey) -- numeric
+ , (pREL_NUM, TCOcc SLIT("RealFloat"), realFloatClassKey) -- numeric
+ , (pREL_READ, TCOcc SLIT("Read"), readClassKey) -- derivable
+ , (iX, TCOcc SLIT("Ix"), ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm)
+ , (fOREIGN, TCOcc SLIT("CCallable"), cCallableClassKey) -- mentioned, ccallish
+ , (fOREIGN, TCOcc SLIT("CReturnable"), cReturnableClassKey) -- mentioned, ccallish
+
+
+ -- ClassOps
+ , (pREL_BASE, VarOcc SLIT("fromInt"), fromIntClassOpKey)
+ , (pREL_BASE, VarOcc SLIT("fromInteger"), fromIntegerClassOpKey)
+ , (pREL_BASE, VarOcc SLIT("enumFrom"), enumFromClassOpKey)
+ , (pREL_BASE, VarOcc SLIT("enumFromThen"), enumFromThenClassOpKey)
+ , (pREL_BASE, VarOcc SLIT("enumFromTo"), enumFromToClassOpKey)
+ , (pREL_BASE, VarOcc SLIT("enumFromThenTo"), enumFromThenToClassOpKey)
+ , (pREL_BASE, VarOcc SLIT("fromEnum"), fromEnumClassOpKey)
+ , (pREL_BASE, VarOcc SLIT("=="), eqClassOpKey)
+ , (pREL_BASE, VarOcc SLIT(">>="), thenMClassOpKey)
+ , (pREL_BASE, VarOcc SLIT("zero"), zeroClassOpKey)
+ , (pREL_NUM, VarOcc SLIT("fromRational"), fromRationalClassOpKey)
]
\end{code}
+ToDo: make it do the ``like'' part properly (as in 0.26 and before).
-Ids, Synonyms, Classes and ClassOps with builtin keys.
-For the Ids we may also have some builtin IdInfo.
\begin{code}
-id_keys_infos :: [(OrigName, Unique, Maybe IdInfo)]
-id_keys_infos
- = [ -- here because we use them in derived instances
- (OrigName pRELUDE SLIT("&&"), andandIdKey, Nothing)
- , (OrigName pRELUDE SLIT("."), composeIdKey, 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)
- , (OrigName pRELUDE SLIT("showString"), showStringIdKey,Nothing)
- , (OrigName gHC__ SLIT("readList__"), ureadListIdKey, Nothing)
- , (OrigName gHC__ SLIT("showList__"), ushowListIdKey, Nothing)
- , (OrigName gHC__ SLIT("showSpace"), showSpaceIdKey, Nothing)
- ]
+maybeCharLikeTyCon tc = if (uniqueOf tc == charDataConKey) then Just charDataCon else Nothing
+maybeIntLikeTyCon tc = if (uniqueOf tc == intDataConKey) then Just intDataCon else Nothing
+\end{code}
-tysyn_keys
- = [ (OrigName gHC__ SLIT("IO"), (iOTyConKey, RnImplicitTyCon))
- , (OrigName pRELUDE SLIT("Ordering"), (orderingTyConKey, RnImplicitTyCon))
- , (OrigName rATIO SLIT("Rational"), (rationalTyConKey, RnImplicitTyCon))
- , (OrigName rATIO SLIT("Ratio"), (ratioTyConKey, RnImplicitTyCon))
- ]
+%************************************************************************
+%* *
+\subsection{Commonly-used RdrNames}
+%* *
+%************************************************************************
--- this "class_keys" list *must* include:
--- classes that are grabbed by key (e.g., eqClassKey)
--- classes in "Class.standardClassKeys" (quite a few)
-
-class_keys
- = [ (str_mod, (k, RnImplicitClass)) | (str_mod,k) <-
- [ (OrigName pRELUDE SLIT("Eq"), eqClassKey) -- mentioned, derivable
- , (OrigName pRELUDE SLIT("Eval"), evalClassKey) -- mentioned
- , (OrigName pRELUDE SLIT("Ord"), ordClassKey) -- derivable
- , (OrigName pRELUDE SLIT("Num"), numClassKey) -- mentioned, numeric
- , (OrigName pRELUDE SLIT("Real"), realClassKey) -- numeric
- , (OrigName pRELUDE SLIT("Integral"), integralClassKey) -- numeric
- , (OrigName pRELUDE SLIT("Fractional"), fractionalClassKey) -- numeric
- , (OrigName pRELUDE SLIT("Floating"), floatingClassKey) -- numeric
- , (OrigName pRELUDE SLIT("RealFrac"), realFracClassKey) -- numeric
- , (OrigName pRELUDE SLIT("RealFloat"), realFloatClassKey) -- numeric
- , (OrigName iX SLIT("Ix"), ixClassKey) -- derivable (but it isn't Prelude.Ix; hmmm)
- , (OrigName pRELUDE SLIT("Bounded"), boundedClassKey) -- derivable
- , (OrigName pRELUDE SLIT("Enum"), enumClassKey) -- derivable
- , (OrigName pRELUDE SLIT("Show"), showClassKey) -- derivable
- , (OrigName pRELUDE SLIT("Read"), readClassKey) -- derivable
- , (OrigName pRELUDE SLIT("Monad"), monadClassKey)
- , (OrigName pRELUDE SLIT("MonadZero"), monadZeroClassKey)
- , (OrigName pRELUDE SLIT("MonadPlus"), monadPlusClassKey)
- , (OrigName pRELUDE SLIT("Functor"), functorClassKey)
- , (OrigName gHC__ SLIT("CCallable"), cCallableClassKey) -- mentioned, ccallish
- , (OrigName gHC__ SLIT("CReturnable"), cReturnableClassKey) -- mentioned, ccallish
- ]]
-
-class_op_keys
- = [ (str_mod, (k, RnImplicit)) | (str_mod,k) <-
- [ (OrigName pRELUDE SLIT("fromInt"), fromIntClassOpKey)
- , (OrigName pRELUDE SLIT("fromInteger"), fromIntegerClassOpKey)
- , (OrigName pRELUDE SLIT("fromRational"), fromRationalClassOpKey)
- , (OrigName pRELUDE SLIT("enumFrom"), enumFromClassOpKey)
- , (OrigName pRELUDE SLIT("enumFromThen"), enumFromThenClassOpKey)
- , (OrigName pRELUDE SLIT("enumFromTo"), enumFromToClassOpKey)
- , (OrigName pRELUDE SLIT("enumFromThenTo"),enumFromThenToClassOpKey)
- , (OrigName pRELUDE SLIT("=="), eqClassOpKey)
- , (OrigName pRELUDE SLIT(">>="), thenMClassOpKey)
- , (OrigName pRELUDE SLIT("zero"), zeroClassOpKey)
- ]]
+These RdrNames are not really "built in", but some parts of the compiler
+(notably the deriving mechanism) need to mention their names, and it's convenient
+to write them all down in one place.
+
+\begin{code}
+prelude_primop op = qual (modAndOcc (primOpName op))
+
+eqClass_RDR = tcQual (pREL_BASE, SLIT("Eq"))
+ordClass_RDR = tcQual (pREL_BASE, SLIT("Ord"))
+evalClass_RDR = tcQual (pREL_BASE, SLIT("Eval"))
+monadZeroClass_RDR = tcQual (pREL_BASE, SLIT("MonadZero"))
+enumClass_RDR = tcQual (pREL_BASE, SLIT("Enum"))
+numClass_RDR = tcQual (pREL_BASE, SLIT("Num"))
+fractionalClass_RDR = tcQual (pREL_NUM, SLIT("Fractional"))
+ccallableClass_RDR = tcQual (fOREIGN, SLIT("CCallable"))
+creturnableClass_RDR = tcQual (fOREIGN, SLIT("CReturnable"))
+
+negate_RDR = varQual (pREL_BASE, SLIT("negate"))
+eq_RDR = varQual (pREL_BASE, SLIT("=="))
+ne_RDR = varQual (pREL_BASE, SLIT("/="))
+le_RDR = varQual (pREL_BASE, SLIT("<="))
+lt_RDR = varQual (pREL_BASE, SLIT("<"))
+ge_RDR = varQual (pREL_BASE, SLIT(">="))
+gt_RDR = varQual (pREL_BASE, SLIT(">"))
+ltTag_RDR = varQual (pREL_BASE, SLIT("LT"))
+eqTag_RDR = varQual (pREL_BASE, SLIT("EQ"))
+gtTag_RDR = varQual (pREL_BASE, SLIT("GT"))
+max_RDR = varQual (pREL_BASE, SLIT("max"))
+min_RDR = varQual (pREL_BASE, SLIT("min"))
+compare_RDR = varQual (pREL_BASE, SLIT("compare"))
+minBound_RDR = varQual (pREL_BASE, SLIT("minBound"))
+maxBound_RDR = varQual (pREL_BASE, SLIT("maxBound"))
+false_RDR = varQual (pREL_BASE, SLIT("False"))
+true_RDR = varQual (pREL_BASE, SLIT("True"))
+and_RDR = varQual (pREL_BASE, SLIT("&&"))
+not_RDR = varQual (pREL_BASE, SLIT("not"))
+compose_RDR = varQual (pREL_BASE, SLIT("."))
+append_RDR = varQual (pREL_BASE, SLIT("++"))
+map_RDR = varQual (pREL_BASE, SLIT("map"))
+
+showList___RDR = varQual (pREL_BASE, SLIT("showList__"))
+showsPrec_RDR = varQual (pREL_BASE, SLIT("showsPrec"))
+showList_RDR = varQual (pREL_BASE, SLIT("showList"))
+showSpace_RDR = varQual (pREL_BASE, SLIT("showSpace"))
+showString_RDR = varQual (pREL_BASE, SLIT("showString"))
+showParen_RDR = varQual (pREL_BASE, SLIT("showParen"))
+
+range_RDR = varQual (iX, SLIT("range"))
+index_RDR = varQual (iX, SLIT("index"))
+inRange_RDR = varQual (iX, SLIT("inRange"))
+
+readsPrec_RDR = varQual (pREL_READ, SLIT("readsPrec"))
+readList_RDR = varQual (pREL_READ, SLIT("readList"))
+readParen_RDR = varQual (pREL_READ, SLIT("readParen"))
+lex_RDR = varQual (pREL_READ, SLIT("lex"))
+readList___RDR = varQual (pREL_READ, SLIT("readList__"))
+
+fromEnum_RDR = varQual (pREL_BASE, SLIT("fromEnum"))
+enumFrom_RDR = varQual (pREL_BASE, SLIT("enumFrom"))
+enumFromTo_RDR = varQual (pREL_BASE, SLIT("enumFromTo"))
+enumFromThen_RDR = varQual (pREL_BASE, SLIT("enumFromThen"))
+enumFromThenTo_RDR = varQual (pREL_BASE, SLIT("enumFromThenTo"))
+plus_RDR = varQual (pREL_BASE, SLIT("+"))
+times_RDR = varQual (pREL_BASE, SLIT("*"))
+mkInt_RDR = varQual (pREL_BASE, SLIT("I#"))
+
+error_RDR = varQual (iO_BASE, SLIT("error"))
+
+eqH_Char_RDR = prelude_primop CharEqOp
+ltH_Char_RDR = prelude_primop CharLtOp
+eqH_Word_RDR = prelude_primop WordEqOp
+ltH_Word_RDR = prelude_primop WordLtOp
+eqH_Addr_RDR = prelude_primop AddrEqOp
+ltH_Addr_RDR = prelude_primop AddrLtOp
+eqH_Float_RDR = prelude_primop FloatEqOp
+ltH_Float_RDR = prelude_primop FloatLtOp
+eqH_Double_RDR = prelude_primop DoubleEqOp
+ltH_Double_RDR = prelude_primop DoubleLtOp
+eqH_Int_RDR = prelude_primop IntEqOp
+ltH_Int_RDR = prelude_primop IntLtOp
+geH_RDR = prelude_primop IntGeOp
+leH_RDR = prelude_primop IntLeOp
+minusH_RDR = prelude_primop IntSubOp
+
+intType_RDR = qual (modAndOcc intTyCon)
\end{code}
-ToDo: make it do the ``like'' part properly (as in 0.26 and before).
+%************************************************************************
+%* *
+\subsection[Class-std-groups]{Standard groups of Prelude classes}
+%* *
+%************************************************************************
+
+@derivableClassKeys@ is also used in checking \tr{deriving} constructs
+(@TcDeriv@).
+
+@derivingOccurrences@ maps a class name to a list of the (qualified) occurrences
+that will be mentioned by the derived code for the class when it is later generated.
+We don't need to put in things that are WiredIn (because they are already mapped to their
+correct name by the @NameSupply@. The class itself, and all its class ops, is
+already flagged as an occurrence so we don't need to mention that either.
+
+@derivingOccurrences@ has an item for every derivable class, even if that item is empty,
+because we treat lookup failure as indicating that the class is illegal in a deriving clause.
+
\begin{code}
-maybeCharLikeTyCon tc = if (uniqueOf tc == charDataConKey) then Just charDataCon else Nothing
-maybeIntLikeTyCon tc = if (uniqueOf tc == intDataConKey) then Just intDataCon else Nothing
+derivingOccurrences :: UniqFM [RdrName]
+derivingOccurrences = listToUFM deriving_occ_info
+
+derivableClassKeys = map fst deriving_occ_info
+
+deriving_occ_info
+ = [ (eqClassKey, [intType_RDR, and_RDR, not_RDR])
+ , (ordClassKey, [intType_RDR, compose_RDR])
+ , (enumClassKey, [intType_RDR, map_RDR])
+ , (evalClassKey, [intType_RDR])
+ , (boundedClassKey, [intType_RDR])
+ , (showClassKey, [intType_RDR, numClass_RDR, ordClass_RDR, compose_RDR, showString_RDR,
+ showParen_RDR, showSpace_RDR, showList___RDR])
+ , (readClassKey, [intType_RDR, numClass_RDR, ordClass_RDR, append_RDR,
+ lex_RDR, readParen_RDR, readList___RDR])
+ , (ixClassKey, [intType_RDR, numClass_RDR, and_RDR, map_RDR])
+ ]
+ -- intType: Practically any deriving needs Int, either for index calculations,
+ -- or for taggery.
+ -- ordClass: really it's the methods that are actually used.
+ -- numClass: for Int literals
+\end{code}
+
+
+NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@
+even though every numeric class has these two as a superclass,
+because the list of ambiguous dictionaries hasn't been simplified.
+
+\begin{code}
+isCcallishClass, isNoDictClass, isNumericClass, isStandardClass :: Class -> Bool
+
+isNumericClass clas = classKey clas `is_elem` numericClassKeys
+isStandardClass clas = classKey clas `is_elem` standardClassKeys
+isCcallishClass clas = classKey clas `is_elem` cCallishClassKeys
+isNoDictClass clas = classKey clas `is_elem` noDictClassKeys
+is_elem = isIn "is_X_Class"
+
+numericClassKeys
+ = [ numClassKey
+ , realClassKey
+ , integralClassKey
+ , fractionalClassKey
+ , floatingClassKey
+ , realFracClassKey
+ , realFloatClassKey
+ ]
+
+needsDataDeclCtxtClassKeys -- see comments in TcDeriv
+ = [ readClassKey
+ ]
+
+cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
+
+standardClassKeys
+ = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
+ --
+ -- We have to have "CCallable" and "CReturnable" in the standard
+ -- classes, so that if you go...
+ --
+ -- _ccall_ foo ... 93{-numeric literal-} ...
+ --
+ -- ... it can do The Right Thing on the 93.
+
+noDictClassKeys -- These classes are used only for type annotations;
+ -- they are not implemented by dictionaries, ever.
+ = cCallishClassKeys
+ -- I used to think that class Eval belonged in here, but
+ -- we really want functions with type (Eval a => ...) and that
+ -- means that we really want to pass a placeholder for an Eval
+ -- dictionary. The unit tuple is what we'll get if we leave things
+ -- alone, and that'll do for now. Could arrange to drop that parameter
+ -- in the end.
\end{code}
import Class ( GenClass )
import CoreUnfold ( mkMagicUnfolding, Unfolding )
-import IdUtils ( primOpNameInfo )
-import Name ( Name, OrigName, mkPrimitiveName, mkWiredInName, ExportFlag )
+import IdUtils ( primOpName )
+import Name ( Name, ExportFlag )
import PrimOp ( PrimOp )
import RnHsSyn ( RnName )
import Type ( mkSigmaTy, mkFunTy, mkFunTys, GenType )
import Usage ( GenUsage )
mkMagicUnfolding :: Unique -> Unfolding
-mkPrimitiveName :: 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
mkFunTy :: GenType a b -> GenType a b -> GenType a b
-primOpNameInfo :: PrimOp -> (_PackedString, RnName)
+primOpName :: PrimOp -> Name
\end{code}
\begin{code}
#include "HsVersions.h"
-module PrelMods (
- gHC_BUILTINS, -- things that are really and truly primitive
- pRELUDE, gHC__,
- rATIO, iX,
- modulesWithBuiltins
- ) where
+module PrelMods where
CHK_Ubiq() -- debugging consistency check
\end{code}
\begin{code}
+gHC__ = SLIT("GHC") -- Primitive types and values
+
pRELUDE = SLIT("Prelude")
-gHC_BUILTINS = SLIT("GHCbuiltins") -- the truly-primitive things
-gHC__ = SLIT("GHCbase") -- all GHC basics, add-ons, extras, everything
- -- (which can be defined in Haskell)
+pREL_BASE = SLIT("PrelBase")
+pREL_READ = SLIT("PrelRead")
+pREL_NUM = SLIT("PrelNum")
+pREL_LIST = SLIT("PrelList")
+pREL_TUP = SLIT("PrelTup")
+pACKED_STRING= SLIT("PackedString")
+cONC_BASE = SLIT("ConcBase")
+iO_BASE = SLIT("IOBase")
+mONAD = SLIT("Monad")
rATIO = SLIT("Ratio")
iX = SLIT("Ix")
+sT_BASE = SLIT("STBase")
+aRR_BASE = SLIT("ArrBase")
+fOREIGN = SLIT("Foreign")
-modulesWithBuiltins = [ gHC_BUILTINS, gHC__, pRELUDE, rATIO, iX ]
+mAIN = SLIT("Main")
+gHC_MAIN = SLIT("GHCmain")
+gHC_ERR = SLIT("GHCerr")
\end{code}
IMP_Ubiq()
IMPORT_DELOOPER(IdLoop) ( UnfoldingGuidance(..), nullSpecEnv, SpecEnv )
-import Id ( SYN_IE(Id), GenId, mkImported, mkUserId, mkTemplateLocals )
+import Id ( SYN_IE(Id), GenId, mkImported, mkTemplateLocals )
IMPORT_DELOOPER(PrelLoop)
-- friends:
import CoreSyn -- quite a bit
import IdInfo -- quite a bit
import Literal ( mkMachInt )
-import Name ( ExportFlag(..) )
+import Name ( mkWiredInIdName )
import PragmaInfo
import PrimOp ( PrimOp(..) )
import Type ( mkTyVarTy )
\begin{code}
-- only used herein:
-pcMiscPrelId :: Unique{-IdKey-} -> FAST_STRING -> FAST_STRING -> Type -> IdInfo -> Id
+pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
-pcMiscPrelId key m n ty info
+pcMiscPrelId key mod occ ty info
= let
- name = mkWiredInName key (OrigName m n) ExportAll
+ name = mkWiredInIdName key mod occ imp
imp = mkImported name ty info -- the usual case...
in
imp
pc_bottoming_Id key mod name ty
= pcMiscPrelId key mod name ty bottoming_info
where
- bottoming_info = noIdInfo `addInfo` mkBottomStrictnessInfo
+ bottoming_info = noIdInfo `addStrictnessInfo` mkBottomStrictnessInfo
-- these "bottom" out, no matter what their arguments
eRROR_ID
- = pc_bottoming_Id errorIdKey pRELUDE SLIT("error") errorTy
+ = pc_bottoming_Id errorIdKey iO_BASE SLIT("error") errorTy
generic_ERROR_ID u n
- = pc_bottoming_Id u SLIT("GHCerr") n errorTy
+ = pc_bottoming_Id u gHC_ERR n errorTy
pAT_ERROR_ID
= generic_ERROR_ID patErrorIdKey SLIT("patError")
= generic_ERROR_ID nonExplicitMethodErrorIdKey SLIT("noExplicitMethodError")
aBSENT_ERROR_ID
- = pc_bottoming_Id absentErrorIdKey SLIT("GHCerr") SLIT("absentErr")
+ = pc_bottoming_Id absentErrorIdKey gHC_ERR SLIT("absentErr")
(mkSigmaTy [openAlphaTyVar] [] openAlphaTy)
pAR_ERROR_ID
- = pcMiscPrelId parErrorIdKey SLIT("GHCerr") SLIT("parError")
+ = pcMiscPrelId parErrorIdKey gHC_ERR SLIT("parError")
(mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noIdInfo
openAlphaTy = mkTyVarTy openAlphaTyVar
and make a jolly old mess.
\begin{code}
tRACE_ID
- = pcMiscPrelId traceIdKey gHC__ SLIT("trace") traceTy
- (noIdInfo `addInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
+ = pcMiscPrelId traceIdKey iO_BASE SLIT("trace") traceTy
+ (noIdInfo `addSpecInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
where
traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
\end{code}
\begin{code}
packStringForCId
- = pcMiscPrelId packCStringIdKey{-ToDo:rename-} gHC__ SLIT("packStringForC__")
+ = pcMiscPrelId packCStringIdKey{-ToDo:rename-} pACKED_STRING SLIT("packCString#")
(mkFunTys [stringTy] byteArrayPrimTy) noIdInfo
--------------------------------------------------------------------
unpackCStringId
- = pcMiscPrelId unpackCStringIdKey gHC__ SLIT("unpackPS__")
+ = pcMiscPrelId unpackCStringIdKey pACKED_STRING SLIT("unpackCString#")
(mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
-- Andy says:
--- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
+-- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` exactArity 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 pACKED_STRING SLIT("unpackCString2#")
(mkFunTys [addrPrimTy{-a char *-}, intPrimTy{-length-}] stringTy)
noIdInfo
--------------------------------------------------------------------
unpackCStringAppendId
- = pcMiscPrelId unpackCStringAppendIdKey gHC__ SLIT("unpackAppendPS__")
+ = pcMiscPrelId unpackCStringAppendIdKey pACKED_STRING SLIT("unpackAppendCString#")
(mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
((noIdInfo
- {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringAppendIdKey-})
- `addInfo` mkArityInfo 2)
+ {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringAppendIdKey-})
+ `addArityInfo` exactArity 2)
unpackCStringFoldrId
- = pcMiscPrelId unpackCStringFoldrIdKey gHC__ SLIT("unpackFoldrPS__")
+ = pcMiscPrelId unpackCStringFoldrIdKey pACKED_STRING SLIT("unpackFoldrCString#")
(mkSigmaTy [alphaTyVar] []
(mkFunTys [addrPrimTy{-a "char *" pointer-},
mkFunTys [charTy, alphaTy] alphaTy,
alphaTy]
alphaTy))
((noIdInfo
- {-LATER:`addInfo_UF` mkMagicUnfolding unpackCStringFoldrIdKey-})
- `addInfo` mkArityInfo 3)
+ {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringFoldrIdKey-})
+ `addArityInfo` exactArity 3)
\end{code}
OK, this is Will's idea: we should have magic values for Integers 0,
+1, +2, and -1 (go ahead, fire me):
+
\begin{code}
integerZeroId
- = pcMiscPrelId integerZeroIdKey gHC__ SLIT("integer_0") integerTy noIdInfo
+ = pcMiscPrelId integerZeroIdKey pREL_NUM SLIT("integer_0") integerTy noIdInfo
integerPlusOneId
- = pcMiscPrelId integerPlusOneIdKey gHC__ SLIT("integer_1") integerTy noIdInfo
+ = pcMiscPrelId integerPlusOneIdKey pREL_NUM SLIT("integer_1") integerTy noIdInfo
integerPlusTwoId
- = pcMiscPrelId integerPlusTwoIdKey gHC__ SLIT("integer_2") integerTy noIdInfo
+ = pcMiscPrelId integerPlusTwoIdKey pREL_NUM SLIT("integer_2") integerTy noIdInfo
integerMinusOneId
- = pcMiscPrelId integerMinusOneIdKey gHC__ SLIT("integer_m1") integerTy noIdInfo
+ = pcMiscPrelId integerMinusOneIdKey pREL_NUM SLIT("integer_m1") integerTy noIdInfo
\end{code}
%************************************************************************
-}
-seqId = pcMiscPrelId seqIdKey gHC__ SLIT("seq")
+seqId = pcMiscPrelId seqIdKey pRELUDE SLIT("seq")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [alphaTy, betaTy] betaTy))
- (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding seq_template))
+ (noIdInfo `addUnfoldInfo` (mkUnfolding True seq_template))
where
[x, y, z]
= mkTemplateLocals [
par = /\ a b -> \ x::a y::b -> case par# x of { 0# -> parError#; _ -> y; }
-}
-parId = pcMiscPrelId parIdKey gHC__ SLIT("par")
+parId = pcMiscPrelId parIdKey cONC_BASE SLIT("par")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [alphaTy, betaTy] betaTy))
- (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding par_template))
+ (noIdInfo `addUnfoldInfo` (mkUnfolding True par_template))
where
[x, y, z]
= mkTemplateLocals [
{-
_fork_ = /\ a b -> \ x::a y::b -> case fork# x of { 0# -> parError#; _ -> y; }
-}
-forkId = pcMiscPrelId forkIdKey gHC__ SLIT("fork")
+forkId = pcMiscPrelId forkIdKey cONC_BASE SLIT("fork")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [alphaTy, betaTy] betaTy))
- (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding fork_template))
+ (noIdInfo `addUnfoldInfo` (mkUnfolding True fork_template))
where
[x, y, z]
= mkTemplateLocals [
GranSim ones:
\begin{code}
{- OUT:
-parLocalId = pcMiscPrelId parLocalIdKey gHC__ SLIT("parLocal")
+parLocalId = pcMiscPrelId parLocalIdKey cONC_BASE SLIT("parLocal")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
- (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parLocal_template))
+ (noIdInfo `addUnfoldInfo` (mkUnfolding True parLocal_template))
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, x, y, z]
[(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
(BindDefault z (Var y))))
-parGlobalId = pcMiscPrelId parGlobalIdKey gHC__ SLIT("parGlobal")
+parGlobalId = pcMiscPrelId parGlobalIdKey cONC_BASE SLIT("parGlobal")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
- (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parGlobal_template))
+ (noIdInfo `addUnfoldInfo` (mkUnfolding True parGlobal_template))
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, x, y, z]
(BindDefault z (Var y))))
-parAtId = pcMiscPrelId parAtIdKey gHC__ SLIT("parAt")
+parAtId = pcMiscPrelId parAtIdKey cONC_BASE SLIT("parAt")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
alphaTy, betaTy, gammaTy] gammaTy))
- (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAt_template))
+ (noIdInfo `addUnfoldInfo` (mkUnfolding True parAt_template))
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, v, x, y, z]
[(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [gammaTy])]
(BindDefault z (Var y))))
-parAtAbsId = pcMiscPrelId parAtAbsIdKey gHC__ SLIT("parAtAbs")
+parAtAbsId = pcMiscPrelId parAtAbsIdKey cONC_BASE SLIT("parAtAbs")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
- (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtAbs_template))
+ (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtAbs_template))
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, v, x, y, z]
[(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
(BindDefault z (Var y))))
-parAtRelId = pcMiscPrelId parAtRelIdKey gHC__ SLIT("parAtRel")
+parAtRelId = pcMiscPrelId parAtRelIdKey cONC_BASE SLIT("parAtRel")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
- (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtRel_template))
+ (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtRel_template))
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, v, x, y, z]
[(mkMachInt 0, mkTyApp (Var pAR_ERROR_ID) [betaTy])]
(BindDefault z (Var y))))
-parAtForNowId = pcMiscPrelId parAtForNowIdKey gHC__ SLIT("parAtForNow")
+parAtForNowId = pcMiscPrelId parAtForNowIdKey cONC_BASE SLIT("parAtForNow")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
alphaTy, betaTy, gammaTy] gammaTy))
- (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding parAtForNow_template))
+ (noIdInfo `addUnfoldInfo` (mkUnfolding True parAtForNow_template))
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, v, x, y, z]
-- copyable and noFollow are currently merely hooks: they are translated into
-- calls to the macros COPYABLE and NOFOLLOW -- HWL
-copyableId = pcMiscPrelId copyableIdKey gHC__ SLIT("copyable")
+copyableId = pcMiscPrelId copyableIdKey cONC_BASE SLIT("copyable")
(mkSigmaTy [alphaTyVar] []
alphaTy)
- (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding copyable_template))
+ (noIdInfo `addUnfoldInfo` (mkUnfolding True copyable_template))
where
-- Annotations: x: closure that's tagged to by copyable
[x, z]
copyable_template
= mkLam [alphaTyVar] [x] ( Prim CopyableOp [TyArg alphaTy, VarArg x] )
-noFollowId = pcMiscPrelId noFollowIdKey gHC__ SLIT("noFollow")
+noFollowId = pcMiscPrelId noFollowIdKey cONC_BASE SLIT("noFollow")
(mkSigmaTy [alphaTyVar] []
alphaTy)
- (noIdInfo `addInfo_UF` (mkUnfolding EssentialUnfolding noFollow_template))
+ (noIdInfo `addUnfoldInfo` (mkUnfolding True noFollow_template))
where
-- Annotations: x: closure that's tagged to not follow
[x, z]
We unfold always, just for simplicity:
\begin{code}
runSTId
- = pcMiscPrelId runSTIdKey gHC__ SLIT("runST") run_ST_ty id_info
+ = pcMiscPrelId runSTIdKey sT_BASE SLIT("runST") run_ST_ty id_info
where
s_tv = betaTyVar
s = betaTy
id_info
= noIdInfo
- `addInfo` mkArityInfo 1
- `addInfo` mkStrictnessInfo [WwStrict] Nothing
- `addInfo` mkArgUsageInfo [ArgUsage 1]
- -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template)
+ `addArityInfo` exactArity 1
+ `addStrictnessInfo` mkStrictnessInfo [WwStrict] Nothing
+ `addArgUsageInfo` mkArgUsageInfo [ArgUsage 1]
+ -- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding True run_ST_template)
-- see example below
{- OUT:
[m, t, r, wild]
Let (NonRec t (Con stateDataCon [TyArg realWorldTy, VarArg realWorldPrimId])) (
Case (App (mkTyApp (Var m) [realWorldTy]) (VarArg t)) (
AlgAlts
- [(mkTupleCon 2, [r, wild], Var r)]
+ [(pairDataCon, [r, wild], Var r)]
NoDefault)))
-}
\end{code}
nasty as-is, change it back to a literal (@Literal@).
\begin{code}
realWorldPrimId
- = pcMiscPrelId realWorldPrimIdKey gHC_BUILTINS SLIT("realWorld#")
+ = pcMiscPrelId realWorldPrimIdKey gHC__ SLIT("realWorld#")
realWorldStatePrimTy
noIdInfo
\end{code}
\begin{code}
-voidId = pcMiscPrelId voidIdKey gHC_BUILTINS SLIT("void") voidTy noIdInfo
+voidId = pcMiscPrelId voidIdKey gHC__ SLIT("void") voidTy noIdInfo
\end{code}
%************************************************************************
\begin{code}
buildId
- = pcMiscPrelId buildIdKey SLIT("GHCerr") SLIT("build") buildTy
+ = pcMiscPrelId buildIdKey gHC_ERR SLIT("build") buildTy
((((noIdInfo
- {-LATER:`addInfo_UF` mkMagicUnfolding buildIdKey-})
- `addInfo` mkStrictnessInfo [WwStrict] Nothing)
- `addInfo` mkArgUsageInfo [ArgUsage 2])
- `addInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
+ {-LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey-})
+ `addStrictnessInfo` mkStrictnessInfo [WwStrict] Nothing)
+ `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2])
+ `addSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
-- cheating, but since _build never actually exists ...
where
-- The type of this strange object is:
\begin{code}
augmentId
- = pcMiscPrelId augmentIdKey SLIT("GHCerr") SLIT("augment") augmentTy
+ = pcMiscPrelId augmentIdKey gHC_ERR SLIT("augment") augmentTy
(((noIdInfo
- {-LATER:`addInfo_UF` mkMagicUnfolding augmentIdKey-})
- `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
- `addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
+ {-LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey-})
+ `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
+ `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
-- cheating, but since _augment never actually exists ...
where
-- The type of this strange object is:
\end{code}
\begin{code}
-foldrId = pcMiscPrelId foldrIdKey pRELUDE SLIT("foldr")
+foldrId = pcMiscPrelId foldrIdKey pREL_BASE SLIT("foldr")
foldrTy idInfo
where
foldrTy =
(mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
idInfo = (((((noIdInfo
- {-LATER:`addInfo_UF` mkMagicUnfolding foldrIdKey-})
- `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
- `addInfo` mkArityInfo 3)
- `addInfo` mkUpdateInfo [2,2,1])
- `addInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
+ {-LATER:`addUnfoldInfo` mkMagicUnfolding foldrIdKey-})
+ `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
+ `addArityInfo` exactArity 3)
+ `addUpdateInfo` mkUpdateInfo [2,2,1])
+ `addSpecInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
-foldlId = pcMiscPrelId foldlIdKey pRELUDE SLIT("foldl")
+foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl")
foldlTy idInfo
where
foldlTy =
(mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
idInfo = (((((noIdInfo
- {-LATER:`addInfo_UF` mkMagicUnfolding foldlIdKey-})
- `addInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
- `addInfo` mkArityInfo 3)
- `addInfo` mkUpdateInfo [2,2,1])
- `addInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
+ {-LATER:`addUnfoldInfo` mkMagicUnfolding foldlIdKey-})
+ `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] Nothing)
+ `addArityInfo` exactArity 3)
+ `addUpdateInfo` mkUpdateInfo [2,2,1])
+ `addSpecInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
-- A bit of magic goes no here. We translate appendId into ++,
-- you have to be carefull when you actually compile append:
--
{- OLD: doesn't apply with 1.3
appendId
- = pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo
+ = pcMiscPrelId appendIdKey mONAD SLIT("++") appendTy idInfo
where
appendTy =
(mkSigmaTy [alphaTyVar] []
(mkFunTys [mkListTy alphaTy, mkListTy alphaTy] (mkListTy alphaTy)))
idInfo = (((noIdInfo
- `addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
- `addInfo` mkArityInfo 2)
- `addInfo` mkUpdateInfo [1,2])
+ `addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
+ `addArityInfo` exactArity 2)
+ `addUpdateInfo` mkUpdateInfo [1,2])
-}
\end{code}
import TysWiredIn
import CStrings ( identToC )
-import CgCompInfo ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
+import Constants ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset )
import PprStyle ( codeStyle{-, PprStyle(..) ToDo:rm-} )
import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} )
primOpInfo CharLtOp = Compare SLIT("ltChar#") charPrimTy
primOpInfo CharLeOp = Compare SLIT("leChar#") charPrimTy
-primOpInfo IntGtOp = Compare SLIT("gtInt#") intPrimTy
-primOpInfo IntGeOp = Compare SLIT("geInt#") intPrimTy
-primOpInfo IntEqOp = Compare SLIT("eqInt#") intPrimTy
-primOpInfo IntNeOp = Compare SLIT("neInt#") intPrimTy
-primOpInfo IntLtOp = Compare SLIT("ltInt#") intPrimTy
-primOpInfo IntLeOp = Compare SLIT("leInt#") intPrimTy
+primOpInfo IntGtOp = Compare SLIT(">#") intPrimTy
+primOpInfo IntGeOp = Compare SLIT(">=#") intPrimTy
+primOpInfo IntEqOp = Compare SLIT("==#") intPrimTy
+primOpInfo IntNeOp = Compare SLIT("/=#") intPrimTy
+primOpInfo IntLtOp = Compare SLIT("<#") intPrimTy
+primOpInfo IntLeOp = Compare SLIT("<=#") intPrimTy
primOpInfo WordGtOp = Compare SLIT("gtWord#") wordPrimTy
primOpInfo WordGeOp = Compare SLIT("geWord#") wordPrimTy
primOpInfo FloatLtOp = Compare SLIT("ltFloat#") floatPrimTy
primOpInfo FloatLeOp = Compare SLIT("leFloat#") floatPrimTy
-primOpInfo DoubleGtOp = Compare SLIT("gtDouble#") doublePrimTy
-primOpInfo DoubleGeOp = Compare SLIT("geDouble#") doublePrimTy
-primOpInfo DoubleEqOp = Compare SLIT("eqDouble#") doublePrimTy
-primOpInfo DoubleNeOp = Compare SLIT("neDouble#") doublePrimTy
-primOpInfo DoubleLtOp = Compare SLIT("ltDouble#") doublePrimTy
-primOpInfo DoubleLeOp = Compare SLIT("leDouble#") doublePrimTy
+primOpInfo DoubleGtOp = Compare SLIT(">##") doublePrimTy
+primOpInfo DoubleGeOp = Compare SLIT(">=##") doublePrimTy
+primOpInfo DoubleEqOp = Compare SLIT("==##") doublePrimTy
+primOpInfo DoubleNeOp = Compare SLIT("/=##") doublePrimTy
+primOpInfo DoubleLtOp = Compare SLIT("<##") doublePrimTy
+primOpInfo DoubleLeOp = Compare SLIT("<=##") doublePrimTy
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-primOpInfo IntAddOp = Dyadic SLIT("plusInt#") intPrimTy
-primOpInfo IntSubOp = Dyadic SLIT("minusInt#") intPrimTy
-primOpInfo IntMulOp = Dyadic SLIT("timesInt#") intPrimTy
+primOpInfo IntAddOp = Dyadic SLIT("+#") intPrimTy
+primOpInfo IntSubOp = Dyadic SLIT("-#") intPrimTy
+primOpInfo IntMulOp = Dyadic SLIT("*#") intPrimTy
primOpInfo IntQuotOp = Dyadic SLIT("quotInt#") intPrimTy
primOpInfo IntRemOp = Dyadic SLIT("remInt#") intPrimTy
similar).
\begin{code}
-primOpInfo DoubleAddOp = Dyadic SLIT("plusDouble#") doublePrimTy
-primOpInfo DoubleSubOp = Dyadic SLIT("minusDouble#") doublePrimTy
-primOpInfo DoubleMulOp = Dyadic SLIT("timesDouble#") doublePrimTy
-primOpInfo DoubleDivOp = Dyadic SLIT("divideDouble#") doublePrimTy
+primOpInfo DoubleAddOp = Dyadic SLIT("+##") doublePrimTy
+primOpInfo DoubleSubOp = Dyadic SLIT("-##") doublePrimTy
+primOpInfo DoubleMulOp = Dyadic SLIT("*##") doublePrimTy
+primOpInfo DoubleDivOp = Dyadic SLIT("/##") doublePrimTy
primOpInfo DoubleNegOp = Monadic SLIT("negateDouble#") doublePrimTy
primOpInfo Double2IntOp = Coercing SLIT("double2Int#") doublePrimTy intPrimTy
primOpInfo DoubleSinhOp = Monadic SLIT("sinhDouble#") doublePrimTy
primOpInfo DoubleCoshOp = Monadic SLIT("coshDouble#") doublePrimTy
primOpInfo DoubleTanhOp = Monadic SLIT("tanhDouble#") doublePrimTy
-primOpInfo DoublePowerOp= Dyadic SLIT("powerDouble#") doublePrimTy
+primOpInfo DoublePowerOp= Dyadic SLIT("**##") doublePrimTy
\end{code}
%************************************************************************
IMP_Ubiq(){-uitous-}
import Kind ( mkUnboxedTypeKind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
-import Name ( mkPrimitiveName )
-import PrelMods ( gHC_BUILTINS )
+import Name ( mkWiredInTyConName )
import PrimRep ( PrimRep(..) ) -- getPrimRepInfo uses PrimRep repn
import TyCon ( mkPrimTyCon, mkDataTyCon, NewOrData(..) )
import Type ( applyTyCon, mkTyVarTys, mkTyConTy )
import TyVar ( GenTyVar(..), alphaTyVars )
import Usage ( usageOmega )
+import PrelMods ( gHC__ )
import Unique
\end{code}
pcPrimTyCon :: Unique{-TyConKey-} -> FAST_STRING -> Int -> PrimRep -> TyCon
pcPrimTyCon key str arity primrep
- = mkPrimTyCon name (mk_kind arity) primrep
+ = the_tycon
where
- name = mkPrimitiveName key (OrigName gHC_BUILTINS str)
-
+ name = mkWiredInTyConName key gHC__ str the_tycon
+ the_tycon = mkPrimTyCon name (mk_kind arity) primrep
mk_kind 0 = mkUnboxedTypeKind
mk_kind n = mkTypeKind `mkArrowKind` mk_kind (n-1)
system, to parameterise State#.
\begin{code}
-realWorldTy = applyTyCon realWorldTyCon []
-realWorldTyCon
- = mkDataTyCon name mkBoxedTypeKind
- [{-no tyvars-}]
- [{-no context-}]
- [{-no data cons!-}] -- we tell you *nothing* about this guy
- [{-no derivings-}]
- DataType
- where
- name = mkPrimitiveName realWorldTyConKey (OrigName gHC_BUILTINS SLIT("RealWorld"))
-
+realWorldTy = applyTyCon realWorldTyCon []
+realWorldTyCon = mk_no_constr_tycon realWorldTyConKey SLIT("RealWorld")
realWorldStatePrimTy = mkStatePrimTy realWorldTy
\end{code}
--
-- ) It's boxed; there is only one value of this
-- type, namely "void", whose semantics is just bottom.
-voidTy = mkTyConTy voidTyCon
-
-voidTyCon
- = mkDataTyCon name mkBoxedTypeKind
- [{-no tyvars-}]
- [{-no context-}]
- [{-no data cons!-}]
- [{-no derivings-}]
- DataType
+voidTy = mkTyConTy voidTyCon
+voidTyCon = mk_no_constr_tycon voidTyConKey SLIT("Void")
+\end{code}
+
+\begin{code}
+mk_no_constr_tycon key str
+ = the_tycon
where
- name = mkPrimitiveName voidTyConKey (OrigName gHC_BUILTINS SLIT("Void"))
+ name = mkWiredInTyConName key gHC__ str the_tycon
+ the_tycon = mkDataTyCon name mkBoxedTypeKind
+ [{-no tyvars-}]
+ [{-no context-}]
+ [{-no data cons!-}] -- we tell you *nothing* about this guy
+ [{-no derivings-}]
+ DataType
\end{code}
%************************************************************************
mkPrimIoTy,
mkStateTy,
mkStateTransformerTy,
+ tupleTyCon, tupleCon, unitTyCon, unitDataCon, pairTyCon, pairDataCon,
mkTupleTy,
nilDataCon,
primIoTyCon,
--import Kind
IMP_Ubiq()
-IMPORT_DELOOPER(TyLoop) ( mkDataCon, StrictnessMark(..) )
+IMPORT_DELOOPER(TyLoop) ( mkDataCon, mkTupleCon, StrictnessMark(..) )
IMPORT_DELOOPER(IdLoop) ( SpecEnv )
-- friends:
-- others:
import Kind ( mkBoxedTypeKind, mkArrowKind )
-import Name ( mkWiredInName, ExportFlag(..) )
-import SrcLoc ( mkBuiltinSrcLoc )
+import Name ( mkWiredInTyConName, mkWiredInIdName, mkTupNameStr )
import TyCon ( mkDataTyCon, mkTupleTyCon, mkSynTyCon,
NewOrData(..), TyCon
)
-import Type ( mkTyConTy, applyTyCon, mkSigmaTy,
- mkFunTy, maybeAppTyCon,
+import Type ( mkTyConTy, applyTyCon, mkSigmaTy, mkTyVarTys,
+ mkFunTy, mkFunTys, maybeAppTyCon,
GenType(..), SYN_IE(ThetaType), SYN_IE(TauType) )
-import TyVar ( tyVarKind, alphaTyVar, betaTyVar )
+import TyVar ( tyVarKind, alphaTyVars, alphaTyVar, betaTyVar )
+import Lex ( mkTupNameStr )
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) ExportAll) tycon_kind
+ = tycon
+ where
+ tycon = mkDataTyCon name tycon_kind
tyvars [{-no context-}] cons [{-no derivings-}]
new_or_data
- where
+ name = mkWiredInTyConName key mod str tycon
tycon_kind = foldr (mkArrowKind . tyVarKind) mkBoxedTypeKind tyvars
pcSynTyCon key mod str kind arity tyvars expansion
- = mkSynTyCon
- (mkWiredInName key (OrigName mod str) ExportAll)
- kind arity tyvars expansion
+ = tycon
+ where
+ tycon = mkSynTyCon name kind arity tyvars expansion
+ name = mkWiredInTyConName key mod str tycon
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) ExportAll)
- [ NotMarkedStrict | a <- arg_tys ]
- [ {- no labelled fields -} ]
- tyvars context arg_tys tycon
- -- specenv
+ = data_con
+ where
+ data_con = mkDataCon name
+ [ NotMarkedStrict | a <- arg_tys ]
+ [ {- no labelled fields -} ]
+ tyvars context arg_tys tycon
+ name = mkWiredInIdName key mod str data_con
pcGenerateDataSpecs :: Type -> SpecEnv
pcGenerateDataSpecs ty
%************************************************************************
%* *
+\subsection[TysWiredIn-tuples]{The tuple types}
+%* *
+%************************************************************************
+
+\begin{code}
+tupleTyCon :: Arity -> TyCon
+tupleTyCon arity
+ = tycon
+ where
+ tycon = mkTupleTyCon uniq name arity
+ uniq = mkTupleTyConUnique arity
+ name = mkWiredInTyConName uniq mod_name (mkTupNameStr arity) tycon
+ mod_name | arity == 0 = pREL_BASE
+ | otherwise = pREL_TUP
+
+tupleCon :: Arity -> Id
+tupleCon arity
+ = tuple_con
+ where
+ tuple_con = mkTupleCon arity name ty
+ uniq = mkTupleDataConUnique arity
+ name = mkWiredInIdName uniq mod_name (mkTupNameStr arity) tuple_con
+ mod_name | arity == 0 = pREL_BASE
+ | otherwise = pREL_TUP
+ ty = mkSigmaTy tyvars [] (mkFunTys tyvar_tys (applyTyCon tycon tyvar_tys))
+ tyvars = take arity alphaTyVars
+ tyvar_tys = mkTyVarTys tyvars
+ tycon = tupleTyCon arity
+
+unitTyCon = tupleTyCon 0
+pairTyCon = tupleTyCon 2
+
+unitDataCon = tupleCon 0
+pairDataCon = tupleCon 2
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection[TysWiredIn-boxed-prim]{The ``boxed primitive'' types (@Char@, @Int@, etc)}
%* *
%************************************************************************
\begin{code}
charTy = mkTyConTy charTyCon
-charTyCon = pcDataTyCon charTyConKey pRELUDE SLIT("Char") [] [charDataCon]
-charDataCon = pcDataCon charDataConKey pRELUDE SLIT("C#") [] [] [charPrimTy] charTyCon nullSpecEnv
+charTyCon = pcDataTyCon charTyConKey pREL_BASE SLIT("Char") [] [charDataCon]
+charDataCon = pcDataCon charDataConKey pREL_BASE SLIT("C#") [] [] [charPrimTy] charTyCon nullSpecEnv
stringTy = mkListTy charTy -- convenience only
\end{code}
\begin{code}
intTy = mkTyConTy intTyCon
-intTyCon = pcDataTyCon intTyConKey pRELUDE SLIT("Int") [] [intDataCon]
-intDataCon = pcDataCon intDataConKey pRELUDE SLIT("I#") [] [] [intPrimTy] intTyCon nullSpecEnv
+intTyCon = pcDataTyCon intTyConKey pREL_BASE SLIT("Int") [] [intDataCon]
+intDataCon = pcDataCon intDataConKey pREL_BASE SLIT("I#") [] [] [intPrimTy] intTyCon nullSpecEnv
\end{code}
\begin{code}
wordTy = mkTyConTy wordTyCon
-wordTyCon = pcDataTyCon wordTyConKey gHC__ SLIT("Word") [] [wordDataCon]
+wordTyCon = pcDataTyCon wordTyConKey fOREIGN SLIT("Word") [] [wordDataCon]
wordDataCon = pcDataCon wordDataConKey gHC__ SLIT("W#") [] [] [wordPrimTy] wordTyCon nullSpecEnv
\end{code}
\begin{code}
addrTy = mkTyConTy addrTyCon
-addrTyCon = pcDataTyCon addrTyConKey gHC__ SLIT("Addr") [] [addrDataCon]
+addrTyCon = pcDataTyCon addrTyConKey fOREIGN SLIT("Addr") [] [addrDataCon]
addrDataCon = pcDataCon addrDataConKey gHC__ SLIT("A#") [] [] [addrPrimTy] addrTyCon nullSpecEnv
\end{code}
\begin{code}
floatTy = mkTyConTy floatTyCon
-floatTyCon = pcDataTyCon floatTyConKey pRELUDE SLIT("Float") [] [floatDataCon]
-floatDataCon = pcDataCon floatDataConKey pRELUDE SLIT("F#") [] [] [floatPrimTy] floatTyCon nullSpecEnv
+floatTyCon = pcDataTyCon floatTyConKey pREL_BASE SLIT("Float") [] [floatDataCon]
+floatDataCon = pcDataCon floatDataConKey pREL_BASE SLIT("F#") [] [] [floatPrimTy] floatTyCon nullSpecEnv
\end{code}
\begin{code}
doubleTy = mkTyConTy doubleTyCon
-doubleTyCon = pcDataTyCon doubleTyConKey pRELUDE SLIT("Double") [] [doubleDataCon]
-doubleDataCon = pcDataCon doubleDataConKey pRELUDE SLIT("D#") [] [] [doublePrimTy] doubleTyCon nullSpecEnv
+doubleTyCon = pcDataTyCon doubleTyConKey pREL_BASE SLIT("Double") [] [doubleDataCon]
+doubleDataCon = pcDataCon doubleDataConKey pREL_BASE SLIT("D#") [] [] [doublePrimTy] doubleTyCon nullSpecEnv
\end{code}
\begin{code}
mkStateTy ty = applyTyCon stateTyCon [ty]
realWorldStateTy = mkStateTy realWorldTy -- a common use
-stateTyCon = pcDataTyCon stateTyConKey gHC__ SLIT("State") alpha_tyvar [stateDataCon]
+stateTyCon = pcDataTyCon stateTyConKey sT_BASE SLIT("State") alpha_tyvar [stateDataCon]
stateDataCon
- = pcDataCon stateDataConKey gHC__ SLIT("S#")
+ = pcDataCon stateDataConKey sT_BASE SLIT("S#")
alpha_tyvar [] [mkStatePrimTy alphaTy] stateTyCon nullSpecEnv
\end{code}
\begin{code}
stablePtrTyCon
- = pcDataTyCon stablePtrTyConKey gHC__ SLIT("StablePtr")
+ = pcDataTyCon stablePtrTyConKey fOREIGN SLIT("StablePtr")
alpha_tyvar [stablePtrDataCon]
where
stablePtrDataCon
- = pcDataCon stablePtrDataConKey gHC__ SLIT("StablePtr")
+ = pcDataCon stablePtrDataConKey fOREIGN SLIT("StablePtr")
alpha_tyvar [] [mkStablePtrPrimTy alphaTy] stablePtrTyCon nullSpecEnv
\end{code}
\begin{code}
foreignObjTyCon
- = pcDataTyCon foreignObjTyConKey gHC__ SLIT("ForeignObj")
+ = pcDataTyCon foreignObjTyConKey fOREIGN SLIT("ForeignObj")
[] [foreignObjDataCon]
where
foreignObjDataCon
- = pcDataCon foreignObjDataConKey gHC__ SLIT("ForeignObj")
+ = pcDataCon foreignObjDataConKey fOREIGN SLIT("ForeignObj")
[] [] [foreignObjPrimTy] foreignObjTyCon nullSpecEnv
\end{code}
integerTy :: GenType t u
integerTy = mkTyConTy integerTyCon
-integerTyCon = pcDataTyCon integerTyConKey pRELUDE SLIT("Integer") [] [integerDataCon]
+integerTyCon = pcDataTyCon integerTyConKey pREL_BASE SLIT("Integer") [] [integerDataCon]
-integerDataCon = pcDataCon integerDataConKey pRELUDE SLIT("J#")
+integerDataCon = pcDataCon integerDataConKey pREL_BASE SLIT("J#")
[] [] [intPrimTy, intPrimTy, byteArrayPrimTy] integerTyCon nullSpecEnv
\end{code}
And the other pairing types:
\begin{code}
return2GMPsTyCon = pcDataTyCon return2GMPsTyConKey
- gHC__ SLIT("Return2GMPs") [] [return2GMPsDataCon]
+ pREL_NUM SLIT("Return2GMPs") [] [return2GMPsDataCon]
return2GMPsDataCon
- = pcDataCon return2GMPsDataConKey gHC__ SLIT("Return2GMPs") [] []
+ = pcDataCon return2GMPsDataConKey pREL_NUM SLIT("Return2GMPs") [] []
[intPrimTy, intPrimTy, byteArrayPrimTy,
intPrimTy, intPrimTy, byteArrayPrimTy] return2GMPsTyCon nullSpecEnv
returnIntAndGMPTyCon = pcDataTyCon returnIntAndGMPTyConKey
- gHC__ SLIT("ReturnIntAndGMP") [] [returnIntAndGMPDataCon]
+ pREL_NUM SLIT("ReturnIntAndGMP") [] [returnIntAndGMPDataCon]
returnIntAndGMPDataCon
- = pcDataCon returnIntAndGMPDataConKey gHC__ SLIT("ReturnIntAndGMP") [] []
+ = pcDataCon returnIntAndGMPDataConKey pREL_NUM SLIT("ReturnIntAndGMP") [] []
[intPrimTy, intPrimTy, intPrimTy, byteArrayPrimTy] returnIntAndGMPTyCon nullSpecEnv
\end{code}
\begin{code}
stateAndPtrPrimTyCon
- = pcDataTyCon stateAndPtrPrimTyConKey gHC__ SLIT("StateAndPtr#")
+ = pcDataTyCon stateAndPtrPrimTyConKey sT_BASE SLIT("StateAndPtr#")
alpha_beta_tyvars [stateAndPtrPrimDataCon]
stateAndPtrPrimDataCon
- = pcDataCon stateAndPtrPrimDataConKey gHC__ SLIT("StateAndPtr#")
+ = pcDataCon stateAndPtrPrimDataConKey sT_BASE SLIT("StateAndPtr#")
alpha_beta_tyvars [] [mkStatePrimTy alphaTy, betaTy]
stateAndPtrPrimTyCon nullSpecEnv
stateAndCharPrimTyCon
- = pcDataTyCon stateAndCharPrimTyConKey gHC__ SLIT("StateAndChar#")
+ = pcDataTyCon stateAndCharPrimTyConKey sT_BASE SLIT("StateAndChar#")
alpha_tyvar [stateAndCharPrimDataCon]
stateAndCharPrimDataCon
- = pcDataCon stateAndCharPrimDataConKey gHC__ SLIT("StateAndChar#")
+ = pcDataCon stateAndCharPrimDataConKey sT_BASE SLIT("StateAndChar#")
alpha_tyvar [] [mkStatePrimTy alphaTy, charPrimTy]
stateAndCharPrimTyCon nullSpecEnv
stateAndIntPrimTyCon
- = pcDataTyCon stateAndIntPrimTyConKey gHC__ SLIT("StateAndInt#")
+ = pcDataTyCon stateAndIntPrimTyConKey sT_BASE SLIT("StateAndInt#")
alpha_tyvar [stateAndIntPrimDataCon]
stateAndIntPrimDataCon
- = pcDataCon stateAndIntPrimDataConKey gHC__ SLIT("StateAndInt#")
+ = pcDataCon stateAndIntPrimDataConKey sT_BASE SLIT("StateAndInt#")
alpha_tyvar [] [mkStatePrimTy alphaTy, intPrimTy]
stateAndIntPrimTyCon nullSpecEnv
stateAndWordPrimTyCon
- = pcDataTyCon stateAndWordPrimTyConKey gHC__ SLIT("StateAndWord#")
+ = pcDataTyCon stateAndWordPrimTyConKey sT_BASE SLIT("StateAndWord#")
alpha_tyvar [stateAndWordPrimDataCon]
stateAndWordPrimDataCon
- = pcDataCon stateAndWordPrimDataConKey gHC__ SLIT("StateAndWord#")
+ = pcDataCon stateAndWordPrimDataConKey sT_BASE SLIT("StateAndWord#")
alpha_tyvar [] [mkStatePrimTy alphaTy, wordPrimTy]
stateAndWordPrimTyCon nullSpecEnv
stateAndAddrPrimTyCon
- = pcDataTyCon stateAndAddrPrimTyConKey gHC__ SLIT("StateAndAddr#")
+ = pcDataTyCon stateAndAddrPrimTyConKey sT_BASE SLIT("StateAndAddr#")
alpha_tyvar [stateAndAddrPrimDataCon]
stateAndAddrPrimDataCon
- = pcDataCon stateAndAddrPrimDataConKey gHC__ SLIT("StateAndAddr#")
+ = pcDataCon stateAndAddrPrimDataConKey sT_BASE SLIT("StateAndAddr#")
alpha_tyvar [] [mkStatePrimTy alphaTy, addrPrimTy]
stateAndAddrPrimTyCon nullSpecEnv
stateAndStablePtrPrimTyCon
- = pcDataTyCon stateAndStablePtrPrimTyConKey gHC__ SLIT("StateAndStablePtr#")
+ = pcDataTyCon stateAndStablePtrPrimTyConKey fOREIGN SLIT("StateAndStablePtr#")
alpha_beta_tyvars [stateAndStablePtrPrimDataCon]
stateAndStablePtrPrimDataCon
- = pcDataCon stateAndStablePtrPrimDataConKey gHC__ SLIT("StateAndStablePtr#")
+ = pcDataCon stateAndStablePtrPrimDataConKey fOREIGN SLIT("StateAndStablePtr#")
alpha_beta_tyvars []
[mkStatePrimTy alphaTy, applyTyCon stablePtrPrimTyCon [betaTy]]
stateAndStablePtrPrimTyCon nullSpecEnv
stateAndForeignObjPrimTyCon
- = pcDataTyCon stateAndForeignObjPrimTyConKey gHC__ SLIT("StateAndForeignObj#")
+ = pcDataTyCon stateAndForeignObjPrimTyConKey fOREIGN SLIT("StateAndForeignObj#")
alpha_tyvar [stateAndForeignObjPrimDataCon]
stateAndForeignObjPrimDataCon
- = pcDataCon stateAndForeignObjPrimDataConKey gHC__ SLIT("StateAndForeignObj#")
+ = pcDataCon stateAndForeignObjPrimDataConKey fOREIGN SLIT("StateAndForeignObj#")
alpha_tyvar []
[mkStatePrimTy alphaTy, applyTyCon foreignObjPrimTyCon []]
stateAndForeignObjPrimTyCon nullSpecEnv
stateAndFloatPrimTyCon
- = pcDataTyCon stateAndFloatPrimTyConKey gHC__ SLIT("StateAndFloat#")
+ = pcDataTyCon stateAndFloatPrimTyConKey sT_BASE SLIT("StateAndFloat#")
alpha_tyvar [stateAndFloatPrimDataCon]
stateAndFloatPrimDataCon
- = pcDataCon stateAndFloatPrimDataConKey gHC__ SLIT("StateAndFloat#")
+ = pcDataCon stateAndFloatPrimDataConKey sT_BASE SLIT("StateAndFloat#")
alpha_tyvar [] [mkStatePrimTy alphaTy, floatPrimTy]
stateAndFloatPrimTyCon nullSpecEnv
stateAndDoublePrimTyCon
- = pcDataTyCon stateAndDoublePrimTyConKey gHC__ SLIT("StateAndDouble#")
+ = pcDataTyCon stateAndDoublePrimTyConKey sT_BASE SLIT("StateAndDouble#")
alpha_tyvar [stateAndDoublePrimDataCon]
stateAndDoublePrimDataCon
- = pcDataCon stateAndDoublePrimDataConKey gHC__ SLIT("StateAndDouble#")
+ = pcDataCon stateAndDoublePrimDataConKey sT_BASE SLIT("StateAndDouble#")
alpha_tyvar [] [mkStatePrimTy alphaTy, doublePrimTy]
stateAndDoublePrimTyCon nullSpecEnv
\end{code}
\begin{code}
stateAndArrayPrimTyCon
- = pcDataTyCon stateAndArrayPrimTyConKey gHC__ SLIT("StateAndArray#")
+ = pcDataTyCon stateAndArrayPrimTyConKey aRR_BASE SLIT("StateAndArray#")
alpha_beta_tyvars [stateAndArrayPrimDataCon]
stateAndArrayPrimDataCon
- = pcDataCon stateAndArrayPrimDataConKey gHC__ SLIT("StateAndArray#")
+ = pcDataCon stateAndArrayPrimDataConKey aRR_BASE SLIT("StateAndArray#")
alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkArrayPrimTy betaTy]
stateAndArrayPrimTyCon nullSpecEnv
stateAndMutableArrayPrimTyCon
- = pcDataTyCon stateAndMutableArrayPrimTyConKey gHC__ SLIT("StateAndMutableArray#")
+ = pcDataTyCon stateAndMutableArrayPrimTyConKey aRR_BASE SLIT("StateAndMutableArray#")
alpha_beta_tyvars [stateAndMutableArrayPrimDataCon]
stateAndMutableArrayPrimDataCon
- = pcDataCon stateAndMutableArrayPrimDataConKey gHC__ SLIT("StateAndMutableArray#")
+ = pcDataCon stateAndMutableArrayPrimDataConKey aRR_BASE SLIT("StateAndMutableArray#")
alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkMutableArrayPrimTy alphaTy betaTy]
stateAndMutableArrayPrimTyCon nullSpecEnv
stateAndByteArrayPrimTyCon
- = pcDataTyCon stateAndByteArrayPrimTyConKey gHC__ SLIT("StateAndByteArray#")
+ = pcDataTyCon stateAndByteArrayPrimTyConKey aRR_BASE SLIT("StateAndByteArray#")
alpha_tyvar [stateAndByteArrayPrimDataCon]
stateAndByteArrayPrimDataCon
- = pcDataCon stateAndByteArrayPrimDataConKey gHC__ SLIT("StateAndByteArray#")
+ = pcDataCon stateAndByteArrayPrimDataConKey aRR_BASE SLIT("StateAndByteArray#")
alpha_tyvar [] [mkStatePrimTy alphaTy, byteArrayPrimTy]
stateAndByteArrayPrimTyCon nullSpecEnv
stateAndMutableByteArrayPrimTyCon
- = pcDataTyCon stateAndMutableByteArrayPrimTyConKey gHC__ SLIT("StateAndMutableByteArray#")
+ = pcDataTyCon stateAndMutableByteArrayPrimTyConKey aRR_BASE SLIT("StateAndMutableByteArray#")
alpha_tyvar [stateAndMutableByteArrayPrimDataCon]
stateAndMutableByteArrayPrimDataCon
- = pcDataCon stateAndMutableByteArrayPrimDataConKey gHC__ SLIT("StateAndMutableByteArray#")
+ = pcDataCon stateAndMutableByteArrayPrimDataConKey aRR_BASE SLIT("StateAndMutableByteArray#")
alpha_tyvar [] [mkStatePrimTy alphaTy, applyTyCon mutableByteArrayPrimTyCon alpha_ty]
stateAndMutableByteArrayPrimTyCon nullSpecEnv
stateAndSynchVarPrimTyCon
- = pcDataTyCon stateAndSynchVarPrimTyConKey gHC__ SLIT("StateAndSynchVar#")
+ = pcDataTyCon stateAndSynchVarPrimTyConKey cONC_BASE SLIT("StateAndSynchVar#")
alpha_beta_tyvars [stateAndSynchVarPrimDataCon]
stateAndSynchVarPrimDataCon
- = pcDataCon stateAndSynchVarPrimDataConKey gHC__ SLIT("StateAndSynchVar#")
+ = pcDataCon stateAndSynchVarPrimDataConKey cONC_BASE SLIT("StateAndSynchVar#")
alpha_beta_tyvars [] [mkStatePrimTy alphaTy, mkSynchVarPrimTy alphaTy betaTy]
stateAndSynchVarPrimTyCon nullSpecEnv
\end{code}
\begin{code}
mkStateTransformerTy s a = applyTyCon stTyCon [s, a]
-stTyCon = pcNewTyCon stTyConKey gHC__ SLIT("ST") alpha_beta_tyvars [stDataCon]
+stTyCon = pcNewTyCon stTyConKey sT_BASE SLIT("ST") alpha_beta_tyvars [stDataCon]
-stDataCon = pcDataCon stDataConKey gHC__ SLIT("ST")
+stDataCon = pcDataCon stDataConKey sT_BASE SLIT("ST")
alpha_beta_tyvars [] [ty] stTyCon nullSpecEnv
where
ty = mkFunTy (mkStateTy alphaTy) (mkTupleTy 2 [betaTy, mkStateTy alphaTy])
primIoTyCon
= pcSynTyCon
- primIoTyConKey gHC__ SLIT("PrimIO")
+ primIoTyConKey iO_BASE SLIT("PrimIO")
(mkBoxedTypeKind `mkArrowKind` mkBoxedTypeKind)
1 alpha_tyvar (mkPrimIoTy alphaTy)
\end{code}
\begin{code}
boolTy = mkTyConTy boolTyCon
-boolTyCon = pcDataTyCon boolTyConKey pRELUDE SLIT("Bool") [] [falseDataCon, trueDataCon]
+boolTyCon = pcDataTyCon boolTyConKey pREL_BASE SLIT("Bool") [] [falseDataCon, trueDataCon]
-falseDataCon = pcDataCon falseDataConKey pRELUDE SLIT("False") [] [] [] boolTyCon nullSpecEnv
-trueDataCon = pcDataCon trueDataConKey pRELUDE SLIT("True") [] [] [] boolTyCon nullSpecEnv
+falseDataCon = pcDataCon falseDataConKey pREL_BASE SLIT("False") [] [] [] boolTyCon nullSpecEnv
+trueDataCon = pcDataCon trueDataConKey pREL_BASE SLIT("True") [] [] [] boolTyCon nullSpecEnv
\end{code}
%************************************************************************
alphaListTy = mkSigmaTy alpha_tyvar [] (applyTyCon listTyCon alpha_ty)
-listTyCon = pcDataTyCon listTyConKey pRELUDE SLIT("[]")
+listTyCon = pcDataTyCon listTyConKey pREL_BASE SLIT("[]")
alpha_tyvar [nilDataCon, consDataCon]
-nilDataCon = pcDataCon nilDataConKey pRELUDE SLIT("[]") alpha_tyvar [] [] listTyCon
+nilDataCon = pcDataCon nilDataConKey pREL_BASE SLIT("[]") alpha_tyvar [] [] listTyCon
(pcGenerateDataSpecs alphaListTy)
-consDataCon = pcDataCon consDataConKey pRELUDE SLIT(":")
+consDataCon = pcDataCon consDataConKey pREL_BASE SLIT(":")
alpha_tyvar [] [alphaTy, applyTyCon listTyCon alpha_ty] listTyCon
(pcGenerateDataSpecs alphaListTy)
-- Interesting: polymorphic recursion would help here.
\begin{code}
mkTupleTy :: Int -> [GenType t u] -> GenType t u
-mkTupleTy arity tys = applyTyCon (mkTupleTyCon arity) tys
+mkTupleTy arity tys = applyTyCon (tupleTyCon arity) tys
unitTy = mkTupleTy 0 []
\end{code}
alphaLiftTy = mkSigmaTy alpha_tyvar [] (applyTyCon liftTyCon alpha_ty)
liftTyCon
- = pcDataTyCon liftTyConKey gHC__ SLIT("Lift") alpha_tyvar [liftDataCon]
+ = pcDataTyCon liftTyConKey pREL_BASE SLIT("Lift") alpha_tyvar [liftDataCon]
liftDataCon
- = pcDataCon liftDataConKey gHC__ SLIT("Lift")
+ = pcDataCon liftDataConKey pREL_BASE SLIT("Lift")
alpha_tyvar [] alpha_ty liftTyCon
((pcGenerateDataSpecs alphaLiftTy) `addOneToSpecEnv`
(mkSpecInfo [Just realWorldStatePrimTy] 0 bottom))
import Id ( externallyVisibleId, GenId, SYN_IE(Id) )
import CStrings ( identToC, stringToC )
-import Name ( showRdr, getOccName, RdrName )
+import Name ( OccName, getOccString, moduleString )
import Pretty ( ppShow, prettyToUn )
import PprStyle ( PprStyle(..) )
import UniqSet
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))
+ do_dupd is_dupd (basic_kind ++ ('/': moduleString mod_name) ++ ('/': _UNPK_ grp_name))
else
basic_kind
where
do_id :: Id -> String
do_id id
= if print_as_string
- then showRdr sty (getOccName id) -- use occ name
- else showId sty id -- we really do
+ then getOccString id -- use occ name
+ else showId sty id -- we really do
---------------
do_dupd ADupdCC str = if friendly_sty then str ++ "/DUPD" else str
import Id ( idType, mkSysLocal, emptyIdSet )
import Maybes ( maybeToBool )
import PprStyle -- ToDo: rm
-import SrcLoc ( mkUnknownSrcLoc )
+import SrcLoc ( noSrcLoc )
import Type ( splitSigmaTy, getFunTy_maybe )
import UniqSupply ( getUnique, splitUniqSupply )
import Util ( removeDups, assertPanic )
-- make a trivial let-binding for the top-level function
getUniqueMM `thenMM` \ uniq ->
let
- new_var = mkSysLocal SLIT("ho") uniq var_type mkUnknownSrcLoc
+ new_var = mkSysLocal SLIT("ho") uniq var_type noSrcLoc
in
returnMM ( (new_var, old_var) : bindings, StgVarAtom new_var )
else
-- tell if its a Sig or a ClassOpSig,
-- so we just save the pieces:
| RdrTySig [RdrName] -- vars getting sigs
- RdrNamePolyType -- the type
+ RdrNameHsType -- the type
SrcLoc
-- user pragmas come in in a Sig-ish way/form...
cvValSig,
cvClassOpSig,
cvInstDeclSig,
+
cvBinds,
+ cvMonoBindsAndSigs,
cvMatches,
- cvMonoBinds,
- cvSepdBinds,
- sepDeclsForTopBinds,
- sepDeclsIntoSigsAndBinds
+ cvOtherDecls
) where
IMP_Ubiq(){-uitous-}
import RdrHsSyn
import HsPragmas ( noGenPragmas, noClassOpPragmas )
-import SrcLoc ( mkSrcLoc2 )
+import SrcLoc ( mkSrcLoc )
import Util ( mapAndUnzip, panic, assertPanic )
\end{code}
cvValSig, cvClassOpSig, cvInstDeclSig :: SigConverter
cvValSig (RdrTySig vars poly_ty src_loc)
- = [ Sig v poly_ty noGenPragmas src_loc | v <- vars ]
+ = [ Sig v poly_ty src_loc | v <- vars ]
cvClassOpSig (RdrTySig vars poly_ty src_loc)
= [ ClassOpSig v poly_ty noClassOpPragmas src_loc | v <- vars ]
\begin{code}
cvBinds :: SrcFile -> SigConverter -> RdrBinding -> RdrNameHsBinds
-cvBinds sf sig_cvtr raw_binding
- = cvSepdBinds sf sig_cvtr (sepDeclsForBinds raw_binding)
-
-cvSepdBinds :: SrcFile -> SigConverter -> [RdrBinding] -> RdrNameHsBinds
-cvSepdBinds sf sig_cvtr bindings
- = case (mkMonoBindsAndSigs sf sig_cvtr bindings) of { (mbs, sigs) ->
+cvBinds sf sig_cvtr binding
+ = case (cvMonoBindsAndSigs sf sig_cvtr binding) of { (mbs, sigs) ->
if (null sigs)
then SingleBind (RecBind mbs)
else BindWith (RecBind mbs) sigs
}
-
-cvMonoBinds :: SrcFile -> [RdrBinding] -> RdrNameMonoBinds
-cvMonoBinds sf bindings
- = case (mkMonoBindsAndSigs sf bottom bindings) of { (mbs,sigs) ->
- if (null sigs)
- then mbs
- else panic "cvMonoBinds: some sigs present"
- }
- where
- bottom = panic "cvMonoBinds: sig converter!"
\end{code}
\begin{code}
-mkMonoBindsAndSigs :: SrcFile
+cvMonoBindsAndSigs :: SrcFile
-> SigConverter
- -> [RdrBinding]
+ -> RdrBinding
-> (RdrNameMonoBinds, [RdrNameSig])
-mkMonoBindsAndSigs sf sig_cvtr fbs
- = foldl mangle_bind (EmptyMonoBinds, []) fbs
+cvMonoBindsAndSigs sf sig_cvtr fb
+ = mangle_bind (EmptyMonoBinds, []) fb
where
-- If the function being bound has at least one argument, then the
-- guarded right hand sides of each pattern binding are knitted
-- function. Otherwise there is only one pattern, which is paired
-- with a guarded right hand side.
+ mangle_bind acc (RdrAndBindings fb1 fb2)
+ = mangle_bind (mangle_bind acc fb1) fb2
+
mangle_bind (b_acc, s_acc) sig@(RdrTySig _ _ _)
= (b_acc, s_acc ++ sig_cvtr sig)
-- WDP: the parser has trouble getting a good line-number on RdrPatternBindings.
= case (cvPatMonoBind sf patbinding) of { (pat, grhss, binds) ->
let
- src_loc = mkSrcLoc2 sf good_srcline
+ src_loc = mkSrcLoc sf good_srcline
in
(b_acc `AndMonoBinds`
PatMonoBind pat (GRHSsAndBindsIn grhss binds) src_loc, s_acc)
-- must be a function binding...
= case (cvFunMonoBind sf patbindings) of { (var, inf, matches) ->
(b_acc `AndMonoBinds`
- FunMonoBind var inf matches (mkSrcLoc2 sf srcline), s_acc)
+ FunMonoBind var inf matches (mkSrcLoc sf srcline), s_acc)
}
+
+ mangle_bind (b_acc, s_acc) other = (b_acc, s_acc)
\end{code}
\begin{code}
cvPatMonoBind :: SrcFile -> RdrMatch -> (RdrNamePat, [RdrNameGRHS], RdrNameHsBinds)
cvPatMonoBind sf (RdrMatch_NoGuard srcline srcfun pat expr binding)
- = (pat, [OtherwiseGRHS expr (mkSrcLoc2 sf srcline)], cvBinds sf cvValSig binding)
+ = (pat, [OtherwiseGRHS expr (mkSrcLoc sf srcline)], cvBinds sf cvValSig binding)
cvPatMonoBind sf (RdrMatch_Guards srcline srcfun pat guardedexprs binding)
= (pat, map (cvGRHS sf srcline) guardedexprs, cvBinds sf cvValSig binding)
where
(pat, binding, guarded_exprs)
= case rdr_match of
- RdrMatch_NoGuard ln b c expr d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc2 sf ln)])
+ RdrMatch_NoGuard ln b c expr d -> (c,d, [OtherwiseGRHS expr (mkSrcLoc sf ln)])
RdrMatch_Guards ln b c gd_exps d -> (c,d, map (cvGRHS sf ln) gd_exps)
cvGRHS :: SrcFile -> SrcLine -> (RdrNameHsExpr, RdrNameHsExpr) -> RdrNameGRHS
-cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc2 sf sl)
+cvGRHS sf sl (g, e) = GRHS g e (mkSrcLoc sf sl)
\end{code}
%************************************************************************
%************************************************************************
Separate declarations into all the various kinds:
-\begin{display}
-tys RdrTyDecl
-ty "sigs" RdrSpecDataSig
-classes RdrClassDecl
-insts RdrInstDecl
-inst "sigs" RdrSpecInstSig
-defaults RdrDefaultDecl
-binds RdrFunctionBinding RdrPatternBinding RdrTySig
- RdrSpecValSig RdrInlineValSig RdrDeforestSig
- RdrMagicUnfoldingSig
-\end{display}
-
-This function isn't called directly; some other function calls it,
-then checks that what it got is appropriate for that situation.
-(Those functions follow...)
-
-\begin{code}
-sepDecls (RdrTyDecl a)
- tys tysigs classes insts instsigs defaults binds
- = (a:tys,tysigs,classes,insts,instsigs,defaults,binds)
-
-sepDecls a@(RdrFunctionBinding _ _)
- tys tysigs classes insts instsigs defaults binds
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
-
-sepDecls a@(RdrPatternBinding _ _)
- tys tysigs classes insts instsigs defaults binds
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
-
--- RdrAndBindings catered for below...
-
-sepDecls (RdrClassDecl a)
- tys tysigs classes insts instsigs defaults binds
- = (tys,tysigs,a:classes,insts,instsigs,defaults,binds)
-
-sepDecls (RdrInstDecl a)
- tys tysigs classes insts instsigs defaults binds
- = (tys,tysigs,classes,a:insts,instsigs,defaults,binds)
-
-sepDecls (RdrDefaultDecl a)
- tys tysigs classes insts instsigs defaults binds
- = (tys,tysigs,classes,insts,instsigs,a:defaults,binds)
-
-sepDecls a@(RdrTySig _ _ _)
- tys tysigs classes insts instsigs defaults binds
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
-
-sepDecls a@(RdrSpecValSig _)
- tys tysigs classes insts instsigs defaults binds
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
-
-sepDecls a@(RdrInlineValSig _)
- tys tysigs classes insts instsigs defaults binds
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
-
-sepDecls a@(RdrDeforestSig _)
- tys tysigs classes insts instsigs defaults binds
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
-
-sepDecls a@(RdrMagicUnfoldingSig _)
- tys tysigs classes insts instsigs defaults binds
- = (tys,tysigs,classes,insts,instsigs,defaults,a:binds)
-
-sepDecls (RdrSpecInstSig a)
- tys tysigs classes insts instsigs defaults binds
- = (tys,tysigs,classes,insts,a:instsigs,defaults,binds)
-
-sepDecls (RdrSpecDataSig a)
- tys tysigs classes insts instsigs defaults binds
- = (tys,a:tysigs,classes,insts,instsigs,defaults,binds)
-
-sepDecls RdrNullBind
- tys tysigs classes insts instsigs defaults binds
- = (tys,tysigs,classes,insts,instsigs,defaults,binds)
-
-sepDecls (RdrAndBindings bs1 bs2)
- tys tysigs classes insts instsigs defaults binds
- = case (sepDecls bs2 tys tysigs classes insts instsigs defaults binds) of {
- (tys,tysigs,classes,insts,instsigs,defaults,binds) ->
- sepDecls bs1 tys tysigs classes insts instsigs defaults binds
- }
-\end{code}
\begin{code}
-sepDeclsForTopBinds binding
- = sepDecls binding [] [] [] [] [] [] []
-
-sepDeclsForBinds binding
- = case (sepDecls binding [] [] [] [] [] [] [])
- of { (tys,tysigs,classes,insts,instsigs,defaults,binds) ->
- ASSERT ((null tys)
- && (null tysigs)
- && (null classes)
- && (null insts)
- && (null instsigs)
- && (null defaults))
- binds
- }
-
-sepDeclsIntoSigsAndBinds binding
- = case (sepDeclsForBinds binding) of { sigs_and_binds ->
- foldr sep_stuff ([],[]) sigs_and_binds
- }
+cvOtherDecls :: RdrBinding -> [RdrNameHsDecl]
+cvOtherDecls b
+ = go [] b
where
- sep_stuff s@(RdrTySig _ _ _) (sigs,defs) = (s:sigs,defs)
- sep_stuff s@(RdrSpecValSig _) (sigs,defs) = (s:sigs,defs)
- sep_stuff s@(RdrInlineValSig _) (sigs,defs) = (s:sigs,defs)
- sep_stuff s@(RdrDeforestSig _) (sigs,defs) = (s:sigs,defs)
- sep_stuff s@(RdrMagicUnfoldingSig _) (sigs,defs) = (s:sigs,defs)
- sep_stuff d@(RdrFunctionBinding _ _) (sigs,defs) = (sigs,d:defs)
- sep_stuff d@(RdrPatternBinding _ _) (sigs,defs) = (sigs,d:defs)
-
-
+ go acc (RdrAndBindings b1 b2) = go (go acc b1) b2
+ go acc (RdrTyDecl d) = TyD d : acc
+ go acc (RdrClassDecl d) = ClD d : acc
+ go acc (RdrInstDecl d) = InstD d : acc
+ go acc (RdrDefaultDecl d) = DefD d : acc
+ go acc other = acc
\end{code}
SYN_IE(RdrNameGRHS),
SYN_IE(RdrNameGRHSsAndBinds),
SYN_IE(RdrNameHsBinds),
+ SYN_IE(RdrNameHsDecl),
SYN_IE(RdrNameHsExpr),
SYN_IE(RdrNameHsModule),
SYN_IE(RdrNameIE),
SYN_IE(RdrNameInstDecl),
SYN_IE(RdrNameMatch),
SYN_IE(RdrNameMonoBinds),
- SYN_IE(RdrNameMonoType),
SYN_IE(RdrNamePat),
- SYN_IE(RdrNamePolyType),
+ SYN_IE(RdrNameHsType),
SYN_IE(RdrNameQual),
SYN_IE(RdrNameSig),
SYN_IE(RdrNameSpecInstSig),
SYN_IE(RdrNameGenPragmas),
SYN_IE(RdrNameInstancePragmas),
SYN_IE(RdrNameCoreExpr),
+ extractHsTyVars,
+
+ RdrName(..),
+ qual, varQual, tcQual, varUnqual,
+ dummyRdrVarName, dummyRdrTcName,
+ isUnqual, isQual,
+ showRdr, rdrNameOcc,
+ cmpRdr
- getRawImportees,
- getRawExportees
) where
IMP_Ubiq()
import HsSyn
-import Name ( ExportFlag(..) )
+import Lex
+import PrelMods ( pRELUDE )
+import Name ( ExportFlag(..), Module(..), pprModule,
+ OccName(..), pprOccName )
+import Pretty
+import PprStyle ( PprStyle(..) )
+import Util ( cmpPString, panic, thenCmp )
\end{code}
\begin{code}
type RdrNameClassOpSig = Sig RdrName
type RdrNameConDecl = ConDecl RdrName
type RdrNameContext = Context RdrName
+type RdrNameHsDecl = HsDecl Fake Fake RdrName RdrNamePat
type RdrNameSpecDataSig = SpecDataSig RdrName
type RdrNameDefaultDecl = DefaultDecl RdrName
type RdrNameFixityDecl = FixityDecl RdrName
type RdrNameInstDecl = InstDecl Fake Fake RdrName RdrNamePat
type RdrNameMatch = Match Fake Fake RdrName RdrNamePat
type RdrNameMonoBinds = MonoBinds Fake Fake RdrName RdrNamePat
-type RdrNameMonoType = MonoType RdrName
type RdrNamePat = InPat RdrName
-type RdrNamePolyType = PolyType RdrName
+type RdrNameHsType = HsType RdrName
type RdrNameQual = Qualifier Fake Fake RdrName RdrNamePat
type RdrNameSig = Sig RdrName
type RdrNameSpecInstSig = SpecInstSig RdrName
type RdrNameDataPragmas = DataPragmas RdrName
type RdrNameGenPragmas = GenPragmas RdrName
type RdrNameInstancePragmas = InstancePragmas RdrName
-type RdrNameCoreExpr = UnfoldingCoreExpr RdrName
+type RdrNameCoreExpr = GenCoreExpr RdrName RdrName RdrName RdrName
+\end{code}
+
+@extractHsTyVars@ looks just for things that could be type variables.
+It's used when making the for-alls explicit.
+
+\begin{code}
+extractHsTyVars :: HsType RdrName -> [RdrName]
+extractHsTyVars ty
+ = get ty []
+ where
+ get (MonoTyApp con tys) acc = foldr get (insert con acc) tys
+ get (MonoListTy tc ty) acc = get ty acc
+ get (MonoTupleTy tc tys) acc = foldr get acc tys
+ get (MonoFunTy ty1 ty2) acc = get ty1 (get ty2 acc)
+ get (MonoDictTy cls ty) acc = get ty acc
+ get (MonoTyVar tv) acc = insert tv acc
+ get (HsPreForAllTy ctxt ty) acc = foldr (get . snd) (get ty acc) ctxt
+ get (HsForAllTy tvs ctxt ty) acc = filter (`notElem` locals) $
+ foldr (get . snd) (get ty acc) ctxt
+ where
+ locals = map getTyVarName tvs
+
+ insert (Qual _ _) acc = acc
+ insert (Unqual (TCOcc _)) acc = acc
+ insert other acc | other `elem` acc = acc
+ | otherwise = other : acc
\end{code}
+
%************************************************************************
%* *
-\subsection{Grabbing importees and exportees}
+\subsection[RdrName]{The @RdrName@ datatype; names read from files}
%* *
%************************************************************************
\begin{code}
-getRawImportees :: [RdrNameIE] -> [RdrName]
-getRawExportees :: Maybe [RdrNameIE] -> ([(RdrName, ExportFlag)], [Module])
+data RdrName
+ = Unqual OccName
+ | Qual Module OccName
-getRawImportees imps
- = foldr do_imp [] imps
- where
- do_imp (IEVar n) acc = n:acc
- do_imp (IEThingAbs n) acc = n:acc
- do_imp (IEThingWith n _) acc = n:acc
- do_imp (IEThingAll n) acc = n:acc
-
-getRawExportees Nothing = ([], [])
-getRawExportees (Just exps)
- = foldr do_exp ([],[]) exps
- where
- do_exp (IEVar n) (prs, mods) = ((n, ExportAll):prs, mods)
- do_exp (IEThingAbs n) (prs, mods) = ((n, ExportAbs):prs, mods)
- do_exp (IEThingAll n) (prs, mods) = ((n, ExportAll):prs, mods)
- do_exp (IEThingWith n _) (prs, mods) = ((n, ExportAll):prs, mods)
- do_exp (IEModuleContents n) (prs, mods) = (prs, n : mods)
+qual (m,n) = Qual m n
+tcQual (m,n) = Qual m (TCOcc n)
+varQual (m,n) = Qual m (VarOcc n)
+
+ -- This guy is used by the reader when HsSyn has a slot for
+ -- an implicit name that's going to be filled in by
+ -- the renamer. We can't just put "error..." because
+ -- we sometimes want to print out stuff after reading but
+ -- before renaming
+dummyRdrVarName = Unqual (VarOcc SLIT("V-DUMMY"))
+dummyRdrTcName = Unqual (VarOcc SLIT("TC-DUMMY"))
+
+varUnqual n = Unqual (VarOcc n)
+
+isUnqual (Unqual _) = True
+isUnqual (Qual _ _) = False
+
+isQual (Unqual _) = False
+isQual (Qual _ _) = True
+
+cmpRdr (Unqual n1) (Unqual n2) = n1 `cmp` n2
+cmpRdr (Unqual n1) (Qual m2 n2) = LT_
+cmpRdr (Qual m1 n1) (Unqual n2) = GT_
+cmpRdr (Qual m1 n1) (Qual m2 n2) = (n1 `cmp` n2) `thenCmp` (_CMP_STRING_ m1 m2)
+ -- always compare module-names *second*
+
+rdrNameOcc :: RdrName -> OccName
+rdrNameOcc (Unqual occ) = occ
+rdrNameOcc (Qual _ occ) = occ
+
+instance Text RdrName where -- debugging
+ showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn))
+
+instance Eq RdrName where
+ a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False }
+ a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True }
+
+instance Ord RdrName where
+ a <= b = case (a `cmp` b) of { LT_ -> True; EQ_ -> True; GT__ -> False }
+ a < b = case (a `cmp` b) of { LT_ -> True; EQ_ -> False; GT__ -> False }
+ a >= b = case (a `cmp` b) of { LT_ -> False; EQ_ -> True; GT__ -> True }
+ a > b = case (a `cmp` b) of { LT_ -> False; EQ_ -> False; GT__ -> True }
+
+instance Ord3 RdrName where
+ cmp = cmpRdr
+
+instance Outputable RdrName where
+ ppr sty (Unqual n) = pprOccName sty n
+ ppr sty (Qual m n) = ppBesides [pprModule sty m, ppStr ".", pprOccName sty n]
+
+instance NamedThing RdrName where -- Just so that pretty-printing of expressions works
+ getOccName = rdrNameOcc
+ getName = panic "no getName for RdrNames"
+
+showRdr sty rdr = ppShow 100 (ppr sty rdr)
\end{code}
+
import UgenAll -- all Yacc parser gumpff...
import PrefixSyn -- and various syntaxen.
import HsSyn
+import HsTypes ( HsTyVar(..) )
import HsPragmas ( noDataPragmas, noClassPragmas, noInstancePragmas, noGenPragmas )
import RdrHsSyn
import PrefixToHs
import ErrUtils ( addErrLoc, ghcExit )
import FiniteMap ( elemFM, FiniteMap )
-import Name ( RdrName(..), isRdrLexConOrSpecial, preludeQual )
+import Name ( RdrName(..), OccName(..) )
+import Lex ( isLexConId )
import PprStyle ( PprStyle(..) )
-import PrelMods ( pRELUDE )
+import PrelMods
import Pretty
-import SrcLoc ( mkBuiltinSrcLoc, SrcLoc )
+import SrcLoc ( mkGeneratedSrcLoc, noSrcLoc, SrcLoc )
import Util ( nOfThem, pprError, panic )
\end{code}
\end{code}
\begin{code}
-rdQid :: ParseTree -> UgnM RdrName
-rdQid pt = rdU_qid pt `thenUgn` \ qid -> wlkQid qid
-
-wlkQid :: U_qid -> UgnM RdrName
-wlkQid (U_noqual name)
- = returnUgn (Unqual name)
-wlkQid (U_aqual mod name)
- = returnUgn (Qual mod name)
-wlkQid (U_gid n name)
- = returnUgn (preludeQual name)
+wlkTvId = wlkQid TvOcc
+wlkTCId = wlkQid TCOcc
+wlkVarId = wlkQid VarOcc
+wlkDataId = wlkQid VarOcc
+wlkEntId = wlkQid (\occ -> if isLexConId occ
+ then TCOcc occ
+ else VarOcc occ)
+
+wlkQid :: (FAST_STRING -> OccName) -> U_qid -> UgnM RdrName
+wlkQid mk_occ_name (U_noqual name)
+ = returnUgn (Unqual (mk_occ_name name))
+wlkQid mk_occ_name (U_aqual mod name)
+ = returnUgn (Qual mod (mk_occ_name name))
+
+ -- I don't understand this one! It is what shows up when we meet (), [], or (,,,).
+wlkQid mk_occ_name (U_gid n name)
+ = returnUgn (Unqual (mk_occ_name name))
+
+rdTCId pt = rdU_qid pt `thenUgn` \ qid -> wlkTCId qid
+rdVarId pt = rdU_qid pt `thenUgn` \ qid -> wlkVarId qid
cvFlag :: U_long -> Bool
cvFlag 0 = False
wlkList rdFixOp hfixlist `thenUgn` \ fixities ->
wlkBinding hmodlist `thenUgn` \ binding ->
- case sepDeclsForTopBinds binding of
- (tydecls, tysigs, classdecls, instdecls, instsigs, defaultdecls, binds) ->
-
- returnUgn (modname,
- HsModule modname
+ let
+ val_decl = ValD (add_main_sig modname (cvBinds srcfile cvValSig binding))
+ other_decls = cvOtherDecls binding
+ in
+ returnUgn (modname,
+ HsModule modname
(case srciface_version of { 0 -> Nothing; n -> Just n })
exports
imports
fixities
- tydecls
- tysigs
- classdecls
- instdecls
- instsigs
- defaultdecls
- (add_main_sig modname (cvSepdBinds srcfile cvValSig binds))
- [{-no interface sigs yet-}]
+ (val_decl: other_decls)
src_loc
)
where
add_main_sig modname binds
- = if modname == SLIT("Main") then
+ = if modname == mAIN then
let
- s = Sig (Unqual SLIT("main")) (io_ty SLIT("IO")) noGenPragmas mkBuiltinSrcLoc
+ s = Sig (varUnqual SLIT("main")) (io_ty SLIT("IO")) mkGeneratedSrcLoc
in
add_sig binds s
- else if modname == SLIT("GHCmain") then
+ else if modname == gHC_MAIN then
let
- s = Sig (Unqual SLIT("mainPrimIO")) (io_ty SLIT("PrimIO")) noGenPragmas mkBuiltinSrcLoc
+ s = Sig (varUnqual SLIT("mainPrimIO")) (io_ty SLIT("PrimIO")) mkGeneratedSrcLoc
in
add_sig binds s
add_sig (BindWith b ss) s = BindWith b (s:ss)
add_sig _ _ = panic "rdModule:add_sig"
- io_ty t = HsForAllTy [] [] (MonoTyApp (Unqual t) [MonoTupleTy []])
+ io_ty t = MonoTyApp (Unqual (TCOcc t)) [MonoTupleTy dummyRdrTcName []]
\end{code}
%************************************************************************
U_lsection lsexp lop -> -- left section
wlkExpr lsexp `thenUgn` \ expr ->
- wlkQid lop `thenUgn` \ op ->
+ wlkVarId lop `thenUgn` \ op ->
returnUgn (SectionL expr (HsVar op))
U_rsection rop rsexp -> -- right section
- wlkQid rop `thenUgn` \ op ->
+ wlkVarId rop `thenUgn` \ op ->
wlkExpr rsexp `thenUgn` \ expr ->
returnUgn (SectionR (HsVar op) expr)
U_restr restre restrt -> -- expression with type signature
wlkExpr restre `thenUgn` \ expr ->
- wlkPolyType restrt `thenUgn` \ ty ->
+ wlkHsType restrt `thenUgn` \ ty ->
returnUgn (ExprWithTySig expr ty)
--------------------------------------------------------------
returnUgn (HsLit lit)
U_ident n -> -- simple identifier
- wlkQid n `thenUgn` \ var ->
+ wlkVarId n `thenUgn` \ var ->
returnUgn (HsVar var)
U_ap fun arg -> -- application
returnUgn (HsApp expr1 expr2)
U_infixap fun arg1 arg2 -> -- infix application
- wlkQid fun `thenUgn` \ op ->
+ wlkVarId fun `thenUgn` \ op ->
wlkExpr arg1 `thenUgn` \ expr1 ->
wlkExpr arg2 `thenUgn` \ expr2 ->
returnUgn (OpApp expr1 (HsVar op) expr2)
U_negate nexp -> -- prefix negation
wlkExpr nexp `thenUgn` \ expr ->
- -- this is a hack
- let
- rdr = preludeQual SLIT("negate")
- in
- returnUgn (NegApp expr (HsVar rdr))
+ returnUgn (NegApp expr (HsVar dummyRdrVarName))
U_llist llist -> -- explicit list
wlkList rdExpr llist `thenUgn` \ exprs ->
returnUgn (ExplicitTuple exprs)
U_record con rbinds -> -- record construction
- wlkQid con `thenUgn` \ rcon ->
+ wlkDataId con `thenUgn` \ rcon ->
wlkList rdRbind rbinds `thenUgn` \ recbinds ->
returnUgn (RecordCon (HsVar rcon) recbinds)
rdRbind pt
= rdU_tree pt `thenUgn` \ (U_rbind var exp) ->
- wlkQid var `thenUgn` \ rvar ->
+ wlkVarId var `thenUgn` \ rvar ->
wlkMaybe rdExpr exp `thenUgn` \ expr_maybe ->
returnUgn (
case expr_maybe of
)
U_as avar as_pat -> -- "as" pattern
- wlkQid avar `thenUgn` \ var ->
+ wlkVarId avar `thenUgn` \ var ->
wlkPat as_pat `thenUgn` \ pat ->
returnUgn (AsPatIn var pat)
returnUgn (LitPatIn lit)
U_ident nn -> -- simple identifier
- wlkQid nn `thenUgn` \ n ->
+ wlkVarId nn `thenUgn` \ n ->
returnUgn (
- if isRdrLexConOrSpecial n
- then ConPatIn n []
- else VarPatIn n
+ case rdrNameOcc n of
+ VarOcc occ | isLexConId occ -> ConPatIn n []
+ other -> VarPatIn n
)
U_ap l r -> -- "application": there's a list of patterns lurking here!
returnUgn (pat,acc)
U_infixap fun arg1 arg2 -> -- infix pattern
- wlkQid fun `thenUgn` \ op ->
+ wlkVarId fun `thenUgn` \ op ->
wlkPat arg1 `thenUgn` \ pat1 ->
wlkPat arg2 `thenUgn` \ pat2 ->
returnUgn (ConOpPatIn pat1 op pat2)
returnUgn (TuplePatIn pats)
U_record con rpats -> -- record destruction
- wlkQid con `thenUgn` \ rcon ->
+ wlkDataId con `thenUgn` \ rcon ->
wlkList rdRpat rpats `thenUgn` \ recpats ->
returnUgn (RecPatIn rcon recpats)
where
rdRpat pt
= rdU_tree pt `thenUgn` \ (U_rbind var pat) ->
- wlkQid var `thenUgn` \ rvar ->
+ wlkVarId var `thenUgn` \ rvar ->
wlkMaybe rdPat pat `thenUgn` \ pat_maybe ->
returnUgn (
case pat_maybe of
mkSrcLocUgn srcline $ \ src_loc ->
wlkContext ntctxt `thenUgn` \ ctxt ->
wlkTyConAndTyVars nttype `thenUgn` \ (tycon, tyvars) ->
- wlkList rdConDecl ntcon `thenUgn` \ con ->
+ wlkList rdConDecl ntcon `thenUgn` \ [con] ->
wlkDerivings ntderivs `thenUgn` \ derivings ->
returnUgn (RdrTyDecl (TyNew ctxt tycon tyvars con derivings noDataPragmas src_loc))
wlkBinding cbindw `thenUgn` \ binding ->
getSrcFileUgn `thenUgn` \ sf ->
let
- (class_sigs, class_methods) = sepDeclsIntoSigsAndBinds binding
-
- final_sigs = concat (map cvClassOpSig class_sigs)
- final_methods = cvMonoBinds sf class_methods
+ (final_methods, final_sigs) = cvMonoBindsAndSigs sf cvClassOpSig binding
in
returnUgn (RdrClassDecl
(ClassDecl ctxt clas tyvar final_sigs final_methods noClassPragmas src_loc))
U_ibind ibindc iclas ibindi ibindw srcline ->
mkSrcLocUgn srcline $ \ src_loc ->
wlkContext ibindc `thenUgn` \ ctxt ->
- wlkQid iclas `thenUgn` \ clas ->
- wlkMonoType ibindi `thenUgn` \ inst_ty ->
+ wlkTCId iclas `thenUgn` \ clas ->
+ wlkMonoType ibindi `thenUgn` \ at_ty ->
wlkBinding ibindw `thenUgn` \ binding ->
getSrcModUgn `thenUgn` \ modname ->
getSrcFileUgn `thenUgn` \ sf ->
let
- (ss, bs) = sepDeclsIntoSigsAndBinds binding
- binds = cvMonoBinds sf bs
- uprags = concat (map cvInstDeclSig ss)
- ctxt_inst_ty = HsPreForAllTy ctxt inst_ty
+ (binds,uprags) = cvMonoBindsAndSigs sf cvInstDeclSig binding
+ inst_ty = HsPreForAllTy ctxt (MonoDictTy clas at_ty)
in
returnUgn (RdrInstDecl
- (InstDecl clas ctxt_inst_ty binds True{-from here-} modname uprags noInstancePragmas src_loc))
+ (InstDecl inst_ty binds uprags Nothing {- No dfun id -} src_loc))
-- "default" declaration
U_dbind dbindts srcline ->
wlkDerivings (U_nothing) = returnUgn Nothing
wlkDerivings (U_just pt)
= rdU_list pt `thenUgn` \ ds ->
- wlkList rdQid ds `thenUgn` \ derivs ->
+ wlkList rdTCId ds `thenUgn` \ derivs ->
returnUgn (Just derivs)
\end{code}
-- type signature
wlk_sig_thing (U_sbind sbindids sbindid srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
- wlkList rdQid sbindids `thenUgn` \ vars ->
- wlkPolyType sbindid `thenUgn` \ poly_ty ->
+ wlkList rdVarId sbindids `thenUgn` \ vars ->
+ wlkHsType sbindid `thenUgn` \ poly_ty ->
returnUgn (RdrTySig vars poly_ty src_loc)
-- value specialisation user-pragma
wlk_sig_thing (U_vspec_uprag uvar vspec_tys srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid uvar `thenUgn` \ var ->
+ wlkVarId uvar `thenUgn` \ var ->
wlkList rd_ty_and_id vspec_tys `thenUgn` \ tys_and_ids ->
returnUgn (RdrSpecValSig [SpecSig var ty using_id src_loc
| (ty, using_id) <- tys_and_ids ])
where
- rd_ty_and_id :: ParseTree -> UgnM (RdrNamePolyType, Maybe RdrName)
+ rd_ty_and_id :: ParseTree -> UgnM (RdrNameHsType, Maybe RdrName)
rd_ty_and_id pt
= rdU_binding pt `thenUgn` \ (U_vspec_ty_and_id vspec_ty vspec_id) ->
- wlkPolyType vspec_ty `thenUgn` \ ty ->
- wlkMaybe rdQid vspec_id `thenUgn` \ id_maybe ->
+ wlkHsType vspec_ty `thenUgn` \ ty ->
+ wlkMaybe rdVarId vspec_id `thenUgn` \ id_maybe ->
returnUgn(ty, id_maybe)
-- instance specialisation user-pragma
wlk_sig_thing (U_ispec_uprag iclas ispec_ty srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid iclas `thenUgn` \ clas ->
+ wlkTCId iclas `thenUgn` \ clas ->
wlkMonoType ispec_ty `thenUgn` \ ty ->
returnUgn (RdrSpecInstSig (SpecInstSig clas ty src_loc))
-- data specialisation user-pragma
wlk_sig_thing (U_dspec_uprag itycon dspec_tys srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid itycon `thenUgn` \ tycon ->
+ wlkTCId itycon `thenUgn` \ tycon ->
wlkList rdMonoType dspec_tys `thenUgn` \ tys ->
returnUgn (RdrSpecDataSig (SpecDataSig tycon (MonoTyApp tycon tys) src_loc))
-- value inlining user-pragma
wlk_sig_thing (U_inline_uprag ivar srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid ivar `thenUgn` \ var ->
+ wlkVarId ivar `thenUgn` \ var ->
returnUgn (RdrInlineValSig (InlineSig var src_loc))
-- "deforest me" user-pragma
wlk_sig_thing (U_deforest_uprag ivar srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid ivar `thenUgn` \ var ->
+ wlkVarId ivar `thenUgn` \ var ->
returnUgn (RdrDeforestSig (DeforestSig var src_loc))
-- "magic" unfolding user-pragma
wlk_sig_thing (U_magicuf_uprag ivar str srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid ivar `thenUgn` \ var ->
+ wlkVarId ivar `thenUgn` \ var ->
returnUgn (RdrMagicUnfoldingSig (MagicUnfoldingSig var str src_loc))
\end{code}
%************************************************************************
\begin{code}
-rdPolyType :: ParseTree -> UgnM RdrNamePolyType
-rdMonoType :: ParseTree -> UgnM RdrNameMonoType
+rdHsType :: ParseTree -> UgnM RdrNameHsType
+rdMonoType :: ParseTree -> UgnM RdrNameHsType
-rdPolyType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkPolyType ttype
+rdHsType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkHsType ttype
rdMonoType pt = rdU_ttype pt `thenUgn` \ ttype -> wlkMonoType ttype
-wlkPolyType :: U_ttype -> UgnM RdrNamePolyType
-wlkMonoType :: U_ttype -> UgnM RdrNameMonoType
+wlkHsType :: U_ttype -> UgnM RdrNameHsType
+wlkMonoType :: U_ttype -> UgnM RdrNameHsType
-wlkPolyType ttype
+wlkHsType ttype
= case ttype of
U_context tcontextl tcontextt -> -- context
wlkContext tcontextl `thenUgn` \ ctxt ->
wlkMonoType ttype
= case ttype of
U_namedtvar tv -> -- type variable
- wlkQid tv `thenUgn` \ tyvar ->
+ wlkTvId tv `thenUgn` \ tyvar ->
returnUgn (MonoTyVar tyvar)
U_tname tcon -> -- type constructor
- wlkQid tcon `thenUgn` \ tycon ->
+ wlkTCId tcon `thenUgn` \ tycon ->
returnUgn (MonoTyApp tycon [])
U_tapp t1 t2 ->
= case t of
U_tapp t1 t2 -> wlkMonoType t2 `thenUgn` \ ty2 ->
collect t1 (ty2:acc)
- U_tname tcon -> wlkQid tcon `thenUgn` \ tycon ->
+ U_tname tcon -> wlkTCId tcon `thenUgn` \ tycon ->
returnUgn (tycon, acc)
- U_namedtvar tv -> wlkQid tv `thenUgn` \ tyvar ->
+ U_namedtvar tv -> wlkTvId tv `thenUgn` \ tyvar ->
returnUgn (tyvar, acc)
U_tllist _ -> panic "tlist"
U_ttuple _ -> panic "ttuple"
U_tllist tlist -> -- list type
wlkMonoType tlist `thenUgn` \ ty ->
- returnUgn (MonoListTy ty)
+ returnUgn (MonoListTy dummyRdrTcName ty)
U_ttuple ttuple ->
wlkList rdMonoType ttuple `thenUgn` \ tys ->
- returnUgn (MonoTupleTy tys)
+ returnUgn (MonoTupleTy dummyRdrTcName tys)
U_tfun tfun targ ->
wlkMonoType tfun `thenUgn` \ ty1 ->
\end{code}
\begin{code}
-wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [RdrName])
+wlkTyConAndTyVars :: U_ttype -> UgnM (RdrName, [HsTyVar RdrName])
wlkContext :: U_list -> UgnM RdrNameContext
-wlkClassAssertTy :: U_ttype -> UgnM (RdrName, RdrName)
+wlkClassAssertTy :: U_ttype -> UgnM (RdrName, HsTyVar RdrName)
wlkTyConAndTyVars ttype
= wlkMonoType ttype `thenUgn` \ (MonoTyApp tycon ty_args) ->
let
- args = [ a | (MonoTyVar a) <- ty_args ]
+ args = [ UserTyVar a | (MonoTyVar a) <- ty_args ]
in
returnUgn (tycon, args)
wlkClassAssertTy xs
= wlkMonoType xs `thenUgn` \ mono_ty ->
- returnUgn (mk_class_assertion mono_ty)
+ returnUgn (case mk_class_assertion mono_ty of
+ (clas, MonoTyVar tyvar) -> (clas, UserTyVar tyvar)
+ )
-mk_class_assertion :: RdrNameMonoType -> (RdrName, RdrName)
+mk_class_assertion :: RdrNameHsType -> (RdrName, RdrNameHsType)
-mk_class_assertion (MonoTyApp name [(MonoTyVar tyname)]) = (name, tyname)
+mk_class_assertion (MonoTyApp name [ty@(MonoTyVar tyname)]) = (name, ty)
mk_class_assertion other
= pprError "ERROR: malformed type context: " (ppr PprForUser other)
-- regrettably, the parser does let some junk past
wlkConDecl (U_constrpre ccon ctys srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid ccon `thenUgn` \ con ->
+ wlkDataId ccon `thenUgn` \ con ->
wlkList rdBangType ctys `thenUgn` \ tys ->
returnUgn (ConDecl con tys src_loc)
wlkConDecl (U_constrinf cty1 cop cty2 srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
wlkBangType cty1 `thenUgn` \ ty1 ->
- wlkQid cop `thenUgn` \ op ->
+ wlkDataId cop `thenUgn` \ op ->
wlkBangType cty2 `thenUgn` \ ty2 ->
returnUgn (ConOpDecl ty1 op ty2 src_loc)
wlkConDecl (U_constrnew ccon cty srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid ccon `thenUgn` \ con ->
+ wlkDataId ccon `thenUgn` \ con ->
wlkMonoType cty `thenUgn` \ ty ->
returnUgn (NewConDecl con ty src_loc)
wlkConDecl (U_constrrec ccon cfields srcline)
= mkSrcLocUgn srcline $ \ src_loc ->
- wlkQid ccon `thenUgn` \ con ->
+ wlkDataId ccon `thenUgn` \ con ->
wlkList rd_field cfields `thenUgn` \ fields_lists ->
returnUgn (RecConDecl con fields_lists src_loc)
where
rd_field :: ParseTree -> UgnM ([RdrName], BangType RdrName)
rd_field pt
= rdU_constr pt `thenUgn` \ (U_field fvars fty) ->
- wlkList rdQid fvars `thenUgn` \ vars ->
+ wlkList rdVarId fvars `thenUgn` \ vars ->
wlkBangType fty `thenUgn` \ ty ->
returnUgn (vars, ty)
wlkBangType :: U_ttype -> UgnM (BangType RdrName)
wlkBangType (U_tbang bty) = wlkMonoType bty `thenUgn` \ ty ->
- returnUgn (Banged (HsPreForAllTy [] ty))
+ returnUgn (Banged ty)
wlkBangType uty = wlkMonoType uty `thenUgn` \ ty ->
- returnUgn (Unbanged (HsPreForAllTy [] ty))
+ returnUgn (Unbanged ty)
\end{code}
%************************************************************************
mkSrcLocUgn srcline $ \ src_loc ->
wlkPat gpat `thenUgn` \ pat ->
wlkBinding gbind `thenUgn` \ binding ->
- wlkQid gsrcfun `thenUgn` \ srcfun ->
+ wlkVarId gsrcfun `thenUgn` \ srcfun ->
let
wlk_guards (U_pnoguards exp)
= wlkExpr exp `thenUgn` \ expr ->
rdFixOp pt
= rdU_tree pt `thenUgn` \ fix ->
case fix of
- U_fixop op (-1) prec -> wlkQid op `thenUgn` \ op ->
- returnUgn (InfixL op prec)
- U_fixop op 0 prec -> wlkQid op `thenUgn` \ op ->
- returnUgn (InfixN op prec)
- U_fixop op 1 prec -> wlkQid op `thenUgn` \ op ->
- returnUgn (InfixR op prec)
+ U_fixop op dir_n prec -> wlkVarId op `thenUgn` \ op ->
+ returnUgn (FixityDecl op (Fixity prec dir) noSrcLoc)
+ -- ToDo: add SrcLoc!
+ where
+ dir = case dir_n of
+ (-1) -> InfixL
+ 0 -> InfixN
+ 1 -> InfixR
_ -> error "ReadPrefix:rdFixOp"
\end{code}
= rdU_entidt pt `thenUgn` \ entity ->
case entity of
U_entid evar -> -- just a value
- wlkQid evar `thenUgn` \ var ->
+ wlkEntId evar `thenUgn` \ var ->
returnUgn (IEVar var)
U_enttype x -> -- abstract type constructor/class
- wlkQid x `thenUgn` \ thing ->
+ wlkTCId x `thenUgn` \ thing ->
returnUgn (IEThingAbs thing)
U_enttypeall x -> -- non-abstract type constructor/class
- wlkQid x `thenUgn` \ thing ->
+ wlkTCId x `thenUgn` \ thing ->
returnUgn (IEThingAll thing)
U_enttypenamed x ns -> -- non-abstract type constructor/class
-- with specified constrs/methods
- wlkQid x `thenUgn` \ thing ->
- wlkList rdQid ns `thenUgn` \ names ->
+ wlkTCId x `thenUgn` \ thing ->
+ wlkList rdVarId ns `thenUgn` \ names ->
returnUgn (IEThingWith thing names)
U_entmod mod -> -- everything provided unqualified by a module
IMP_Ubiq(){-uitous-}
-import ParseUtils
-
import HsSyn -- quite a bit of stuff
import RdrHsSyn -- oodles of synonyms
-import HsPragmas ( noGenPragmas )
+import HsDecls ( HsIdInfo(..) )
+import HsTypes ( mkHsForAllTy )
+import HsCore
+import Literal
+import HsPragmas ( noGenPragmas, noDataPragmas, noClassPragmas, noClassOpPragmas, noInstancePragmas )
+import IdInfo ( exactArity, mkStrictnessInfo, mkBottomStrictnessInfo,
+ ArgUsageInfo, FBTypeInfo
+ )
+import Kind ( Kind, mkArrowKind, mkTypeKind )
+import Lex
+import RnMonad ( SYN_IE(ImportVersion), SYN_IE(LocalVersion), ParsedIface(..),
+ SYN_IE(RdrNamePragma), SYN_IE(ExportItem)
+ )
import Bag ( emptyBag, unitBag, snocBag )
import FiniteMap ( emptyFM, unitFM, addToFM, plusFM, bagToFM, FiniteMap )
-import Name ( ExportFlag(..), mkTupNameStr, preludeQual,
- RdrName(..){-instance Outputable:ToDo:rm-}
- )
---import Outputable -- ToDo:rm
---import PprStyle ( PprStyle(..) ) -- ToDo: rm debugging
+import Name ( OccName(..), Provenance )
import SrcLoc ( mkIfaceSrcLoc )
import Util ( panic{-, pprPanic ToDo:rm-} )
+
-----------------------------------------------------------------
parseIface = parseIToks . lexIface
BANG { ITbang }
CBRACK { ITcbrack }
CCURLY { ITccurly }
- DCCURLY { ITdccurly }
CLASS { ITclass }
COMMA { ITcomma }
CPAREN { ITcparen }
DARROW { ITdarrow }
DATA { ITdata }
DCOLON { ITdcolon }
+ DERIVING { ITderiving }
DOTDOT { ITdotdot }
EQUAL { ITequal }
FORALL { ITforall }
NEWTYPE { ITnewtype }
OBRACK { ITobrack }
OCURLY { ITocurly }
- DOCURLY { ITdocurly }
OPAREN { IToparen }
RARROW { ITrarrow }
SEMI { ITsemi }
QCONID { ITqconid $$ }
QVARSYM { ITqvarsym $$ }
QCONSYM { ITqconsym $$ }
+
+ ARITY_PART { ITarity }
+ STRICT_PART { ITstrict }
+ UNFOLD_PART { ITunfold }
+ DEMAND { ITdemand $$ }
+ BOTTOM { ITbottom }
+ LAM { ITlam }
+ BIGLAM { ITbiglam }
+ CASE { ITcase }
+ OF { ITof }
+ LET { ITlet }
+ LETREC { ITletrec }
+ IN { ITin }
+ COERCE_IN { ITcoerce_in }
+ COERCE_OUT { ITcoerce_out }
+ CHAR { ITchar $$ }
+ STRING { ITstring $$ }
%%
iface :: { ParsedIface }
iface : INTERFACE CONID INTEGER
- usages_part versions_part
- exports_part inst_modules_part
- fixities_part decls_part instances_part pragmas_part
- { case $9 of { (tm, vm) ->
- ParsedIface $2 (panic "merge modules") (fromInteger $3) Nothing{-src version-}
- $4 -- usages
- $5 -- local versions
- $6 -- exports map
- $7 -- instance modules
- $8 -- fixities map
- tm -- decls maps
- vm
- $10 -- local instances
- $11 -- pragmas map
+ inst_modules_part
+ usages_part
+ exports_part fixities_part
+ instances_part
+ decls_part
+ { ParsedIface
+ $2 -- Module name
+ (fromInteger $3) -- Module version
+ $5 -- Usages
+ $6 -- Exports
+ $4 -- Instance modules
+ $7 -- Fixities
+ $9 -- Decls
+ $8 -- Local instances
}
+
+
+usages_part :: { [ImportVersion OccName] }
+usages_part : USAGES_PART module_stuff_pairs { $2 }
+ | { [] }
+
+module_stuff_pairs :: { [ImportVersion OccName] }
+module_stuff_pairs : { [] }
+ | module_stuff_pair module_stuff_pairs { $1 : $2 }
+
+module_stuff_pair :: { ImportVersion OccName }
+module_stuff_pair : mod_name INTEGER DCOLON name_version_pairs SEMI
+ { ($1, fromInteger $2, $4) }
+
+versions_part :: { [LocalVersion OccName] }
+versions_part : VERSIONS_PART name_version_pairs { $2 }
+ | { [] }
+
+name_version_pairs :: { [LocalVersion OccName] }
+name_version_pairs : { [] }
+ | name_version_pair name_version_pairs { $1 : $2 }
+
+name_version_pair :: { LocalVersion OccName }
+name_version_pair : entity_occ INTEGER { ($1, fromInteger $2)
--------------------------------------------------------------------------
- }
-
-usages_part :: { UsagesMap }
-usages_part : USAGES_PART module_stuff_pairs { bagToFM $2 }
- | { emptyFM }
-
-versions_part :: { VersionsMap }
-versions_part : VERSIONS_PART name_version_pairs { bagToFM $2 }
- | { emptyFM }
-
-module_stuff_pairs :: { Bag (Module, (Version, FiniteMap FAST_STRING Version)) }
-module_stuff_pairs : module_stuff_pair
- { unitBag $1 }
- | module_stuff_pairs module_stuff_pair
- { $1 `snocBag` $2 }
-
-module_stuff_pair :: { (Module, (Version, FiniteMap FAST_STRING Version)) }
-module_stuff_pair : CONID INTEGER DCOLON name_version_pairs SEMI
- { ($1, (fromInteger $2, bagToFM $4)) }
-
-name_version_pairs :: { Bag (FAST_STRING, Int) }
-name_version_pairs : name_version_pair
- { unitBag $1 }
- | name_version_pairs name_version_pair
- { $1 `snocBag` $2 }
-
-name_version_pair :: { (FAST_STRING, Int) }
-name_version_pair : name INTEGER
- { ($1, fromInteger $2)
---------------------------------------------------------------------------
- }
+ }
-exports_part :: { ExportsMap }
-exports_part : EXPORTS_PART export_items { bagToFM $2 }
- | { emptyFM }
+exports_part :: { [ExportItem] }
+exports_part : EXPORTS_PART export_items { $2 }
+ | { [] }
-export_items :: { Bag (FAST_STRING, (OrigName, ExportFlag)) }
-export_items : export_item { unitBag $1 }
- | export_items export_item { $1 `snocBag` $2 }
+export_items :: { [ExportItem] }
+export_items : { [] }
+ | export_item export_items { $1 : $2 }
-export_item :: { (FAST_STRING, (OrigName, ExportFlag)) }
-export_item : CONID name maybe_dotdot { ($2, (OrigName $1 $2, $3)) }
+export_item :: { ExportItem }
+export_item : mod_name entity_occ maybe_dotdot { ($1, $2, $3) }
-maybe_dotdot :: { ExportFlag }
-maybe_dotdot : DOTDOT { ExportAll }
- | { ExportAbs
+maybe_dotdot :: { [OccName] }
+maybe_dotdot : { [] }
+ | OPAREN val_occs CPAREN { $2
--------------------------------------------------------------------------
- }
+ }
-inst_modules_part :: { Bag Module }
-inst_modules_part : INSTANCE_MODULES_PART mod_list { $2 }
- | { emptyBag }
+inst_modules_part :: { [Module] }
+inst_modules_part : { [] }
+ | INSTANCE_MODULES_PART mod_list { $2 }
-mod_list :: { Bag Module }
-mod_list : CONID { unitBag $1 }
- | mod_list CONID { $1 `snocBag` $2
+mod_list :: { [Module] }
+mod_list : { [] }
+ | mod_name mod_list { $1 : $2
--------------------------------------------------------------------------
- }
+ }
-fixities_part :: { FixitiesMap }
-fixities_part : FIXITIES_PART fixes { $2 }
- | { emptyFM }
+fixities_part :: { [(OccName,Fixity)] }
+fixities_part : { [] }
+ | FIXITIES_PART fixes { $2 }
-fixes :: { FixitiesMap }
-fixes : fix { case $1 of (k,v) -> unitFM k v }
- | fixes fix { case $2 of (k,v) -> addToFM $1 k v }
+fixes :: { [(OccName,Fixity)] }
+fixes : { [] }
+ | fix fixes { $1 : $2 }
-fix :: { (FAST_STRING, RdrNameFixityDecl) }
-fix : INFIXL INTEGER qname SEMI { (de_qual $3, InfixL $3 (fromInteger $2)) }
- | INFIXR INTEGER qname SEMI { (de_qual $3, InfixR $3 (fromInteger $2)) }
- | INFIX INTEGER qname SEMI { (de_qual $3, InfixN $3 (fromInteger $2))
+fix :: { (OccName, Fixity) }
+fix : INFIXL INTEGER val_occ SEMI { ($3, Fixity (fromInteger $2) InfixL) }
+ | INFIXR INTEGER val_occ SEMI { ($3, Fixity (fromInteger $2) InfixR) }
+ | INFIX INTEGER val_occ SEMI { ($3, Fixity (fromInteger $2) InfixN)
--------------------------------------------------------------------------
- }
-
-decls_part :: { (LocalTyDefsMap, LocalValDefsMap) }
-decls_part : DECLARATIONS_PART topdecls { $2 }
- | { (emptyFM, emptyFM) }
-
-topdecls :: { (LocalTyDefsMap, LocalValDefsMap) }
-topdecls : topdecl { $1 }
- | topdecls topdecl { case $1 of { (ts1, vs1) ->
- case $2 of { (ts2, vs2) ->
- (plusFM ts1 ts2, plusFM vs1 vs2)}}
- }
-
-topdecl :: { (LocalTyDefsMap, LocalValDefsMap) }
-topdecl : typed SEMI { ($1, emptyFM) }
- | datad SEMI { $1 }
- | newtd SEMI { $1 }
- | classd SEMI { $1 }
- | decl { case $1 of { (n, Sig qn ty _ loc) ->
- (emptyFM, unitFM n (ValSig qn loc ty)) }
- }
-
-typed :: { LocalTyDefsMap }
-typed : TYPE simple EQUAL type { mk_type $2 $4 }
-
-datad :: { (LocalTyDefsMap, LocalValDefsMap) }
-datad : DATA simple EQUAL constrs { mk_data [] $2 $4 }
- | DATA context DARROW simple EQUAL constrs { mk_data $2 $4 $6 }
-
-newtd :: { (LocalTyDefsMap, LocalValDefsMap) }
-newtd : NEWTYPE simple EQUAL constr1 { mk_new [] $2 $4 }
- | NEWTYPE context DARROW simple EQUAL constr1 { mk_new $2 $4 $6 }
-
-classd :: { (LocalTyDefsMap, LocalValDefsMap) }
-classd : CLASS class cbody { mk_class [] $2 $3 }
- | CLASS context DARROW class cbody { mk_class $2 $4 $5 }
-
-cbody :: { [(FAST_STRING, RdrNameSig)] }
-cbody : WHERE OCURLY decls CCURLY { $3 }
- | { [] }
-
-decls :: { [(FAST_STRING, RdrNameSig)] }
-decls : decl { [$1] }
- | decls decl { $1 ++ [$2] }
-
-decl :: { (FAST_STRING, RdrNameSig) }
-decl : var DCOLON ctype SEMI { (de_qual $1, Sig $1 $3 noGenPragmas mkIfaceSrcLoc) }
+ }
+
+decls_part :: { [(Version, RdrNameHsDecl)] }
+decls_part : { [] }
+ | DECLARATIONS_PART topdecls { $2 }
+
+topdecls :: { [(Version, RdrNameHsDecl)] }
+topdecls : { [] }
+ | version topdecl topdecls { ($1,$2) : $3 }
+
+version :: { Version }
+version : INTEGER { fromInteger $1 }
+
+topdecl :: { RdrNameHsDecl }
+topdecl : TYPE tc_name tv_bndrs EQUAL type SEMI
+ { TyD (TySynonym $2 $3 $5 mkIfaceSrcLoc) }
+ | DATA decl_context tc_name tv_bndrs EQUAL constrs deriving SEMI
+ { TyD (TyData $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) }
+ | NEWTYPE decl_context tc_name tv_bndrs EQUAL constr1 deriving SEMI
+ { TyD (TyNew $2 $3 $4 $6 $7 noDataPragmas mkIfaceSrcLoc) }
+ | CLASS decl_context tc_name tv_bndr csigs SEMI
+ { ClD (ClassDecl $2 $3 $4 $5 EmptyMonoBinds noClassPragmas mkIfaceSrcLoc) }
+ | var_name DCOLON ctype id_info SEMI
+ { SigD (IfaceSig $1 $3 $4 mkIfaceSrcLoc) }
+
+decl_context :: { RdrNameContext }
+decl_context : { [] }
+ | OCURLY context_list1 CCURLY DARROW { $2 }
+
+csigs :: { [RdrNameSig] }
+csigs : { [] }
+ | WHERE OCURLY csigs1 CCURLY { $3 }
+
+csigs1 :: { [RdrNameSig] }
+csigs1 : csig { [$1] }
+ | csig SEMI csigs1 { $1 : $3 }
+
+csig :: { RdrNameSig }
+csig : var_name DCOLON ctype { ClassOpSig $1 $3 noClassOpPragmas mkIfaceSrcLoc
+----------------------------------------------------------------
+ }
+
+constrs :: { [RdrNameConDecl] }
+constrs : constr { [$1] }
+ | constr VBAR constrs { $1 : $3 }
+
+constr :: { RdrNameConDecl }
+constr : data_name batypes { ConDecl $1 $2 mkIfaceSrcLoc }
+ | data_name OCURLY fields1 CCURLY { RecConDecl $1 $3 mkIfaceSrcLoc }
+
+constr1 :: { RdrNameConDecl {- For a newtype -} }
+constr1 : data_name atype { NewConDecl $1 $2 mkIfaceSrcLoc }
+
+deriving :: { Maybe [RdrName] }
+ : { Nothing }
+ | DERIVING OPAREN qtc_names1 CPAREN { Just $3 }
+
+batypes :: { [RdrNameBangType] }
+batypes : { [] }
+ | batype batypes { $1 : $2 }
+
+batype :: { RdrNameBangType }
+batype : atype { Unbanged $1 }
+ | BANG atype { Banged $2 }
+
+fields1 :: { [([RdrName], RdrNameBangType)] }
+fields1 : field { [$1] }
+ | field COMMA fields1 { $1 : $3 }
+
+field :: { ([RdrName], RdrNameBangType) }
+field : var_name DCOLON ctype { ([$1], Unbanged $3) }
+ | var_name DCOLON BANG ctype { ([$1], Banged $4)
+--------------------------------------------------------------------------
+ }
+
+forall :: { [HsTyVar RdrName] }
+forall : OBRACK tv_bndrs CBRACK { $2 }
context :: { RdrNameContext }
-context : DOCURLY context_list DCCURLY { reverse $2 }
-
-context_list :: { RdrNameContext{-reversed-} }
-context_list : class { [$1] }
- | context_list COMMA class { $3 : $1 }
-
-class :: { (RdrName, RdrName) }
-class : gtycon VARID { ($1, Unqual $2) }
-
-ctype :: { RdrNamePolyType }
-ctype : FORALL OBRACK tyvars CBRACK context DARROW type { HsForAllTy (map Unqual $3) $5 $7 }
- | FORALL OBRACK tyvars CBRACK type { HsForAllTy (map Unqual $3) [] $5 }
- | type { HsForAllTy [] [] $1 }
-
-type :: { RdrNameMonoType }
-type : btype { $1 }
- | btype RARROW type { MonoFunTy $1 $3 }
-
-types :: { [RdrNameMonoType] }
-types : type { [$1] }
- | types COMMA type { $1 ++ [$3] }
-
-btype :: { RdrNameMonoType }
-btype : gtyconapp { case $1 of (tc, tys) -> MonoTyApp tc tys }
- | ntyconapp { case $1 of { (ty1, tys) ->
- if null tys
- then ty1
- else
- case ty1 of {
- MonoTyVar tv -> MonoTyApp tv tys;
- MonoTyApp tc ts -> MonoTyApp tc (ts++tys);
- MonoFunTy t1 t2 -> MonoTyApp (preludeQual SLIT("->")) (t1:t2:tys);
- MonoListTy ty -> MonoTyApp (preludeQual SLIT("[]")) (ty:tys);
- MonoTupleTy ts -> MonoTyApp (preludeQual (mkTupNameStr (length ts)))
- (ts++tys);
--- _ -> pprPanic "test:" (ppr PprDebug $1)
- }}
- }
+context : { [] }
+ | OCURLY context_list1 CCURLY { $2 }
-ntyconapp :: { (RdrNameMonoType, [RdrNameMonoType]) }
-ntyconapp : ntycon { ($1, []) }
- | ntyconapp atype { case $1 of (t1,tys) -> (t1, tys ++ [$2]) }
+context_list1 :: { RdrNameContext }
+context_list1 : class { [$1] }
+ | class COMMA context_list1 { $1 : $3 }
-gtyconapp :: { (RdrName, [RdrNameMonoType]) }
-gtyconapp : gtycon { ($1, []) }
- | gtyconapp atype { case $1 of (tc,tys) -> (tc, tys ++ [$2]) }
+class :: { (RdrName, RdrNameHsType) }
+class : qtc_name atype { ($1, $2) }
-atype :: { RdrNameMonoType }
-atype : gtycon { MonoTyApp $1 [] }
- | ntycon { $1 }
+ctype :: { RdrNameHsType }
+ctype : FORALL forall context DARROW type { mkHsForAllTy $2 $3 $5 }
+ | type { $1 }
-atypes :: { [RdrNameMonoType] }
-atypes : atype { [$1] }
- | atypes atype { $1 ++ [$2] }
+type :: { RdrNameHsType }
+type : btype { $1 }
+ | btype RARROW type { MonoFunTy $1 $3 }
-ntycon :: { RdrNameMonoType }
-ntycon : VARID { MonoTyVar (Unqual $1) }
- | OPAREN type COMMA types CPAREN { MonoTupleTy ($2 : $4) }
- | OBRACK type CBRACK { MonoListTy $2 }
- | OPAREN type CPAREN { $2 }
+ctypes2 :: { [RdrNameHsType] {- Two or more -} }
+ctypes2 : ctype COMMA ctype { [$1,$3] }
+ | ctype COMMA ctypes2 { $1 : $3 }
-gtycon :: { RdrName }
-gtycon : QCONID { $1 }
- | OPAREN RARROW CPAREN { preludeQual SLIT("->") }
- | OBRACK CBRACK { preludeQual SLIT("[]") }
- | OPAREN CPAREN { preludeQual SLIT("()") }
- | OPAREN commas CPAREN { preludeQual (mkTupNameStr $2) }
+btype :: { RdrNameHsType }
+btype : atype { $1 }
+ | qtc_name atypes1 { MonoTyApp $1 $2 }
+ | tv_name atypes1 { MonoTyApp $1 $2 }
-commas :: { Int }
-commas : COMMA { 2{-1 comma => arity 2-} }
- | commas COMMA { $1 + 1 }
+atype :: { RdrNameHsType }
+atype : qtc_name { MonoTyApp $1 [] }
+ | tv_name { MonoTyVar $1 }
+ | OPAREN ctypes2 CPAREN { MonoTupleTy dummyRdrTcName $2 }
+ | OBRACK type CBRACK { MonoListTy dummyRdrTcName $2 }
+ | OCURLY qtc_name atype CCURLY { MonoDictTy $2 $3 }
+ | OPAREN ctype CPAREN { $2 }
-simple :: { (RdrName, [FAST_STRING]) }
-simple : gtycon { ($1, []) }
- | gtyconvars { case $1 of (tc,tvs) -> (tc, reverse tvs) }
+atypes1 :: { [RdrNameHsType] {- One or more -} }
+atypes1 : atype { [$1] }
+ | atype atypes1 { $1 : $2
+---------------------------------------------------------------------
+ }
-gtyconvars :: { (RdrName, [FAST_STRING] {-reversed-}) }
-gtyconvars : gtycon VARID { ($1, [$2]) }
- | gtyconvars VARID { case $1 of (tc,tvs) -> (tc, $2 : tvs) }
+mod_name :: { Module }
+ : CONID { $1 }
-constrs :: { [(RdrName, RdrNameConDecl)] }
-constrs : constr { [$1] }
- | constrs VBAR constr { $1 ++ [$3] }
+var_occ :: { OccName }
+var_occ : VARID { VarOcc $1 }
+ | VARSYM { VarOcc $1 }
+ | BANG { VarOcc SLIT("!") {-sigh, double-sigh-} }
-constr :: { (RdrName, RdrNameConDecl) }
-constr : btyconapp
- { case $1 of (con, tys) -> (con, ConDecl con tys mkIfaceSrcLoc) }
- | QCONSYM { ($1, ConDecl $1 [] mkIfaceSrcLoc) }
- | QCONSYM batypes { ($1, ConDecl $1 $2 mkIfaceSrcLoc) }
- | gtycon OCURLY fields CCURLY
- { ($1, RecConDecl $1 $3 mkIfaceSrcLoc) }
+entity_occ :: { OccName }
+entity_occ : var_occ { $1 }
+ | CONID { TCOcc $1 }
+ | CONSYM { TCOcc $1 }
-btyconapp :: { (RdrName, [RdrNameBangType]) }
-btyconapp : gtycon { ($1, []) }
- | btyconapp batype { case $1 of (tc,tys) -> (tc, tys ++ [$2]) }
+val_occ :: { OccName }
+val_occ : var_occ { $1 }
+ | CONID { VarOcc $1 }
+ | CONSYM { VarOcc $1 }
-batype :: { RdrNameBangType }
-batype : atype { Unbanged (HsForAllTy [{-ToDo:tvs-}] [] $1) }
- | BANG atype { Banged (HsForAllTy [{-ToDo:tvs-}] [] $2) }
+val_occs :: { [OccName] }
+ : { [] }
+ | val_occ val_occs { $1 : $2 }
-batypes :: { [RdrNameBangType] }
-batypes : batype { [$1] }
- | batypes batype { $1 ++ [$2] }
-fields :: { [([RdrName], RdrNameBangType)] }
-fields : field { [$1] }
- | fields COMMA field { $1 ++ [$3] }
+qvar_name :: { RdrName }
+ : QVARID { varQual $1 }
+ | QVARSYM { varQual $1 }
-field :: { ([RdrName], RdrNameBangType) }
-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) }
-
-var :: { RdrName }
-var : QVARID { $1 }
- | QVARSYM { $1 }
-
-qname :: { RdrName }
-qname : QVARID { $1 }
- | QCONID { $1 }
- | QVARSYM { $1 }
- | QCONSYM { $1 }
-
-name :: { FAST_STRING }
-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 }
+var_name :: { RdrName }
+var_name : var_occ { Unqual $1 }
+
+
+qdata_name :: { RdrName }
+qdata_name : QCONID { varQual $1 }
+ | QCONSYM { varQual $1 }
+
+data_name :: { RdrName }
+data_name : CONID { Unqual (VarOcc $1) }
+ | CONSYM { Unqual (VarOcc $1) }
+
+
+qtc_name :: { RdrName }
+qtc_name : QCONID { tcQual $1 }
+
+qtc_names1 :: { [RdrName] }
+ : qtc_name { [$1] }
+ | qtc_name COMMA qtc_names1 { $1 : $3 }
+
+tc_name :: { RdrName }
+tc_name : CONID { Unqual (TCOcc $1) }
+
+
+tv_name :: { RdrName }
+tv_name : VARID { Unqual (TvOcc $1) }
+
+tv_names :: { [RdrName] }
+ : { [] }
+ | tv_name tv_names { $1 : $2 }
+
+tv_bndr :: { HsTyVar RdrName }
+tv_bndr : tv_name DCOLON akind { IfaceTyVar $1 $3 }
+ | tv_name { UserTyVar $1 }
+
+tv_bndrs :: { [HsTyVar RdrName] }
+ : { [] }
+ | tv_bndr tv_bndrs { $1 : $2 }
+
+kind :: { Kind }
+ : akind { $1 }
+ | akind RARROW kind { mkArrowKind $1 $3 }
+
+akind :: { Kind }
+ : VARSYM { mkTypeKind {- ToDo: check that it's "*" -} }
+ | OPAREN kind CPAREN { $2
+--------------------------------------------------------------------------
+ }
+
+
+instances_part :: { [RdrNameInstDecl] }
instances_part : INSTANCES_PART instdecls { $2 }
- | { emptyBag }
-
-instdecls :: { Bag RdrIfaceInst }
-instdecls : instd { unitBag $1 }
- | instdecls instd { $1 `snocBag` $2 }
-
-instd :: { RdrIfaceInst }
-instd : INSTANCE FORALL OBRACK tyvars CBRACK context DARROW gtycon restrict_inst SEMI { mk_inst (map Unqual $4) $6 $8 $9 }
- | INSTANCE FORALL OBRACK tyvars CBRACK gtycon general_inst SEMI { mk_inst (map Unqual $4) [] $6 $7 }
- | INSTANCE gtycon general_inst SEMI { mk_inst [] [] $2 $3 }
-
-restrict_inst :: { RdrNameMonoType }
-restrict_inst : gtycon { MonoTyApp $1 [] }
- | 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) }
-
-general_inst :: { RdrNameMonoType }
-general_inst : gtycon { MonoTyApp $1 [] }
- | OPAREN gtyconapp CPAREN { case $2 of (tc,tys) -> MonoTyApp tc tys }
- | OPAREN type COMMA types CPAREN { MonoTupleTy ($2:$4) }
- | OBRACK type CBRACK { MonoListTy $2 }
- | OPAREN btype RARROW type CPAREN { MonoFunTy $2 $4 }
-
-tyvars :: { [FAST_STRING] }
-tyvars : VARID { [$1] }
- | tyvars COMMA VARID { $1 ++ [$3]
+ | { [] }
+
+instdecls :: { [RdrNameInstDecl] }
+instdecls : { [] }
+ | instd instdecls { $1 : $2 }
+
+instd :: { RdrNameInstDecl }
+instd : INSTANCE ctype EQUAL var_name SEMI
+ { InstDecl $2
+ EmptyMonoBinds {- No bindings -}
+ [] {- No user pragmas -}
+ (Just $4) {- Dfun id -}
+ mkIfaceSrcLoc
--------------------------------------------------------------------------
- }
+ }
+
+id_info :: { [HsIdInfo RdrName] }
+id_info : { [] }
+ | ARITY_PART arity_info id_info { HsArity $2 : $3 }
+ | STRICT_PART strict_info id_info { HsStrictness $2 : $3 }
+ | UNFOLD_PART core_expr id_info { HsUnfold $2 : $3 }
+
+arity_info :: { ArityInfo }
+arity_info : INTEGER { exactArity (fromInteger $1) }
+
+strict_info :: { StrictnessInfo RdrName }
+strict_info : DEMAND qvar_name { mkStrictnessInfo $1 (Just $2) }
+ | DEMAND { mkStrictnessInfo $1 Nothing }
+ | BOTTOM { mkBottomStrictnessInfo }
+
+core_expr :: { UfExpr RdrName }
+core_expr : var_name { UfVar $1 }
+ | qvar_name { UfVar $1 }
+ | qdata_name { UfVar $1 }
+ | core_lit { UfLit $1 }
+ | core_expr core_arg { UfApp $1 $2 }
+ | LAM core_val_bndr RARROW core_expr { UfLam $2 $4 }
+ | BIGLAM core_tv_bndrs RARROW core_expr { foldr UfLam $4 $2 }
+
+ | CASE core_expr OF
+ OCURLY alg_alts core_default CCURLY { UfCase $2 (UfAlgAlts $5 $6) }
+ | CASE BANG core_expr OF
+ OCURLY prim_alts core_default CCURLY { UfCase $3 (UfPrimAlts $6 $7) }
+
+ | LET OCURLY core_val_bndr EQUAL core_expr CCURLY
+ IN core_expr { UfLet (UfNonRec $3 $5) $8 }
+ | LETREC OCURLY rec_binds CCURLY
+ IN core_expr { UfLet (UfRec $3) $6 }
+
+ | qdata_name BANG core_args { UfCon $1 $3 }
+ | qvar_name BANG core_args { UfPrim (UfOtherOp $1) $3 }
+ | coerce atype core_expr { UfCoerce $1 $2 $3 }
+
+rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] }
+ : { [] }
+ | core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 }
+
+coerce :: { UfCoercion RdrName }
+coerce : COERCE_IN qdata_name { UfIn $2 }
+ | COERCE_OUT qdata_name { UfOut $2 }
+
+prim_alts :: { [(Literal,UfExpr RdrName)] }
+ : { [] }
+ | core_lit RARROW core_expr SEMI prim_alts { ($1,$3) : $5 }
+
+alg_alts :: { [(RdrName, [UfBinder RdrName], UfExpr RdrName)] }
+ : { [] }
+ | qdata_name core_val_bndrs RARROW
+ core_expr SEMI alg_alts { ($1,$2,$4) : $6 }
+
+core_default :: { UfDefault RdrName }
+ : { UfNoDefault }
+ | core_val_bndr RARROW core_expr { UfBindDefault $1 $3 }
+
+core_arg :: { UfArg RdrName }
+ : var_name { UfVarArg $1 }
+ | qvar_name { UfVarArg $1 }
+ | qdata_name { UfVarArg $1 }
+ | core_lit { UfLitArg $1 }
+ | OBRACK atype CBRACK { UfTyArg $2 }
+
+core_args :: { [UfArg RdrName] }
+ : { [] }
+ | core_arg core_args { $1 : $2 }
+
+core_lit :: { Literal }
+core_lit : INTEGER { MachInt $1 True }
+ | CHAR { MachChar $1 }
+ | STRING { MachStr $1 }
+
+core_val_bndr :: { UfBinder RdrName }
+core_val_bndr : var_name DCOLON atype { UfValBinder $1 $3 }
+
+core_val_bndrs :: { [UfBinder RdrName] }
+core_val_bndrs : { [] }
+ | core_val_bndr core_val_bndrs { $1 : $2 }
+
+core_tv_bndr :: { UfBinder RdrName }
+core_tv_bndr : tv_name DCOLON akind { UfTyBinder $1 $3 }
+ | tv_name { UfTyBinder $1 mkTypeKind }
+
+core_tv_bndrs :: { [UfBinder RdrName] }
+core_tv_bndrs : { [] }
+ | core_tv_bndr core_tv_bndrs { $1 : $2 }
-pragmas_part :: { LocalPragmasMap }
-pragmas_part : PRAGMAS_PART
- { emptyFM }
- | { emptyFM }
-{
-}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[ParseUtils]{Help the interface parser}
-
-\begin{code}
-#include "HsVersions.h"
-
-module ParseUtils where
-
-IMP_Ubiq(){-uitous-}
-
-IMPORT_1_3(Char(isDigit, isAlpha, isAlphanum, isUpper))
-IMPORT_1_3(List(partition))
-
-import HsSyn -- quite a bit of stuff
-import RdrHsSyn -- oodles of synonyms
-import HsPragmas ( noDataPragmas, noClassPragmas, noClassOpPragmas,
- noInstancePragmas
- )
-
-import ErrUtils ( SYN_IE(Error) )
-import FiniteMap ( unitFM, listToFM, lookupFM, plusFM, FiniteMap )
-import Maybes ( maybeToBool, MaybeErr(..) )
-import Name ( isLexConId, isLexVarId, isLexConSym,
- mkTupNameStr, preludeQual, isRdrLexCon,
- RdrName(..) {-instance Outputable:ToDo:rm-}
- )
-import PprStyle ( PprStyle(..) ) -- ToDo: rm debugging
-import PrelMods ( pRELUDE )
-import Pretty ( ppCat, ppPStr, ppInt, ppShow, ppStr )
-import SrcLoc ( mkIfaceSrcLoc )
-import Util ( startsWith, isIn, panic, assertPanic{-, pprTrace ToDo:rm-} )
-\end{code}
-
-\begin{code}
-type UsagesMap = FiniteMap Module (Version, VersionsMap)
- -- module => its version, then to all its entities
- -- and their versions; "instance" is a magic entity
- -- representing all the instances def'd in that module
-type VersionsMap = FiniteMap FAST_STRING Version
- -- Versions for things def'd in this module
-type ExportsMap = FiniteMap FAST_STRING (OrigName, ExportFlag)
-type FixitiesMap = FiniteMap FAST_STRING RdrNameFixityDecl
-type LocalTyDefsMap = FiniteMap FAST_STRING RdrIfaceDecl -- for TyCon/Class
-type LocalValDefsMap = FiniteMap FAST_STRING RdrIfaceDecl -- for values incl DataCon
-type LocalPragmasMap = FiniteMap FAST_STRING PragmaStuff
-
-type PragmaStuff = String
-
-data ParsedIface
- = ParsedIface
- Module -- Module name
- (Bool, Bag Module) -- From a merging of these modules; True => merging occured
- Version -- Module version number
- (Maybe Version) -- Source version number
- UsagesMap -- Used when compiling this module
- VersionsMap -- Version numbers of things from this module
- ExportsMap -- Exported names
- (Bag Module) -- Special instance modules
- FixitiesMap -- fixities of local things
- LocalTyDefsMap -- Local TyCon/Class names defined
- LocalValDefsMap -- Local value names defined
- (Bag RdrIfaceInst) -- Local instance declarations
- LocalPragmasMap -- Pragmas for local names
-
------------------------------------------------------------------
-
-data RdrIfaceDecl
- = TypeSig RdrName SrcLoc RdrNameTyDecl
- | NewTypeSig RdrName RdrName SrcLoc RdrNameTyDecl
- | DataSig RdrName [RdrName] [RdrName] SrcLoc RdrNameTyDecl
- | ClassSig RdrName [RdrName] SrcLoc RdrNameClassDecl
- | ValSig RdrName SrcLoc RdrNamePolyType
-
-data RdrIfaceInst
- = InstSig RdrName RdrName SrcLoc (Module -> RdrNameInstDecl)
- -- InstDecl minus a Module name
-\end{code}
-
-\begin{code}
------------------------------------------------------------------
-data IfaceToken
- = ITinterface -- keywords
- | ITusages
- | ITversions
- | ITexports
- | ITinstance_modules
- | ITinstances
- | ITfixities
- | ITdeclarations
- | ITpragmas
- | ITdata
- | ITtype
- | ITnewtype
- | ITclass
- | ITwhere
- | ITinstance
- | ITinfixl
- | ITinfixr
- | ITinfix
- | ITforall
- | ITbang -- magic symbols
- | ITvbar
- | ITdcolon
- | ITcomma
- | ITdarrow
- | ITdotdot
- | ITequal
- | ITocurly
- | ITdccurly
- | ITdocurly
- | ITobrack
- | IToparen
- | ITrarrow
- | ITccurly
- | ITcbrack
- | ITcparen
- | ITsemi
- | ITinteger Integer -- numbers and names
- | ITvarid FAST_STRING
- | ITconid FAST_STRING
- | ITvarsym FAST_STRING
- | ITconsym FAST_STRING
- | ITqvarid RdrName
- | ITqconid RdrName
- | ITqvarsym RdrName
- | ITqconsym RdrName
- deriving Text -- debugging
-
-instance Text RdrName where -- debugging
- showsPrec _ rn = showString (ppShow 80 (ppr PprDebug rn))
-
------------------------------------------------------------------
-de_qual (Unqual n) = n
-de_qual (Qual _ n) = n
-
-en_mono :: FAST_STRING -> RdrNameMonoType
-en_mono tv = MonoTyVar (Unqual tv)
-
-{-OLD:
-type2context (MonoTupleTy tys) = map type2class_assertion tys
-type2context other_ty = [ type2class_assertion other_ty ]
-
-type2class_assertion (MonoTyApp clas [MonoTyVar tyvar]) = (clas, tyvar)
-type2class_assertion _ = panic "type2class_assertion: bad format"
--}
-
------------------------------------------------------------------
-mk_type :: (RdrName, [FAST_STRING])
- -> RdrNameMonoType
- -> LocalTyDefsMap
-
-mk_type (qtycon@(Qual mod tycon), tyvars) ty
- = let
- qtyvars = map Unqual tyvars
- in
- unitFM tycon (TypeSig qtycon mkIfaceSrcLoc $
- TySynonym qtycon qtyvars ty mkIfaceSrcLoc)
-
-mk_data :: RdrNameContext
- -> (RdrName, [FAST_STRING])
- -> [(RdrName, RdrNameConDecl)]
- -> (LocalTyDefsMap, LocalValDefsMap)
-
-mk_data ctxt (qtycon@(Qual mod tycon), tyvars) names_and_constrs
- = let
- (qthingnames, constrs) = unzip names_and_constrs
- (qconnames, qfieldnames) = partition isRdrLexCon qthingnames
- thingnames = [ t | (Qual _ t) <- qthingnames]
- qtyvars = map Unqual tyvars
-
- decl = DataSig qtycon qconnames qfieldnames mkIfaceSrcLoc $
- TyData ctxt qtycon qtyvars constrs Nothing noDataPragmas mkIfaceSrcLoc
- in
- (unitFM tycon decl, listToFM [(t,decl) | t <- thingnames])
-
-mk_new :: RdrNameContext
- -> (RdrName, [FAST_STRING])
- -> (RdrName, RdrNameMonoType)
- -> (LocalTyDefsMap, LocalValDefsMap)
-
-mk_new ctxt (qtycon@(Qual mod1 tycon), tyvars) (qconname@(Qual mod2 conname), ty)
- = ASSERT(mod1 == mod2)
- let
- qtyvars = map Unqual tyvars
- constr = NewConDecl qconname ty mkIfaceSrcLoc
-
- decl = NewTypeSig qtycon qconname mkIfaceSrcLoc $
- TyNew ctxt qtycon qtyvars [constr] Nothing noDataPragmas mkIfaceSrcLoc
- in
- (unitFM tycon decl, unitFM conname decl)
-
-mk_class :: RdrNameContext
- -> (RdrName, RdrName)
- -> [(FAST_STRING, RdrNameSig)]
- -> (LocalTyDefsMap, LocalValDefsMap)
-
-mk_class ctxt (qclas@(Qual mod clas), tyvar) ops_and_sigs
- = case (unzip ops_and_sigs) of { (opnames, sigs) ->
- let
- qopnames = map (Qual mod) opnames
- op_sigs = map opify sigs
-
- decl = ClassSig qclas qopnames mkIfaceSrcLoc $
- ClassDecl ctxt qclas tyvar op_sigs EmptyMonoBinds noClassPragmas mkIfaceSrcLoc
- in
- (unitFM clas decl, listToFM [(o,decl) | o <- opnames]) }
- where
- opify (Sig f ty _ loc) = ClassOpSig f ty noClassOpPragmas loc
-
-mk_inst :: [RdrName]
- -> RdrNameContext
- -> RdrName -- class
- -> RdrNameMonoType -- fish the tycon out yourself...
- -> RdrIfaceInst
-
-mk_inst tvs ctxt qclas@(Qual cmod cname) mono_ty
- = let
- ty = HsForAllTy tvs 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
- tycon_name (MonoListTy _) = preludeQual SLIT("[]")
- tycon_name (MonoFunTy _ _) = preludeQual SLIT("->")
- tycon_name (MonoTupleTy ts) = preludeQual (mkTupNameStr (length ts))
-
------------------------------------------------------------------
-lexIface :: String -> [IfaceToken]
-
-lexIface input
- = _scc_ "Lexer"
- case input of
- [] -> []
-
- -- whitespace and comments
- ' ' : cs -> lexIface cs
- '\t' : cs -> lexIface cs
- '\n' : cs -> lexIface cs
- '-' : '-' : cs -> lex_comment cs
- '{' : '-' : cs -> lex_nested_comment 1{-one seen-} cs
-
- '(' : '.' : '.' : ')' : cs -> ITdotdot : lexIface cs
- '{' : '{' : cs -> ITdocurly : lexIface cs
- '}' : '}' : cs -> ITdccurly : lexIface cs
- '{' : cs -> ITocurly : lexIface cs
- '}' : cs -> ITccurly : lexIface cs
- '(' : cs -> IToparen : lexIface cs
- ')' : cs -> ITcparen : lexIface cs
- '[' : cs -> ITobrack : lexIface cs
- ']' : cs -> ITcbrack : lexIface cs
- ',' : cs -> ITcomma : lexIface cs
- ';' : cs -> ITsemi : lexIface cs
-
- '_' : '_' : cs -> lex_keyword cs
-
- c : cs | isUpper c -> lex_word input -- don't know if "Module." on front or not
- | isDigit c -> lex_num input
- | isAlpha c -> lex_name Nothing is_var_sym input
- | is_sym_sym c -> lex_name Nothing is_sym_sym input
-
- other -> error ("lexing:"++other)
- where
- lex_comment str
- = case (span ((/=) '\n') str) of { (junk, rest) ->
- lexIface rest }
-
- ------------------
- lex_nested_comment lvl [] = error "EOF in nested comment in interface"
- lex_nested_comment lvl str
- = case str of
- '{' : '-' : xs -> lex_nested_comment (lvl+1) xs
- '-' : '}' : xs -> if lvl == 1
- then lexIface xs
- else lex_nested_comment (lvl-1) xs
- _ : xs -> lex_nested_comment lvl xs
-
- -----------
- lex_num str
- = case (span isDigit str) of { (num, rest) ->
- ITinteger (read num) : lexIface rest }
-
- -----------
- 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_var_sym1 '_' = False
- is_var_sym1 c = is_var_sym c
-
- 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...
- case (module_dot str) of
- Nothing -> lex_name Nothing (in_the_club str) str
- Just (m,rest) -> lex_name (Just m) (in_the_club rest) rest
- where
- in_the_club [] = panic "lex_word:in_the_club"
- in_the_club (x:y) | 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:y))
-
- module_dot (c:cs)
- = if not (isUpper c) || c == '\'' then
- Nothing
- else
- case (span is_var_sym cs) of { (word, rest) ->
- case rest of
- [] -> Nothing
- (r:rs) | r == '.' -> Just (_PK_ (c:word), rs)
- _ -> Nothing
- }
-
- lex_keyword str
- = case (span is_var_sym str) of { (kw, rest) ->
- case (lookupFM keywordsFM kw) of
- Nothing -> panic ("lex_keyword:"++str)
- Just xx -> xx : lexIface rest
- }
-
- lex_name module_dot in_the_club str
- = case (span in_the_club str) of { (word, rest) ->
- case (lookupFM keywordsFM word) of
- Just xx -> let
- cont = xx : lexIface rest
- in
- case xx of
- ITbang -> case module_dot of
- Nothing -> cont
- Just m -> ITqvarsym (Qual m SLIT("!"))
- : lexIface rest
- _ -> cont
- Nothing ->
- (let
- f = head word -- first char
- n = _PK_ word
- in
- case module_dot of
- Nothing ->
- categ f n (ITconid n) (ITvarid n) (ITconsym n) (ITvarsym n)
- Just m ->
- let
- q = Qual m n
- in
- categ f n (ITqconid q) (ITqvarid q) (ITqconsym q) (ITqvarsym q)
-
- ) : lexIface rest ;
- }
- ------------
- 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
-
- ------------
- keywordsFM :: FiniteMap String IfaceToken
- keywordsFM = listToFM [
- ("interface", ITinterface)
-
- ,("usages__", ITusages)
- ,("versions__", ITversions)
- ,("exports__", ITexports)
- ,("instance_modules__", ITinstance_modules)
- ,("instances__", ITinstances)
- ,("fixities__", ITfixities)
- ,("declarations__", ITdeclarations)
- ,("pragmas__", ITpragmas)
- ,("forall__", ITforall)
-
- ,("data", ITdata)
- ,("type", ITtype)
- ,("newtype", ITnewtype)
- ,("class", ITclass)
- ,("where", ITwhere)
- ,("instance", ITinstance)
- ,("infixl", ITinfixl)
- ,("infixr", ITinfixr)
- ,("infix", ITinfix)
-
- ,("->", ITrarrow)
- ,("|", ITvbar)
- ,("!", ITbang)
- ,("::", ITdcolon)
- ,("=>", ITdarrow)
- ,("=", ITequal)
- ]
-
------------------------------------------------------------------
-type IfM a = MaybeErr a Error
-
-returnIf :: a -> IfM a
-thenIf :: IfM a -> (a -> IfM b) -> IfM b
-happyError :: Int -> [IfaceToken] -> IfM a
-
-returnIf a = Succeeded a
-
-thenIf (Succeeded a) k = k a
-thenIf (Failed err) _ = Failed err
-
-happyError ln toks = Failed (ifaceParseErr ln toks)
------------------------------------------------------------------
-
-ifaceParseErr ln toks sty
- = ppCat [ppPStr SLIT("Interface-file parse error: line"), ppInt ln, ppStr "toks=", ppStr (show (take 10 toks))]
-\end{code}
IMPORT_1_3(List(partition))
import HsSyn
-import RdrHsSyn ( SYN_IE(RdrNameHsModule), SYN_IE(RdrNameImportDecl) )
-import RnHsSyn ( RnName(..){-.. is for Ix hack only-}, SYN_IE(RenamedHsModule), isRnTyConOrClass, isRnWired )
-
---ToDo:rm: all for debugging only
---import Maybes
---import Name
---import Outputable
---import RnIfaces
---import PprStyle
---import Pretty
---import FiniteMap
---import Util (pprPanic, pprTrace)
-
-import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), RdrIfaceInst(..),
- UsagesMap(..), VersionsMap(..)
- )
-import RnMonad
-import RnNames ( getGlobalNames, SYN_IE(GlobalNameInfo) )
-import RnSource ( rnSource )
-import RnIfaces ( rnIfaces, initIfaceCache, IfaceCache )
-import RnUtils ( SYN_IE(RnEnv), extendGlobalRnEnv, emptyRnEnv )
+import RdrHsSyn ( RdrName, SYN_IE(RdrNameHsModule), SYN_IE(RdrNameImportDecl) )
+import RnHsSyn ( SYN_IE(RenamedHsModule), SYN_IE(RenamedHsDecl), extractHsTyNames )
-import Bag ( isEmptyBag, unionBags, unionManyBags, bagToList, listToBag )
-import CmdLineOpts ( opt_HiMap, opt_NoImplicitPrelude )
+import CmdLineOpts ( opt_HiMap )
+import RnMonad
+import RnNames ( getGlobalNames )
+import RnSource ( rnDecl )
+import RnIfaces ( getImportedInstDecls, getDecl, getImportVersions, getSpecialInstModules,
+ mkSearchPath, getWiredInDecl
+ )
+import RnEnv ( availsToNameSet, addAvailToNameSet, addImplicitOccsRn )
+import Id ( GenId {- instance NamedThing -} )
+import Name ( Name, Provenance, ExportFlag(..), isLocallyDefined,
+ NameSet(..), elemNameSet, mkNameSet, unionNameSets, nameSetToList,
+ isWiredInName, modAndOcc
+ )
+import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon )
+import TyCon ( TyCon )
import ErrUtils ( SYN_IE(Error), SYN_IE(Warning) )
import FiniteMap ( emptyFM, eltsFM, fmToList, addToFM, FiniteMap )
-import Maybes ( catMaybes )
-import Name ( isLocallyDefined, mkWiredInName, getLocalName, isLocalName,
- origName,
- Name, RdrName(..), ExportFlag(..)
- )
---import PprStyle -- ToDo:rm
-import PrelInfo ( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
import Pretty
-import Unique ( ixClassKey )
-import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM )
-import UniqSupply ( splitUniqSupply )
-import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} )
+import PprStyle ( PprStyle(..) )
+import Util ( panic, assertPanic, pprTrace )
\end{code}
+
+
\begin{code}
renameModule :: UniqSupply
-> RdrNameHsModule
-
- -> IO (RenamedHsModule, -- output, after renaming
- RnEnv, -- final env (for renaming derivings)
- [Module], -- imported modules; for profiling
-
- (Name -> ExportFlag, -- export info
- ([(Name,ExportFlag)],
- [(Name,ExportFlag)])),
-
- (UsagesMap,
- VersionsMap, -- version info; for usage
- [Module]), -- instance modules; for iface
-
- Bag Error,
- Bag Warning)
+ -> IO (Maybe -- Nothing <=> everything up to date;
+ -- no ned to recompile any further
+ (RenamedHsModule, -- Output, after renaming
+ InterfaceDetails, -- Interface; for interface file generatino
+ RnNameSupply, -- Final env; for renaming derivings
+ [Module]), -- Imported modules; for profiling
+ Bag Error,
+ Bag Warning
+ )
\end{code}
-ToDo: May want to arrange to return old interface for this module!
-ToDo: Deal with instances (instance version, this module on instance list ???)
\begin{code}
-renameModule us input@(HsModule modname _ _ imports _ _ _ _ _ _ _ _ _ _)
-
- = {-
- let
- pp_pair (n,m) = ppBesides [ppPStr m,ppChar '.',ppPStr n]
- in
- pprTrace "builtins:\n" (case builtinNameMaps of { (builtin_ids, builtin_tcs) ->
- ppAboves [ ppCat (map pp_pair (keysFM builtin_ids))
- , ppCat (map pp_pair (keysFM builtin_tcs))
- , ppCat (map pp_pair (keysFM builtinKeysMap))
- ]}) $
- -}
- -- _scc_ "rnGlobalNames"
- makeHiMap opt_HiMap >>= \ hi_files ->
--- pprTrace "HiMap:\n" (ppAboves [ ppCat [ppPStr m, ppStr p] | (m,p) <- fmToList hi_files])
- initIfaceCache modname hi_files >>= \ iface_cache ->
-
- fixIO ( \ ~(_, _, _, _, rec_occ_fm, ~(rec_export_fn,_)) ->
+renameModule us this_mod@(HsModule mod_name vers exports imports fixities local_decls loc)
+ = -- INITIALISE THE RENAMER MONAD
+ initRn mod_name us (mkSearchPath opt_HiMap) loc $
+
+ -- FIND THE GLOBAL NAME ENVIRONMENT
+ getGlobalNames this_mod `thenRn` \ global_name_info ->
+
+ case global_name_info of {
+ Nothing -> -- Everything is up to date; no need to recompile further
+ returnRn Nothing ;
+
+ -- Otherwise, just carry on
+ Just (export_env, rn_env, local_avails) ->
+
+ -- RENAME THE SOURCE
+ -- We also add occurrences for Int, Double, and (), because they
+ -- are the types to which ambigious type variables may be defaulted by
+ -- the type checker; so they won't every appear explicitly.
+ -- [The () one is a GHC extension for defaulting CCall results.]
+ initRnMS rn_env mod_name SourceMode (mapRn rnDecl local_decls) `thenRn` \ rn_local_decls ->
+ addImplicitOccsRn [getName intTyCon,
+ getName doubleTyCon,
+ getName unitTyCon] `thenRn_`
+
+ -- SLURP IN ALL THE NEEDED DECLARATIONS
+ -- Notice that the rnEnv starts empty
+ closeDecls rn_local_decls (availsToNameSet local_avails) []
+ `thenRn` \ (rn_all_decls, imported_avails) ->
+
+ -- SLURP IN ALL NEEDED INSTANCE DECLARATIONS
+ -- We keep the ones that only mention things (type constructors, classes) that are
+ -- already imported. Ones which don't can't possibly be useful to us.
+ getImportedInstDecls `thenRn` \ imported_insts ->
let
- rec_occ_fn :: Name -> [RdrName]
- rec_occ_fn n = case lookupUFM rec_occ_fm n of
- Nothing -> []
- Just (rn,occs) -> occs
+ all_big_names = mkNameSet [name | Avail name _ <- local_avails] `unionNameSets`
+ mkNameSet [name | Avail name _ <- imported_avails]
- global_name_info = (builtinNameMaps, builtinKeysMap, rec_export_fn, rec_occ_fn)
+ rn_needed_insts = [ initRnMS emptyRnEnv mod_name InterfaceMode (rnDecl (InstD inst_decl))
+ | (inst_names, mod_name, inst_decl) <- imported_insts,
+ all (`elemNameSet` all_big_names) inst_names
+ ]
in
- getGlobalNames iface_cache global_name_info us1 input >>=
- \ (occ_env, imp_mods, unqual_imps, imp_fixes, top_errs, top_warns) ->
+ sequenceRn rn_needed_insts `thenRn` \ inst_decls ->
+ -- Maybe we need to do another close-decls?
- if not (isEmptyBag top_errs) then
- return (rn_panic, rn_panic, top_errs, top_warns, emptyUFM, rn_panic)
- else
- -- No top-level name errors so rename source ...
- -- _scc_ "rnSource"
- case initRn True modname occ_env us2
- (rnSource imp_mods unqual_imps imp_fixes input) of {
- ((rn_module, export_fn, module_dotdots, src_occs), src_errs, src_warns) ->
+ -- GENERATE THE VERSION/USAGE INFO
+ getImportVersions imported_avails `thenRn` \ import_versions ->
+ getNameSupplyRn `thenRn` \ name_supply ->
- --pprTrace "renameModule:" (ppCat (map (ppr PprDebug . fst) (bagToList src_occs))) $
- let
- occ_fm :: UniqFM (RnName, [RdrName])
- occ_list = [ (rn,(rn,[occ])) | (rn,occ) <- bagToList src_occs]
- occ_fm = addListToUFM_C insert_occ emptyUFM occ_list
-
- insert_occ (rn,olds) (rn',[new]) = (rn, insert new olds)
-
- insert new [] = [new]
- insert new xxs@(x:xs) = case cmp new x of LT_ -> new : xxs
- EQ_ -> xxs
- GT__ -> x : insert new xs
-
- occ_warns = map multipleOccWarn (filter multiple_occs (eltsUFM occ_fm))
-
- multiple_occs (rn, (o1:o2:_)) = getLocalName o1 /= SLIT("negate")
- -- the user is rarely responsible if
- -- "negate" is mentioned in multiple ways
- multiple_occs _ = False
+ -- GENERATE THE SPECIAL-INSTANCE MODULE LIST
+ -- The "special instance" modules are those modules that contain instance
+ -- declarations that contain no type constructor or class that was declared
+ -- in that module.
+ getSpecialInstModules `thenRn` \ imported_special_inst_mods ->
+ let
+ special_inst_decls = [d | InstD d@(InstDecl inst_ty _ _ _ _) <- rn_local_decls,
+ all (not.isLocallyDefined) (nameSetToList (extractHsTyNames inst_ty))
+ ]
+ special_inst_mods | null special_inst_decls = imported_special_inst_mods
+ | otherwise = mod_name : imported_special_inst_mods
in
- return (rn_module, imp_mods,
- top_errs `unionBags` src_errs,
- top_warns `unionBags` src_warns `unionBags` listToBag occ_warns,
- occ_fm, (export_fn, module_dotdots))
-
- }) >>= \ (rn_module, imp_mods, errs_so_far, warns_so_far, occ_fm, export_stuff) ->
+
+
- if not (isEmptyBag errs_so_far) then
- 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 ...
- -- _scc_ "preRnIfaces"
+ -- RETURN THE RENAMED MODULE
let
- -- split up all names that occurred in the source; between
- -- those that are defined therein and those merely mentioned.
- -- We also divide by tycon/class and value names (as usual).
-
- occ_rns = [ rn | (rn,_) <- eltsUFM occ_fm ]
- -- all occurrence names, from this module and imported
-
- (defined_here, defined_elsewhere)
- = partition isLocallyDefined occ_rns
-
- (_, imports_used)
- = partition isRnWired defined_elsewhere
-
- (def_tcs, def_vals) = partition isRnTyConOrClass defined_here
- (occ_tcs, occ_vals) = partition isRnTyConOrClass occ_rns
- -- the occ stuff includes *all* occurrences,
- -- including those for which we have definitions
-
- (orig_def_env, orig_def_dups)
- = extendGlobalRnEnv emptyRnEnv (map pairify_rn def_vals)
- (map pairify_rn def_tcs)
- (orig_occ_env, orig_occ_dups)
- = extendGlobalRnEnv emptyRnEnv (map pairify_rn occ_vals)
- (map pairify_rn occ_tcs)
-
- -- This stuff is pretty dodgy right now: I think original
- -- names and occurrence names may be getting entangled
- -- when they shouldn't be... WDP 96/06
-
- pairify_rn rn -- ToDo: move to Name?
- = let
- name = getName rn
- in
- (if isLocalName name
- then Unqual (getLocalName name)
- else case (origName "pairify_rn" name) of { OrigName m n ->
- Qual m n }
- , rn)
+ import_mods = [mod | ImportDecl mod _ _ _ _ <- imports]
+
+ renamed_module = HsModule mod_name vers
+ trashed_exports trashed_imports trashed_fixities
+ (inst_decls ++ rn_all_decls)
+ loc
in
--- ASSERT (isEmptyBag orig_occ_dups)
--- (if (isEmptyBag orig_occ_dups) then \x->x
--- else pprTrace "orig_occ_dups:" (ppAboves [ ppCat [ppr PprDebug m, ppr PprDebug n, ppr PprDebug o] | (m,n,o) <- bagToList orig_occ_dups])) $
- ASSERT (isEmptyBag orig_def_dups)
-
- -- _scc_ "rnIfaces"
- rnIfaces iface_cache imp_mods us3 orig_def_env orig_occ_env
- rn_module (initMustHaves ++ imports_used) >>=
- \ (rn_module_with_imports, final_env,
- (implicit_val_fm, implicit_tc_fm),
- usage_stuff,
- (iface_errs, iface_warns)) ->
-
- return (rn_module_with_imports,
- final_env,
- imp_mods,
- export_stuff,
- usage_stuff,
- errs_so_far `unionBags` iface_errs,
- warns_so_far `unionBags` iface_warns)
+ returnRn (Just (renamed_module,
+ (import_versions, export_env, special_inst_mods),
+ name_supply,
+ import_mods))
+ }
where
- rn_panic = panic "renameModule: aborted with errors"
-
- (us1, us') = splitUniqSupply us
- (us2, us3) = splitUniqSupply us'
-
-initMustHaves :: [RnName]
- -- things we *must* find declarations for, because the
- -- compiler may eventually make reference to them (e.g.,
- -- class Eq)
-initMustHaves
- | opt_NoImplicitPrelude
- = [{-no Prelude.hi, no point looking-}]
- | otherwise
- = [ name_fn (mkWiredInName u orig ExportAll)
- | (orig@(OrigName mod str), (u, name_fn)) <- fmToList builtinKeysMap ]
+ trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
+ trashed_imports = {-trace "rnSource:trashed_imports"-} []
+ trashed_fixities = []
\end{code}
\begin{code}
-makeHiMap :: Maybe String -> IO (FiniteMap Module FilePath)
-
-makeHiMap Nothing = error "Rename.makeHiMap:no .hi map given by the GHC driver (?)"
-makeHiMap (Just f)
- = readFile f >>= \ cts ->
- return (snag_mod emptyFM cts [])
- where
- -- we alternate between "snag"ging mod(ule names) and path(names),
- -- accumulating names (reversed) and the final resulting map
- -- as we move along.
-
- snag_mod map [] [] = map
- snag_mod map (' ':cs) rmod = snag_path map (_PK_ (reverse rmod)) cs []
- snag_mod map (c:cs) rmod = snag_mod map cs (c:rmod)
-
- snag_path map mod [] rpath = addToFM map mod (reverse rpath)
- snag_path map mod ('\n':cs) rpath = snag_mod (addToFM map mod (reverse rpath)) cs []
- snag_path map mod (c:cs) rpath = snag_path map mod cs (c:rpath)
+closeDecls :: [RenamedHsDecl] -- Declarations got so far
+ -> NameSet -- Names bound by those declarations
+ -> [AvailInfo] -- Available stuff generated by closeDecls so far
+ -> RnMG ([RenamedHsDecl], -- The closed set
+ [AvailInfo]) -- Available stuff generated by closeDecls
+ -- The monad includes a list of possibly-unresolved Names
+ -- This list is empty when closeDecls returns
+
+closeDecls decls decl_names import_avails
+ = popOccurrenceName `thenRn` \ maybe_unresolved ->
+
+ case maybe_unresolved of
+
+ -- No more unresolved names; we're done
+ Nothing -> returnRn (decls, import_avails)
+
+ -- An "unresolved" name that we've already dealt with
+ Just (name,_) | name `elemNameSet` decl_names
+ -> closeDecls decls decl_names import_avails
+
+ -- An unresolved name that's wired in. In this case there's no
+ -- declaration to get, but we still want to record it as now available,
+ -- so that we remember to look for instance declarations involving it.
+ Just (name,_) | isWiredInName name
+ -> getWiredInDecl name `thenRn` \ decl_avail ->
+ closeDecls decls
+ (addAvailToNameSet decl_names decl_avail)
+ (decl_avail : import_avails)
+
+ -- Genuinely unresolved name
+ Just (name,necessity) | otherwise
+ -> getDecl name `thenRn` \ (decl_avail,new_decl) ->
+ case decl_avail of
+
+ -- Can't find the declaration; check that it was optional
+ NotAvailable -> checkRn (case necessity of { Optional -> True; other -> False})
+ (getDeclErr name) `thenRn_`
+ closeDecls decls decl_names import_avails
+
+ -- Found it
+ other -> initRnMS emptyRnEnv mod_name InterfaceMode (
+ rnDecl new_decl
+ ) `thenRn` \ rn_decl ->
+ closeDecls (rn_decl : decls)
+ (addAvailToNameSet decl_names decl_avail)
+ (decl_avail : import_avails)
+ where
+ (mod_name,_) = modAndOcc name
+
+getDeclErr name sty
+ = ppSep [ppStr "Failed to find interface decl for", ppr sty name]
\end{code}
-Warning message used herein:
-\begin{code}
-multipleOccWarn (name, occs) sty
- = ppBesides [ppStr "warning:multiple names used to refer to `", ppr sty name, ppStr "': ",
- ppInterleave ppComma (map (ppr sty) occs)]
-\end{code}
+
#include "HsVersions.h"
module RnBinds (
- rnTopBinds,
+ rnTopBinds, rnTopMonoBinds,
rnMethodBinds,
- rnBinds,
- SYN_IE(FreeVars),
- SYN_IE(DefinedVars)
+ rnBinds, rnMonoBinds
) where
IMP_Ubiq()
import RnHsSyn
import RnMonad
import RnExpr ( rnMatch, rnGRHSsAndBinds, rnPat, checkPrecMatch )
+import RnEnv ( bindLocatedLocalsRn, lookupRn, lookupOccRn, isUnboundName )
import CmdLineOpts ( opt_SigsRequired )
import Digraph ( stronglyConnComp )
import ErrUtils ( addErrLoc, addShortErrLocLine )
-import Name ( getLocalName, RdrName )
+import Name ( OccName(..), Provenance,
+ Name {- instance Eq -},
+ NameSet(..), emptyNameSet, mkNameSet, unionNameSets,
+ minusNameSet, unionManyNameSets, elemNameSet, unitNameSet, nameSetToList
+ )
import Maybes ( catMaybes )
--import PprStyle--ToDo:rm
import Pretty
-import UniqSet ( emptyUniqSet, unitUniqSet, mkUniqSet,
- unionUniqSets, unionManyUniqSets,
- elementOfUniqSet, uniqSetToList, SYN_IE(UniqSet) )
import Util ( thenCmp, isIn, removeDups, panic, panic#, assertPanic )
+import UniqSet ( SYN_IE(UniqSet) )
+import ListSetOps ( minusList )
+import Bag ( bagToList )
+import UniqFM ( UniqFM )
+import ErrUtils ( SYN_IE(Error) )
\end{code}
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
ToDo: deal with case where a single monobinds binds the same variable
twice.
-Sets of variable names are represented as sets explicitly, rather than lists.
-
-\begin{code}
-type DefinedVars = UniqSet RnName
-type FreeVars = UniqSet RnName
-\end{code}
-
-i.e., binders.
-
The vertag tag is a unique @Int@; the tags only need to be unique
within one @MonoBinds@, so that unique-Int plumbing is done explicitly
(heavy monad machinery not needed).
%* naming conventions *
%* *
%************************************************************************
+
\subsection[name-conventions]{Name conventions}
The basic algorithm involves walking over the tree and returning a tuple
%* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) *
%* *
%************************************************************************
+
\subsubsection[dep-HsBinds]{Polymorphic bindings}
Non-recursive expressions are reconstructed without any changes at top
it expects the global environment to contain bindings for the binders
(which are all class operations).
+%************************************************************************
+%* *
+%* Top-level bindings
+%* *
+%************************************************************************
+
+@rnTopBinds@ and @rnTopMonoBinds@ assume that the environment already
+contains bindings for the binders of this particular binding.
+
\begin{code}
-rnTopBinds :: RdrNameHsBinds -> RnM_Fixes s RenamedHsBinds
-rnMethodBinds :: RnName{-class-} -> RdrNameMonoBinds -> RnM_Fixes s RenamedMonoBinds
-rnBinds :: RdrNameHsBinds -> RnM_Fixes s (RenamedHsBinds, FreeVars, [RnName])
+rnTopBinds :: RdrNameHsBinds -> RnMS s RenamedHsBinds
-rnTopBinds EmptyBinds = returnRn EmptyBinds
+rnTopBinds EmptyBinds = returnRn EmptyBinds
rnTopBinds (SingleBind (RecBind bind)) = rnTopMonoBinds bind []
rnTopBinds (BindWith (RecBind bind) sigs) = rnTopMonoBinds bind sigs
- -- the parser doesn't produce other forms
-
--- ********************************************************************
-
-rnMethodBinds class_name EmptyMonoBinds = returnRn EmptyMonoBinds
-
-rnMethodBinds class_name (AndMonoBinds mb1 mb2)
- = andRn AndMonoBinds (rnMethodBinds class_name mb1)
- (rnMethodBinds class_name mb2)
+ -- The parser doesn't produce other forms
-rnMethodBinds class_name (FunMonoBind occname inf matches locn)
- = pushSrcLocRn locn $
- lookupClassOp class_name occname `thenRn` \ op_name ->
- mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
- mapRn (checkPrecMatch inf op_name) new_matches `thenRn_`
- returnRn (FunMonoBind op_name inf new_matches locn)
-
-rnMethodBinds class_name (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
- = pushSrcLocRn locn $
- lookupClassOp class_name occname `thenRn` \ op_name ->
- rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) ->
- returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
--- Can't handle method pattern-bindings which bind multiple methods.
-rnMethodBinds _ mbind@(PatMonoBind other_pat _ locn)
- = failButContinueRn EmptyMonoBinds (methodBindErr mbind locn)
+rnTopMonoBinds :: RdrNameMonoBinds
+ -> [RdrNameSig]
+ -> RnMS s RenamedHsBinds
--- ********************************************************************
+rnTopMonoBinds EmptyMonoBinds sigs
+ = returnRn EmptyBinds
-rnBinds EmptyBinds = returnRn (EmptyBinds,emptyUniqSet,[])
-rnBinds (SingleBind (RecBind bind)) = rnNestedMonoBinds bind []
-rnBinds (BindWith (RecBind bind) sigs) = rnNestedMonoBinds bind sigs
- -- the parser doesn't produce other forms
+rnTopMonoBinds mbinds sigs
+ = mapRn lookupRn binder_rdr_names `thenRn` \ binder_names ->
+ let
+ binder_set = mkNameSet binder_names
+ in
+ rn_mono_binds True {- top level -}
+ binder_set mbinds sigs `thenRn` \ (new_binds, fv_set) ->
+ returnRn new_binds
+ where
+ binder_rdr_names = map fst (bagToList (collectMonoBinders mbinds))
\end{code}
-@rnNestedMonoBinds@
+%************************************************************************
+%* *
+%* Nested binds
+%* *
+%************************************************************************
+
+@rnMonoBinds@
- collects up the binders for this declaration group,
- - checkes that they form a set
+ - checks that they form a set
- extends the environment to bind them to new local names
- calls @rnMonoBinds@ to do the real work
the free var info.
\begin{code}
-rnTopMonoBinds :: RdrNameMonoBinds -> [RdrNameSig] -> RnM_Fixes s RenamedHsBinds
+rnBinds :: RdrNameHsBinds
+ -> (RenamedHsBinds -> RnMS s (result, FreeVars))
+ -> RnMS s (result, FreeVars)
-rnTopMonoBinds EmptyMonoBinds sigs = returnRn EmptyBinds
-
-rnTopMonoBinds mbs sigs
- = rnBindSigs True{-top-level-} (collectMonoBinders mbs) sigs `thenRn` \ siglist ->
- rnMonoBinds mbs siglist `thenRn` \ (new_binds, fv_set) ->
- returnRn new_binds
+rnBinds EmptyBinds thing_inside = thing_inside EmptyBinds
+rnBinds (SingleBind (RecBind bind)) thing_inside = rnMonoBinds bind [] thing_inside
+rnBinds (BindWith (RecBind bind) sigs) thing_inside = rnMonoBinds bind sigs thing_inside
+ -- the parser doesn't produce other forms
-rnNestedMonoBinds :: RdrNameMonoBinds -> [RdrNameSig]
- -> RnM_Fixes s (RenamedHsBinds, FreeVars, [RnName])
+rnMonoBinds :: RdrNameMonoBinds -> [RdrNameSig]
+ -> (RenamedHsBinds -> RnMS s (result, FreeVars))
+ -> RnMS s (result, FreeVars)
-rnNestedMonoBinds EmptyMonoBinds sigs
- = returnRn (EmptyBinds, emptyUniqSet, [])
+rnMonoBinds EmptyMonoBinds sigs thing_inside = thing_inside EmptyBinds
-rnNestedMonoBinds mbinds sigs -- Non-empty monobinds
- =
- -- Extract all the binders in this group,
+rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
+ = -- Extract all the binders in this group,
-- and extend current scope, inventing new names for the new binders
-- This also checks that the names form a set
+ bindLocatedLocalsRn "binding group" mbinders_w_srclocs $ \ new_mbinders ->
let
- mbinders_w_srclocs = collectMonoBindersAndLocs mbinds
- mbinders = map fst mbinders_w_srclocs
+ binder_set = mkNameSet new_mbinders
in
- newLocalNames "variable"
- mbinders_w_srclocs `thenRn` \ new_mbinders ->
-
- extendSS2 new_mbinders (
- rnBindSigs False{-not top- level-} mbinders sigs `thenRn` \ siglist ->
- rnMonoBinds mbinds siglist
- ) `thenRn` \ (new_binds, fv_set) ->
- returnRn (new_binds, fv_set, new_mbinders)
+ rn_mono_binds False {- not top level -}
+ binder_set mbinds sigs `thenRn` \ (binds,bind_fvs) ->
+
+ -- Now do the "thing inside", and deal with the free-variable calculations
+ thing_inside binds `thenRn` \ (result,result_fvs) ->
+ returnRn (result, (result_fvs `unionNameSets` bind_fvs) `minusNameSet` binder_set)
+ where
+ mbinders_w_srclocs = bagToList (collectMonoBinders mbinds)
\end{code}
+
+%************************************************************************
+%* *
+%* MonoBinds -- the main work is done here
+%* *
+%************************************************************************
+
@rnMonoBinds@ is used by *both* top-level and nested bindings. It
assumes that all variables bound in this group are already in scope.
-This is done *either* by pass 3 (for the top-level bindings),
-*or* by @rnNestedMonoBinds@ (for the nested ones).
+This is done *either* by pass 3 (for the top-level bindings), *or* by
+@rnNestedMonoBinds@ (for the nested ones).
\begin{code}
-rnMonoBinds :: RdrNameMonoBinds
- -> [RenamedSig] -- Signatures attached to this group
- -> RnM_Fixes s (RenamedHsBinds, FreeVars)
-
-rnMonoBinds mbinds siglist
+rn_mono_binds :: Bool -- True <=> top level
+ -> NameSet -- Binders of this group
+ -> RdrNameMonoBinds
+ -> [RdrNameSig] -- Signatures attached to this group
+ -> RnMS s (RenamedHsBinds, --
+ FreeVars) -- Free variables
+
+rn_mono_binds is_top_lev binders mbinds sigs
=
-- Rename the bindings, returning a MonoBindsInfo
-- which is a list of indivisible vertices so far as
-- the strongly-connected-components (SCC) analysis is concerned
+ rnBindSigs is_top_lev binders sigs `thenRn` \ siglist ->
flattenMonoBinds 0 siglist mbinds `thenRn` \ (_, mbinds_info) ->
-- Do the SCC analysis
- let vertices = mkVertices mbinds_info
- edges = mkEdges mbinds_info
-
- scc_result = stronglyConnComp (==) edges vertices
+ let vertices = mkVertices mbinds_info
+ edges = mkEdges mbinds_info
+ scc_result = stronglyConnComp (==) edges vertices
+ final_binds = foldr1 ThenBinds (map (reconstructCycle edges mbinds_info) scc_result)
-- Deal with bound and free-var calculation
- rhs_free_vars = foldr f emptyUniqSet mbinds_info
-
- final_binds = reconstructRec scc_result edges mbinds_info
-
- happy_answer = returnRn (final_binds, rhs_free_vars)
+ rhs_fvs = unionManyNameSets [fvs | (_,_,fvs,_,_) <- mbinds_info]
in
- case (inline_sigs_in_recursive_binds final_binds) of
- Nothing -> happy_answer
- Just names_n_locns ->
--- SLPJ: sometimes want recursive INLINE for worker wrapper style stuff
--- addErrRn (inlineInRecursiveBindsErr names_n_locns) `thenRn_`
- {-not so-}happy_answer
- where
- f :: (a,b, FreeVars, c,d) -> FreeVars -> FreeVars
-
- f (_, _, fvs_body, _, _) fvs_sofar = fvs_sofar `unionUniqSets` fvs_body
-
- inline_sigs_in_recursive_binds (BindWith (RecBind _) sigs)
- = case [(n, locn) | (InlineSig n locn) <- sigs ] of
- [] -> Nothing
- sigh ->
-#if OMIT_DEFORESTER
- Just sigh
-#else
- -- Allow INLINEd recursive functions if they are
- -- designated DEFORESTable too.
- case [(n, locn) | (DeforestSig n locn) <- sigs ] of
- [] -> Just sigh
- sigh -> Nothing
-#endif
-
- inline_sigs_in_recursive_binds (ThenBinds b1 b2)
- = case (inline_sigs_in_recursive_binds b1) of
- Nothing -> inline_sigs_in_recursive_binds b2
- Just x -> Just x -- NB: won't report error(s) in b2
-
- inline_sigs_in_recursive_binds anything_else = Nothing
+ returnRn (final_binds, rhs_fvs)
\end{code}
@flattenMonoBinds@ is ever-so-slightly magical in that it sticks
flattenMonoBinds :: Int -- Next free vertex tag
-> [RenamedSig] -- Signatures
-> RdrNameMonoBinds
- -> RnM_Fixes s (Int, FlatMonoBindsInfo)
+ -> RnMS s (Int, FlatMonoBindsInfo)
flattenMonoBinds uniq sigs EmptyMonoBinds = returnRn (uniq, [])
-- Find which things are bound in this group
let
- names_bound_here = collectPatBinders pat'
-
- sigs_etc_for_here = foldl (sig_for_here (\ n -> n `is_elem` names_bound_here))
- [] sigs
-
- sigs_fvs = foldr sig_fv emptyUniqSet sigs_etc_for_here
-
- is_elem = isIn "flattenMonoBinds"
+ names_bound_here = mkNameSet (collectPatBinders pat')
+ sigs_for_me = filter ((`elemNameSet` names_bound_here) . sig_name) sigs
+ sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
in
returnRn (
uniq + 1,
[(uniq,
- mkUniqSet names_bound_here,
- fvs `unionUniqSets` sigs_fvs,
- PatMonoBind pat' grhss_and_binds' locn,
- sigs_etc_for_here
+ names_bound_here,
+ fvs `unionNameSets` sigs_fvs,
+ PatMonoBind pat' grhss_and_binds' locn,
+ sigs_for_me
)]
)
flattenMonoBinds uniq sigs (FunMonoBind name inf matches locn)
= pushSrcLocRn locn $
- lookupValue name `thenRn` \ name' ->
- mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
- mapRn (checkPrecMatch inf name') new_matches `thenRn_`
+ mapRn (checkPrecMatch inf name) matches `thenRn_`
+ lookupRn name `thenRn` \ name' ->
+ mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, fv_lists) ->
let
- fvs = unionManyUniqSets fv_lists
-
- sigs_for_me = foldl (sig_for_here (\ n -> n == name')) [] sigs
-
- sigs_fvs = foldr sig_fv emptyUniqSet sigs_for_me
+ fvs = unionManyNameSets fv_lists
+ sigs_for_me = filter ((name' ==) . sig_name) sigs
+ sigs_fvs = foldr sig_fv emptyNameSet sigs_for_me
in
returnRn (
uniq + 1,
[(uniq,
- unitUniqSet name',
- fvs `unionUniqSets` sigs_fvs,
+ unitNameSet name',
+ fvs `unionNameSets` sigs_fvs,
FunMonoBind name' inf new_matches locn,
sigs_for_me
)]
)
\end{code}
-Grab type-signatures/user-pragmas of interest:
+
+@rnMethodBinds@ is used for the method bindings of an instance
+declaration. like @rnMonoBinds@ but without dependency analysis.
+
\begin{code}
-sig_for_here want_me acc s@(Sig n _ _ _) | want_me n = s:acc
-sig_for_here want_me acc s@(InlineSig n _) | want_me n = s:acc
-sig_for_here want_me acc s@(DeforestSig n _) | want_me n = s:acc
-sig_for_here want_me acc s@(SpecSig n _ _ _) | want_me n = s:acc
-sig_for_here want_me acc s@(MagicUnfoldingSig n _ _)
- | want_me n = s:acc
-sig_for_here want_me acc other_wise = acc
+rnMethodBinds :: RdrNameMonoBinds -> RnMS s RenamedMonoBinds
+
+rnMethodBinds EmptyMonoBinds = returnRn EmptyMonoBinds
+
+rnMethodBinds (AndMonoBinds mb1 mb2)
+ = andRn AndMonoBinds (rnMethodBinds mb1)
+ (rnMethodBinds mb2)
+
+rnMethodBinds (FunMonoBind occname inf matches locn)
+ = pushSrcLocRn locn $
+ mapRn (checkPrecMatch inf occname) matches `thenRn_`
+ lookupRn occname `thenRn` \ op_name ->
+ mapAndUnzipRn rnMatch matches `thenRn` \ (new_matches, _) ->
+ returnRn (FunMonoBind op_name inf new_matches locn)
+
+rnMethodBinds (PatMonoBind (VarPatIn occname) grhss_and_binds locn)
+ = pushSrcLocRn locn $
+ lookupRn occname `thenRn` \ op_name ->
+ rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', _) ->
+ returnRn (PatMonoBind (VarPatIn op_name) grhss_and_binds' locn)
+
+-- Can't handle method pattern-bindings which bind multiple methods.
+rnMethodBinds mbind@(PatMonoBind other_pat _ locn)
+ = pushSrcLocRn locn $
+ failWithRn EmptyMonoBinds (methodBindErr mbind)
+\end{code}
+\begin{code}
-- If a SPECIALIZE pragma is of the "... = blah" form,
-- then we'd better make sure "blah" is taken into
-- acct in the dependency analysis (or we get an
-- unexpected out-of-scope error)! WDP 95/07
-sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionUniqSets` unitUniqSet blah
+sig_fv (SpecSig _ _ (Just blah) _) acc = acc `unionNameSets` (unitNameSet blah)
sig_fv _ acc = acc
\end{code}
as the two cases are similar.
\begin{code}
-reconstructRec :: [Cycle] -- Result of SCC analysis; at least one
- -> [Edge] -- Original edges
- -> FlatMonoBindsInfo
- -> RenamedHsBinds
+reconstructCycle :: [Edge] -- Original edges
+ -> FlatMonoBindsInfo
+ -> Cycle
+ -> RenamedHsBinds
-reconstructRec cycles edges mbi
- = foldr1 ThenBinds (map (reconstructCycle mbi) cycles)
+reconstructCycle edges mbi cycle
+ = mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle)
where
- reconstructCycle :: FlatMonoBindsInfo -> Cycle -> RenamedHsBinds
-
- reconstructCycle mbi2 cycle
- = case [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi2, vertex `is_elem` cycle]
- of { relevant_binds_and_sigs ->
-
- case (unzip relevant_binds_and_sigs) of { (binds, sig_lists) ->
-
- case (foldr AndMonoBinds EmptyMonoBinds binds) of { this_gp_binds ->
- let
- this_gp_sigs = foldr1 (++) sig_lists
- have_sigs = not (null sig_lists)
- -- ToDo: this might not be the right
- -- thing to call this predicate;
- -- e.g. "have_sigs [[], [], []]" ???????????
- in
- mk_binds this_gp_binds this_gp_sigs (isCyclic edges cycle) have_sigs
- }}}
- where
- is_elem = isIn "reconstructRec"
-
- mk_binds :: RenamedMonoBinds -> [RenamedSig]
- -> Bool -> Bool -> RenamedHsBinds
-
- mk_binds bs ss True False = SingleBind (RecBind bs)
- mk_binds bs ss True True{-have sigs-} = BindWith (RecBind bs) ss
- mk_binds bs ss False False = SingleBind (NonRecBind bs)
- mk_binds bs ss False True{-have sigs-} = BindWith (NonRecBind bs) ss
-
- -- moved from Digraph, as this is the only use here
- -- (avoid overloading cost). We have to use elem
- -- (not FiniteMaps or whatever), because there may be
- -- many edges out of one vertex. We give it its own
- -- "elem" just for speed.
-
- isCyclic es [] = panic "isCyclic: empty component"
- isCyclic es [v] = (v,v) `elem` es
- isCyclic es vs = True
-
- elem _ [] = False
- elem x (y:ys) = x==y || elem x ys
+ relevant_binds_and_sigs = [(binds,sigs) | (vertex, _, _, binds, sigs) <- mbi,
+ vertex `is_elem` cycle]
+ (binds, sig_lists) = unzip relevant_binds_and_sigs
+ this_gp_binds = foldr1 AndMonoBinds binds
+ this_gp_sigs = foldr1 (++) sig_lists
+
+ is_elem = isIn "reconstructRec"
+
+ mk_binds :: RenamedMonoBinds -> [RenamedSig] -> Bool -> RenamedHsBinds
+ mk_binds bs [] True = SingleBind (RecBind bs)
+ mk_binds bs ss True = BindWith (RecBind bs) ss
+ mk_binds bs [] False = SingleBind (NonRecBind bs)
+ mk_binds bs ss False = BindWith (NonRecBind bs) ss
+
+ -- moved from Digraph, as this is the only use here
+ -- (avoid overloading cost). We have to use elem
+ -- (not FiniteMaps or whatever), because there may be
+ -- many edges out of one vertex. We give it its own
+ -- "elem" just for speed.
+
+ isCyclic es [] = panic "isCyclic: empty component"
+ isCyclic es [v] = (v,v) `elem` es
+ isCyclic es vs = True
+
+ elem _ [] = False
+ elem x (y:ys) = x==y || elem x ys
\end{code}
%************************************************************************
\begin{code}
type FlatMonoBindsInfo
= [(VertexTag, -- Identifies the vertex
- UniqSet RnName, -- Set of names defined in this vertex
- UniqSet RnName, -- Set of names used in this vertex
+ NameSet, -- Set of names defined in this vertex
+ NameSet, -- Set of names used in this vertex
RenamedMonoBinds, -- Binding for this vertex (always just one binding, either fun or pat)
[RenamedSig]) -- Signatures, if any, for this vertex
]
mkVertices info = [ vertex | (vertex,_,_,_,_) <- info]
-mkEdges flat_info
- -- An edge (v,v') indicates that v depends on v'
- = -- pprTrace "mkEdges:" (ppAboves [ppAboves[ppInt v, ppCat [ppr PprDebug d|d <- uniqSetToList defd], ppCat [ppr PprDebug u|u <- uniqSetToList used]] | (v,defd,used,_,_) <- flat_info]) $
- [ (source_vertex, target_vertex)
+mkEdges flat_info -- An edge (v,v') indicates that v depends on v'
+ = [ (source_vertex, target_vertex)
| (source_vertex, _, used_names, _, _) <- flat_info,
- target_name <- uniqSetToList used_names,
+ target_name <- nameSetToList used_names,
target_vertex <- vertices_defining target_name flat_info
]
where
-- error) needs more thought.
vertices_defining name flat_info2
- = [ vertex | (vertex, names_defined, _, _, _) <- flat_info2,
- name `elementOfUniqSet` names_defined
+ = [ vertex | (vertex, names_defined, _, _, _) <- flat_info2,
+ name `elemNameSet` names_defined
]
\end{code}
\begin{code}
rnBindSigs :: Bool -- True <=> top-level binders
- -> [RdrName] -- Binders for this decl group
+ -> NameSet -- Set of names bound in this group
-> [RdrNameSig]
- -> RnM_Fixes s [RenamedSig] -- List of Sig constructors
-
-rnBindSigs is_toplev binder_occnames sigs
- =
- -- Rename the signatures
- -- Will complain about sigs for variables not in this group
- mapRn rename_sig sigs `thenRn` \ sigs_maybe ->
- let
- sigs' = catMaybes sigs_maybe
+ -> RnMS s [RenamedSig] -- List of Sig constructors
- -- Discard unbound ones we've already complained about, so we
- -- complain about duplicate ones.
+rnBindSigs is_toplev binders sigs
+ = -- Rename the signatures
+ mapRn renameSig sigs `thenRn` \ sigs' ->
- (goodies, dups) = removeDups compare (filter (\ x -> not_unbound x && not_main x) sigs')
+ -- Check for (a) duplicate signatures
+ -- (b) signatures for things not in this group
+ -- (c) optionally, bindings with no signature
+ let
+ (goodies, dups) = removeDups cmp_sig (filter (not.isUnboundName.sig_name) sigs')
+ not_this_group = filter (\sig -> not (sig_name sig `elemNameSet` binders)) goodies
+ type_sig_vars = [n | Sig n _ _ <- goodies]
+ un_sigd_binders
+ | is_toplev && opt_SigsRequired = nameSetToList binders `minusList` type_sig_vars
+ | otherwise = []
in
- mapRn (addErrRn . dupSigDeclErr) dups `thenRn_`
-
- getSrcLocRn `thenRn` \ locn ->
-
- (if (is_toplev && opt_SigsRequired) then
- let
- sig_frees = catMaybes (map (sig_free sigs) binder_occnames)
- in
- mapRn (addErrRn . missingSigErr locn) sig_frees
- else
- returnRn []
- ) `thenRn_`
+ mapRn dupSigDeclErr dups `thenRn_`
+ mapRn unknownSigErr not_this_group `thenRn_`
+ mapRn (addErrRn.missingSigErr) un_sigd_binders `thenRn_`
returnRn sigs' -- bad ones and all:
-- we need bindings of *some* sort for every name
+
+
+renameSig (Sig v ty src_loc)
+ = pushSrcLocRn src_loc $
+ lookupRn v `thenRn` \ new_v ->
+ rnHsType ty `thenRn` \ new_ty ->
+ returnRn (Sig new_v new_ty src_loc)
+
+renameSig (SpecSig v ty using src_loc)
+ = pushSrcLocRn src_loc $
+ lookupRn v `thenRn` \ new_v ->
+ rnHsType ty `thenRn` \ new_ty ->
+ rn_using using `thenRn` \ new_using ->
+ returnRn (SpecSig new_v new_ty new_using src_loc)
where
- rename_sig (Sig v ty pragmas src_loc)
- = pushSrcLocRn src_loc $
- if not (v `elem` binder_occnames) then
- addErrRn (unknownSigDeclErr "type signature" v src_loc) `thenRn_`
- returnRn Nothing
- else
- lookupValue v `thenRn` \ new_v ->
- rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
-
- ASSERT(isNoGenPragmas pragmas)
- returnRn (Just (Sig new_v new_ty noGenPragmas src_loc))
-
- -- and now, the various flavours of value-modifying user-pragmas:
-
- rename_sig (SpecSig v ty using src_loc)
- = pushSrcLocRn src_loc $
- if not (v `elem` binder_occnames) then
- addErrRn (unknownSigDeclErr "SPECIALIZE pragma" v src_loc) `thenRn_`
- returnRn Nothing
- else
- lookupValue v `thenRn` \ new_v ->
- rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
- rn_using using `thenRn` \ new_using ->
- returnRn (Just (SpecSig new_v new_ty new_using src_loc))
- where
- rn_using Nothing = returnRn Nothing
- rn_using (Just x) = lookupValue x `thenRn` \ new_x ->
- returnRn (Just new_x)
-
- rename_sig (InlineSig v src_loc)
- = pushSrcLocRn src_loc $
- if not (v `elem` binder_occnames) then
- addErrRn (unknownSigDeclErr "INLINE pragma" v src_loc) `thenRn_`
- returnRn Nothing
- else
- lookupValue v `thenRn` \ new_v ->
- returnRn (Just (InlineSig new_v src_loc))
-
- rename_sig (DeforestSig v src_loc)
- = pushSrcLocRn src_loc $
- if not (v `elem` binder_occnames) then
- addErrRn (unknownSigDeclErr "DEFOREST pragma" v src_loc) `thenRn_`
- returnRn Nothing
- else
- lookupValue v `thenRn` \ new_v ->
- returnRn (Just (DeforestSig new_v src_loc))
-
- rename_sig (MagicUnfoldingSig v str src_loc)
- = pushSrcLocRn src_loc $
- if not (v `elem` binder_occnames) then
- addErrRn (unknownSigDeclErr "MAGIC_UNFOLDING pragma" v src_loc) `thenRn_`
- returnRn Nothing
- else
- lookupValue v `thenRn` \ new_v ->
- returnRn (Just (MagicUnfoldingSig new_v str src_loc))
-
- not_unbound, not_main :: RenamedSig -> Bool
-
- not_unbound (Sig n _ _ _) = not (isRnUnbound n)
- not_unbound (SpecSig n _ _ _) = not (isRnUnbound n)
- not_unbound (InlineSig n _) = not (isRnUnbound n)
- not_unbound (DeforestSig n _) = not (isRnUnbound n)
- not_unbound (MagicUnfoldingSig n _ _) = not (isRnUnbound n)
-
- not_main (Sig n _ _ _) = let str = getLocalName n in
- not (str == SLIT("main") || str == SLIT("mainPrimIO"))
- not_main _ = True
-
- -------------------------------------
- sig_free :: [RdrNameSig] -> RdrName -> Maybe RdrName
- -- Return "Just x" if "x" has no type signature in
- -- sigs. Nothing, otherwise.
-
- sig_free [] ny = Just ny
- sig_free (Sig nx _ _ _ : rest) ny
- = if (nx == ny) then Nothing else sig_free rest ny
- sig_free (_ : rest) ny = sig_free rest ny
-
- -------------------------------------
- compare :: RenamedSig -> RenamedSig -> TAG_
- compare (Sig n1 _ _ _) (Sig n2 _ _ _) = n1 `cmp` n2
- compare (InlineSig n1 _) (InlineSig n2 _) = n1 `cmp` n2
- compare (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2
- compare (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
- = -- may have many specialisations for one value;
+ rn_using Nothing = returnRn Nothing
+ rn_using (Just x) = lookupOccRn x `thenRn` \ new_x ->
+ returnRn (Just new_x)
+
+renameSig (InlineSig v src_loc)
+ = pushSrcLocRn src_loc $
+ lookupRn v `thenRn` \ new_v ->
+ returnRn (InlineSig new_v src_loc)
+
+renameSig (DeforestSig v src_loc)
+ = pushSrcLocRn src_loc $
+ lookupRn v `thenRn` \ new_v ->
+ returnRn (DeforestSig new_v src_loc)
+
+renameSig (MagicUnfoldingSig v str src_loc)
+ = pushSrcLocRn src_loc $
+ lookupRn v `thenRn` \ new_v ->
+ returnRn (MagicUnfoldingSig new_v str src_loc)
+\end{code}
+
+Checking for distinct signatures; oh, so boring
+
+\begin{code}
+cmp_sig :: RenamedSig -> RenamedSig -> TAG_
+cmp_sig (Sig n1 _ _) (Sig n2 _ _) = n1 `cmp` n2
+cmp_sig (InlineSig n1 _) (InlineSig n2 _) = n1 `cmp` n2
+cmp_sig (MagicUnfoldingSig n1 _ _) (MagicUnfoldingSig n2 _ _) = n1 `cmp` n2
+cmp_sig (SpecSig n1 ty1 _ _) (SpecSig n2 ty2 _ _)
+ = -- may have many specialisations for one value;
-- but not ones that are exactly the same...
- thenCmp (n1 `cmp` n2) (cmpPolyType cmp ty1 ty2)
-
- compare other_1 other_2 -- tags *must* be different
- = let tag1 = tag other_1
- tag2 = tag other_2
- in
- if tag1 _LT_ tag2 then LT_ else GT_
-
- tag (Sig n1 _ _ _) = (ILIT(1) :: FAST_INT)
- tag (SpecSig n1 _ _ _) = ILIT(2)
- tag (InlineSig n1 _) = ILIT(3)
- tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
- tag (DeforestSig n1 _) = ILIT(5)
- tag _ = panic# "tag(RnBinds)"
+ thenCmp (n1 `cmp` n2) (cmpHsType cmp ty1 ty2)
+
+cmp_sig other_1 other_2 -- Tags *must* be different
+ | (sig_tag other_1) _LT_ (sig_tag other_2) = LT_
+ | otherwise = GT_
+
+sig_tag (Sig n1 _ _) = (ILIT(1) :: FAST_INT)
+sig_tag (SpecSig n1 _ _ _) = ILIT(2)
+sig_tag (InlineSig n1 _) = ILIT(3)
+sig_tag (MagicUnfoldingSig n1 _ _) = ILIT(4)
+sig_tag (DeforestSig n1 _) = ILIT(5)
+sig_tag _ = panic# "tag(RnBinds)"
+
+sig_name (Sig n _ _) = n
+sig_name (ClassOpSig n _ _ _) = n
+sig_name (SpecSig n _ _ _) = n
+sig_name (InlineSig n _) = n
+sig_name (MagicUnfoldingSig n _ _) = n
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-dupSigDeclErr sigs
- = let
- undup_sigs = fst (removeDups cmp_sig sigs)
- in
- addErrLoc locn1
- ("more than one "++what_it_is++"\n\thas been given for these variables") ( \ sty ->
- ppAboves (map (ppr sty) undup_sigs) )
+dupSigDeclErr (sig:sigs)
+ = pushSrcLocRn loc $
+ addErrRn (\sty -> ppSep [ppStr "more than one",
+ ppStr what_it_is, ppStr "given for",
+ ppQuote (ppr sty (sig_name sig))])
where
- (what_it_is, locn1)
- = case (head sigs) of
- Sig _ _ _ loc -> ("type signature",loc)
- ClassOpSig _ _ _ loc -> ("class-method type signature", loc)
- SpecSig _ _ _ loc -> ("SPECIALIZE pragma",loc)
- InlineSig _ loc -> ("INLINE pragma",loc)
- MagicUnfoldingSig _ _ loc -> ("MAGIC_UNFOLDING pragma",loc)
-
- cmp_sig a b = get_name a `cmp` get_name b
-
- get_name (Sig n _ _ _) = n
- get_name (ClassOpSig n _ _ _) = n
- get_name (SpecSig n _ _ _) = n
- get_name (InlineSig n _) = n
- get_name (MagicUnfoldingSig n _ _) = n
-
-------------------------
-methodBindErr mbind locn
- = addErrLoc locn "Can't handle multiple methods defined by one pattern binding"
- (\ sty -> ppr sty mbind)
-
---------------------------
-missingSigErr locn var
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr "a definition but no type signature for `",
- ppr sty var,
- ppStr "'."])
-
---------------------------------
-unknownSigDeclErr flavor var locn
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr flavor, ppStr " but no definition for `",
- ppr sty var,
- ppStr "'."])
+ (what_it_is, loc) = sig_doc sig
+
+unknownSigErr sig
+ = pushSrcLocRn loc $
+ addErrRn (\sty -> ppSep [ppStr flavour, ppStr "but no definition for",
+ ppQuote (ppr sty (sig_name sig))])
+ where
+ (flavour, loc) = sig_doc sig
+
+sig_doc (Sig _ _ loc) = ("type signature",loc)
+sig_doc (ClassOpSig _ _ _ loc) = ("class-method type signature", loc)
+sig_doc (SpecSig _ _ _ loc) = ("SPECIALIZE pragma",loc)
+sig_doc (InlineSig _ loc) = ("INLINE pragma",loc)
+sig_doc (MagicUnfoldingSig _ _ loc) = ("MAGIC_UNFOLDING pragma",loc)
+
+missingSigErr var sty
+ = ppSep [ppStr "a definition but no type signature for", ppQuote (ppr sty var)]
+
+methodBindErr mbind sty
+ = ppHang (ppStr "Can't handle multiple methods defined by one pattern binding")
+ 4 (ppr sty mbind)
\end{code}
--- /dev/null
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+\section[RnEnv]{Environment manipulation for the renamer monad}
+
+\begin{code}
+#include "HsVersions.h"
+
+module RnEnv where -- Export everything
+
+IMP_Ubiq()
+
+import CmdLineOpts ( opt_WarnNameShadowing, opt_IgnoreIfacePragmas )
+import HsSyn
+import RdrHsSyn ( RdrName(..), SYN_IE(RdrNameIE),
+ rdrNameOcc, isQual, qual
+ )
+import HsTypes ( getTyVarName, replaceTyVarName )
+import RnMonad
+import Name ( Name, OccName(..), Provenance(..), DefnInfo(..), ExportFlag(..),
+ occNameString, occNameFlavour,
+ SYN_IE(NameSet), emptyNameSet, addListToNameSet,
+ mkLocalName, mkGlobalName, modAndOcc,
+ isLocalName, isWiredInName, nameOccName, setNameProvenance,
+ pprProvenance, pprOccName, pprModule, pprNonSymOcc, pprNameProvenance
+ )
+import TyCon ( TyCon )
+import TysWiredIn ( tupleTyCon, listTyCon, charTyCon, intTyCon )
+import FiniteMap
+import Unique ( Unique, unboundKey )
+import Maybes ( maybeToBool )
+import UniqSupply
+import SrcLoc ( SrcLoc, noSrcLoc )
+import Pretty
+import PprStyle ( PprStyle(..) )
+import Util ( panic, removeDups, pprTrace, assertPanic )
+\end{code}
+
+
+
+%*********************************************************
+%* *
+\subsection{Making new names}
+%* *
+%*********************************************************
+
+\begin{code}
+newGlobalName :: Module -> OccName -> RnM s d Name
+newGlobalName mod occ
+ = -- First check the cache
+ getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
+ case lookupFM cache (mod,occ) of
+
+ -- A hit in the cache! Return it, but change the src loc
+ -- of the thing we've found if this is a second definition site
+ -- (that is, if loc /= NoSrcLoc)
+ Just name -> returnRn name
+
+ -- Miss in the cache, so build a new original name,
+ -- and put it in the cache
+ Nothing ->
+ let
+ (us', us1) = splitUniqSupply us
+ uniq = getUnique us1
+ name = mkGlobalName uniq mod occ VanillaDefn Implicit
+ cache' = addToFM cache (mod,occ) name
+ in
+ setNameSupplyRn (us', inst_ns, cache') `thenRn_`
+ returnRn name
+
+newLocallyDefinedGlobalName :: Module -> OccName
+ -> (Name -> ExportFlag) -> SrcLoc
+ -> RnM s d Name
+newLocallyDefinedGlobalName mod occ rec_exp_fn loc
+ = -- First check the cache
+ getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
+
+ -- We are at the binding site for a locally-defined thing, so
+ -- you might think it can't be in the cache, but it can if it's a
+ -- wired in thing. In that case we need to use the correct unique etc...
+ -- so all we do is replace its provenance.
+ -- If it's not in the cache we put it there with the correct provenance.
+ -- The idea is that, after all this, the cache
+ -- will contain a Name with the correct Provenance (i.e. Local)
+ let
+ provenance = LocalDef (rec_exp_fn new_name) loc
+ (us', us1) = splitUniqSupply us
+ uniq = getUnique us1
+ new_name = case lookupFM cache (mod,occ) of
+ Just name -> setNameProvenance name provenance
+ Nothing -> mkGlobalName uniq mod occ VanillaDefn provenance
+ cache' = addToFM cache (mod,occ) new_name
+ in
+ setNameSupplyRn (us', inst_ns, cache') `thenRn_`
+ returnRn new_name
+
+-- newDfunName is used to allocate a name for the dictionary function for
+-- a local instance declaration. No need to put it in the cache (I think!).
+newDfunName :: SrcLoc -> RnMS s Name
+newDfunName src_loc
+ = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
+ getModuleRn `thenRn` \ mod_name ->
+ let
+ (us', us1) = splitUniqSupply us
+ uniq = getUnique us1
+ dfun_name = mkGlobalName uniq mod_name (VarOcc (_PK_ ("df" ++ show inst_ns)))
+ VanillaDefn (LocalDef Exported src_loc)
+ in
+ setNameSupplyRn (us', inst_ns+1, cache) `thenRn_`
+ returnRn dfun_name
+
+
+newLocalNames :: [(RdrName,SrcLoc)] -> RnM s d [Name]
+newLocalNames rdr_names
+ = getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
+ let
+ n = length rdr_names
+ (us', us1) = splitUniqSupply us
+ uniqs = getUniques n us1
+ locals = [ mkLocalName uniq (rdrNameOcc rdr_name) loc
+ | ((rdr_name,loc), uniq) <- rdr_names `zip` uniqs
+ ]
+ in
+ setNameSupplyRn (us', inst_ns, cache) `thenRn_`
+ returnRn locals
+
+-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
+-- during compiler debugging.
+mkUnboundName :: RdrName -> Name
+mkUnboundName rdr_name = mkLocalName unboundKey (rdrNameOcc rdr_name) noSrcLoc
+
+isUnboundName :: Name -> Bool
+isUnboundName name = uniqueOf name == unboundKey
+\end{code}
+
+\begin{code}
+bindLocatedLocalsRn :: String -- Documentation string for error message
+ -> [(RdrName,SrcLoc)]
+ -> ([Name] -> RnMS s a)
+ -> RnMS s a
+bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope
+ = -- Check for use of qualified names
+ mapRn (qualNameErr doc_str) quals `thenRn_`
+ -- Check for dupicated names in a binding group
+ mapRn (dupNamesErr doc_str) dups `thenRn_`
+
+ getNameEnv `thenRn` \ name_env ->
+ (if opt_WarnNameShadowing
+ then
+ mapRn (check_shadow name_env) rdr_names_w_loc
+ else
+ returnRn []
+ ) `thenRn_`
+
+ newLocalNames rdr_names_w_loc `thenRn` \ names ->
+ let
+ new_name_env = addListToFM name_env (map fst rdr_names_w_loc `zip` names)
+ in
+ setNameEnv new_name_env (enclosed_scope names)
+ where
+ quals = filter (isQual.fst) rdr_names_w_loc
+ (these, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `cmp` n2) rdr_names_w_loc
+ check_shadow name_env (rdr_name,loc)
+ = case lookupFM name_env rdr_name of
+ Nothing -> returnRn ()
+ Just name -> pushSrcLocRn loc $
+ addWarnRn (shadowedNameWarn rdr_name)
+
+bindLocalsRn doc_str rdr_names enclosed_scope
+ = getSrcLocRn `thenRn` \ loc ->
+ bindLocatedLocalsRn doc_str (rdr_names `zip` repeat loc) enclosed_scope
+
+bindTyVarsRn doc_str tyvar_names enclosed_scope
+ = getSrcLocRn `thenRn` \ loc ->
+ let
+ located_tyvars = [(getTyVarName tv, loc) | tv <- tyvar_names]
+ in
+ bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
+ enclosed_scope (zipWith replaceTyVarName tyvar_names names)
+\end{code}
+
+
+%*********************************************************
+%* *
+\subsection{Looking up names}
+%* *
+%*********************************************************
+
+Looking up a name in the RnEnv.
+
+\begin{code}
+lookupRn :: RdrName -> RnMS s Name
+lookupRn rdr_name
+ = getNameEnv `thenRn` \ name_env ->
+ case lookupFM name_env rdr_name of
+
+ -- Found it!
+ Just name -> returnRn name
+
+ -- Not found
+ Nothing -> getModeRn `thenRn` \ mode ->
+ case mode of
+ -- Not found when processing source code; so fail
+ SourceMode -> failWithRn (mkUnboundName rdr_name)
+ (unknownNameErr rdr_name)
+
+ -- Not found when processing an imported declaration,
+ -- so we create a new name for the purpose
+ InterfaceMode ->
+ case rdr_name of
+
+ Qual mod_name occ -> newGlobalName mod_name occ
+
+ -- An Unqual is allowed; interface files contain
+ -- unqualified names for locally-defined things, such as
+ -- constructors of a data type.
+ Unqual occ -> getModuleRn `thenRn ` \ mod_name ->
+ newGlobalName mod_name occ
+
+
+-- Just like lookupRn except that we record the occurrence too
+-- Perhaps surprisingly, even wired-in names are recorded.
+-- Why? So that we know which wired-in names are referred to when
+-- deciding which instance declarations to import.
+lookupOccRn :: RdrName -> RnMS s Name
+lookupOccRn rdr_name
+ = lookupRn rdr_name `thenRn` \ name ->
+ if isLocalName name then
+ returnRn name
+ else
+ addOccurrenceName Compulsory name `thenRn_`
+ returnRn name
+
+-- lookupOptionalOccRn is similar, but it's used in places where
+-- we don't *have* to find a definition for the thing.
+lookupOptionalOccRn :: RdrName -> RnMS s Name
+lookupOptionalOccRn rdr_name
+ = lookupRn rdr_name `thenRn` \ name ->
+ if opt_IgnoreIfacePragmas || isLocalName name then
+ -- Never look for optional things if we're
+ -- ignoring optional input interface information
+ returnRn name
+ else
+ addOccurrenceName Optional name `thenRn_`
+ returnRn name
+
+-- lookupImplicitOccRn takes an RdrName representing an *original* name, and
+-- adds it to the occurrence pool so that it'll be loaded later. This is
+-- used when language constructs (such as monad comprehensions, overloaded literals,
+-- or deriving clauses) require some stuff to be loaded that isn't explicitly
+-- mentioned in the code.
+--
+-- This doesn't apply in interface mode, where everything is explicit, but
+-- we don't check for this case: it does no harm to record an "extra" occurrence
+-- and lookupImplicitOccRn isn't used much in interface mode (it's only the
+-- Nothing clause of rnDerivs that calls it at all I think.
+--
+-- For List and Tuple types it's important to get the correct
+-- isLocallyDefined flag, which is used in turn when deciding
+-- whether there are any instance decls in this module are "special".
+-- The name cache should have the correct provenance, though.
+
+lookupImplicitOccRn :: RdrName -> RnMS s Name
+lookupImplicitOccRn (Qual mod occ)
+ = newGlobalName mod occ `thenRn` \ name ->
+ addOccurrenceName Compulsory name `thenRn_`
+ returnRn name
+
+addImplicitOccRn :: Name -> RnM s d ()
+addImplicitOccRn name = addOccurrenceName Compulsory name
+
+addImplicitOccsRn :: [Name] -> RnM s d ()
+addImplicitOccsRn names = addOccurrenceNames Compulsory names
+
+intType_RDR = qual (modAndOcc (getName intTyCon))
+listType_RDR = qual (modAndOcc listType_name)
+tupleType_RDR n = qual (modAndOcc (tupleType_name n))
+
+charType_name = getName charTyCon
+listType_name = getName listTyCon
+tupleType_name n = getName (tupleTyCon n)
+\end{code}
+
+\begin{code}
+lookupFixity :: RdrName -> RnMS s Fixity
+lookupFixity rdr_name
+ = getFixityEnv `thenRn` \ fixity_env ->
+ returnRn (lookupFixityEnv fixity_env rdr_name)
+\end{code}
+
+
+
+%************************************************************************
+%* *
+\subsection{Envt utility functions}
+%* *
+%************************************************************************
+
+=============== RnEnv ================
+\begin{code}
+plusRnEnv (RnEnv n1 f1) (RnEnv n2 f2)
+ = plusNameEnvRn n1 n2 `thenRn` \ n ->
+ plusFixityEnvRn f1 f2 `thenRn` \ f ->
+ returnRn (RnEnv n f)
+\end{code}
+
+=============== NameEnv ================
+\begin{code}
+plusNameEnvRn :: NameEnv -> NameEnv -> RnM s d NameEnv
+plusNameEnvRn n1 n2
+ = mapRn (addErrRn.nameClashErr) (conflictsFM (/=) n1 n2) `thenRn_`
+ returnRn (n1 `plusFM` n2)
+
+addOneToNameEnvRn :: NameEnv -> RdrName -> Name -> RnM s d NameEnv
+addOneToNameEnvRn env rdr_name name
+ = mapRn (addErrRn.nameClashErr) (conflictFM (/=) env rdr_name name) `thenRn_`
+ returnRn (addToFM env rdr_name name)
+
+lookupNameEnv :: NameEnv -> RdrName -> Maybe Name
+lookupNameEnv = lookupFM
+\end{code}
+
+=============== FixityEnv ================
+\begin{code}
+plusFixityEnvRn f1 f2
+ = mapRn (addErrRn.fixityClashErr) (conflictsFM bad_fix f1 f2) `thenRn_`
+ returnRn (f1 `plusFM` f2)
+
+addOneToFixityEnvRn env rdr_name fixity
+ = mapRn (addErrRn.fixityClashErr) (conflictFM bad_fix env rdr_name fixity) `thenRn_`
+ returnRn (addToFM env rdr_name fixity)
+
+lookupFixityEnv env rdr_name
+ = case lookupFM env rdr_name of
+ Just (fixity,_) -> fixity
+ Nothing -> Fixity 9 InfixL -- Default case
+
+bad_fix :: (Fixity, Provenance) -> (Fixity, Provenance) -> Bool
+bad_fix (f1,_) (f2,_) = f1 /= f2
+
+pprFixityProvenance :: PprStyle -> (Fixity,Provenance) -> Pretty
+pprFixityProvenance sty (fixity, prov) = pprProvenance sty prov
+\end{code}
+
+
+
+=============== Avails ================
+\begin{code}
+emptyModuleAvails :: ModuleAvails
+plusModuleAvails :: ModuleAvails -> ModuleAvails -> ModuleAvails
+lookupModuleAvails :: ModuleAvails -> Module -> Maybe [AvailInfo]
+
+emptyModuleAvails = emptyFM
+plusModuleAvails = plusFM_C (++)
+lookupModuleAvails = lookupFM
+\end{code}
+
+
+=============== AvailInfo ================
+\begin{code}
+plusAvail (Avail n1 ns1) (Avail n2 ns2) = Avail n1 (nub (ns1 ++ ns2))
+plusAvail a NotAvailable = a
+plusAvail NotAvailable a = a
+
+addAvailToNameSet :: NameSet -> AvailInfo -> NameSet
+addAvailToNameSet names NotAvailable = names
+addAvailToNameSet names (Avail n ns) = addListToNameSet names (n:ns)
+
+availsToNameSet :: [AvailInfo] -> NameSet
+availsToNameSet avails = foldl addAvailToNameSet emptyNameSet avails
+
+availNames :: AvailInfo -> [Name]
+availNames NotAvailable = []
+availNames (Avail n ns) = n:ns
+
+filterAvail :: RdrNameIE -> AvailInfo -> AvailInfo
+filterAvail (IEThingWith _ wanted) NotAvailable = NotAvailable
+filterAvail (IEThingWith _ wanted) (Avail n ns)
+ | sub_names_ok = Avail n (filter is_wanted ns)
+ | otherwise = NotAvailable
+ where
+ is_wanted name = nameOccName name `elem` wanted_occs
+ sub_names_ok = all (`elem` avail_occs) wanted_occs
+ wanted_occs = map rdrNameOcc wanted
+ avail_occs = map nameOccName ns
+
+
+filterAvail (IEThingAll _) avail = avail
+filterAvail ie (Avail n ns) = Avail n [] -- IEThingAbs and IEVar
+
+-- pprAvail gets given the OccName of the "host" thing
+pprAvail sty NotAvailable = ppStr "NotAvailable"
+pprAvail sty (Avail n ns) = ppCat [pprOccName sty (nameOccName n),
+ ppStr "(",
+ ppInterleave ppComma (map (pprOccName sty.nameOccName) ns),
+ ppStr ")"]
+\end{code}
+
+
+
+
+%************************************************************************
+%* *
+\subsection{Finite map utilities}
+%* *
+%************************************************************************
+
+
+Generally useful function on finite maps to check for overlap.
+
+\begin{code}
+conflictsFM :: Ord a
+ => (b->b->Bool) -- False <=> no conflict; you can pick either
+ -> FiniteMap a b -> FiniteMap a b
+ -> [(a,(b,b))]
+conflictsFM bad fm1 fm2
+ = filter (\(a,(b1,b2)) -> bad b1 b2)
+ (fmToList (intersectFM_C (\b1 b2 -> (b1,b2)) fm1 fm2))
+
+conflictFM :: Ord a
+ => (b->b->Bool)
+ -> FiniteMap a b -> a -> b
+ -> [(a,(b,b))]
+conflictFM bad fm key elt
+ = case lookupFM fm key of
+ Just elt' | bad elt elt' -> [(key,(elt,elt'))]
+ other -> []
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Envt utility functions}
+%* *
+%************************************************************************
+
+
+\begin{code}
+nameClashErr (rdr_name, (name1,name2)) sty
+ = ppHang (ppCat [ppStr "Conflicting definitions for: ", ppr sty rdr_name])
+ 4 (ppAboves [pprNameProvenance sty name1,
+ pprNameProvenance sty name2])
+
+fixityClashErr (rdr_name, (fp1,fp2)) sty
+ = ppHang (ppCat [ppStr "Conflicting fixities for: ", ppr sty rdr_name])
+ 4 (ppAboves [pprFixityProvenance sty fp1,
+ pprFixityProvenance sty fp2])
+
+shadowedNameWarn shadow sty
+ = ppBesides [ppStr "More than one value with the same name (shadowing): ", ppr sty shadow]
+
+unknownNameErr name sty
+ = ppSep [ppStr flavour, ppStr "not in scope:", ppr sty name]
+ where
+ flavour = occNameFlavour (rdrNameOcc name)
+
+qualNameErr descriptor (name,loc)
+ = pushSrcLocRn loc $
+ addErrRn (\sty -> ppBesides [ppStr "invalid use of qualified ",
+ ppStr descriptor, ppStr ": ",
+ pprNonSymOcc sty (rdrNameOcc name) ])
+
+dupNamesErr descriptor ((name,loc) : dup_things)
+ = pushSrcLocRn loc $
+ addErrRn (\sty -> ppBesides [ppStr "duplicate bindings of `",
+ ppr sty name, ppStr "' in ",
+ ppStr descriptor])
+\end{code}
+
import RdrHsSyn
import RnHsSyn
import RnMonad
-
+import RnEnv
+import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR,
+ creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR,
+ negate_RDR
+ )
+import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon,
+ floatPrimTyCon, doublePrimTyCon
+ )
+import TyCon ( TyCon )
import ErrUtils ( addErrLoc, addShortErrLocLine )
-import Name ( isLocallyDefinedName, pprSym, Name, RdrName )
+import Name
import Pretty
import UniqFM ( lookupUFM{-, ufmToList ToDo:rm-} )
import UniqSet ( emptyUniqSet, unitUniqSet,
*********************************************************
\begin{code}
-rnPat :: RdrNamePat -> RnM_Fixes s RenamedPat
+rnPat :: RdrNamePat -> RnMS s RenamedPat
rnPat WildPatIn = returnRn WildPatIn
rnPat (VarPatIn name)
- = lookupValue name `thenRn` \ vname ->
+ = lookupRn name `thenRn` \ vname ->
returnRn (VarPatIn vname)
-rnPat (LitPatIn n) = returnRn (LitPatIn n)
+rnPat (LitPatIn lit)
+ = litOccurrence lit `thenRn_`
+ lookupImplicitOccRn eqClass_RDR `thenRn_` -- Needed to find equality on pattern
+ returnRn (LitPatIn lit)
rnPat (LazyPatIn pat)
= rnPat pat `thenRn` \ pat' ->
rnPat (AsPatIn name pat)
= rnPat pat `thenRn` \ pat' ->
- lookupValue name `thenRn` \ vname ->
+ lookupRn name `thenRn` \ vname ->
returnRn (AsPatIn vname pat')
rnPat (ConPatIn con pats)
- = lookupConstr con `thenRn` \ con' ->
+ = lookupRn con `thenRn` \ con' ->
mapRn rnPat pats `thenRn` \ patslist ->
returnRn (ConPatIn con' patslist)
rnPat (ConOpPatIn pat1 con pat2)
- = lookupConstr con `thenRn` \ con' ->
- rnPat pat1 `thenRn` \ pat1' ->
- rnPat pat2 `thenRn` \ pat2' ->
- precParsePat (ConOpPatIn pat1' con' pat2')
+ = rnOpPat pat1 con pat2
+-- Negated patters can only be literals, and they are dealt with
+-- by negating the literal at compile time, not by using the negation
+-- operation in Num. So we don't need to make an implicit reference
+-- to negate_RDR.
rnPat neg@(NegPatIn pat)
- = getSrcLocRn `thenRn` \ src_loc ->
- addErrIfRn (not (valid_neg_pat pat)) (negPatErr neg src_loc)
+ = checkRn (valid_neg_pat pat) (negPatErr neg)
`thenRn_`
rnPat pat `thenRn` \ pat' ->
returnRn (NegPatIn pat')
returnRn (ParPatIn pat')
rnPat (ListPatIn pats)
- = mapRn rnPat pats `thenRn` \ patslist ->
+ = addImplicitOccRn listType_name `thenRn_`
+ mapRn rnPat pats `thenRn` \ patslist ->
returnRn (ListPatIn patslist)
rnPat (TuplePatIn pats)
- = mapRn rnPat pats `thenRn` \ patslist ->
+ = addImplicitOccRn (tupleType_name (length pats)) `thenRn_`
+ mapRn rnPat pats `thenRn` \ patslist ->
returnRn (TuplePatIn patslist)
rnPat (RecPatIn con rpats)
- = lookupConstr con `thenRn` \ con' ->
+ = lookupRn con `thenRn` \ con' ->
rnRpats rpats `thenRn` \ rpats' ->
returnRn (RecPatIn con' rpats')
\end{code}
************************************************************************
\begin{code}
-rnMatch :: RdrNameMatch -> RnM_Fixes s (RenamedMatch, FreeVars)
-
-rnMatch match
- = getSrcLocRn `thenRn` \ src_loc ->
- newLocalNames "variable in pattern"
- (binders `zip` repeat src_loc) `thenRn` \ new_binders ->
- extendSS2 new_binders (rnMatch_aux match)
- where
- binders = collect_binders match
-
- collect_binders :: RdrNameMatch -> [RdrName]
+rnMatch :: RdrNameMatch -> RnMS s (RenamedMatch, FreeVars)
- collect_binders (GRHSMatch _) = []
- collect_binders (PatMatch pat match)
- = collectPatBinders pat ++ collect_binders match
-
-rnMatch_aux (PatMatch pat match)
- = rnPat pat `thenRn` \ pat' ->
- rnMatch_aux match `thenRn` \ (match', fvMatch) ->
- returnRn (PatMatch pat' match', fvMatch)
+rnMatch (PatMatch pat match)
+ = bindLocalsRn "pattern" binders $ \ new_binders ->
+ rnPat pat `thenRn` \ pat' ->
+ rnMatch match `thenRn` \ (match', fvMatch) ->
+ returnRn (PatMatch pat' match', fvMatch `minusNameSet` mkNameSet new_binders)
+ where
+ binders = collectPatBinders pat
-rnMatch_aux (GRHSMatch grhss_and_binds)
+rnMatch (GRHSMatch grhss_and_binds)
= rnGRHSsAndBinds grhss_and_binds `thenRn` \ (grhss_and_binds', fvs) ->
returnRn (GRHSMatch grhss_and_binds', fvs)
\end{code}
%************************************************************************
\begin{code}
-rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnM_Fixes s (RenamedGRHSsAndBinds, FreeVars)
+rnGRHSsAndBinds :: RdrNameGRHSsAndBinds -> RnMS s (RenamedGRHSsAndBinds, FreeVars)
rnGRHSsAndBinds (GRHSsAndBindsIn grhss binds)
- = rnBinds binds `thenRn` \ (binds', fvBinds, scope) ->
- extendSS2 scope (rnGRHSs grhss) `thenRn` \ (grhss', fvGRHS) ->
- returnRn (GRHSsAndBindsIn grhss' binds', fvBinds `unionUniqSets` fvGRHS)
+ = rnBinds binds $ \ binds' ->
+ rnGRHSs grhss `thenRn` \ (grhss', fvGRHS) ->
+ returnRn (GRHSsAndBindsIn grhss' binds', fvGRHS)
where
- rnGRHSs [] = returnRn ([], emptyUniqSet)
+ rnGRHSs [] = returnRn ([], emptyNameSet)
rnGRHSs (grhs:grhss)
= rnGRHS grhs `thenRn` \ (grhs', fvs) ->
rnGRHSs grhss `thenRn` \ (grhss', fvss) ->
- returnRn (grhs' : grhss', fvs `unionUniqSets` fvss)
+ returnRn (grhs' : grhss', fvs `unionNameSets` fvss)
rnGRHS (GRHS guard expr locn)
= pushSrcLocRn locn $
rnExpr guard `thenRn` \ (guard', fvsg) ->
rnExpr expr `thenRn` \ (expr', fvse) ->
- returnRn (GRHS guard' expr' locn, fvsg `unionUniqSets` fvse)
+ returnRn (GRHS guard' expr' locn, fvsg `unionNameSets` fvse)
rnGRHS (OtherwiseGRHS expr locn)
= pushSrcLocRn locn $
%************************************************************************
\begin{code}
-rnExprs :: [RdrNameHsExpr] -> RnM_Fixes s ([RenamedHsExpr], FreeVars)
+rnExprs :: [RdrNameHsExpr] -> RnMS s ([RenamedHsExpr], FreeVars)
-rnExprs [] = returnRn ([], emptyUniqSet)
+rnExprs [] = returnRn ([], emptyNameSet)
rnExprs (expr:exprs)
= rnExpr expr `thenRn` \ (expr', fvExpr) ->
rnExprs exprs `thenRn` \ (exprs', fvExprs) ->
- returnRn (expr':exprs', fvExpr `unionUniqSets` fvExprs)
+ returnRn (expr':exprs', fvExpr `unionNameSets` fvExprs)
\end{code}
Variables. We look up the variable and return the resulting name. The
interesting question is what the free-variable set should be. We
don't want to return imported or prelude things as free vars. So we
-look at the RnName returned from the lookup, and make it part of the
-free-var set iff if it's a LocallyDefined RnName.
-
-ToDo: what about RnClassOps ???
+look at the Name returned from the lookup, and make it part of the
+free-var set iff if it's a LocallyDefined Name.
\end{itemize}
\begin{code}
-fv_set vname@(RnName n) | isLocallyDefinedName n
- = unitUniqSet vname
-fv_set _ = emptyUniqSet
-
-
-rnExpr :: RdrNameHsExpr -> RnM_Fixes s (RenamedHsExpr, FreeVars)
+rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars)
rnExpr (HsVar v)
- = lookupValue v `thenRn` \ vname ->
- returnRn (HsVar vname, fv_set vname)
+ = lookupOccRn v `thenRn` \ vname ->
+ returnRn (HsVar vname, if isLocallyDefined vname
+ then unitNameSet vname
+ else emptyUniqSet)
-rnExpr (HsLit lit)
- = returnRn (HsLit lit, emptyUniqSet)
+rnExpr (HsLit lit)
+ = litOccurrence lit `thenRn_`
+ returnRn (HsLit lit, emptyNameSet)
rnExpr (HsLam match)
= rnMatch match `thenRn` \ (match', fvMatch) ->
rnExpr (HsApp fun arg)
= rnExpr fun `thenRn` \ (fun',fvFun) ->
rnExpr arg `thenRn` \ (arg',fvArg) ->
- returnRn (HsApp fun' arg', fvFun `unionUniqSets` fvArg)
+ returnRn (HsApp fun' arg', fvFun `unionNameSets` fvArg)
-rnExpr (OpApp e1 op e2)
- = rnExpr e1 `thenRn` \ (e1', fvs_e1) ->
- rnExpr op `thenRn` \ (op', fvs_op) ->
- rnExpr e2 `thenRn` \ (e2', fvs_e2) ->
- precParseExpr (OpApp e1' op' e2') `thenRn` \ exp ->
- returnRn (exp, (fvs_op `unionUniqSets` fvs_e1) `unionUniqSets` fvs_e2)
+rnExpr (OpApp e1 (HsVar op) e2) = rnOpApp e1 op e2
-rnExpr (NegApp e n)
- = rnExpr e `thenRn` \ (e', fvs_e) ->
- rnExpr n `thenRn` \ (n', fvs_n) ->
- returnRn (NegApp e' n', fvs_e `unionUniqSets` fvs_n)
+rnExpr (NegApp e n) = completeNegApp (rnExpr e)
rnExpr (HsPar e)
= rnExpr e `thenRn` \ (e', fvs_e) ->
rnExpr (SectionL expr op)
= rnExpr expr `thenRn` \ (expr', fvs_expr) ->
rnExpr op `thenRn` \ (op', fvs_op) ->
- returnRn (SectionL expr' op', fvs_op `unionUniqSets` fvs_expr)
+ returnRn (SectionL expr' op', fvs_op `unionNameSets` fvs_expr)
rnExpr (SectionR op expr)
= rnExpr op `thenRn` \ (op', fvs_op) ->
rnExpr expr `thenRn` \ (expr', fvs_expr) ->
- returnRn (SectionR op' expr', fvs_op `unionUniqSets` fvs_expr)
+ returnRn (SectionR op' expr', fvs_op `unionNameSets` fvs_expr)
rnExpr (CCall fun args may_gc is_casm fake_result_ty)
- = rnExprs args `thenRn` \ (args', fvs_args) ->
+ = lookupImplicitOccRn ccallableClass_RDR `thenRn_`
+ lookupImplicitOccRn creturnableClass_RDR `thenRn_`
+ rnExprs args `thenRn` \ (args', fvs_args) ->
returnRn (CCall fun args' may_gc is_casm fake_result_ty, fvs_args)
rnExpr (HsSCC label expr)
= pushSrcLocRn src_loc $
rnExpr expr `thenRn` \ (new_expr, e_fvs) ->
mapAndUnzipRn rnMatch ms `thenRn` \ (new_ms, ms_fvs) ->
- returnRn (HsCase new_expr new_ms src_loc, unionManyUniqSets (e_fvs : ms_fvs))
+ returnRn (HsCase new_expr new_ms src_loc, unionManyNameSets (e_fvs : ms_fvs))
rnExpr (HsLet binds expr)
- = rnBinds binds `thenRn` \ (binds', fvBinds, new_binders) ->
- extendSS2 new_binders (rnExpr expr) `thenRn` \ (expr',fvExpr) ->
- returnRn (HsLet binds' expr', fvBinds `unionUniqSets` fvExpr)
+ = rnBinds binds $ \ binds' ->
+ rnExpr expr `thenRn` \ (expr',fvExpr) ->
+ returnRn (HsLet binds' expr', fvExpr)
rnExpr (HsDo stmts src_loc)
= pushSrcLocRn src_loc $
- rnStmts stmts `thenRn` \ (stmts', fvStmts) ->
+ lookupImplicitOccRn monadZeroClass_RDR `thenRn_` -- Forces Monad to come too
+ rnStmts stmts `thenRn` \ (stmts', fvStmts) ->
returnRn (HsDo stmts' src_loc, fvStmts)
rnExpr (ListComp expr quals)
- = rnQuals quals `thenRn` \ ((quals', qual_binders), fvQuals) ->
- extendSS2 qual_binders (rnExpr expr) `thenRn` \ (expr', fvExpr) ->
- returnRn (ListComp expr' quals', fvExpr `unionUniqSets` fvQuals)
+ = addImplicitOccRn listType_name `thenRn_`
+ rnQuals expr quals `thenRn` \ ((expr', quals'), fvs) ->
+ returnRn (ListComp expr' quals', fvs)
rnExpr (ExplicitList exps)
- = rnExprs exps `thenRn` \ (exps', fvs) ->
+ = addImplicitOccRn listType_name `thenRn_`
+ rnExprs exps `thenRn` \ (exps', fvs) ->
returnRn (ExplicitList exps', fvs)
rnExpr (ExplicitTuple exps)
- = rnExprs exps `thenRn` \ (exps', fvExps) ->
+ = addImplicitOccRn (tupleType_name (length exps)) `thenRn_`
+ rnExprs exps `thenRn` \ (exps', fvExps) ->
returnRn (ExplicitTuple exps', fvExps)
rnExpr (RecordCon (HsVar con) rbinds)
- = lookupConstr con `thenRn` \ conname ->
+ = lookupOccRn con `thenRn` \ conname ->
rnRbinds "construction" rbinds `thenRn` \ (rbinds', fvRbinds) ->
returnRn (RecordCon (HsVar conname) rbinds', fvRbinds)
rnExpr (RecordUpd expr rbinds)
= rnExpr expr `thenRn` \ (expr', fvExpr) ->
rnRbinds "update" rbinds `thenRn` \ (rbinds', fvRbinds) ->
- returnRn (RecordUpd expr' rbinds', fvExpr `unionUniqSets` fvRbinds)
+ returnRn (RecordUpd expr' rbinds', fvExpr `unionNameSets` fvRbinds)
rnExpr (ExprWithTySig expr pty)
= rnExpr expr `thenRn` \ (expr', fvExpr) ->
- rnPolyType nullTyVarNamesEnv pty `thenRn` \ pty' ->
+ rnHsType pty `thenRn` \ pty' ->
returnRn (ExprWithTySig expr' pty', fvExpr)
rnExpr (HsIf p b1 b2 src_loc)
rnExpr p `thenRn` \ (p', fvP) ->
rnExpr b1 `thenRn` \ (b1', fvB1) ->
rnExpr b2 `thenRn` \ (b2', fvB2) ->
- returnRn (HsIf p' b1' b2' src_loc, unionManyUniqSets [fvP, fvB1, fvB2])
+ returnRn (HsIf p' b1' b2' src_loc, unionManyNameSets [fvP, fvB1, fvB2])
rnExpr (ArithSeqIn seq)
- = rn_seq seq `thenRn` \ (new_seq, fvs) ->
+ = lookupImplicitOccRn enumClass_RDR `thenRn_`
+ rn_seq seq `thenRn` \ (new_seq, fvs) ->
returnRn (ArithSeqIn new_seq, fvs)
where
rn_seq (From expr)
rn_seq (FromThen expr1 expr2)
= rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
- returnRn (FromThen expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
+ returnRn (FromThen expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
rn_seq (FromTo expr1 expr2)
= rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
- returnRn (FromTo expr1' expr2', fvExpr1 `unionUniqSets` fvExpr2)
+ returnRn (FromTo expr1' expr2', fvExpr1 `unionNameSets` fvExpr2)
rn_seq (FromThenTo expr1 expr2 expr3)
= rnExpr expr1 `thenRn` \ (expr1', fvExpr1) ->
rnExpr expr2 `thenRn` \ (expr2', fvExpr2) ->
rnExpr expr3 `thenRn` \ (expr3', fvExpr3) ->
returnRn (FromThenTo expr1' expr2' expr3',
- unionManyUniqSets [fvExpr1, fvExpr2, fvExpr3])
+ unionManyNameSets [fvExpr1, fvExpr2, fvExpr3])
\end{code}
%************************************************************************
rnRbinds str rbinds
= mapRn field_dup_err dup_fields `thenRn_`
mapAndUnzipRn rn_rbind rbinds `thenRn` \ (rbinds', fvRbind_s) ->
- returnRn (rbinds', unionManyUniqSets fvRbind_s)
+ returnRn (rbinds', unionManyNameSets fvRbind_s)
where
(_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rbinds ]
- field_dup_err dups = getSrcLocRn `thenRn` \ src_loc ->
- addErrRn (dupFieldErr str src_loc dups)
+ field_dup_err dups = addErrRn (dupFieldErr str dups)
rn_rbind (field, expr, pun)
- = lookupField field `thenRn` \ fieldname ->
+ = lookupOccRn field `thenRn` \ fieldname ->
rnExpr expr `thenRn` \ (expr', fvExpr) ->
returnRn ((fieldname, expr', pun), fvExpr)
where
(_, dup_fields) = removeDups cmp [ f | (f,_,_) <- rpats ]
- field_dup_err dups = getSrcLocRn `thenRn` \ src_loc ->
- addErrRn (dupFieldErr "pattern" src_loc dups)
+ field_dup_err dups = addErrRn (dupFieldErr "pattern" dups)
rn_rpat (field, pat, pun)
- = lookupField field `thenRn` \ fieldname ->
+ = lookupOccRn field `thenRn` \ fieldname ->
rnPat pat `thenRn` \ pat' ->
returnRn (fieldname, pat', pun)
\end{code}
Quals.
\begin{code}
-rnQuals :: [RdrNameQual]
- -> RnM_Fixes s (([RenamedQual], -- renamed qualifiers
- [RnName]), -- qualifiers' binders
- FreeVars) -- free variables
-
-rnQuals [qual] -- must be at least one qual
- = rnQual qual `thenRn` \ ((new_qual, bs), fvs) ->
- returnRn (([new_qual], bs), fvs)
-
-rnQuals (qual: quals)
- = rnQual qual `thenRn` \ ((qual', bs1), fvQuals1) ->
- extendSS2 bs1 (rnQuals quals) `thenRn` \ ((quals', bs2), fvQuals2) ->
- returnRn
- ((qual' : quals', bs1 ++ bs2), -- The ones on the right (bs2) shadow the
- -- ones on the left (bs1)
- fvQuals1 `unionUniqSets` fvQuals2)
-
-rnQual (GeneratorQual pat expr)
- = rnExpr expr `thenRn` \ (expr', fvExpr) ->
- let
- binders = collectPatBinders pat
- in
- getSrcLocRn `thenRn` \ src_loc ->
- newLocalNames "variable in list-comprehension-generator pattern"
- (binders `zip` repeat src_loc) `thenRn` \ new_binders ->
- extendSS new_binders (rnPat pat) `thenRn` \ pat' ->
+rnQuals :: RdrNameHsExpr -> [RdrNameQual]
+ -> RnMS s ((RenamedHsExpr, [RenamedQual]), FreeVars)
+
+rnQuals expr [qual] -- must be at least one qual
+ = rnQual qual $ \ new_qual ->
+ rnExpr expr `thenRn` \ (expr', fvs) ->
+ returnRn ((expr', [new_qual]), fvs)
+
+rnQuals expr (qual: quals)
+ = rnQual qual $ \ qual' ->
+ rnQuals expr quals `thenRn` \ ((expr', quals'), fv_quals) ->
+ returnRn ((expr', qual' : quals'), fv_quals)
- returnRn ((GeneratorQual pat' expr', new_binders), fvExpr)
-rnQual (FilterQual expr)
- = rnExpr expr `thenRn` \ (expr', fvs) ->
- returnRn ((FilterQual expr', []), fvs)
+-- rnQual :: RdrNameQual
+-- -> (RenamedQual -> RnMS s (a,FreeVars))
+-- -> RnMS s (a,FreeVars)
+-- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2]
-rnQual (LetQual binds)
- = rnBinds binds `thenRn` \ (binds', binds_fvs, new_binders) ->
- returnRn ((LetQual binds', new_binders), binds_fvs)
+rnQual (GeneratorQual pat expr) thing_inside
+ = rnExpr expr `thenRn` \ (expr', fv_expr) ->
+ bindLocalsRn "pattern in list comprehension" binders $ \ new_binders ->
+ rnPat pat `thenRn` \ pat' ->
+
+ thing_inside (GeneratorQual pat' expr') `thenRn` \ (result, fvs) ->
+ returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
+ where
+ binders = collectPatBinders pat
+
+rnQual (FilterQual expr) thing_inside
+ = rnExpr expr `thenRn` \ (expr', fv_expr) ->
+ thing_inside (FilterQual expr') `thenRn` \ (result, fvs) ->
+ returnRn (result, fv_expr `unionNameSets` fvs)
+
+rnQual (LetQual binds) thing_inside
+ = rnBinds binds $ \ binds' ->
+ thing_inside (LetQual binds')
\end{code}
%************************************************************************
\begin{code}
-rnStmts :: [RdrNameStmt] -> RnM_Fixes s ([RenamedStmt], FreeVars)
+rnStmts :: [RdrNameStmt] -> RnMS s ([RenamedStmt], FreeVars)
-rnStmts [stmt@(ExprStmt _ _)] -- last stmt must be ExprStmt
- = rnStmt stmt `thenRn` \ ((stmt',[]), fvStmt) ->
- returnRn ([stmt'], fvStmt)
+rnStmts [stmt@(ExprStmt expr src_loc)] -- last stmt must be ExprStmt
+ = pushSrcLocRn src_loc $
+ rnExpr expr `thenRn` \ (expr', fv_expr) ->
+ returnRn ([ExprStmt expr' src_loc], fv_expr)
rnStmts (stmt:stmts)
- = rnStmt stmt `thenRn` \ ((stmt',bs), fvStmt) ->
- extendSS2 bs (rnStmts stmts) `thenRn` \ (stmts', fvStmts) ->
- returnRn (stmt':stmts', fvStmt `unionUniqSets` fvStmts)
+ = rnStmt stmt $ \ stmt' ->
+ rnStmts stmts `thenRn` \ (stmts', fv_stmts) ->
+ returnRn (stmt':stmts', fv_stmts)
-rnStmt (BindStmt pat expr src_loc)
- = pushSrcLocRn src_loc $
- rnExpr expr `thenRn` \ (expr', fvExpr) ->
- let
- binders = collectPatBinders pat
- in
- newLocalNames "variable in do binding"
- (binders `zip` repeat src_loc) `thenRn` \ new_binders ->
- extendSS new_binders (rnPat pat) `thenRn` \ pat' ->
+-- rnStmt :: RdrNameStmt -> (RenamedStmt -> RnMS s (a, FreeVars)) -> RnMS s (a, FreeVars)
+-- Because of mutual recursion the actual type is a bit less general than this [Haskell 1.2]
- returnRn ((BindStmt pat' expr' src_loc, new_binders), fvExpr)
+rnStmt (BindStmt pat expr src_loc) thing_inside
+ = pushSrcLocRn src_loc $
+ rnExpr expr `thenRn` \ (expr', fv_expr) ->
+ bindLocalsRn "pattern in do binding" binders $ \ new_binders ->
+ rnPat pat `thenRn` \ pat' ->
-rnStmt (ExprStmt expr src_loc)
- =
- rnExpr expr `thenRn` \ (expr', fvs) ->
- returnRn ((ExprStmt expr' src_loc, []), fvs)
+ thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ (result, fvs) ->
+ returnRn (result, fv_expr `unionNameSets` (fvs `minusNameSet` mkNameSet new_binders))
+ where
+ binders = collectPatBinders pat
-rnStmt (LetStmt binds)
- = rnBinds binds `thenRn` \ (binds', binds_fvs, new_binders) ->
- returnRn ((LetStmt binds', new_binders), binds_fvs)
+rnStmt (ExprStmt expr src_loc) thing_inside
+ = pushSrcLocRn src_loc $
+ rnExpr expr `thenRn` \ (expr', fv_expr) ->
+ thing_inside (ExprStmt expr' src_loc) `thenRn` \ (result, fvs) ->
+ returnRn (result, fv_expr `unionNameSets` fvs)
+rnStmt (LetStmt binds) thing_inside
+ = rnBinds binds $ \ binds' ->
+ thing_inside (LetStmt binds')
\end{code}
%************************************************************************
%* *
%************************************************************************
-\begin{code}
-precParseExpr :: RenamedHsExpr -> RnM_Fixes s RenamedHsExpr
-precParsePat :: RenamedPat -> RnM_Fixes s RenamedPat
+@rnOpApp@ deals with operator applications. It does some rearrangement of
+the expression so that the precedences are right. This must be done on the
+expression *before* renaming, because fixity info applies to the things
+the programmer actually wrote.
-precParseExpr exp@(OpApp (NegApp e1 n) (HsVar op) e2)
- = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
- if 6 < op_prec then
+\begin{code}
+rnOpApp (NegApp e11 n) op e2
+ = lookupFixity op `thenRn` \ (Fixity op_prec op_dir) ->
+ if op_prec > 6 then
-- negate precedence 6 wired in
-- (-x)*y ==> -(x*y)
- precParseExpr (OpApp e1 (HsVar op) e2) `thenRn` \ op_app ->
- returnRn (NegApp op_app n)
+ completeNegApp (rnOpApp e11 op e2)
else
- returnRn exp
+ completeOpApp (completeNegApp (rnExpr e11)) op (rnExpr e2)
-precParseExpr exp@(OpApp (OpApp e11 (HsVar op1) e12) (HsVar op) e2)
- = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
- lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) ->
- -- pprTrace "precParse:" (ppCat [ppr PprDebug op, ppInt op_prec, ppr PprDebug op1, ppInt op1_prec]) $
+rnOpApp (OpApp e11 (HsVar op1) e12) op e2
+ = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
+ lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
+ -- pprTrace "rnOpApp:" (ppCat [ppr PprDebug op, ppInt op_prec, ppr PprDebug op1, ppInt op1_prec]) $
case (op1_prec `cmp` op_prec) of
LT_ -> rearrange
- EQ_ -> case (op1_fix, op_fix) of
- (INFIXR, INFIXR) -> rearrange
- (INFIXL, INFIXL) -> returnRn exp
- _ -> getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn exp
- (precParseErr (op1,op1_fix,op1_prec) (op,op_fix,op_prec) src_loc)
- GT__ -> returnRn exp
+ EQ_ -> case (op1_dir, op_dir) of
+ (InfixR, InfixR) -> rearrange
+ (InfixL, InfixL) -> dont_rearrange
+ _ -> addErrRn (precParseErr (op1,op1_fix) (op,op_fix)) `thenRn_`
+ dont_rearrange
+ GT__ -> dont_rearrange
where
- rearrange = precParseExpr (OpApp e12 (HsVar op) e2) `thenRn` \ e2' ->
- returnRn (OpApp e11 (HsVar op1) e2')
+ rearrange = rnOpApp e11 op1 (OpApp e12 (HsVar op) e2)
+ dont_rearrange = completeOpApp (rnOpApp e11 op1 e12) op (rnExpr e2)
+
+rnOpApp e1 op e2 = completeOpApp (rnExpr e1) op (rnExpr e2)
-precParseExpr exp = returnRn exp
+completeOpApp rn_e1 op rn_e2
+ = rn_e1 `thenRn` \ (e1', fvs1) ->
+ rn_e2 `thenRn` \ (e2', fvs2) ->
+ rnExpr (HsVar op) `thenRn` \ (op', fvs3) ->
+ returnRn (OpApp e1' op' e2', fvs1 `unionNameSets` fvs2 `unionNameSets` fvs3)
+completeNegApp rn_expr
+ = rn_expr `thenRn` \ (e', fvs_e) ->
+ lookupImplicitOccRn negate_RDR `thenRn` \ neg ->
+ returnRn (NegApp e' (HsVar neg), fvs_e)
+\end{code}
-precParsePat pat@(ConOpPatIn (NegPatIn e1) op e2)
- = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
- if 6 < op_prec then
+\begin{code}
+rnOpPat p1@(NegPatIn p11) op p2
+ = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
+ if op_prec > 6 then
-- negate precedence 6 wired in
- getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn pat (precParseNegPatErr (op,op_fix,op_prec) src_loc)
+ addErrRn (precParseNegPatErr (op,op_fix)) `thenRn_`
+ rnOpPat p11 op p2 `thenRn` \ op_pat ->
+ returnRn (NegPatIn op_pat)
else
- returnRn pat
+ completeOpPat (rnPat p1) op (rnPat p2)
-precParsePat pat@(ConOpPatIn (ConOpPatIn p11 op1 p12) op p2)
- = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
- lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) ->
+rnOpPat (ConOpPatIn p11 op1 p12) op p2
+ = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
+ lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
case (op1_prec `cmp` op_prec) of
LT_ -> rearrange
- EQ_ -> case (op1_fix, op_fix) of
- (INFIXR, INFIXR) -> rearrange
- (INFIXL, INFIXL) -> returnRn pat
- _ -> getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn pat
- (precParseErr (op1,op1_fix,op1_prec) (op,op_fix,op_prec) src_loc)
- GT__ -> returnRn pat
+ EQ_ -> case (op1_dir, op_dir) of
+ (InfixR, InfixR) -> rearrange
+ (InfixL, InfixL) -> dont_rearrange
+ _ -> addErrRn (precParseErr (op1,op1_fix) (op,op_fix)) `thenRn_`
+ dont_rearrange
+ GT__ -> dont_rearrange
where
- rearrange = precParsePat (ConOpPatIn p12 op p2) `thenRn` \ p2' ->
- returnRn (ConOpPatIn p11 op1 p2')
-
-precParsePat pat = returnRn pat
+ rearrange = rnOpPat p11 op1 (ConOpPatIn p12 op p2)
+ dont_rearrange = completeOpPat (rnOpPat p11 op1 p12) op (rnPat p2)
-data INFIX = INFIXL | INFIXR | INFIXN deriving Eq
+rnOpPat p1 op p2 = completeOpPat (rnPat p1) op (rnPat p2)
-lookupFixity :: RnName -> RnM_Fixes s (INFIX, Int)
-lookupFixity op
- = getExtraRn `thenRn` \ fixity_fm ->
- -- pprTrace "lookupFixity:" (ppAboves [ppCat [pprUnique u, ppr PprDebug i_f] | (u,i_f) <- ufmToList fixity_fm]) $
- case lookupUFM fixity_fm op of
- Nothing -> returnRn (INFIXL, 9)
- Just (InfixL _ n) -> returnRn (INFIXL, n)
- Just (InfixR _ n) -> returnRn (INFIXR, n)
- Just (InfixN _ n) -> returnRn (INFIXN, n)
+completeOpPat rn_p1 op rn_p2
+ = rn_p1 `thenRn` \ p1' ->
+ rn_p2 `thenRn` \ p2' ->
+ lookupRn op `thenRn` \ op' ->
+ returnRn (ConOpPatIn p1' op' p2')
\end{code}
\begin{code}
-checkPrecMatch :: Bool -> RnName -> RenamedMatch -> RnM_Fixes s ()
+checkPrecMatch :: Bool -> RdrName -> RdrNameMatch -> RnMS s ()
checkPrecMatch False fn match
= returnRn ()
= panic "checkPrecMatch"
checkPrec op (ConOpPatIn _ op1 _) right
- = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
- lookupFixity op1 `thenRn` \ (op1_fix, op1_prec) ->
- getSrcLocRn `thenRn` \ src_loc ->
+ = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
+ lookupFixity op1 `thenRn` \ op1_fix@(Fixity op1_prec op1_dir) ->
let
inf_ok = op1_prec > op_prec ||
(op1_prec == op_prec &&
- (op1_fix == INFIXR && op_fix == INFIXR && right ||
- op1_fix == INFIXL && op_fix == INFIXL && not right))
+ (op1_dir == InfixR && op_dir == InfixR && right ||
+ op1_dir == InfixL && op_dir == InfixL && not right))
- info = (op,op_fix,op_prec)
- info1 = (op1,op1_fix,op1_prec)
+ info = (op,op_fix)
+ info1 = (op1,op1_fix)
(infol, infor) = if right then (info, info1) else (info1, info)
in
- addErrIfRn (not inf_ok) (precParseErr infol infor src_loc)
+ checkRn inf_ok (precParseErr infol infor)
checkPrec op (NegPatIn _) right
- = lookupFixity op `thenRn` \ (op_fix, op_prec) ->
- getSrcLocRn `thenRn` \ src_loc ->
- addErrIfRn (6 < op_prec) (precParseNegPatErr (op,op_fix,op_prec) src_loc)
+ = lookupFixity op `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
+ checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
checkPrec op pat right
= returnRn ()
\end{code}
+%************************************************************************
+%* *
+\subsubsection{Literals}
+%* *
+%************************************************************************
+
+When literals occur we have to make sure that the types and classes they involve
+are made available.
+
+\begin{code}
+litOccurrence (HsChar _)
+ = addImplicitOccRn charType_name
+
+litOccurrence (HsCharPrim _)
+ = addImplicitOccRn (getName charPrimTyCon)
+
+litOccurrence (HsString _)
+ = addImplicitOccRn listType_name `thenRn_`
+ addImplicitOccRn charType_name
+
+litOccurrence (HsStringPrim _)
+ = addImplicitOccRn (getName addrPrimTyCon)
+
+litOccurrence (HsInt _)
+ = lookupImplicitOccRn numClass_RDR `thenRn_` -- Int and Integer are forced in by Num
+ returnRn ()
+
+litOccurrence (HsFrac _)
+ = lookupImplicitOccRn fractionalClass_RDR `thenRn_` -- ... similarly Rational
+ returnRn ()
+
+litOccurrence (HsIntPrim _)
+ = addImplicitOccRn (getName intPrimTyCon)
+
+litOccurrence (HsFloatPrim _)
+ = addImplicitOccRn (getName floatPrimTyCon)
+
+litOccurrence (HsDoublePrim _)
+ = addImplicitOccRn (getName doublePrimTyCon)
+
+litOccurrence (HsLitLit _)
+ = lookupImplicitOccRn ccallableClass_RDR `thenRn_`
+ returnRn ()
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsubsection{Errors}
+%* *
+%************************************************************************
+
\begin{code}
-dupFieldErr str src_loc (dup:rest)
- = addShortErrLocLine src_loc (\ sty ->
- ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str])
-
-negPatErr pat src_loc
- = addShortErrLocLine src_loc (\ sty ->
- ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat])
-
-precParseNegPatErr op src_loc
- = addErrLoc src_loc "precedence parsing error" (\ sty ->
- ppBesides [ppStr "prefix `-' has lower precedence than ", pp_op sty op, ppStr " in pattern"])
-
-precParseErr op1 op2 src_loc
- = addErrLoc src_loc "precedence parsing error" (\ sty ->
- ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2,
- ppStr " in the same infix expression"])
-
-pp_op sty (op, fix, prec) = ppBesides [pprSym sty op, ppLparen, pp_fix fix, ppSP, ppInt prec, ppRparen]
-pp_fix INFIXL = ppStr "infixl"
-pp_fix INFIXR = ppStr "infixr"
-pp_fix INFIXN = ppStr "infix"
+dupFieldErr str (dup:rest) sty
+ = ppBesides [ppStr "duplicate field name `", ppr sty dup, ppStr "' in record ", ppStr str]
+
+negPatErr pat sty
+ = ppSep [ppStr "prefix `-' not applied to literal in pattern", ppr sty pat]
+
+precParseNegPatErr op sty
+ = ppHang (ppStr "precedence parsing error")
+ 4 (ppBesides [ppStr "prefix `-' has lower precedence than ", pp_op sty op, ppStr " in pattern"])
+
+precParseErr op1 op2 sty
+ = ppHang (ppStr "precedence parsing error")
+ 4 (ppBesides [ppStr "cannot mix ", pp_op sty op1, ppStr " and ", pp_op sty op2,
+ ppStr " in the same infix expression"])
+
+pp_op sty (op, fix) = ppBesides [pprSym sty op, ppLparen, ppr sty fix, ppRparen]
\end{code}
import HsSyn
-import Id ( isDataCon, GenId, SYN_IE(Id) )
-import Name ( isLocalName, nameUnique, Name, RdrName(..),
- mkLocalName
- )
+import Id ( GenId, SYN_IE(Id) )
+import Name ( Name )
import Outputable ( Outputable(..){-instance * []-} )
import PprStyle ( PprStyle(..) )
import PprType ( GenType, GenTyVar, TyCon )
import Pretty
+import Name ( SYN_IE(NameSet), unitNameSet, mkNameSet, minusNameSet, unionNameSets, emptyNameSet )
import TyCon ( TyCon )
import TyVar ( GenTyVar )
-import Unique ( mkAlphaTyVarUnique, Unique )
+import Unique ( Unique )
import Util ( panic, pprPanic{-, pprTrace ToDo:rm-} )
\end{code}
-\begin{code}
-data RnName
- = WiredInId Id
- | WiredInTyCon TyCon
- | RnName Name -- functions/binders/tyvars
- | RnSyn Name -- type synonym
- | RnData Name [Name] [Name] -- data type (with constrs and fields)
- | RnConstr Name Name -- constructor (with data type)
- | RnField Name Name -- field (with data type)
- | RnClass Name [Name] -- class (with class ops)
- | RnClassOp Name Name -- class op (with class)
- | RnImplicit Name -- implicitly imported
- | RnImplicitTyCon Name -- implicitly imported
- | RnImplicitClass Name -- implicitly imported
- | RnUnbound RdrName -- place holder
-
-mkRnName = RnName
-mkRnImplicit = RnImplicit
-mkRnImplicitTyCon = RnImplicitTyCon
-mkRnImplicitClass = RnImplicitClass
-mkRnUnbound = RnUnbound
-
-isRnWired (WiredInId _) = True
-isRnWired (WiredInTyCon _) = True
-isRnWired _ = False
-
-isRnLocal (RnName n) = isLocalName n
-isRnLocal _ = False
-
-isRnTyCon (WiredInTyCon _) = True
-isRnTyCon (RnSyn _) = True
-isRnTyCon (RnData _ _ _) = True
-isRnTyCon (RnImplicitTyCon _) = True
-isRnTyCon _ = False
-
-isRnClass (RnClass _ _) = True
-isRnClass (RnImplicitClass _) = True
-isRnClass _ = False
-
--- a common need: isRnTyCon || isRnClass:
-isRnTyConOrClass (WiredInTyCon _) = True
-isRnTyConOrClass (RnSyn _) = True
-isRnTyConOrClass (RnData _ _ _) = True
-isRnTyConOrClass (RnImplicitTyCon _) = True
-isRnTyConOrClass (RnClass _ _) = True
-isRnTyConOrClass (RnImplicitClass _) = True
-isRnTyConOrClass _ = False
-
-isRnConstr (RnConstr _ _) = True
-isRnConstr (WiredInId id) = isDataCon id
-isRnConstr _ = False
-
-isRnField (RnField _ _) = True
-isRnField _ = False
-
-isRnClassOp cls (RnClassOp _ op_cls) = eqUniqsNamed cls op_cls
-isRnClassOp cls n = True -- pprTrace "isRnClassOp:" (ppr PprShowAll n) $ True -- let it past anyway
-
-isRnImplicit (RnImplicit _) = True
-isRnImplicit (RnImplicitTyCon _) = True
-isRnImplicit (RnImplicitClass _) = True
-isRnImplicit _ = False
-
-isRnUnbound (RnUnbound _) = True
-isRnUnbound _ = False
-
-isRnEntity (WiredInId _) = True
-isRnEntity (WiredInTyCon _) = True
-isRnEntity (RnName n) = not (isLocalName n)
-isRnEntity (RnSyn _) = True
-isRnEntity (RnData _ _ _) = True
-isRnEntity (RnClass _ _) = True
-isRnEntity _ = False
-
--- Very general NamedThing comparison, used when comparing
--- Uniquable things with different types
-
-eqUniqsNamed n1 n2 = uniqueOf n1 == uniqueOf n2
-cmpUniqsNamed n1 n2 = uniqueOf n1 `cmp` uniqueOf n2
-
-instance Eq RnName where
- a == b = eqUniqsNamed a b
-
-instance Ord3 RnName where
- a `cmp` b = cmpUniqsNamed a b
-
-instance Uniquable RnName where
- uniqueOf = nameUnique . getName
-
-instance NamedThing RnName where
- getName (WiredInId id) = getName id
- getName (WiredInTyCon tc) = getName tc
- getName (RnName n) = n
- getName (RnSyn n) = n
- getName (RnData n _ _) = n
- getName (RnConstr n _) = n
- getName (RnField n _) = n
- getName (RnClass n _) = n
- getName (RnClassOp n _) = n
- getName (RnImplicit n) = n
- getName (RnImplicitTyCon n) = n
- getName (RnImplicitClass n) = n
- 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)
- where bottom = mkAlphaTyVarUnique 0 -- anything; just something that will print
- bottom2 = panic "getRnName: srcloc"
-
-instance Outputable RnName where
-#ifdef DEBUG
- ppr sty@PprShowAll (RnData n cs fs) = ppBesides [ppr sty n, ppStr "{-", ppr sty cs, ppr sty fs, ppStr "-}"]
- ppr sty@PprShowAll (RnConstr n d) = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
- ppr sty@PprShowAll (RnField n d) = ppBesides [ppr sty n, ppStr "{-", ppr sty d, ppStr "-}"]
- ppr sty@PprShowAll (RnClass n ops) = ppBesides [ppr sty n, ppStr "{-", ppr sty ops, ppStr "-}"]
- ppr sty@PprShowAll (RnClassOp n c) = ppBesides [ppr sty n, ppStr "{-", ppr sty c, ppStr "-}"]
-#endif
- ppr sty (WiredInId id) = ppr sty id
- ppr sty (WiredInTyCon tycon)= ppr sty tycon
- ppr sty (RnUnbound occ) = ppBeside (ppr sty occ) (ppPStr SLIT("{-UNBOUND-}"))
- ppr sty rn_name = ppr sty (getName rn_name)
-\end{code}
\begin{code}
-type RenamedArithSeqInfo = ArithSeqInfo Fake Fake RnName RenamedPat
-type RenamedBind = Bind Fake Fake RnName RenamedPat
-type RenamedClassDecl = ClassDecl Fake Fake RnName RenamedPat
-type RenamedClassOpSig = Sig RnName
-type RenamedConDecl = ConDecl RnName
-type RenamedContext = Context RnName
-type RenamedSpecDataSig = SpecDataSig RnName
-type RenamedDefaultDecl = DefaultDecl RnName
-type RenamedFixityDecl = FixityDecl RnName
-type RenamedGRHS = GRHS Fake Fake RnName RenamedPat
-type RenamedGRHSsAndBinds = GRHSsAndBinds Fake Fake RnName RenamedPat
-type RenamedHsBinds = HsBinds Fake Fake RnName RenamedPat
-type RenamedHsExpr = HsExpr Fake Fake RnName RenamedPat
-type RenamedHsModule = HsModule Fake Fake RnName RenamedPat
-type RenamedInstDecl = InstDecl Fake Fake RnName RenamedPat
-type RenamedMatch = Match Fake Fake RnName RenamedPat
-type RenamedMonoBinds = MonoBinds Fake Fake RnName RenamedPat
-type RenamedMonoType = MonoType RnName
-type RenamedPat = InPat RnName
-type RenamedPolyType = PolyType RnName
-type RenamedRecordBinds = HsRecordBinds Fake Fake RnName RenamedPat
-type RenamedQual = Qualifier Fake Fake RnName RenamedPat
-type RenamedSig = Sig RnName
-type RenamedSpecInstSig = SpecInstSig RnName
-type RenamedStmt = Stmt Fake Fake RnName RenamedPat
-type RenamedTyDecl = TyDecl RnName
-
-type RenamedClassOpPragmas = ClassOpPragmas RnName
-type RenamedClassPragmas = ClassPragmas RnName
-type RenamedDataPragmas = DataPragmas RnName
-type RenamedGenPragmas = GenPragmas RnName
-type RenamedInstancePragmas = InstancePragmas RnName
+type RenamedArithSeqInfo = ArithSeqInfo Fake Fake Name RenamedPat
+type RenamedBind = Bind Fake Fake Name RenamedPat
+type RenamedClassDecl = ClassDecl Fake Fake Name RenamedPat
+type RenamedClassOpSig = Sig Name
+type RenamedConDecl = ConDecl Name
+type RenamedContext = Context Name
+type RenamedHsDecl = HsDecl Fake Fake Name RenamedPat
+type RenamedSpecDataSig = SpecDataSig Name
+type RenamedDefaultDecl = DefaultDecl Name
+type RenamedFixityDecl = FixityDecl Name
+type RenamedGRHS = GRHS Fake Fake Name RenamedPat
+type RenamedGRHSsAndBinds = GRHSsAndBinds Fake Fake Name RenamedPat
+type RenamedHsBinds = HsBinds Fake Fake Name RenamedPat
+type RenamedHsExpr = HsExpr Fake Fake Name RenamedPat
+type RenamedHsModule = HsModule Fake Fake Name RenamedPat
+type RenamedInstDecl = InstDecl Fake Fake Name RenamedPat
+type RenamedMatch = Match Fake Fake Name RenamedPat
+type RenamedMonoBinds = MonoBinds Fake Fake Name RenamedPat
+type RenamedPat = InPat Name
+type RenamedHsType = HsType Name
+type RenamedRecordBinds = HsRecordBinds Fake Fake Name RenamedPat
+type RenamedQual = Qualifier Fake Fake Name RenamedPat
+type RenamedSig = Sig Name
+type RenamedSpecInstSig = SpecInstSig Name
+type RenamedStmt = Stmt Fake Fake Name RenamedPat
+type RenamedTyDecl = TyDecl Name
+
+type RenamedClassOpPragmas = ClassOpPragmas Name
+type RenamedClassPragmas = ClassPragmas Name
+type RenamedDataPragmas = DataPragmas Name
+type RenamedGenPragmas = GenPragmas Name
+type RenamedInstancePragmas = InstancePragmas Name
\end{code}
+%************************************************************************
+%* *
+\subsection{Free variables}
+%* *
+%************************************************************************
+
\begin{code}
-collectQualBinders :: [RenamedQual] -> [RnName]
+extractCtxtTyNames :: RenamedContext -> NameSet
+extractCtxtTyNames ctxt = foldr (unionNameSets . extractHsTyNames . snd) emptyNameSet ctxt
-collectQualBinders quals
- = concat (map collect quals)
+extractHsTyNames :: RenamedHsType -> NameSet
+extractHsTyNames ty
+ = get ty
where
- collect (GeneratorQual pat _) = collectPatBinders pat
- collect (FilterQual expr) = []
- collect (LetQual binds) = collectTopLevelBinders binds
+ get (MonoTyApp con tys) = foldr (unionNameSets . get) (unitNameSet con) tys
+ get (MonoListTy tc ty) = unitNameSet tc `unionNameSets` get ty
+ get (MonoTupleTy tc tys) = foldr (unionNameSets . get) (unitNameSet tc) tys
+ get (MonoFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2
+ get (MonoDictTy cls ty) = unitNameSet cls `unionNameSets` get ty
+ get (MonoTyVar tv) = unitNameSet tv
+ get (HsForAllTy tvs ctxt ty) = foldr (unionNameSets . get . snd) (get ty) ctxt
+ `minusNameSet`
+ mkNameSet (map getTyVarName tvs)
-fixDeclName :: FixityDecl name -> name
-fixDeclName (InfixL name i) = name
-fixDeclName (InfixR name i) = name
-fixDeclName (InfixN name i) = name
\end{code}
#include "HsVersions.h"
module RnIfaces (
- cachedIface,
- cachedDecl, CachingResult(..),
- rnIfaces,
- IfaceCache, initIfaceCache
+ getInterfaceExports,
+ getImportedInstDecls,
+ getSpecialInstModules,
+ getDecl, getWiredInDecl,
+ getImportVersions,
+
+ checkUpToDate,
+
+ getDeclBinders,
+ mkSearchPath
) where
IMP_Ubiq()
-import PreludeGlaST ( thenPrimIO, newVar, readVar, writeVar, SYN_IE(MutableVar) )
-#if __GLASGOW_HASKELL__ >= 200
-# define ST_THEN `stThen`
-# define TRY_IO tryIO
-IMPORT_1_3(GHCio(stThen,tryIO))
-#else
-# define ST_THEN `thenPrimIO`
-# define TRY_IO try
-#endif
-
-import HsSyn
-import HsPragmas ( noGenPragmas )
-import RdrHsSyn
-import RnHsSyn
+import HsSyn ( HsDecl(..), TyDecl(..), ClassDecl(..), HsTyVar, Bind, HsExpr, Sig(..),
+ HsBinds(..), MonoBinds, DefaultDecl, ConDecl(..), HsType, BangType, IfaceSig(..),
+ FixityDecl(..), Fixity, Fake, InPat, InstDecl(..), SYN_IE(Version), HsIdInfo
+ )
+import HsPragmas ( noGenPragmas )
+import RdrHsSyn ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl),
+ RdrName, rdrNameOcc
+ )
+import RnEnv ( newGlobalName, lookupRn, addImplicitOccsRn, availNames )
+import RnSource ( rnHsType )
import RnMonad
-import RnSource ( rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType )
-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 ( 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-}, FiniteMap
- )
-import Maybes ( maybeToBool, MaybeErr(..) )
-import Name ( origName, moduleOf, nameOf, qualToOrigName, OrigName(..),
- isLexCon, RdrName(..), Name{-instance NamedThing-} )
---import PprStyle -- ToDo:rm
---import Outputable -- ToDo:rm
-import PrelInfo ( builtinNameMaps, builtinKeysMap, builtinTcNamesMap, SYN_IE(BuiltinNames) )
+import FiniteMap ( FiniteMap, emptyFM, unitFM, lookupFM, addToFM, addListToFM, fmToList )
+import Name ( Name {-instance NamedThing-}, Provenance, OccName(..),
+ modAndOcc, occNameString, moduleString, pprModule,
+ NameSet(..), emptyNameSet, unionNameSets, nameSetToList,
+ minusNameSet, mkNameSet,
+ isWiredInName, maybeWiredInTyConName, maybeWiredInIdName
+ )
+import Id ( GenId, Id(..), idType, dataConTyCon, isDataCon )
+import TyCon ( TyCon, tyConDataCons, isSynTyCon, getSynTyConDefn )
+import Type ( namesOfType )
+import TyVar ( GenTyVar )
+import SrcLoc ( mkIfaceSrcLoc )
+import PrelMods ( gHC__ )
+import Bag
+import Maybes ( MaybeErr(..), expectJust, maybeToBool )
+import ListSetOps ( unionLists )
import Pretty
-import UniqFM ( emptyUFM )
-import UniqSupply ( splitUniqSupply )
-import Util ( sortLt, removeDups, cmpPString, startsWith,
- panic, pprPanic, assertPanic{-, pprTrace ToDo:rm-} )
-\end{code}
-
-\begin{code}
-type ModuleToIfaceContents = FiniteMap Module ParsedIface
-type ModuleToIfaceFilePath = FiniteMap Module FilePath
-
-#if __GLASGOW_HASKELL__ >= 200
-# define REAL_WORLD RealWorld
-#else
-# define REAL_WORLD _RealWorld
-#endif
-
-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 REAL_WORLD
- (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) ST_THEN \ iface_var ->
- return (IfaceCache mod builtinNameMaps iface_var)
+import PprStyle ( PprStyle(..) )
+import Util ( pprPanic )
\end{code}
-*********************************************************
-* *
-\subsection{Reading interface files}
-* *
-*********************************************************
-
-Return cached info about a Module's interface; otherwise,
-read the interface (using our @ModuleToIfaceFilePath@ map
-to decide where to look).
-
-Note: we have two notions of interface
- * the interface for a particular file name
- * the (combined) interface for a particular module name
-The idea is that two source files may declare a module
-with the same name with the declarations being merged.
-
-This allows us to have file PreludeList.hs producing
-PreludeList.hi but defining part of module Prelude.
-When PreludeList is imported its contents will be
-added to Prelude. In this way all the original names
-for a particular module will be available the imported
-decls are renamed.
-
-ToDo: Check duplicate definitons are the same.
-ToDo: Check/Merge duplicate pragmas.
+%*********************************************************
+%* *
+\subsection{Loading a new interface file}
+%* *
+%*********************************************************
\begin{code}
-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 (IfaceCache _ _ iface_var) want_orig_iface item modname
- = readVar iface_var ST_THEN \ (iface_fm, orig_fm, file_fm) ->
-
- case (lookupFM iface_fm modname) of
- Just iface -> return (want_iface iface orig_fm)
- Nothing ->
- case (lookupFM file_fm modname) of
- Nothing -> return (Failed (noIfaceErr modname))
- Just file ->
- 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)
- Succeeded iface ->
- let
- iface_fm' = addToFM iface_fm modname iface
- orig_fm' = addToFM_C mergeIfaces orig_fm (iface_mod iface) iface
- in
- writeVar iface_var (iface_fm', orig_fm', file_fm) ST_THEN \ _ ->
- return (want_iface iface orig_fm')
- where
- want_iface iface orig_fm
- | want_orig_iface
- = case lookupFM orig_fm modname of
- Nothing -> Failed (noOrigIfaceErr modname)
- Just orig_iface -> Succeeded orig_iface
- | otherwise
- = Succeeded iface
-
- iface_mod (ParsedIface mod _ _ _ _ _ _ _ _ _ _ _ _) = mod
-
-----------
-mergeIfaces (ParsedIface mod1 (_, files1) _ _ _ _ _ _ fixes1 tdefs1 vdefs1 idefs1 prags1)
- (ParsedIface mod2 (_, files2) _ _ _ _ _ _ fixes2 tdefs2 vdefs2 idefs2 prags2)
- = --pprTrace "mergeIfaces:" (ppCat [ppStr "import", ppCat (map ppPStr (bagToList files2)),
- -- ppStr "merged with", ppPStr mod1]) $
- ASSERT(mod1 == mod2)
- ParsedIface mod1
- (True, unionBags files2 files1)
- (panic "mergeIface: module version numbers")
- (panic "mergeIface: source version numbers") -- Version numbers etc must be extracted from
- (panic "mergeIface: usage version numbers") -- the merged file interfaces named above
- (panic "mergeIface: decl version numbers")
- (panic "mergeIface: exports")
- (panic "mergeIface: instance modules")
- (plusFM_C (dup_merge {-"fixity" (ppr PprDebug . fixDeclName)-}) fixes1 fixes2)
- (plusFM_C (dup_merge {-"tycon/class" (ppr PprDebug . idecl_nm)-}) tdefs1 tdefs2)
- (plusFM_C (dup_merge {-"value" (ppr PprDebug . idecl_nm)-}) vdefs1 vdefs2)
- (unionBags idefs1 idefs2)
- (plusFM_C (dup_merge {-"pragma" ppStr-}) prags1 prags2)
- where
- dup_merge {-str ppr_dup-} dup1 dup2
- = --pprTrace "mergeIfaces:"
- -- (ppCat [ppPStr mod1, ppPStr mod2, ppStr ": dup", ppStr str, ppStr "decl",
- -- ppr_dup dup1, ppr_dup dup2]) $
- dup2
-
- idecl_nm (TypeSig n _ _) = n
- idecl_nm (NewTypeSig n _ _ _) = n
- idecl_nm (DataSig n _ _ _ _) = n
- idecl_nm (ClassSig n _ _ _) = n
- 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 CachingResult
-
-cachedDecl iface_cache@(IfaceCache this_mod (b_val_names,b_tc_names) _)
- class_or_tycon name@(OrigName mod str)
-
- = -- pprTrace "cachedDecl:" (ppr PprDebug name) $
- if mod == this_mod then -- some i/face has made a reference
- return (CachingAvoided Nothing) -- to something from this module
- else
+loadInterface :: Pretty -> Module -> RnMG Ifaces
+loadInterface doc_str load_mod
+ = getIfacesRn `thenRn` \ ifaces ->
let
- b_env = if class_or_tycon then b_tc_names else b_val_names
+ Ifaces this_mod mod_vers_map export_env_map vers_map decls_map inst_map inst_mods = ifaces
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 CachingResult
-
-cachedDeclByType iface_cache rn
- -- the idea is: check that, e.g., if we're given an
- -- RnClass, then we really get back a ClassDecl from
- -- the cache (not an RnData, or something silly)
- = cachedDecl iface_cache (isRnTyConOrClass rn) (origName "cachedDeclByType" rn) >>= \ maybe_decl ->
+ -- CHECK WHETHER WE HAVE IT ALREADY
+ if maybeToBool (lookupFM export_env_map load_mod)
+ then
+ returnRn ifaces -- Already in the cache; don't re-read it
+ else
+
+ -- READ THE MODULE IN
+ findAndReadIface doc_str load_mod `thenRn` \ read_result ->
+ case read_result of {
+ -- Check for not found
+ Nothing -> -- Not found, so add an empty export env to the Ifaces map
+ -- so that we don't look again
+ let
+ new_export_env_map = addToFM export_env_map load_mod ([],[])
+ new_ifaces = Ifaces this_mod mod_vers_map
+ new_export_env_map
+ vers_map decls_map inst_map inst_mods
+ in
+ setIfacesRn new_ifaces `thenRn_`
+ failWithRn new_ifaces (noIfaceErr load_mod) ;
+
+ -- Found and parsed!
+ Just (ParsedIface _ mod_vers usages exports rd_inst_mods fixs decls insts) ->
+
+ -- LOAD IT INTO Ifaces
+ mapRn loadExport exports `thenRn` \ avails ->
+ foldlRn (loadDecl load_mod) (decls_map,vers_map) decls `thenRn` \ (new_decls_map, new_vers_map) ->
+ foldlRn (loadInstDecl load_mod) inst_map insts `thenRn` \ new_insts_map ->
let
- return_maybe_decl = return maybe_decl
- return_failed msg = return (CachingFail msg)
+ export_env = (avails, fixs)
+
+ -- Exclude this module from the "special-inst" modules
+ new_inst_mods = inst_mods `unionLists` (filter (/= this_mod) rd_inst_mods)
+
+ new_ifaces = Ifaces this_mod
+ (addToFM mod_vers_map load_mod mod_vers)
+ (addToFM export_env_map load_mod export_env)
+ new_vers_map
+ new_decls_map
+ new_insts_map
+ new_inst_mods
in
- case maybe_decl of
- 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)
- RnUnbound _ -> panic "cachedDeclByType:" -- (ppr PprDebug rn)
-
- RnSyn _ -> return_maybe_decl
- RnData _ _ _ -> return_maybe_decl
- RnImplicitTyCon _ -> if is_tycon_decl if_decl
- then return_maybe_decl
- else return_failed (badIfaceLookupErr "type constructor" rn if_decl)
-
- RnClass _ _ -> return_maybe_decl
- RnImplicitClass _ -> if is_class_decl if_decl
- then return_maybe_decl
- else return_failed (badIfaceLookupErr "class" rn if_decl)
-
- RnName _ -> return_maybe_decl
- RnConstr _ _ -> return_maybe_decl
- RnField _ _ -> return_maybe_decl
- RnClassOp _ _ -> return_maybe_decl
- RnImplicit _ -> if is_val_decl if_decl
- then return_maybe_decl
- else return_failed (badIfaceLookupErr "value" rn if_decl)
+ setIfacesRn new_ifaces `thenRn_`
+ returnRn new_ifaces
+ }
+
+loadExport :: ExportItem -> RnMG AvailInfo
+loadExport (mod, occ, occs)
+ = new_name occ `thenRn` \ name ->
+ mapRn new_name occs `thenRn` \ names ->
+ returnRn (Avail name names)
+ where
+ new_name occ = newGlobalName mod occ
+
+loadVersion :: Module -> VersionMap -> (OccName,Version) -> RnMG VersionMap
+loadVersion mod vers_map (occ, version)
+ = newGlobalName mod occ `thenRn` \ name ->
+ returnRn (addToFM vers_map name version)
+
+
+loadDecl :: Module -> (DeclsMap, VersionMap)
+ -> (Version, RdrNameHsDecl)
+ -> RnMG (DeclsMap, VersionMap)
+loadDecl mod (decls_map, vers_map) (version, decl)
+ = getDeclBinders new_implicit_name decl `thenRn` \ avail@(Avail name _) ->
+ returnRn (addListToFM decls_map
+ [(name,(avail,decl)) | name <- availNames avail],
+ addToFM vers_map name version
+ )
where
- is_tycon_decl (TypeSig _ _ _) = True
- is_tycon_decl (NewTypeSig _ _ _ _) = True
- is_tycon_decl (DataSig _ _ _ _ _) = True
- is_tycon_decl _ = False
-
- is_class_decl (ClassSig _ _ _ _) = True
- is_class_decl _ = False
-
- is_val_decl (ValSig _ _ _) = True
- is_val_decl (DataSig _ _ _ _ _) = True -- may be a constr or field
- is_val_decl (NewTypeSig _ _ _ _) = True -- may be a constr
- is_val_decl (ClassSig _ _ _ _) = True -- may be a method
- is_val_decl _ = False
+ new_implicit_name rdr_name loc = newGlobalName mod (rdrNameOcc rdr_name)
+
+loadInstDecl :: Module -> Bag IfaceInst -> RdrNameInstDecl -> RnMG (Bag IfaceInst)
+loadInstDecl mod_name insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
+ = initRnMS emptyRnEnv mod_name InterfaceMode $
+
+ -- Find out what type constructors and classes are mentioned in the
+ -- instance declaration. We have to be a bit clever.
+ --
+ -- We want to rename the type so that we can find what
+ -- (free) type constructors are inside it. But we must *not* thereby
+ -- put new occurrences into the global pool because otherwise we'll force
+ -- them all to be loaded. We kill two birds with ones stone by renaming
+ -- with a fresh occurrence pool.
+ findOccurrencesRn (rnHsType inst_ty) `thenRn` \ ty_names ->
+
+ returnRn ((ty_names, mod_name, decl) `consBag` insts)
\end{code}
-\begin{code}
-readIface :: FilePath -> Module -> FAST_STRING -> IO (MaybeErr ParsedIface Error)
-readIface file modname item
- = --hPutStr stderr (" reading "++file++" ("++ _UNPK_ item ++")") >>
- TRY_IO (readFile file) >>= \ read_result ->
+%********************************************************
+%* *
+\subsection{Loading usage information}
+%* *
+%********************************************************
+
+\begin{code}
+checkUpToDate :: Module -> RnMG Bool -- True <=> no need to recompile
+checkUpToDate mod_name
+ = findAndReadIface doc_str mod_name `thenRn` \ read_result ->
case read_result of
- Left err -> return (Failed (cannaeReadErr file err))
- Right contents -> --hPutStr stderr ".." >>
- let parsed = parseIface contents in
- --hPutStr stderr "..\n" >>
- return (
- case parsed of
- Failed _ -> parsed
- Succeeded p -> Succeeded (init_merge modname p)
- )
+ Nothing -> -- Old interface file not found, so we'd better bale out
+ traceRn (ppSep [ppStr "Didnt find old iface", pprModule PprDebug mod_name]) `thenRn_`
+ returnRn False
+
+ Just (ParsedIface _ _ usages _ _ _ _ _)
+ -> -- Found it, so now check it
+ checkModUsage usages
where
- init_merge this (ParsedIface mod _ v sv us vs exps insts fixes tdefs vdefs idefs prags)
- = ParsedIface mod (False, unitBag this) v sv us vs exps insts fixes tdefs vdefs idefs prags
-\end{code}
+ -- Only look in current directory, with suffix .hi
+ doc_str = ppSep [ppStr "Need usage info from", pprModule PprDebug mod_name]
-\begin{code}
-rnIfaces :: IfaceCache -- iface cache (mutvar)
- -> [Module] -- directly imported modules
- -> UniqSupply
- -> RnEnv -- defined (in the source) name env
- -> RnEnv -- mentioned (in the source) name env
- -> RenamedHsModule -- module to extend with iface decls
- -> [RnName] -- imported names required (really the
- -- same info as in mentioned name env)
- -- Also, all the things we may look up
- -- later by key (Unique).
- -> IO (RenamedHsModule, -- extended module
- RnEnv, -- final env (for renaming derivings)
- ImplicitEnv, -- implicit names used (for usage info)
- (UsagesMap,VersionsMap,[Module]), -- usage info
- (Bag Error, Bag Warning))
-
-rnIfaces iface_cache imp_mods us
- def_env@((dqual, dunqual, dtc_qual, dtc_unqual), dstack)
- occ_env@((qual, unqual, tc_qual, tc_unqual), stack)
- rn_module@(HsModule modname iface_version exports imports fixities
- typedecls typesigs classdecls instdecls instsigs
- defdecls binds sigs src_loc)
- todo
- = {-
- pprTrace "rnIfaces:going after:" (ppCat (map (ppr PprDebug) todo)) $
- pprTrace "rnIfaces:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
- pprTrace "rnIfaces:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
- pprTrace "rnIfaces:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
- pprTrace "rnIfaces:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
-
- pprTrace "rnIfaces:dqual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dqual]) $
- pprTrace "rnIfaces:dunqual:" (ppCat (map ppPStr (keysFM dunqual))) $
- pprTrace "rnIfaces:dtc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM dtc_qual]) $
- pprTrace "rnIfaces:dtc_unqual:"(ppCat (map ppPStr (keysFM dtc_unqual))) $
- -}
-
- -- do transitive closure to bring in all needed names/defns and insts:
-
- decls_and_insts todo def_env occ_env empty_return us
- >>= \ (((if_typedecls, if_classdecls, if_instdecls, if_sigs),
- if_implicits,
- if_errs_warns),
- if_final_env) ->
-
- -- finalize what we want to say we learned about the
- -- things we used
- finalIfaceInfo iface_cache modname if_final_env if_instdecls {-all_imports_used imp_mods-} >>=
- \ usage_stuff@(usage_info, version_info, instance_mods) ->
-
- return (HsModule modname iface_version exports imports fixities
- (typedecls ++ if_typedecls)
- typesigs
- (classdecls ++ if_classdecls)
- (instdecls ++ if_instdecls)
- instsigs defdecls binds
- (sigs ++ if_sigs)
- src_loc,
- if_final_env,
- if_implicits,
- usage_stuff,
- if_errs_warns)
- where
- decls_and_insts todo def_env occ_env to_return us
- = let
- (us1,us2) = splitUniqSupply us
- in
- do_decls todo -- initial batch of names to process
- (def_env, occ_env, us1) -- init stuff down
- to_return -- acc results
- >>= \ (decls_return,
- decls_def_env,
- decls_occ_env) ->
-
- cacheInstModules iface_cache imp_mods >>= \ errs ->
-
- do_insts decls_def_env decls_occ_env emptyRnEnv emptyFM
- (add_errs errs decls_return) us2
-
- --------
- do_insts def_env occ_env prev_env done_insts to_return us
- | size_tc_env occ_env == size_tc_env prev_env
- = return (to_return, occ_env)
-
- | otherwise
- = rnIfaceInstStuff iface_cache modname us1 occ_env done_insts to_return
- >>= \ (insts_return,
- new_insts,
- insts_occ_env,
- new_unknowns) ->
-
- do_decls new_unknowns -- new batch of names to process
- (def_env, insts_occ_env, us2) -- init stuff down
- insts_return -- acc results
- >>= \ (decls_return,
- decls_def_env,
- decls_occ_env) ->
-
- do_insts decls_def_env decls_occ_env occ_env new_insts decls_return us3
- where
- (us1,us') = splitUniqSupply us
- (us2,us3) = splitUniqSupply us'
-
- size_tc_env ((_, _, qual, unqual), _)
- = sizeFM qual + sizeFM unqual
-
-
- do_decls :: [RnName] -- Names we're looking for; we keep adding/deleting
- -- from this list; we're done when empty (nothing
- -- more needs to be looked for)
- -> Go_Down -- see defn below
- -> To_Return -- accumulated result
- -> IO (To_Return,
- RnEnv, -- extended decl env
- RnEnv) -- extended occ env
-
- do_decls to_find@[] down to_return
- = return (to_return, defenv down, occenv down)
-
- do_decls to_find@(n:ns) down to_return
- = case (lookup_defd down n) of
- Just _ -> -- previous processing must've found the stuff for this name;
- -- continue with the rest:
- -- pprTrace "do_decls:done:" (ppr PprDebug n) $
- do_decls ns down to_return
-
- Nothing
- | moduleOf (origName "do_decls" n) == modname ->
- -- avoid looking in interface for the module being compiled
- --pprTrace "do_decls:this module error:" (ppr PprDebug n) $
- do_decls ns down (add_warn (thisModImplicitWarn modname n) to_return)
-
- | otherwise ->
- -- OK, see what the cache has for us...
-
- cachedDeclByType iface_cache n >>= \ maybe_ans ->
- case maybe_ans of
- 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)
-
- CachingHit iface_decl -> -- something needing renaming!
- let
- (us1, us2) = splitUniqSupply (uniqsupply down)
- in
- case (initRn False{-iface-} modname (occenv down) us1 (
- setExtraRn emptyUFM{-no fixities-} $
- rnIfaceDecl iface_decl)) of {
- ((if_decl, if_defd, if_implicits), if_errs, if_warns) ->
- let
- new_unknowns = eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits)
- in
- {-
- pprTrace "do_decls:renamed:" (ppAboves [ppr PprDebug n
- , ppCat [ppStr "new unknowns:", interpp'SP PprDebug new_unknowns]
- , ppCat [ppStr "defd vals:", interpp'SP PprDebug [n | (_,n) <- fst if_defd] ]
- , ppCat [ppStr "defd tcs:", interpp'SP PprDebug [n | (_,n) <- snd if_defd] ]
- ]) $
- -}
- do_decls (new_unknowns ++ ns)
- (add_occs if_defd if_implicits $
- new_uniqsupply us2 down)
- (add_decl if_decl $
- add_implicits if_implicits $
- add_errs if_errs $
- add_warns if_warns to_return)
- }
-
------------
-type Go_Down = (RnEnv, -- stuff we already have defns for;
- -- to check quickly if we've already
- -- found something for the name under consideration,
- -- due to previous processing.
- -- It starts off just w/ the defns for
- -- the things in this module.
- RnEnv, -- occurrence env; this gets added to as
- -- we process new iface decls. It includes
- -- entries for *all* occurrences, including those
- -- for which we have definitions.
- UniqSupply -- the obvious
- )
-
-lookup_defd (def_env, _, _) n
- = (if isRnTyConOrClass n then lookupTcRnEnv else lookupRnEnv) def_env
- (case (origName "lookup_defd" n) of { OrigName m s -> Qual m s })
- -- this is hack because we are reusing the RnEnv technology
-
-defenv (def_env, _, _) = def_env
-occenv (_, occ_env, _) = occ_env
-uniqsupply (_, _, us) = us
-
-new_uniqsupply us (def_env, occ_env, _) = (def_env, occ_env, us)
-
-add_occs (val_defds, tc_defds) (val_imps, tc_imps) (def_env, occ_env, us)
- = case (extendGlobalRnEnv def_env val_defds tc_defds) of { (new_def_env, def_dups) ->
- --(if isEmptyBag def_dups then \x->x else pprTrace "add_occs:" (ppCat [ppr PprDebug n | (n,_,_) <- bagToList def_dups])) $
--- ASSERT(isEmptyBag def_dups)
- let
- de_orig imps = [ (Qual m n, v) | (OrigName m n, v) <- fmToList imps ]
- -- again, this hackery because we are reusing the RnEnv technology
+checkModUsage [] = returnRn True -- Yes! Everything is up to date!
- val_occs = val_defds ++ de_orig val_imps
- tc_occs = tc_defds ++ de_orig tc_imps
+checkModUsage ((mod, old_mod_vers, old_local_vers) : rest)
+ = loadInterface doc_str mod `thenRn` \ ifaces ->
+ let
+ Ifaces _ mod_vers_map _ new_vers_map _ _ _ = ifaces
+ maybe_new_mod_vers = lookupFM mod_vers_map mod
+ Just new_mod_vers = maybe_new_mod_vers
in
- case (extendGlobalRnEnv occ_env val_occs tc_occs) of { (new_occ_env, occ_dups) ->
+ -- If we can't find a version number for the old module then
+ -- bale out saying things aren't up to date
+ if not (maybeToBool maybe_new_mod_vers) then
+ returnRn False
+ else
+
+ -- If the module version hasn't changed, just move on
+ if new_mod_vers == old_mod_vers then
+ traceRn (ppSep [ppStr "Module version unchanged:", pprModule PprDebug mod]) `thenRn_`
+ checkModUsage rest
+ else
+ traceRn (ppSep [ppStr "Module version has changed:", pprModule PprDebug mod]) `thenRn_`
--- ASSERT(isEmptyBag occ_dups)
--- False because we may get a dup on the name we just shoved in
+ -- New module version, so check entities inside
+ checkEntityUsage mod new_vers_map old_local_vers `thenRn` \ up_to_date ->
+ if up_to_date then
+ traceRn (ppStr "...but the bits I use havn't.") `thenRn_`
+ checkModUsage rest -- This one's ok, so check the rest
+ else
+ returnRn False -- This one failed, so just bail out now
+ where
+ doc_str = ppSep [ppStr "need version info for", pprModule PprDebug mod]
- (new_def_env, new_occ_env, us) }}
-----------------
-type To_Return = (([RenamedTyDecl], [RenamedClassDecl], [RenamedInstDecl], [RenamedSig]),
- ImplicitEnv, -- new names used implicitly
- (Bag Error, Bag Warning)
- )
-
-empty_return :: To_Return
-empty_return = (([],[],[],[]), emptyImplicitEnv, (emptyBag,emptyBag))
-
-add_decl decl ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
- = case decl of
- AddedTy t -> ((t:tydecls, classdecls, instdecls, sigs), implicit, msgs)
- AddedClass c -> ((tydecls, c:classdecls, instdecls, sigs), implicit, msgs)
- AddedSig s -> ((tydecls, classdecls, instdecls, s:sigs), implicit, msgs)
-
-add_insts is ((tydecls, classdecls, instdecls, sigs), implicit, msgs)
- = ((tydecls, classdecls, is ++ instdecls, sigs), implicit, msgs)
-
-add_implicits (val_imps, tc_imps) (decls, (val_fm, tc_fm), msgs)
- = (decls, (val_fm `plusFM` val_imps, tc_fm `plusFM` tc_imps), msgs)
-
-add_err err (decls,implicit,(errs,warns)) = (decls,implicit,(errs `snocBag` err,warns))
-add_errs ers (decls,implicit,(errs,warns)) = (decls,implicit,(errs `unionBags` ers,warns))
-add_warn wrn (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `snocBag` wrn))
-add_warns ws (decls,implicit,(errs,warns)) = (decls,implicit,(errs, warns `unionBags` ws))
+checkEntityUsage mod new_vers_map []
+ = returnRn True -- Yes! All up to date!
+
+checkEntityUsage mod new_vers_map ((occ_name,old_vers) : rest)
+ = newGlobalName mod occ_name `thenRn` \ name ->
+ case lookupFM new_vers_map name of
+
+ Nothing -> -- We used it before, but it ain't there now
+ traceRn (ppSep [ppStr "...and this no longer exported:", ppr PprDebug name]) `thenRn_`
+ returnRn False
+
+ Just new_vers -> -- It's there, but is it up to date?
+ if new_vers == old_vers then
+ -- Up to date, so check the rest
+ checkEntityUsage mod new_vers_map rest
+ else
+ traceRn (ppSep [ppStr "...and this is out of date:", ppr PprDebug name]) `thenRn_`
+ returnRn False -- Out of date, so bale out
\end{code}
-\begin{code}
-data AddedDecl -- purely local
- = AddedTy RenamedTyDecl
- | AddedClass RenamedClassDecl
- | AddedSig RenamedSig
-
-rnIfaceDecl :: RdrIfaceDecl
- -> RnM_Fixes REAL_WORLD
- (AddedDecl, -- the resulting decl to add to the pot
- ([(RdrName,RnName)], [(RdrName,RnName)]),
- -- new val/tycon-class names that have
- -- *been defined* while processing this decl
- ImplicitEnv -- new implicit val/tycon-class names that we
- -- stumbled into
- )
-
-rnIfaceDecl (TypeSig tc _ decl)
- = rnTyDecl decl `thenRn` \ rn_decl ->
- lookupTyCon tc `thenRn` \ rn_tc ->
- getImplicitUpRn `thenRn` \ mentioned ->
- let
- defds = ([], [(tc, rn_tc)])
- implicits = mentioned `sub` defds
- in
- returnRn (AddedTy rn_decl, defds, implicits)
-rnIfaceDecl (NewTypeSig tc dc _ decl)
- = rnTyDecl decl `thenRn` \ rn_decl ->
- lookupTyCon tc `thenRn` \ rn_tc ->
- lookupValue dc `thenRn` \ rn_dc ->
- getImplicitUpRn `thenRn` \ mentioned ->
- let
- defds = ([(dc, rn_dc)], [(tc, rn_tc)])
- implicits = mentioned `sub` defds
- in
- returnRn (AddedTy rn_decl, defds, implicits)
-
-rnIfaceDecl (DataSig tc dcs fcs _ decl)
- = rnTyDecl decl `thenRn` \ rn_decl ->
- lookupTyCon tc `thenRn` \ rn_tc ->
- mapRn lookupValue dcs `thenRn` \ rn_dcs ->
- mapRn lookupValue fcs `thenRn` \ rn_fcs ->
- getImplicitUpRn `thenRn` \ mentioned ->
- let
- defds = (zip dcs rn_dcs ++ zip fcs rn_fcs , [(tc, rn_tc)])
- implicits = mentioned `sub` defds
- in
- returnRn (AddedTy rn_decl, defds, implicits)
+%*********************************************************
+%* *
+\subsection{Getting in a declaration}
+%* *
+%*********************************************************
-rnIfaceDecl (ClassSig clas ops _ decl)
- = rnClassDecl decl `thenRn` \ rn_decl ->
- lookupClass clas `thenRn` \ rn_clas ->
- mapRn (lookupClassOp rn_clas) ops `thenRn` \ rn_ops ->
- getImplicitUpRn `thenRn` \ mentioned ->
- let
- defds = (ops `zip` rn_ops, [(clas, rn_clas)])
- implicits = mentioned `sub` defds
- in
- returnRn (AddedClass rn_decl, defds, implicits)
-
-rnIfaceDecl (ValSig f src_loc ty)
- -- should rename_sig in RnBinds be used here? ToDo
- = lookupValue f `thenRn` \ rn_f ->
- -- pprTrace "rnIfaceDecl:ValSig:" (ppr PprDebug ty) $
- rnPolyType nullTyVarNamesEnv ty `thenRn` \ rn_ty ->
- getImplicitUpRn `thenRn` \ mentioned ->
- let
- defds = ([(f, rn_f)], [])
- implicits = mentioned `sub` defds
- in
- returnRn (AddedSig (Sig rn_f rn_ty noGenPragmas src_loc), defds, implicits)
+\begin{code}
+getDecl :: Name -> RnMG (AvailInfo, RdrNameHsDecl)
+getDecl name
+ = traceRn doc_str `thenRn_`
+ loadInterface doc_str mod `thenRn` \ (Ifaces _ _ _ _ decls_map _ _) ->
+ case lookupFM decls_map name of
-----
-sub :: ImplicitEnv -> ([(RdrName,RnName)], [(RdrName,RnName)]) -> ImplicitEnv
+ Just avail_w_decl -> returnRn avail_w_decl
-sub (val_ment, tc_ment) (val_defds, tc_defds)
- = (delListFromFM val_ment (map (qualToOrigName . fst) val_defds),
- delListFromFM tc_ment (map (qualToOrigName . fst) tc_defds))
+ Nothing -> -- Can happen legitimately for "Optional" occurrences
+ returnRn (NotAvailable, ValD EmptyBinds)
+ where
+ (mod,_) = modAndOcc name
+ doc_str = ppSep [ppStr "Need decl for", ppr PprDebug name]
\end{code}
-% ------------------------------
+@getWiredInDecl@ maps a wired-in @Name@ to what it makes available.
+It behaves exactly as if the wired in decl were actually in an interface file.
+Specifically,
+ * if the wired-in name is a data type constructor or a data constructor,
+ it brings in the type constructor and all the data constructors; and
+ marks as "occurrences" any free vars of the data con.
-@cacheInstModules@: cache instance modules specified in imports
+ * similarly for synonum type constructor
-\begin{code}
-cacheInstModules :: IfaceCache -> [Module] -> IO (Bag Error)
+ * if the wired-in name is another wired-in Id, it marks as "occurrences"
+ the free vars of the Id's type.
-cacheInstModules iface_cache@(IfaceCache _ _ iface_var) imp_mods
- = readVar iface_var ST_THEN \ (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 iface_cache False SLIT("instance_modules")) imp_imods) >>= \ err_or_ifaces ->
+ * it loads the interface file for the wired-in thing for the
+ sole purpose of making sure that its instance declarations are available
- -- Sanity Check:
- -- Assert that instance modules given by direct imports contains
- -- instance modules extracted from all visited modules
+All this is necessary so that we know all types that are "in play", so
+that we know just what instances to bring into scope.
+
+\begin{code}
+getWiredInDecl :: Name -> RnMG AvailInfo
+getWiredInDecl name
+ = -- Force in the home module in case it has instance decls for
+ -- the thing we are interested in
+ (if mod == gHC__ then
+ returnRn () -- Mini hack; GHC is guaranteed not to have
+ -- instance decls, so it's a waste of time
+ -- to read it
+ else
+ loadInterface doc_str mod `thenRn_`
+ returnRn ()
+ ) `thenRn_`
+
+ if (maybeToBool maybe_wired_in_tycon) then
+ get_wired_tycon the_tycon
+ else -- Must be a wired-in-Id
+ if (isDataCon the_id) then -- ... a wired-in data constructor
+ get_wired_tycon (dataConTyCon the_id)
+ else -- ... a wired-in non data-constructor
+ get_wired_id the_id
+ where
+ doc_str = ppSep [ppStr "Need home module for wired in thing", ppr PprDebug name]
+ (mod,_) = modAndOcc name
+ maybe_wired_in_tycon = maybeWiredInTyConName name
+ maybe_wired_in_id = maybeWiredInIdName name
+ Just the_tycon = maybe_wired_in_tycon
+ Just the_id = maybe_wired_in_id
+
+get_wired_id id
+ = addImplicitOccsRn (nameSetToList id_mentioned) `thenRn_`
+ returnRn (Avail (getName id) [])
+ where
+ id_mentioned = namesOfType (idType id)
- readVar iface_var ST_THEN \ (all_iface_fm, _, _) ->
- let
- all_ifaces = eltsFM all_iface_fm
- (all_imods, _) = removeDups cmpPString (bagToList (unionManyBags (map get_ims (all_ifaces))))
- in
- ASSERT(sortLt (<) imp_imods == sortLt (<) all_imods)
+get_wired_tycon tycon
+ | isSynTyCon tycon
+ = addImplicitOccsRn (nameSetToList mentioned) `thenRn_`
+ returnRn (Avail (getName tycon) [])
+ where
+ (tyvars,ty) = getSynTyConDefn tycon
+ mentioned = namesOfType ty `minusNameSet` mkNameSet (map getName tyvars)
- return (bag_errs err_or_ifaces)
+get_wired_tycon tycon
+ | otherwise -- data or newtype
+ = addImplicitOccsRn (nameSetToList mentioned) `thenRn_`
+ returnRn (Avail (getName tycon) (map getName data_cons))
where
- bag_errs [] = emptyBag
- bag_errs (Failed err :rest) = err `consBag` bag_errs rest
- bag_errs (Succeeded _:rest) = bag_errs rest
+ data_cons = tyConDataCons tycon
+ mentioned = foldr (unionNameSets . namesOfType . idType) emptyNameSet data_cons
\end{code}
-@rnIfaceInstStuff@: Deal with instance declarations from interface files.
+%*********************************************************
+%* *
+\subsection{Getting other stuff}
+%* *
+%*********************************************************
\begin{code}
-type InstanceEnv = FiniteMap (OrigName, OrigName) Int
-
-rnIfaceInstStuff
- :: IfaceCache -- all about ifaces we've read
- -> Module
- -> UniqSupply
- -> RnEnv -- current occ env
- -> InstanceEnv -- instances for these tycon/class pairs done
- -> To_Return
- -> IO (To_Return,
- InstanceEnv, -- extended instance env
- RnEnv, -- final occ env
- [RnName]) -- new unknown names
-
-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_var ST_THEN \ (_, orig_iface_fm, _) ->
- let
- all_ifaces = eltsFM orig_iface_fm
- all_insts = concat (map get_insts all_ifaces)
- interesting_insts = filter want_inst all_insts
+getInterfaceExports :: Module -> RnMG (Avails, [(OccName,Fixity)])
+getInterfaceExports mod
+ = loadInterface doc_str mod `thenRn` \ (Ifaces _ _ export_envs _ _ _ _) ->
+ case lookupFM export_envs mod of
+ Nothing -> -- Not there; it must be that the interface file wasn't found;
+ -- the error will have been reported already.
+ -- (Actually loadInterface should put the empty export env in there
+ -- anyway, but this does no harm.)
+ returnRn ([],[])
+
+ Just stuff -> returnRn stuff
+ where
+ doc_str = ppSep [pprModule PprDebug mod, ppStr "is directly imported"]
- -- Sanity Check:
- -- Assert that there are no more instances for the done instances
- claim_done = filter is_done_inst all_insts
- claim_done_env = foldr add_done_inst emptyFM claim_done
+getImportedInstDecls :: RnMG [IfaceInst]
+getImportedInstDecls
+ = -- First load any special-instance modules that aren't aready loaded
+ getSpecialInstModules `thenRn` \ inst_mods ->
+ mapRn load_it inst_mods `thenRn_`
- has_val fm (k,i) = case lookupFM fm k of { Nothing -> False; Just v -> i == v }
+ -- Now we're ready to grab the instance declarations
+ getIfacesRn `thenRn` \ ifaces ->
+ let
+ Ifaces _ _ _ _ _ insts _ = ifaces
in
- {-
- pprTrace "all_insts:\n" (ppr_insts (bagToList all_insts)) $
- pprTrace "interesting_insts:\n" (ppr_insts interesting_insts) $
- -}
- ASSERT(sizeFM done_inst_env == sizeFM claim_done_env)
- ASSERT(all (has_val claim_done_env) (fmToList done_inst_env))
-
- case (initRn False{-iface-} modname occ_env us (
- setExtraRn emptyUFM{-no fixities-} $
- mapRn rnIfaceInst interesting_insts `thenRn` \ insts ->
- getImplicitUpRn `thenRn` \ implicits ->
- returnRn (insts, implicits))) of {
- ((if_insts, if_implicits), if_errs, if_warns) ->
-
- return (add_insts if_insts $
- add_implicits if_implicits $
- add_errs if_errs $
- add_warns if_warns to_return,
- foldr add_done_inst done_inst_env interesting_insts,
- add_imp_occs if_implicits occ_env,
- eltsFM (fst if_implicits) ++ eltsFM (snd if_implicits))
- }
+ returnRn (bagToList insts)
where
- 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
- = addToFM_C (+) inst_env (tycon_class clas tycon) 1
-
- is_done_inst (_, InstSig clas tycon _ _)
- = maybeToBool (lookupFM done_inst_env (tycon_class clas tycon))
-
- add_imp_occs (val_imps, tc_imps) occ_env
- = case (extendGlobalRnEnv occ_env (de_orig val_imps) (de_orig tc_imps)) of
- (ext_occ_env, occ_dups) -> ASSERT(isEmptyBag occ_dups)
- ext_occ_env
- where
- 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@(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)]) $
- mentionable tycon && mentionable clas && not (is_done_inst i)
- where
- mentionable nm
- = case lookupTcRnEnv occ_env nm of
- Just _ -> True
- Nothing -> -- maybe it's builtin
- let orig = qualToOrigName nm in
- case (lookupFM builtinTcNamesMap orig) of
- Just _ -> True
- Nothing -> maybeToBool (lookupFM builtinKeysMap orig)
+ load_it mod = loadInterface (doc_str mod) mod
+ doc_str mod = ppSep [pprModule PprDebug mod, ppStr "is a special-instance module"]
+
+getSpecialInstModules :: RnMG [Module]
+getSpecialInstModules
+ = getIfacesRn `thenRn` \ ifaces ->
+ let
+ Ifaces _ _ _ _ _ _ inst_mods = ifaces
+ in
+ returnRn inst_mods
\end{code}
\begin{code}
-rnIfaceInst :: (Module, RdrIfaceInst) -> RnM_Fixes REAL_WORLD RenamedInstDecl
+getImportVersions :: [AvailInfo] -- Imported avails
+ -> RnMG (VersionInfo Name) -- Version info for these names
-rnIfaceInst (imod, InstSig _ _ _ inst_decl) = rnInstDecl (inst_decl imod)
+getImportVersions imported_avails
+ = getIfacesRn `thenRn` \ ifaces ->
+ let
+ Ifaces _ mod_versions_map _ version_map _ _ _ = ifaces
+
+ -- import_versions is harder: we have to group together all the things imported
+ -- from a particular module. We do this with yet another finite map
+
+ mv_map :: FiniteMap Module [LocalVersion Name]
+ mv_map = foldl add_mv emptyFM imported_avails
+ add_mv mv_map (Avail name _)
+ | isWiredInName name = mv_map -- Don't record versions for wired-in names
+ | otherwise = case lookupFM mv_map mod of
+ Just versions -> addToFM mv_map mod ((name,version):versions)
+ Nothing -> addToFM mv_map mod [(name,version)]
+ where
+ (mod,_) = modAndOcc name
+ version = case lookupFM version_map name of
+ Just v -> v
+ Nothing -> pprPanic "getVersionInfo:" (ppr PprDebug name)
+
+ import_versions = [ (mod, expectJust "import_versions" (lookupFM mod_versions_map mod), local_versions)
+ | (mod, local_versions) <- fmToList mv_map
+ ]
+
+ -- Question: should we filter the builtins out of import_versions?
+ in
+ returnRn import_versions
\end{code}
+%*********************************************************
+%* *
+\subsection{Getting binders out of a declaration}
+%* *
+%*********************************************************
+
+@getDeclBinders@ returns the names for a @RdrNameHsDecl@.
+It's used for both source code (from @availsFromDecl@) and interface files
+(from @loadDecl@).
+
+It doesn't deal with source-code specific things: ValD, DefD. They
+are handled by the sourc-code specific stuff in RnNames.
+
\begin{code}
-type BigMaps = (FiniteMap Module Version, -- module-version map
- FiniteMap (FAST_STRING,Module) Version) -- ordinary version map
-
-finalIfaceInfo ::
- IfaceCache -- iface cache
- -> Module -- this module's name
- -> RnEnv
- -> [RenamedInstDecl]
--- -> [RnName] -- all imported names required
--- -> [Module] -- directly imported modules
- -> IO (UsagesMap,
- VersionsMap, -- info about version numbers
- [Module]) -- special instance modules
-
-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_var ST_THEN \ (_, orig_iface_fm, _) ->
- let
- all_ifaces = eltsFM orig_iface_fm
- -- all the interfaces we have looked at
+getDeclBinders :: (RdrName -> SrcLoc -> RnMG Name) -- New-name function
+ -> RdrNameHsDecl
+ -> RnMG AvailInfo
- big_maps
- -- combine all the version maps we have seen into maps to
- -- (a) lookup a module-version number, lookup an entity's
- -- individual version number
- = foldr mk_map (emptyFM,emptyFM) all_ifaces
+getDeclBinders new_name (TyD (TyData _ tycon _ condecls _ _ src_loc))
+ = new_name tycon src_loc `thenRn` \ tycon_name ->
+ getConFieldNames new_name condecls `thenRn` \ sub_names ->
+ returnRn (Avail tycon_name sub_names)
- val_stuff@(val_usages, val_versions)
- = foldFM (process_item big_maps) (emptyFM, emptyFM){-init-} qual
+getDeclBinders new_name (TyD (TyNew _ tycon _ (NewConDecl con _ con_loc) _ _ src_loc))
+ = new_name tycon src_loc `thenRn` \ tycon_name ->
+ new_name con src_loc `thenRn` \ con_name ->
+ returnRn (Avail tycon_name [con_name])
- (all_usages, all_versions)
- = foldFM (process_item big_maps) val_stuff{-keep going-} tc_qual
- in
- return (all_usages, all_versions, [])
+getDeclBinders new_name (TyD (TySynonym tycon _ _ src_loc))
+ = new_name tycon src_loc `thenRn` \ tycon_name ->
+ returnRn (Avail tycon_name [])
+
+getDeclBinders new_name (ClD (ClassDecl _ cname _ sigs _ _ src_loc))
+ = new_name cname src_loc `thenRn` \ class_name ->
+ mapRn (getClassOpNames new_name) sigs `thenRn` \ sub_names ->
+ returnRn (Avail class_name sub_names)
+
+getDeclBinders new_name (SigD (IfaceSig var ty prags src_loc))
+ = new_name var src_loc `thenRn` \ var_name ->
+ returnRn (Avail var_name [])
+
+getDeclBinders new_name (DefD _) = returnRn NotAvailable
+getDeclBinders new_name (InstD _) = returnRn NotAvailable
+
+----------------
+getConFieldNames new_name (ConDecl con _ src_loc : rest)
+ = new_name con src_loc `thenRn` \ n ->
+ getConFieldNames new_name rest `thenRn` \ ns ->
+ returnRn (n:ns)
+
+getConFieldNames new_name (NewConDecl con _ src_loc : rest)
+ = new_name con src_loc `thenRn` \ n ->
+ getConFieldNames new_name rest `thenRn` \ ns ->
+ returnRn (n:ns)
+
+getConFieldNames new_name (ConOpDecl _ con _ src_loc : rest)
+ = new_name con src_loc `thenRn` \ n ->
+ getConFieldNames new_name rest `thenRn` \ ns ->
+ returnRn (n:ns)
+
+getConFieldNames new_name (RecConDecl con fielddecls src_loc : rest)
+ = mapRn (\n -> new_name n src_loc) (con:fields) `thenRn` \ cfs ->
+ getConFieldNames new_name rest `thenRn` \ ns ->
+ returnRn (cfs ++ ns)
where
- mk_map (ParsedIface m _ mv _ _ vers _ _ _ _ _ _ _) (mv_map, ver_map)
- = (addToFM mv_map m mv, -- add this module
- addListToFM ver_map [ ((n,m), v) | (n,v) <- fmToList vers ])
-
- -----------------------
- process_item :: BigMaps
- -> (FAST_STRING,Module) -> RnName -- RnEnv (QualNames) components
- -> (UsagesMap, VersionsMap) -- input
- -> (UsagesMap, VersionsMap) -- output
-
- process_item (big_mv_map, big_version_map) key@(n,m) rn as_before@(usages, versions)
- | irrelevant rn
- = as_before
- | m == modname -- this module => add to "versions"
- = (usages, addToFM versions n 1{-stub-})
- | otherwise -- from another module => add to "usages"
- = case (add_to_usages usages key) of
- Nothing -> as_before
- Just new_usages -> (new_usages, versions)
- where
- add_to_usages usages key@(n,m)
- = 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.
- irrelevant (RnClassOp _ _) = True
- irrelevant (RnImplicit n) = isLexCon (nameOf (origName "irrelevant" n)) -- really a RnConstr
- irrelevant _ = False
+ fields = concat (map fst fielddecls)
+
+getConFieldNames new_name [] = returnRn []
+getClassOpNames new_name (ClassOpSig op _ _ src_loc) = new_name op src_loc
\end{code}
+%*********************************************************
+%* *
+\subsection{Reading an interface file}
+%* *
+%*********************************************************
+
\begin{code}
-thisModImplicitWarn mod n sty
- = ppBesides [ppPStr SLIT("An interface has an implicit need of "), ppr sty n, ppPStr SLIT("; assuming this module will provide it.")]
+findAndReadIface :: Pretty -> Module -> RnMG (Maybe ParsedIface)
+ -- Nothing <=> file not found, or unreadable, or illegible
+ -- Just x <=> successfully found and parsed
+findAndReadIface doc_str mod
+ = traceRn trace_msg `thenRn_`
+ getSearchPathRn `thenRn` \ dirs ->
+ try dirs dirs
+ where
+ trace_msg = ppHang (ppBesides [ppStr "Reading interface for ",
+ pprModule PprDebug mod, ppSemi])
+ 4 (ppBesides [ppStr "reason: ", doc_str])
+
+ try all_dirs [] = traceRn (ppStr "...failed") `thenRn_`
+ returnRn Nothing
+
+ try all_dirs (dir:dirs)
+ = readIface file_path `thenRn` \ read_result ->
+ case read_result of
+ Nothing -> try all_dirs dirs
+ Just iface -> traceRn (ppStr "...done") `thenRn_`
+ returnRn (Just iface)
+ where
+ file_path = dir ++ "/" ++ moduleString mod ++ ".hi"
+\end{code}
-noIfaceErr mod sty
- = ppCat [ppPStr SLIT("Could not find interface for:"), ppPStr mod]
+@readIface@ trys just one file.
-noOrigIfaceErr mod sty
- = ppCat [ppPStr SLIT("Could not find original interface for:"), ppPStr mod]
+\begin{code}
+readIface :: String -> RnMG (Maybe ParsedIface)
+ -- Nothing <=> file not found, or unreadable, or illegible
+ -- Just x <=> successfully found and parsed
+readIface file_path
+ = ioToRnMG (readFile file_path) `thenRn` \ read_result ->
+ case read_result of
+ Right contents -> case parseIface contents of
+ Failed err -> failWithRn Nothing err
+ Succeeded iface -> returnRn (Just iface)
-noDeclInIfaceErr mod str sty
- = ppBesides [ppPStr SLIT("Could not find interface declaration of: "),
- ppPStr mod, ppStr ".", ppPStr str]
+ Left (NoSuchThing _) -> returnRn Nothing
-cannaeReadErr file err sty
- = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)]
+ Left err -> failWithRn Nothing
+ (cannaeReadFile file_path err)
+
+\end{code}
+
+mkSearchPath takes a string consisting of a colon-separated list of directories, and turns it into
+a list of directories. For example:
+
+ mkSearchPath "foo:.:baz" = ["foo", ".", "baz"]
+
+\begin{code}
+mkSearchPath :: Maybe String -> SearchPath
+mkSearchPath Nothing = ["."]
+mkSearchPath (Just s)
+ = go s
+ where
+ go "" = []
+ go s = first : go (drop 1 rest)
+ where
+ (first,rest) = span (/= ':') s
+\end{code}
-ifaceLookupWiredErr msg n sty
- = ppBesides [ppPStr SLIT("Why am I looking up a wired-in "), ppStr msg, ppChar ':', ppr sty n]
+%*********************************************************
+%* *
+\subsection{Errors}
+%* *
+%*********************************************************
-badIfaceLookupErr msg name decl sty
- = ppBesides [ppPStr SLIT("Expected a "), ppStr msg, ppStr " declaration, but got this: ???"]
+\begin{code}
+noIfaceErr mod sty
+ = ppBesides [ppStr "Could not find interface for ", ppQuote (pprModule sty mod)]
+-- , ppStr " in"]) 4 (ppAboves (map ppStr dirs))
-ifaceIoErr io_msg rn sty
- = ppBesides [io_msg sty, ppStr "; looking for: ", ppr sty rn]
+cannaeReadFile file err sty
+ = ppBesides [ppPStr SLIT("Failed in reading file: "), ppStr file, ppStr "; error=", ppStr (show err)]
\end{code}
\begin{code}
interface RnLoop where
-import RdrHsSyn ( RdrNameHsBinds(..), RdrNamePolyType(..) )
-import RnHsSyn ( RnName, RenamedHsBinds(..), RenamedPolyType(..) )
-import RnBinds ( rnBinds, FreeVars(..) )
-import RnMonad ( TyVarNamesEnv(..), RnM_Fixes(..) )
-import RnSource ( rnPolyType )
+import RdrHsSyn ( RdrNameHsBinds(..), RdrNameHsType(..) )
+import RnHsSyn ( RenamedHsBinds(..), RenamedHsType(..) )
+import RnBinds ( rnBinds )
+import RnMonad ( RnMS(..), FreeVars )
+import RnSource ( rnHsType )
import UniqSet ( UniqSet(..) )
+import Name ( Name )
-rnBinds :: RdrNameHsBinds -> RnM_Fixes s (RenamedHsBinds, FreeVars, [RnName])
-rnPolyType :: TyVarNamesEnv
- -> RdrNamePolyType
- -> RnM_Fixes s RenamedPolyType
-type FreeVars = UniqSet RnName
+rnBinds :: RdrNameHsBinds
+ -> (RenamedHsBinds -> RnMS s (result, FreeVars))
+ -> RnMS s (result, FreeVars)
+
+rnHsType :: RdrNameHsType
+ -> RnMS s RenamedHsType
\end{code}
\begin{code}
#include "HsVersions.h"
-module RnMonad (
- SYN_IE(RnMonad), SYN_IE(RnM), SYN_IE(RnM_Fixes), RnDown, SST_R,
- initRn, thenRn, thenRn_, andRn, returnRn,
- mapRn, mapAndUnzipRn, mapAndUnzip3Rn,
-
- addErrRn, addErrIfRn, addWarnRn, addWarnIfRn,
- failButContinueRn, warnAndContinueRn,
- setExtraRn, getExtraRn, getRnEnv,
- getModuleRn, pushSrcLocRn, getSrcLocRn,
- getSourceRn, getOccurrenceUpRn,
- getImplicitUpRn, SYN_IE(ImplicitEnv), emptyImplicitEnv,
- rnGetUnique, rnGetUniques,
-
- newLocalNames,
- lookupValue, lookupConstr, lookupField, lookupClassOp,
- lookupTyCon, lookupClass, lookupTyConOrClass,
- extendSS2, extendSS,
-
- SYN_IE(TyVarNamesEnv), mkTyVarNamesEnv, domTyVarNamesEnv,
- lookupTyVarName, nullTyVarNamesEnv, catTyVarNamesEnvs,
-
- fixIO
+module RnMonad(
+ RnMonad..,
+ SST_R
) where
IMP_Ubiq(){-uitous-}
-IMPORT_1_3(GHCbase(fixIO))
import SST
+import PreludeGlaST ( SYN_IE(ST), thenST, returnST )
-import HsSyn ( FixityDecl )
-import RnHsSyn ( RnName, mkRnName, mkRnUnbound, mkRnImplicit,
- mkRnImplicitTyCon, mkRnImplicitClass,
- isRnLocal, isRnWired, isRnTyCon, isRnClass,
- isRnTyConOrClass, isRnConstr, isRnField,
- isRnClassOp, RenamedFixityDecl(..) )
-import RnUtils ( SYN_IE(RnEnv), extendLocalRnEnv,
- lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
- qualNameErr, dupNamesErr
- )
-
-import Bag ( Bag, emptyBag, isEmptyBag, snocBag )
-import CmdLineOpts ( opt_WarnNameShadowing )
+import HsSyn
+import RdrHsSyn
import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine,
- SYN_IE(Error), SYN_IE(Warning)
+ pprBagOfErrors, SYN_IE(Error), SYN_IE(Warning)
)
-import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM{-, fmToList ToDo:rm-} )
-import Maybes ( assocMaybe )
-import Name ( SYN_IE(Module), RdrName(..), isQual,
- OrigName(..), Name, mkLocalName, mkImplicitName,
- getOccName, pprNonSym
+import Name ( SYN_IE(Module), Name, OccName, Provenance, SYN_IE(NameSet),
+ modAndOcc, NamedThing(..)
)
-import PrelInfo ( builtinNameMaps, builtinKeysMap, SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
-import PrelMods ( pRELUDE )
---import PprStyle{-ToDo:rm-}
---import Outputable{-ToDo:rm-}
+import CmdLineOpts ( opt_D_show_rn_trace )
+import PrelInfo ( builtinNames )
+import TyCon ( TyCon {- instance NamedThing -} )
+import TysWiredIn ( boolTyCon )
import Pretty
-import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
-import UniqFM ( UniqFM, emptyUFM )
-import UniqSet ( SYN_IE(UniqSet), mkUniqSet, minusUniqSet )
-import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
+import PprStyle ( PprStyle(..) )
+import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
import Unique ( Unique )
+import FiniteMap ( FiniteMap, emptyFM, bagToFM )
+import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
+import UniqSet
import Util
infixr 9 `thenRn`, `thenRn_`
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Somewhat magical interface to other monads}
+%* *
+%************************************************************************
+
\begin{code}
-type RnM s r = RnMonad () s r
-type RnM_Fixes s r = RnMonad (UniqFM RenamedFixityDecl) s r
-
-type RnMonad x s r = RnDown x s -> SST s r
-
-data RnDown x s
- = RnDown
- x
- Module -- Module name
- SrcLoc -- Source location
- (RnMode s) -- Source or Iface
- RnEnv -- Renaming environment
- (MutableVar s UniqSupply) -- Unique supply
- (MutableVar s (Bag Warning, -- Warnings and Errors
- Bag Error))
-
-data RnMode s
- = RnSource (MutableVar s (Bag (RnName, RdrName)))
- -- Renaming source; returning occurences
-
- | RnIface BuiltinNames BuiltinKeys
- (MutableVar s ImplicitEnv)
- -- Renaming interface; creating and returning implicit names
- -- ImplicitEnv: one map for Values and one for TyCons/Classes.
-
-type ImplicitEnv = (FiniteMap OrigName RnName, FiniteMap OrigName RnName)
-emptyImplicitEnv :: ImplicitEnv
-emptyImplicitEnv = (emptyFM, emptyFM)
-
--- With a builtin polymorphic type for runSST the type for
--- initTc should use RnM s r instead of RnM RealWorld r
#if __GLASGOW_HASKELL__ >= 200
-# define REAL_WORLD GHCbuiltins.RealWorld
+# define REAL_WORLD RealWorld
#else
# define REAL_WORLD _RealWorld
#endif
+\end{code}
+
+\begin{code}
+sstToIO :: SST REAL_WORLD r -> IO r
+sstToIO sst
+ = sstToST sst `thenST` \ r ->
+ returnST (Right r)
+
+ioToRnMG :: IO r -> RnMG (Either IOError13 r)
+ioToRnMG io rn_down g_down = stToSST io
+
+traceRn :: Pretty -> RnMG ()
+traceRn msg | opt_D_show_rn_trace = ioToRnMG (hPutStr stderr (ppShow 80 msg) >>
+ hPutStr stderr "\n") `thenRn_`
+ returnRn ()
+ | otherwise = returnRn ()
+\end{code}
-initRn :: Bool -- True => Source; False => Iface
- -> Module
- -> RnEnv
- -> UniqSupply
- -> RnM REAL_WORLD r
- -> (r, Bag Error, Bag Warning)
-initRn source mod env us do_rn
- = runSST (
- newMutVarSST emptyBag `thenSST` \ occ_var ->
- newMutVarSST emptyImplicitEnv `thenSST` \ imp_var ->
- newMutVarSST us `thenSST` \ us_var ->
- newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
- let
- mode = if source then
- RnSource occ_var
- else
- RnIface builtinNameMaps builtinKeysMap imp_var
-
- rn_down = RnDown () mod mkUnknownSrcLoc mode env us_var errs_var
- in
+%************************************************************************
+%* *
+\subsection{Data types}
+%* *
+%************************************************************************
+
+===================================================
+ MONAD TYPES
+===================================================
+
+\begin{code}
+type RnM s d r = RnDown s -> d -> SST s r
+type RnMS s r = RnM s (SDown s) r -- Renaming source
+type RnMG r = RnM REAL_WORLD GDown r -- Getting global names etc
+type MutVar a = MutableVar REAL_WORLD a -- ToDo: there ought to be a standard defn of this
+
+ -- Common part
+data RnDown s = RnDown
+ SrcLoc
+ (MutableVar s RnNameSupply)
+ (MutableVar s (Bag Warning, Bag Error))
+ (MutableVar s [(Name,Necessity)]) -- Occurrences
+
+data Necessity = Compulsory | Optional -- We *must* find definitions for
+ -- compulsory occurrences; we *may* find them
+ -- for optional ones.
+
+ -- For getting global names
+data GDown = GDown
+ SearchPath
+ (MutVar Ifaces)
+
+ -- For renaming source code
+data SDown s = SDown
+ RnEnv
+ Module
+ RnSMode
+
+
+data RnSMode = SourceMode
+ | InterfaceMode
+
+type SearchPath = [String] -- List of directories to seach for interface files
+type FreeVars = NameSet
+\end{code}
+
+===================================================
+ ENVIRONMENTS
+===================================================
+
+\begin{code}
+type RnNameSupply = (UniqSupply, Int, FiniteMap (Module,OccName) Name)
+ -- Ensures that one (m,n) pair gets one unique
+ -- The Int is used to give a number to each instance declaration;
+ -- it's really a separate name supply.
+
+data RnEnv = RnEnv NameEnv FixityEnv
+emptyRnEnv = RnEnv emptyNameEnv emptyFixityEnv
+
+type NameEnv = FiniteMap RdrName Name
+emptyNameEnv = emptyFM
+
+type FixityEnv = FiniteMap RdrName (Fixity, Provenance)
+emptyFixityEnv = emptyFM
+ -- It's possible to have a different fixity for B.op than for op:
+ --
+ -- module A( op ) where module B where
+ -- import qualified B( op ) infixr 2 op
+ -- infixl 9 `op` op = ...
+ -- op a b = a `B.op` b
+
+data ExportEnv = ExportEnv Avails Fixities
+type Avails = [AvailInfo]
+type Fixities = [(OccName, Fixity, Provenance)]
+ -- Can contain duplicates, if one module defines the same fixity,
+ -- or the same type/class/id, more than once. Hence a boring old list.
+ -- This allows us to report duplicates in just one place, namely plusRnEnv.
+
+type ModuleAvails = FiniteMap Module Avails
+
+data AvailInfo = NotAvailable | Avail Name [Name]
+\end{code}
+
+===================================================
+ INTERFACE FILE STUFF
+===================================================
+
+\begin{code}
+type ExportItem = (Module, OccName, [OccName])
+type VersionInfo name = [ImportVersion name]
+type ImportVersion name = (Module, Version, [LocalVersion name])
+type LocalVersion name = (name, Version)
+
+data ParsedIface
+ = ParsedIface
+ Module -- Module name
+ Version -- Module version number
+ [ImportVersion OccName] -- Usages
+ [ExportItem] -- Exports
+ [Module] -- Special instance modules
+ [(OccName,Fixity)] -- Fixities
+ [(Version, RdrNameHsDecl)] -- Local definitions
+ [RdrNameInstDecl] -- Local instance declarations
+
+type InterfaceDetails = (VersionInfo Name, -- Version information
+ ExportEnv, -- What this module exports
+ [Module]) -- Instance modules
+
+type RdrNamePragma = () -- Fudge for now
+-------------------
+
+data Ifaces = Ifaces
+ Module -- Name of this module
+ (FiniteMap Module Version)
+ (FiniteMap Module (Avails, [(OccName,Fixity)])) -- Exports
+ VersionMap
+ DeclsMap
+ (Bag IfaceInst)
+ [Module] -- Set of modules with "special" instance declarations
+ -- Excludes this module
+
+type DeclsMap = FiniteMap Name (AvailInfo, RdrNameHsDecl)
+type VersionMap = FiniteMap Name Version
+type IfaceInst = ([Name], Module, RdrNameInstDecl) -- The Names are those tycons and
+ -- classes mentioned by the instance type
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Main monad code}
+%* *
+%************************************************************************
+
+\begin{code}
+initRn :: Module -> UniqSupply -> SearchPath -> SrcLoc
+ -> RnMG r
+ -> IO (r, Bag Error, Bag Warning)
+
+initRn mod us dirs loc do_rn
+ = sstToIO $
+ newMutVarSST (us, 1, builtins) `thenSST` \ names_var ->
+ newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
+ newMutVarSST (emptyIfaces mod) `thenSST` \ iface_var ->
+ newMutVarSST initOccs `thenSST` \ occs_var ->
+ let
+ rn_down = RnDown loc names_var errs_var occs_var
+ g_down = GDown dirs iface_var
+ in
-- do the buisness
- do_rn rn_down `thenSST` \ res ->
+ do_rn rn_down g_down `thenSST` \ res ->
-- grab errors and return
- readMutVarSST errs_var `thenSST` \ (warns,errs) ->
- returnSST (res, errs, warns)
+ readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+ returnSST (res, errs, warns)
+
+
+initRnMS :: RnEnv -> Module -> RnSMode -> RnMS REAL_WORLD r -> RnMG r
+initRnMS env mod_name mode m rn_down g_down
+ = let
+ s_down = SDown env mod_name mode
+ in
+ m rn_down s_down
+
+
+emptyIfaces :: Module -> Ifaces
+emptyIfaces mod = Ifaces mod emptyFM emptyFM emptyFM emptyFM emptyBag []
+
+builtins :: FiniteMap (Module,OccName) Name
+builtins = bagToFM (mapBag (\ name -> (modAndOcc name, name)) builtinNames)
+
+ -- Initial value for the occurrence pool.
+initOccs :: [(Name,Necessity)]
+initOccs = [(getName boolTyCon, Compulsory)]
+ -- Booleans occur implicitly a lot, so it's tiresome to keep recording the fact, and
+ -- rather implausible that not one will be used in the module.
+ -- We could add some other common types, notably lists, but the general idea is
+ -- to do as much as possible explicitly.
+\end{code}
+
+\end{code}
+
+
+@renameSourceCode@ is used to rename stuff "out-of-line"; that is, not as part of
+the main renamer. Examples: pragmas (which we don't want to rename unless
+we actually explore them); and derived definitions, which are only generated
+in the type checker.
+
+The @RnNameSupply@ includes a @UniqueSupply@, so if you call it more than
+once you must either split it, or install a fresh unique supply.
+
+\begin{code}
+renameSourceCode :: Module
+ -> RnNameSupply
+ -> RnMS REAL_WORLD r
+ -> r
+
+-- Alas, we can't use the real runST, with the desired signature:
+-- renameSourceCode :: RnNameSupply -> RnMS s r -> r
+-- because we can't manufacture "new versions of runST".
+
+renameSourceCode mod_name name_supply m
+ = runSST (
+ newMutVarSST name_supply `thenSST` \ names_var ->
+ newMutVarSST (emptyBag,emptyBag) `thenSST` \ errs_var ->
+ newMutVarSST [] `thenSST` \ occs_var ->
+ let
+ rn_down = RnDown mkGeneratedSrcLoc names_var errs_var occs_var
+ s_down = SDown emptyRnEnv mod_name InterfaceMode
+ in
+ m rn_down s_down `thenSST` \ result ->
+
+ readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+
+ (if not (isEmptyBag errs) then
+ trace ("Urk! renameSourceCode found errors" ++ display errs)
+ else if not (isEmptyBag warns) then
+ trace ("Urk! renameSourceCode found warnings" ++ display warns)
+ else
+ id) $
+
+ returnSST result
)
+ where
+ display errs = ppShow 80 (pprBagOfErrors PprDebug errs)
{-# INLINE thenRn #-}
{-# INLINE thenRn_ #-}
{-# INLINE returnRn #-}
{-# INLINE andRn #-}
-returnRn :: a -> RnMonad x s a
-thenRn :: RnMonad x s a -> (a -> RnMonad x s b) -> RnMonad x s b
-thenRn_ :: RnMonad x s a -> RnMonad x s b -> RnMonad x s b
-andRn :: (a -> a -> a) -> RnMonad x s a -> RnMonad x s a -> RnMonad x s a
-mapRn :: (a -> RnMonad x s b) -> [a] -> RnMonad x s [b]
-mapAndUnzipRn :: (a -> RnMonad x s (b,c)) -> [a] -> RnMonad x s ([b],[c])
-
-returnRn v down = returnSST v
-thenRn m k down = m down `thenSST` \ r -> k r down
-thenRn_ m k down = m down `thenSST_` k down
-
-andRn combiner m1 m2 down
- = m1 down `thenSST` \ res1 ->
- m2 down `thenSST` \ res2 ->
+returnRn :: a -> RnM s d a
+thenRn :: RnM s d a -> (a -> RnM s d b) -> RnM s d b
+thenRn_ :: RnM s d a -> RnM s d b -> RnM s d b
+andRn :: (a -> a -> a) -> RnM s d a -> RnM s d a -> RnM s d a
+mapRn :: (a -> RnM s d b) -> [a] -> RnM s d [b]
+sequenceRn :: [RnM s d a] -> RnM s d [a]
+foldlRn :: (b -> a -> RnM s d b) -> b -> [a] -> RnM s d b
+mapAndUnzipRn :: (a -> RnM s d (b,c)) -> [a] -> RnM s d ([b],[c])
+fixRn :: (a -> RnM s d a) -> RnM s d a
+
+returnRn v gdown ldown = returnSST v
+thenRn m k gdown ldown = m gdown ldown `thenSST` \ r -> k r gdown ldown
+thenRn_ m k gdown ldown = m gdown ldown `thenSST_` k gdown ldown
+fixRn m gdown ldown = fixSST (\r -> m r gdown ldown)
+andRn combiner m1 m2 gdown ldown
+ = m1 gdown ldown `thenSST` \ res1 ->
+ m2 gdown ldown `thenSST` \ res2 ->
returnSST (combiner res1 res2)
+sequenceRn [] = returnRn []
+sequenceRn (m:ms) = m `thenRn` \ r ->
+ sequenceRn ms `thenRn` \ rs ->
+ returnRn (r:rs)
+
mapRn f [] = returnRn []
mapRn f (x:xs)
= f x `thenRn` \ r ->
mapRn f xs `thenRn` \ rs ->
returnRn (r:rs)
+foldlRn k z [] = returnRn z
+foldlRn k z (x:xs) = k z x `thenRn` \ z' ->
+ foldlRn k z' xs
+
mapAndUnzipRn f [] = returnRn ([],[])
mapAndUnzipRn f (x:xs)
= f x `thenRn` \ (r1, r2) ->
returnRn (r1:rs1, r2:rs2, r3:rs3)
\end{code}
-For errors and warnings ...
-\begin{code}
-failButContinueRn :: a -> Error -> RnMonad x s a
-failButContinueRn res err (RnDown _ _ _ _ _ _ errs_var)
- = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
- writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
- returnSST res
-
-warnAndContinueRn :: a -> Warning -> RnMonad x s a
-warnAndContinueRn res warn (RnDown _ _ _ _ _ _ errs_var)
- = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
- writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
- returnSST res
-
-addErrRn :: Error -> RnMonad x s ()
-addErrRn err = failButContinueRn () err
-
-addErrIfRn :: Bool -> Error -> RnMonad x s ()
-addErrIfRn True err = addErrRn err
-addErrIfRn False err = returnRn ()
-
-addWarnRn :: Warning -> RnMonad x s ()
-addWarnRn warn = warnAndContinueRn () warn
-
-addWarnIfRn :: Bool -> Warning -> RnMonad x s ()
-addWarnIfRn True warn = addWarnRn warn
-addWarnIfRn False warn = returnRn ()
-\end{code}
-
-\begin{code}
-getRnEnv :: RnMonad x s RnEnv
-getRnEnv (RnDown _ _ _ _ env _ _)
- = returnSST env
-
-setExtraRn :: x -> RnMonad x s r -> RnMonad y s r
-setExtraRn x m (RnDown _ mod locn mode env us errs)
- = m (RnDown x mod locn mode env us errs)
-
-getExtraRn :: RnMonad x s x
-getExtraRn (RnDown x _ _ _ _ _ _)
- = returnSST x
-
-getModuleRn :: RnMonad x s Module
-getModuleRn (RnDown _ mod _ _ _ _ _)
- = returnSST mod
-
-pushSrcLocRn :: SrcLoc -> RnMonad x s a -> RnMonad x s a
-pushSrcLocRn locn m (RnDown x mod _ mode env us errs)
- = m (RnDown x mod locn mode env us errs)
-
-getSrcLocRn :: RnMonad x s SrcLoc
-getSrcLocRn (RnDown _ _ locn _ _ _ _)
- = returnSST locn
-
-getSourceRn :: RnMonad x s Bool
-getSourceRn (RnDown _ _ _ (RnSource _) _ _ _) = returnSST True
-getSourceRn (RnDown _ _ _ (RnIface _ _ _) _ _ _) = returnSST False
-
-getOccurrenceUpRn :: RnMonad x s (Bag (RnName, RdrName))
-getOccurrenceUpRn (RnDown _ _ _ (RnSource occ_var) _ _ _)
- = readMutVarSST occ_var
-getOccurrenceUpRn (RnDown _ _ _ (RnIface _ _ _) _ _ _)
- = panic "getOccurrenceUpRn:RnIface"
-
-getImplicitUpRn :: RnMonad x s ImplicitEnv
-getImplicitUpRn (RnDown _ _ _ (RnIface _ _ imp_var) _ _ _)
- = readMutVarSST imp_var
-getImplicitUpRn (RnDown _ _ _(RnSource _) _ _ _)
- = panic "getImplicitUpRn:RnIface"
-\end{code}
-\begin{code}
-rnGetUnique :: RnMonad x s Unique
-rnGetUnique (RnDown _ _ _ _ _ us_var _)
- = get_unique us_var
+%************************************************************************
+%* *
+\subsection{Boring plumbing for common part}
+%* *
+%************************************************************************
-rnGetUniques :: Int -> RnMonad x s [Unique]
-rnGetUniques n (RnDown _ _ _ _ _ us_var _)
- = get_uniques n us_var
-
-get_unique us_var
- = readMutVarSST us_var `thenSST` \ uniq_supply ->
- let
- (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
- uniq = getUnique uniq_s
- in
- writeMutVarSST us_var new_uniq_supply `thenSST_`
- returnSST uniq
-
-get_uniques n us_var
- = readMutVarSST us_var `thenSST` \ uniq_supply ->
- let
- (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
- uniqs = getUniques n uniq_s
- in
- writeMutVarSST us_var new_uniq_supply `thenSST_`
- returnSST uniqs
-
-snoc_bag_var add bag_var
- = readMutVarSST bag_var `thenSST` \ bag ->
- writeMutVarSST bag_var (bag `snocBag` add)
-
-\end{code}
-
-*********************************************************
-* *
-\subsection{Making new names}
-* *
-*********************************************************
-
-@newLocalNames@ takes a bunch of RdrNames, which are defined together
-in a group (eg a pattern or set of bindings), checks they are
-unqualified and distinct, and creates new Names for them.
+================ Errors and warnings =====================
\begin{code}
-newLocalNames :: String -- Documentation string
- -> [(RdrName, SrcLoc)]
- -> RnMonad x s [RnName]
-
-newLocalNames str names_w_loc
- = mapRn (addErrRn . qualNameErr str) quals `thenRn_`
- mapRn (addErrRn . dupNamesErr str) dups `thenRn_`
- mkLocalNames these
+failWithRn :: a -> Error -> RnM s d a
+failWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
+ = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+ writeMutVarSST errs_var (warns, errs `snocBag` err) `thenSST_`
+ returnSST res
where
- quals = filter (isQual.fst) names_w_loc
- (these, dups) = removeDups cmp_fst names_w_loc
- cmp_fst (a,_) (b,_) = cmp a b
-\end{code}
+ err = addShortErrLocLine loc msg
-\begin{code}
-mkLocalNames :: [(RdrName, SrcLoc)] -> RnMonad x s [RnName]
-mkLocalNames names_w_locs
- = rnGetUniques (length names_w_locs) `thenRn` \ uniqs ->
- returnRn (zipWithEqual "mkLocalNames" new_local uniqs names_w_locs)
+warnWithRn :: a -> Warning -> RnM s d a
+warnWithRn res msg (RnDown loc names_var errs_var occs_var) l_down
+ = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+ writeMutVarSST errs_var (warns `snocBag` warn, errs) `thenSST_`
+ returnSST res
where
- new_local uniq (Unqual str, srcloc)
- = mkRnName (mkLocalName uniq str False{-emph names-} srcloc)
-\end{code}
+ warn = addShortWarnLocLine loc msg
+addErrRn :: Error -> RnM s d ()
+addErrRn err = failWithRn () err
-*********************************************************
-* *
-\subsection{Looking up values}
-* *
-*********************************************************
+checkRn :: Bool -> Error -> RnM s d () -- Check that a condition is true
+checkRn False err = addErrRn err
+checkRn True err = returnRn ()
-Action to look up a value depends on the RnMode.
-\begin{description}
-\item[RnSource:]
-Lookup value in RnEnv, recording occurrence for non-local values found.
-If not found report error and return Unbound name.
-\item[RnIface:]
-Lookup value in RnEnv. If not found lookup in implicit name env.
-If not found create new implicit name, adding it to the implicit env.
-\end{description}
+addWarnRn :: Warning -> RnM s d ()
+addWarnRn warn = warnWithRn () warn
-\begin{code}
-lookupValue :: RdrName -> RnMonad x s RnName
-lookupConstr :: RdrName -> RnMonad x s RnName
-lookupField :: RdrName -> RnMonad x s RnName
-lookupClassOp :: RnName -> RdrName -> RnMonad x s RnName
-
-lookupValue rdr
- = lookup_val rdr lookupRnEnv (\ rn -> True) (unknownNameErr "value")
-
-lookupConstr rdr
- = lookup_val rdr lookupGlobalRnEnv isRnConstr (unknownNameErr "constructor")
-
-lookupField rdr
- = lookup_val rdr lookupGlobalRnEnv isRnField (unknownNameErr "field")
+checkErrsRn :: RnM s d Bool -- True <=> no errors so far
+checkErrsRn (RnDown loc names_var errs_var occs_var) l_down
+ = readMutVarSST errs_var `thenSST` \ (warns,errs) ->
+ returnSST (isEmptyBag errs)
+\end{code}
-lookupClassOp cls rdr
- = lookup_val rdr lookupGlobalRnEnv (\ rn -> isRnClassOp cls rn) (badClassOpErr cls)
--- Note: the lookup checks are only performed when renaming source
+================ Source location =====================
-lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnSource occ_var) env _ _)
- = case lookup env rdr of
- Just name | check name -> succ name
- | otherwise -> fail
- Nothing -> fail
+\begin{code}
+pushSrcLocRn :: SrcLoc -> RnM s d a -> RnM s d a
+pushSrcLocRn loc' m (RnDown loc names_var errs_var occs_var) l_down
+ = m (RnDown loc' names_var errs_var occs_var) l_down
- where
- succ name = if isRnLocal name || isRnWired name then
- returnSST name
- else
- snoc_bag_var (name,rdr) occ_var `thenSST_`
- returnSST name
- fail = failButContinueRn (mkRnUnbound rdr) (do_err rdr locn) down
-
-lookup_val rdr lookup check do_err down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
- = case lookup env rdr of
- Just name -> returnSST name
- Nothing -> case rdr of
- Unqual n -> panic ("lookup_val:"++ _UNPK_ n)
- Qual m n ->
- lookup_nonexisting_val b_names b_key imp_var us_var (OrigName m n)
-
-lookup_nonexisting_val (b_names,_) b_key imp_var us_var orig
- = case (lookupFM b_names orig) of
- Just xx -> returnSST xx
- Nothing -> lookup_or_create_implicit_val b_key imp_var us_var orig
-
-lookup_or_create_implicit_val b_key imp_var us_var orig
- = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
- case (lookupFM implicit_val_fm orig) of
- Just implicit -> returnSST implicit
- Nothing ->
- (case (lookupFM b_key orig) of
- Just (u,_) -> returnSST u
- _ -> get_unique us_var
- ) `thenSST` \ uniq ->
- let
- implicit = mkRnImplicit (mkImplicitName uniq orig)
- new_val_fm = addToFM implicit_val_fm orig implicit
- in
- writeMutVarSST imp_var (new_val_fm, implicit_tc_fm) `thenSST_`
- returnSST implicit
+getSrcLocRn :: RnM s d SrcLoc
+getSrcLocRn (RnDown loc names_var errs_var occs_var) l_down
+ = returnSST loc
\end{code}
+================ Name supply =====================
\begin{code}
-lookupTyCon :: RdrName -> RnMonad x s RnName
-lookupClass :: RdrName -> RnMonad x s RnName
+getNameSupplyRn :: RnM s d RnNameSupply
+getNameSupplyRn (RnDown loc names_var errs_var occs_var) l_down
+ = readMutVarSST names_var
-lookupTyCon rdr
- = lookup_tc rdr isRnTyCon mkRnImplicitTyCon "type constructor"
-
-lookupClass rdr
- = lookup_tc rdr isRnClass mkRnImplicitClass "class"
-
-lookupTyConOrClass rdr
- = lookup_tc rdr isRnTyConOrClass
- (panic "lookupTC:mk_implicit") "class or type constructor"
-
-lookup_tc rdr check mk_implicit err_str down@(RnDown _ _ locn (RnSource occ_var) env _ _)
- = case lookupTcRnEnv env rdr of
- Just name | check name -> succ name
- | otherwise -> fail
- Nothing -> fail
- where
- succ name = snoc_bag_var (name,rdr) occ_var `thenSST_`
- returnSST name
- fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
-
-lookup_tc rdr@(Qual m n) check mk_implicit err_str down@(RnDown _ _ locn (RnIface b_names b_key imp_var) env us_var _)
- = case lookupTcRnEnv env rdr of
- Just name | check name -> returnSST name
- | otherwise -> fail
- Nothing -> lookup_nonexisting_tc check mk_implicit fail b_names b_key imp_var us_var (OrigName m n)
- where
- fail = failButContinueRn (mkRnUnbound rdr) (unknownNameErr err_str rdr locn) down
-
-lookup_nonexisting_tc check mk_implicit fail (_,b_names) b_key imp_var us_var orig--@(OrigName m n)
- = --pprTrace "lookup:" (ppAboves [case str_mod of {(n,m)->ppCat [ppPStr n, ppPStr m]}, ppAboves [ ppCat [ppPStr n, ppPStr m] | ((n,m), _) <- fmToList b_names]]) $
- case (lookupFM b_names orig) of
- Just xx -> returnSST xx
- Nothing -> lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig
-
-lookup_or_create_implicit_tc check mk_implicit fail b_key imp_var us_var orig
- = readMutVarSST imp_var `thenSST` \ (implicit_val_fm, implicit_tc_fm) ->
- case (lookupFM implicit_tc_fm orig) of
- Just implicit | check implicit -> returnSST implicit
- | otherwise -> fail
- Nothing ->
- (case (lookupFM b_key orig) of
- Just (u,_) -> returnSST u
- _ -> get_unique us_var
- ) `thenSST` \ uniq ->
- let
- implicit = mk_implicit (mkImplicitName uniq orig)
- new_tc_fm = addToFM implicit_tc_fm orig implicit
- in
- writeMutVarSST imp_var (implicit_val_fm, new_tc_fm) `thenSST_`
- returnSST implicit
+setNameSupplyRn :: RnNameSupply -> RnM s d ()
+setNameSupplyRn names' (RnDown loc names_var errs_var occs_var) l_down
+ = writeMutVarSST names_var names'
\end{code}
-
-@extendSS@ extends the scope; @extendSS2@ also removes the newly bound
-free vars from the result.
+================ Occurrences =====================
\begin{code}
-extendSS :: [RnName] -- Newly bound names
- -> RnMonad x s a
- -> RnMonad x s a
-
-extendSS binders m down@(RnDown x mod locn mode env us errs)
- = (mapRn (addErrRn . shadowedNameWarn locn) dups `thenRn_`
- m) (RnDown x mod locn mode new_env us errs)
- where
- (new_env,dups) = extendLocalRnEnv opt_WarnNameShadowing env binders
-
-extendSS2 :: [RnName] -- Newly bound names
- -> RnMonad x s (a, UniqSet RnName)
- -> RnMonad x s (a, UniqSet RnName)
-
-extendSS2 binders m
- = extendSS binders m `thenRn` \ (r, fvs) ->
- returnRn (r, fvs `minusUniqSet` (mkUniqSet binders))
+addOccurrenceName :: Necessity -> Name -> RnM s d ()
+addOccurrenceName necessity name (RnDown loc names_var errs_var occs_var) l_down
+ = readMutVarSST occs_var `thenSST` \ occs ->
+ writeMutVarSST occs_var ((name,necessity) : occs)
+
+addOccurrenceNames :: Necessity -> [Name] -> RnM s d ()
+addOccurrenceNames necessity names (RnDown loc names_var errs_var occs_var) l_down
+ = readMutVarSST occs_var `thenSST` \ occs ->
+ writeMutVarSST occs_var ([(name,necessity) | name <- names] ++ occs)
+
+popOccurrenceName :: RnM s d (Maybe (Name,Necessity))
+popOccurrenceName (RnDown loc names_var errs_var occs_var) l_down
+ = readMutVarSST occs_var `thenSST` \ occs ->
+ case occs of
+ [] -> returnSST Nothing
+ (occ:occs) -> writeMutVarSST occs_var occs `thenSST_`
+ returnSST (Just occ)
+
+-- findOccurrencesRn does the enclosed thing with a *fresh* occurrences
+-- variable, and returns the list of occurrences thus found. It's useful
+-- when loading instance decls and specialisation signatures, when we want to
+-- know the names of the things in the types, but we don't want to treat them
+-- as occurrences.
+
+findOccurrencesRn :: RnM s d a -> RnM s d [Name]
+findOccurrencesRn enclosed_thing (RnDown loc names_var errs_var occs_var) l_down
+ = newMutVarSST [] `thenSST` \ new_occs_var ->
+ enclosed_thing (RnDown loc names_var errs_var new_occs_var) l_down `thenSST_`
+ readMutVarSST new_occs_var `thenSST` \ occs ->
+ returnSST (map fst occs)
\end{code}
-The free var set returned by @(extendSS binders m)@ is that returned
-by @m@, {\em minus} binders.
+%************************************************************************
+%* *
+\subsection{Plumbing for rename-source part}
+%* *
+%************************************************************************
-*********************************************************
-* *
-\subsection{TyVarNamesEnv}
-* *
-*********************************************************
+================ RnEnv =====================
\begin{code}
-type TyVarNamesEnv = [(RdrName, RnName)]
+getNameEnv :: RnMS s NameEnv
+getNameEnv rn_down (SDown (RnEnv name_env fixity_env) mod_name mode)
+ = returnSST name_env
-nullTyVarNamesEnv :: TyVarNamesEnv
-nullTyVarNamesEnv = []
+setNameEnv :: NameEnv -> RnMS s a -> RnMS s a
+setNameEnv name_env' m rn_down (SDown (RnEnv name_env fixity_env) mod_name mode)
+ = m rn_down (SDown (RnEnv name_env' fixity_env) mod_name mode)
-catTyVarNamesEnvs :: TyVarNamesEnv -> TyVarNamesEnv -> TyVarNamesEnv
-catTyVarNamesEnvs e1 e2 = e1 ++ e2
+getFixityEnv :: RnMS s FixityEnv
+getFixityEnv rn_down (SDown (RnEnv name_env fixity_env) mod_name mode)
+ = returnSST fixity_env
-domTyVarNamesEnv :: TyVarNamesEnv -> [RdrName]
-domTyVarNamesEnv env = map fst env
+setRnEnv :: RnEnv -> RnMS s a -> RnMS s a
+setRnEnv rn_env' m rn_down (SDown rn_env mod_name mode)
+ = m rn_down (SDown rn_env' mod_name mode)
\end{code}
-@mkTyVarNamesEnv@ checks for duplicates, and complains if so.
+================ Module and Mode =====================
\begin{code}
-mkTyVarNamesEnv
- :: SrcLoc
- -> [RdrName] -- The type variables
- -> RnMonad x s (TyVarNamesEnv,[RnName]) -- Environment and renamed tyvars
-
-mkTyVarNamesEnv src_loc tyvars
- = newLocalNames "type variable"
- (tyvars `zip` repeat src_loc) `thenRn` \ rn_tyvars ->
-
- -- rn_tyvars may not be in the same order as tyvars, so we need some
- -- jiggery pokery to build the right tyvar env, and return the
- -- renamed tyvars in the original order.
- let tv_occ_name_pairs = map tv_occ_name_pair rn_tyvars
- tv_env = map (lookup_occ_name tv_occ_name_pairs) tyvars
- rn_tyvars_in_orig_order = map snd tv_env
- in
- returnRn (tv_env, rn_tyvars_in_orig_order)
- where
- tv_occ_name_pair :: RnName -> (RdrName, RnName)
- tv_occ_name_pair rn_name = (getOccName rn_name, rn_name)
-
- lookup_occ_name :: [(RdrName, RnName)] -> RdrName -> (RdrName, RnName)
- lookup_occ_name pairs tyvar_occ
- = (tyvar_occ, assoc "mkTyVarNamesEnv" pairs tyvar_occ)
+getModuleRn :: RnMS s Module
+getModuleRn rn_down (SDown rn_env mod_name mode)
+ = returnSST mod_name
\end{code}
\begin{code}
-lookupTyVarName :: TyVarNamesEnv -> RdrName -> RnMonad x s RnName
-lookupTyVarName env occ
- = case (assocMaybe env occ) of
- Just name -> returnRn name
- Nothing -> getSrcLocRn `thenRn` \ loc ->
- failButContinueRn (mkRnUnbound occ)
- (unknownNameErr "type variable" occ loc)
+getModeRn :: RnMS s RnSMode
+getModeRn rn_down (SDown rn_env mod_name mode)
+ = returnSST mode
\end{code}
-\begin{code}
-#if __GLASGOW_HASKELL__ >= 200
- -- can get it from GHCbase
-#else
-fixIO :: (a -> IO a) -> IO a
+%************************************************************************
+%* *
+\subsection{Plumbing for rename-globals part}
+%* *
+%************************************************************************
-fixIO k s = let
- result = k loop s
- (Right loop, _) = result
- in
- result
-#endif
-\end{code}
+\begin{code}
+getIfacesRn :: RnMG Ifaces
+getIfacesRn rn_down (GDown dirs iface_var)
+ = readMutVarSST iface_var
-*********************************************************
-* *
-\subsection{Errors used in RnMonad}
-* *
-*********************************************************
+setIfacesRn :: Ifaces -> RnMG ()
+setIfacesRn ifaces rn_down (GDown dirs iface_var)
+ = writeMutVarSST iface_var ifaces
-\begin{code}
-unknownNameErr descriptor name locn
- = addShortErrLocLine locn $ \ sty ->
- ppBesides [ppStr "undefined ", ppStr descriptor, ppStr ": ", pprNonSym sty name]
-
-badClassOpErr clas op locn
- = addErrLoc locn "" $ \ sty ->
- ppBesides [ppChar '`', pprNonSym sty op, ppStr "' is not an operation of class `",
- ppr sty clas, ppStr "'"]
-
-shadowedNameWarn locn shadow
- = addShortWarnLocLine locn $ \ sty ->
- ppBesides [ppStr "more than one value with the same name (shadowing): ", ppr sty shadow]
+getSearchPathRn :: RnMG SearchPath
+getSearchPathRn rn_down (GDown dirs iface_var)
+ = returnSST dirs
\end{code}
#include "HsVersions.h"
module RnNames (
- getGlobalNames,
- SYN_IE(GlobalNameInfo)
+ getGlobalNames
) where
-import PreludeGlaST ( SYN_IE(MutableVar) )
-
IMP_Ubiq()
-import HsSyn
-import RdrHsSyn
-import RnHsSyn
-
+import CmdLineOpts ( opt_SourceUnchanged )
+import HsSyn ( HsModule(..), HsDecl(..), FixityDecl(..), Fixity, Fake, InPat, IE(..), HsTyVar,
+ TyDecl, ClassDecl, InstDecl, DefaultDecl, ImportDecl(..), HsBinds, IfaceSig
+ )
+import HsBinds ( collectTopBinders )
+import HsImpExp ( ieName )
+import RdrHsSyn ( RdrNameHsDecl(..), RdrName(..), RdrNameIE(..), SYN_IE(RdrNameImportDecl),
+ SYN_IE(RdrNameHsModule), SYN_IE(RdrNameFixityDecl),
+ rdrNameOcc
+ )
+import RnHsSyn ( RenamedHsModule(..), RenamedFixityDecl(..) )
+import RnIfaces ( getInterfaceExports, getDeclBinders, checkUpToDate )
+import RnEnv
import RnMonad
-import RnIfaces ( IfaceCache, cachedIface, cachedDecl, CachingResult(..) )
-import RnUtils ( SYN_IE(RnEnv), emptyRnEnv, initRnEnv, extendGlobalRnEnv,
- lubExportFlag, qualNameErr, dupNamesErr, pprRnEnv
- )
-import ParseUtils ( ParsedIface(..), RdrIfaceDecl(..), ExportsMap(..), RdrIfaceInst )
-
-
-import Bag ( emptyBag, unitBag, consBag, snocBag, unionBags,
- unionManyBags, mapBag, foldBag, filterBag, listToBag, bagToList )
-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, FiniteMap )
-import Id ( GenId )
-import Maybes ( maybeToBool, catMaybes, MaybeErr(..) )
-import Name ( RdrName(..), Name, isQual, mkTopLevName, mkWiredInName, origName,
- nameOf, qualToOrigName, mkImportedName,
- nameExportFlag, nameImportFlag,
- getLocalName, getSrcLoc, getImpLocs,
- moduleNamePair, pprNonSym,
- isLexCon, isLexSpecialSym, ExportFlag(..), OrigName(..)
- )
-import PrelInfo ( SYN_IE(BuiltinNames), SYN_IE(BuiltinKeys) )
-import PrelMods ( pRELUDE, gHC_BUILTINS, modulesWithBuiltins )
+import FiniteMap
+import PrelMods
+import UniqFM ( UniqFM, emptyUFM, addListToUFM_C, lookupUFM )
+import Bag ( Bag, bagToList )
+import Maybes ( maybeToBool, expectJust )
+import Name
import Pretty
-import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
-import TyCon ( tyConDataCons )
-import UniqFM ( emptyUFM, addListToUFM_C, lookupUFM )
-import UniqSupply ( splitUniqSupply )
-import Util ( isIn, assoc, cmpPString, sortLt, removeDups,
- equivClasses, panic, assertPanic
- )
---import PprStyle --ToDo:rm
+import PprStyle ( PprStyle(..) )
+import Util ( panic, pprTrace )
\end{code}
-\begin{code}
-type GlobalNameInfo = (BuiltinNames,
- BuiltinKeys,
- Name -> ExportFlag, -- export flag
- Name -> [RdrName]) -- occurrence names
- -- NB: both of the functions are in a *knot* and
- -- must be tugged on oh-so-gently...
-
-type RnM_Info s r = RnMonad GlobalNameInfo s r
-
-getGlobalNames ::
- IfaceCache
- -> GlobalNameInfo
- -> UniqSupply
- -> RdrNameHsModule
- -> IO (RnEnv,
- [Module], -- directly imported modules
- Bag (Module,RnName), -- unqualified imports from module
- Bag RenamedFixityDecl, -- imported fixity decls
- Bag Error,
- Bag Warning)
-
-getGlobalNames iface_cache info us
- (HsModule mod _ _ imports _ ty_decls _ cls_decls _ _ _ binds _ _)
- = let
- (us1, us2) = splitUniqSupply us
- in
- case initRn True mod emptyRnEnv us1
- (setExtraRn info $
- getSourceNames ty_decls cls_decls binds)
- of { ((src_vals, src_tcs), src_errs, src_warns) ->
- doImportDecls iface_cache info us2 imports >>=
- \ (imp_vals, imp_tcs, imp_mods, unqual_imps, imp_fixes, imp_errs, imp_warns) ->
- let
- unqual_vals = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_vals)
- unqual_tcs = map (\rn -> (Unqual (getLocalName rn), rn)) (bagToList src_tcs)
+%************************************************************************
+%* *
+\subsection{Get global names}
+%* *
+%************************************************************************
- (src_env, src_dups) = extendGlobalRnEnv initRnEnv unqual_vals unqual_tcs
- (all_env, imp_dups) = extendGlobalRnEnv src_env (bagToList imp_vals) (bagToList imp_tcs)
+\begin{code}
+getGlobalNames :: RdrNameHsModule
+ -> RnMG (Maybe (ExportEnv, RnEnv, [AvailInfo]))
+ -- Nothing <=> no need to recompile
+
+getGlobalNames m@(HsModule this_mod _ exports imports _ _ mod_loc)
+ = fixRn (\ ~(rec_exp_fn, _) ->
+
+ -- PROCESS LOCAL DECLS
+ -- Do these *first* so that the correct provenance gets
+ -- into the global name cache.
+ importsFromLocalDecls rec_exp_fn m `thenRn` \ (local_rn_env, local_mod_avails) ->
+
+ -- PROCESS IMPORT DECLS
+ mapAndUnzipRn importsFromImportDecl all_imports
+ `thenRn` \ (imp_rn_envs, imp_avails_s) ->
+
+ -- CHECK FOR EARLY EXIT
+ checkEarlyExit this_mod `thenRn` \ early_exit ->
+ if early_exit then
+ returnRn (junk_exp_fn, Nothing)
+ else
+
+ -- COMBINE RESULTS
+ -- We put the local env first, so that a local provenance
+ -- "wins", even if a module imports itself.
+ foldlRn plusRnEnv emptyRnEnv imp_rn_envs `thenRn` \ imp_rn_env ->
+ plusRnEnv local_rn_env imp_rn_env `thenRn` \ rn_env ->
+ let
+ all_avails :: ModuleAvails
+ all_avails = foldr plusModuleAvails local_mod_avails imp_avails_s
+ local_avails = expectJust "getGlobalNames" (lookupModuleAvails local_mod_avails this_mod)
+ in
+
+ -- PROCESS EXPORT LISTS
+ exportsFromAvail this_mod exports all_avails rn_env
+ `thenRn` \ (export_fn, export_env) ->
+
+ returnRn (export_fn, Just (export_env, rn_env, local_avails))
+ ) `thenRn` \ (_, result) ->
+ returnRn result
+ where
+ junk_exp_fn = error "RnNames:export_fn"
- -- remove dups of the same imported thing
- diff_imp_dups = filterBag diff_orig imp_dups
- diff_orig (_,rn1,rn2) = origName "diff_orig" rn1 /= origName "diff_orig" rn2
+ all_imports = prel_imports ++ imports
- all_dups = bagToList (src_dups `unionBags` diff_imp_dups)
- dup_errs = map dup_err (equivClasses cmp_rdr all_dups)
- cmp_rdr (rdr1,_,_) (rdr2,_,_) = cmp rdr1 rdr2
- dup_err ((rdr,rn1,rn2):rest) = globalDupNamesErr rdr (rn1:rn2: [rn|(_,_,rn)<-rest])
+ prel_imports | this_mod == pRELUDE ||
+ explicit_prelude_import = []
- all_errs = src_errs `unionBags` imp_errs `unionBags` listToBag dup_errs
- all_warns = src_warns `unionBags` imp_warns
- in
--- pprTrace "initRnEnv:" (pprRnEnv PprDebug initRnEnv) $
--- pprTrace "src_env:" (pprRnEnv PprDebug src_env) $
--- pprTrace "all_env:" (pprRnEnv PprDebug all_env) $
- return (all_env, imp_mods, unqual_imps, imp_fixes, all_errs, all_warns) }
+ | otherwise = [ImportDecl pRELUDE
+ False {- Not qualified -}
+ Nothing {- No "as" -}
+ Nothing {- No import list -}
+ mod_loc]
+
+ explicit_prelude_import
+ = not (null [ () | (ImportDecl mod qual _ _ _) <- imports, mod == pRELUDE ])
\end{code}
-
-*********************************************************
-* *
-\subsection{Top-level source names}
-* *
-*********************************************************
+
+\begin{code}
+checkEarlyExit mod
+ = if not opt_SourceUnchanged then
+ -- Source code changed; look no further
+ returnRn False
+ else
+ -- Unchanged source; look further
+ -- We check for
+ -- (a) errors so far. These can arise if a module imports
+ -- something that's no longer exported by the imported module
+ -- (b) usage information up to date
+ checkErrsRn `thenRn` \ no_errs_so_far ->
+ checkUpToDate mod `thenRn` \ up_to_date ->
+ returnRn (no_errs_so_far && up_to_date)
+\end{code}
+
\begin{code}
-getSourceNames :: -- Collects global *binders* (not uses)
- [RdrNameTyDecl]
- -> [RdrNameClassDecl]
- -> RdrNameHsBinds
- -> RnM_Info s (Bag RnName, -- values
- Bag RnName) -- tycons/classes
-
-getSourceNames ty_decls cls_decls binds
- = mapAndUnzip3Rn getTyDeclNames ty_decls `thenRn` \ (tycon_s, constrs_s, fields_s) ->
- mapAndUnzipRn getClassNames cls_decls `thenRn` \ (cls_s, cls_ops_s) ->
- getTopBindsNames binds `thenRn` \ bind_names ->
- returnRn (unionManyBags constrs_s `unionBags`
- unionManyBags fields_s `unionBags`
- unionManyBags cls_ops_s `unionBags` bind_names,
- listToBag tycon_s `unionBags` listToBag cls_s)
-
---------------
-getTyDeclNames :: RdrNameTyDecl
- -> RnM_Info s (RnName, Bag RnName, Bag RnName) -- tycon, constrs and fields
-
-getTyDeclNames (TyData _ tycon _ condecls _ _ src_loc)
- = --getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
- --pprTrace "getTyDeclNames:" (ppr PprDebug tycon) $
- --pprTrace "getTDN1:" (ppAboves [ ppCat [ppPStr m, ppPStr n] | ((OrigName m n), _) <- fmToList b_tc_names]) $
-
- newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
- getConFieldNames (Just (nameExportFlag tycon_name)) emptyBag emptyBag emptyFM
- condecls `thenRn` \ (con_names, field_names) ->
- let
- rn_tycon = RnData tycon_name con_names field_names
- rn_constrs = [ RnConstr name tycon_name | name <- con_names]
- rn_fields = [ RnField name tycon_name | name <- field_names]
- in
- returnRn (rn_tycon, listToBag rn_constrs, listToBag rn_fields)
-
-getTyDeclNames (TyNew _ tycon _ [NewConDecl con _ con_loc] _ _ src_loc)
- = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
- newGlobalName con_loc (Just (nameExportFlag tycon_name)) True{-val-} con
- `thenRn` \ con_name ->
- returnRn (RnData tycon_name [con_name] [],
- unitBag (RnConstr con_name tycon_name),
- emptyBag)
-
-getTyDeclNames (TySynonym tycon _ _ src_loc)
- = newGlobalName src_loc Nothing False{-not val-} tycon `thenRn` \ tycon_name ->
- returnRn (RnSyn tycon_name, emptyBag, emptyBag)
-
-----------------
-getConFieldNames :: Maybe ExportFlag
- -> Bag Name -> Bag Name
- -> FiniteMap RdrName ()
- -> [RdrNameConDecl]
- -> RnM_Info s ([Name], [Name])
-
-getConFieldNames exp constrs fields have []
- = returnRn (bagToList constrs, bagToList fields)
-
-getConFieldNames exp constrs fields have (ConDecl con _ src_loc : rest)
- = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
- getConFieldNames exp (constrs `snocBag` con_name) fields have rest
-
-getConFieldNames exp constrs fields have (ConOpDecl _ con _ src_loc : rest)
- = newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
- getConFieldNames exp (constrs `snocBag` con_name) fields have rest
-
-getConFieldNames exp constrs fields have (RecConDecl con fielddecls src_loc : rest)
- = mapRn (addErrRn . dupFieldErr con src_loc) dups `thenRn_`
- newGlobalName src_loc exp True{-val-} con `thenRn` \ con_name ->
- mapRn (newGlobalName src_loc exp True{-val-}) new_fields `thenRn` \ field_names ->
+importsFromImportDecl :: RdrNameImportDecl
+ -> RnMG (RnEnv, ModuleAvails)
+
+ -- Check for "import M ()", and then don't even look at M.
+ -- This makes sense, and is actually rather useful for the Prelude.
+importsFromImportDecl (ImportDecl mod qual as_mod (Just (False,[])) loc)
+ = returnRn (emptyRnEnv, emptyModuleAvails)
+
+importsFromImportDecl (ImportDecl mod qual as_mod import_spec loc)
+ = pushSrcLocRn loc $
+ getInterfaceExports mod `thenRn` \ (avails, fixities) ->
+ filterImports mod import_spec avails `thenRn` \ filtered_avails ->
let
- all_constrs = constrs `snocBag` con_name
- all_fields = fields `unionBags` listToBag field_names
+ filtered_avails' = [ Avail (set_name_prov n) (map set_name_prov ns)
+ | Avail n ns <- filtered_avails
+ ]
+ fixities' = [ (occ,fixity,provenance) | (occ,fixity) <- fixities ]
in
- getConFieldNames exp all_constrs all_fields new_have rest
+ qualifyImports mod qual as_mod (ExportEnv filtered_avails' fixities')
where
- (uniq_fields, dups) = removeDups cmp (concat (map fst fielddecls))
- new_fields = filter (not . maybeToBool . lookupFM have) uniq_fields
- new_have = addListToFM have (zip new_fields (repeat ()))
-
--------------
-getClassNames :: RdrNameClassDecl
- -> RnM_Info s (RnName, Bag RnName) -- class and class ops
-
-getClassNames (ClassDecl _ cname _ sigs _ _ src_loc)
- = newGlobalName src_loc Nothing False{-notval-} cname `thenRn` \ class_name ->
- getClassOpNames (Just (nameExportFlag class_name))
- sigs `thenRn` \ op_names ->
- returnRn (RnClass class_name op_names,
- listToBag (map (\ n -> RnClassOp n class_name) op_names))
-
----------------
-getClassOpNames :: Maybe ExportFlag
- -> [RdrNameSig]
- -> RnM_Info s [Name]
-
-getClassOpNames exp [] = returnRn []
-
-getClassOpNames exp (ClassOpSig op _ _ src_loc : sigs)
- = newGlobalName src_loc exp True{-val-} op `thenRn` \ op_name ->
- getClassOpNames exp sigs `thenRn` \ op_names ->
- returnRn (op_name : op_names)
-getClassOpNames exp (_ : sigs)
- = getClassOpNames exp sigs
+ set_name_prov name = setNameProvenance name provenance
+ provenance = Imported mod loc
\end{code}
-*********************************************************
-* *
-\subsection{Bindings}
-* *
-*********************************************************
\begin{code}
-getTopBindsNames :: RdrNameHsBinds
- -> RnM_Info s (Bag RnName)
-
-getTopBindsNames binds = doBinds binds
-
-doBinds EmptyBinds = returnRn emptyBag
-doBinds (SingleBind bind) = doBind bind
-doBinds (BindWith bind sigs) = doBind bind
-doBinds (ThenBinds binds1 binds2)
- = andRn unionBags (doBinds binds1) (doBinds binds2)
-
-doBind EmptyBind = returnRn emptyBag
-doBind (NonRecBind mbind) = doMBinds mbind
-doBind (RecBind mbind) = doMBinds mbind
-
-doMBinds EmptyMonoBinds = returnRn emptyBag
-doMBinds (PatMonoBind pat grhss_and_binds locn) = doPat locn pat
-doMBinds (FunMonoBind p_name _ _ locn) = doName locn p_name
-doMBinds (AndMonoBinds mbinds1 mbinds2)
- = andRn unionBags (doMBinds mbinds1) (doMBinds mbinds2)
-
-doPats locn pats
- = mapRn (doPat locn) pats `thenRn` \ pats_s ->
- returnRn (unionManyBags pats_s)
-
-doPat locn WildPatIn = returnRn emptyBag
-doPat locn (LitPatIn _) = returnRn emptyBag
-doPat locn (LazyPatIn pat) = doPat locn pat
-doPat locn (VarPatIn var) = doName locn var
-doPat locn (NegPatIn pat) = doPat locn pat
-doPat locn (ParPatIn pat) = doPat locn pat
-doPat locn (ListPatIn pats) = doPats locn pats
-doPat locn (TuplePatIn pats) = doPats locn pats
-doPat locn (ConPatIn name pats) = doPats locn pats
-doPat locn (ConOpPatIn p1 op p2)
- = andRn unionBags (doPat locn p1) (doPat locn p2)
-doPat locn (AsPatIn as_name pat)
- = andRn unionBags (doName locn as_name) (doPat locn pat)
-doPat locn (RecPatIn name fields)
- = mapRn (doField locn) fields `thenRn` \ fields_s ->
- returnRn (unionManyBags fields_s)
-
-doField locn (_, pat, _) = doPat locn pat
-
-doName locn rdr
- = newGlobalName locn Nothing True{-val-} rdr `thenRn` \ name ->
- returnRn (unitBag (RnName name))
+importsFromLocalDecls rec_exp_fn (HsModule mod _ _ _ fix_decls decls _)
+ = foldlRn getLocalDeclBinders [] decls `thenRn` \ avails ->
+ mapRn fixityFromFixDecl fix_decls `thenRn` \ fixities ->
+ qualifyImports mod
+ False -- Not qualified
+ Nothing -- No "as M" part
+ (ExportEnv avails fixities)
+ where
+ newLocalName rdr_name loc
+ = newLocallyDefinedGlobalName mod (rdrNameOcc rdr_name) rec_exp_fn loc
+
+ getLocalDeclBinders avails (ValD binds)
+ = mapRn do_one (bagToList (collectTopBinders binds)) `thenRn` \ val_avails ->
+ returnRn (val_avails ++ avails)
+
+ getLocalDeclBinders avails decl
+ = getDeclBinders newLocalName decl `thenRn` \ avail ->
+ returnRn (avail : avails)
+
+ do_one (rdr_name, loc)
+ = newLocalName rdr_name loc `thenRn` \ name ->
+ returnRn (Avail name [])
\end{code}
-*********************************************************
-* *
-\subsection{Creating a new global name}
-* *
-*********************************************************
+%************************************************************************
+%* *
+\subsection{Filtering imports}
+%* *
+%************************************************************************
-\begin{code}
-newGlobalName :: SrcLoc
- -> Maybe ExportFlag
- -> Bool{-True<=>value name,False<=>tycon/class-}
- -> RdrName
- -> RnM_Info s Name
-
-newGlobalName locn maybe_exp is_val_name (Unqual name)
- = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
- getModuleRn `thenRn` \ mod ->
- rnGetUnique `thenRn` \ u ->
- let
- orig = OrigName mod name
-
- (uniq, is_toplev)
- = case (lookupFM b_keys orig) of
- Just (key,_) -> (key, True)
- 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!-})
-
- exp = case maybe_exp of
- Just flag -> flag
- Nothing -> rec_exp_fn n
-
- n = if is_toplev
- then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
- else mkWiredInName uniq orig exp
- in
- returnRn n
+@filterImports@ takes the @ExportEnv@ telling what the imported module makes
+available, and filters it through the import spec (if any).
-newGlobalName locn maybe_exp is_val_name rdr@(Qual mod name)
- | opt_CompilingGhcInternals
- -- we are actually defining something that compiler knows about (e.g., Bool)
+\begin{code}
+filterImports :: Module
+ -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hidin
+ -> [AvailInfo] -- What's available
+ -> RnMG [AvailInfo] -- What's actually imported
+ -- Complains if import spec mentions things the
+ -- module doesn't export
- = getExtraRn `thenRn` \ ((b_val_names,b_tc_names),b_keys,rec_exp_fn,rec_occ_fn) ->
- let
- orig = OrigName mod name
-
- (uniq, is_toplev)
- = case (lookupFM b_keys orig) of
- Just (key,_) -> (key, True)
- Nothing -> case (lookupFM (if is_val_name then b_val_names else b_tc_names) orig) of
- Nothing -> (panic "newGlobalName:Qual:uniq", True)
- Just xx -> (uniqueOf xx, False{-builtin!-})
-
- exp = case maybe_exp of
- Just flag -> flag
- Nothing -> rec_exp_fn n
-
- n = if is_toplev
- then mkTopLevName uniq orig locn exp (rec_occ_fn n) -- NB: two "n"s
- else mkWiredInName uniq orig exp
- in
- returnRn n
+filterImports mod Nothing imports
+ = returnRn imports
- | otherwise
- = addErrRn (qualNameErr "name in definition" (rdr, locn)) `thenRn_`
- returnRn (panic "newGlobalName:Qual")
-\end{code}
+filterImports mod (Just (want_hiding, import_items)) avails
+ = -- Check that each import item mentions things that are actually available
+ mapRn check_import_item import_items `thenRn_`
-*********************************************************
-* *
-\subsection{Imported names}
-* *
-*********************************************************
+ -- Return filtered environment; no need to filter fixities
+ returnRn (map new_avail avails)
-\begin{code}
-type ImportNameInfo
- = (GlobalNameInfo,
- FiniteMap OrigName RnName, -- values imported so far
- FiniteMap OrigName RnName, -- tycons/classes imported so far
- Name -> (ExportFlag, [SrcLoc])) -- import flag and src locns;
- -- NB: this last field is in a knot
- -- and mustn't be tugged on!
-
-type RnM_IInfo s r = RnMonad ImportNameInfo s r
-
-------------------------------------------------------------------
-doImportDecls ::
- IfaceCache
- -> GlobalNameInfo -- builtin and knot name info
- -> UniqSupply
- -> [RdrNameImportDecl] -- import declarations
- -> IO (Bag (RdrName,RnName), -- imported values in scope
- Bag (RdrName,RnName), -- imported tycons/classes in scope
- [Module], -- directly imported modules
- Bag (Module,RnName), -- unqualified import from module
- Bag RenamedFixityDecl, -- fixity info for imported names
- Bag Error,
- Bag Warning)
-
-doImportDecls iface_cache g_info us src_imps
- = fixIO ( \ ~(_, _, _, _, _, _, rec_imp_stuff) ->
- let
- rec_imp_fm = addListToUFM_C add_stuff emptyUFM (bagToList rec_imp_stuff)
- add_stuff (imp1,locns1) (imp2,locns2) = (lubExportFlag imp1 imp2, locns1 `unionBags` locns2)
-
- rec_imp_fn :: Name -> (ExportFlag, [SrcLoc])
- rec_imp_fn n = case lookupUFM rec_imp_fm n of
- Nothing -> (NotExported,[mkBuiltinSrcLoc])
- -- panic "RnNames:rec_imp_fn"
- -- but the panic can show up
- -- in error messages
- Just (flag, locns) -> (flag, bagToList locns)
-
- i_info = (g_info, emptyFM, emptyFM, rec_imp_fn)
- in
- -- cache the imported modules
- -- this ensures that all directly imported modules
- -- will have their original name iface in scope
- -- pprTrace "doImportDecls:" (ppCat (map ppPStr imp_mods)) $
- accumulate (map (cachedIface iface_cache False SLIT("doImportDecls")) imp_mods) >>
-
- -- process the imports
- doImports iface_cache i_info us all_imps
-
- ) >>= \ (vals, tcs, unquals, fixes, errs, warns, _) ->
-
- return (vals, tcs, imp_mods, unquals, fixes,
- imp_errs `unionBags` errs,
- imp_warns `unionBags` warns)
where
- all_imps = implicit_prel ++ src_imps
--- all_imps = implicit_qprel ++ the_imps
+ import_fm :: FiniteMap OccName RdrNameIE
+ import_fm = listToFM [(ieOcc ie, ie) | ie <- import_items]
+
+ avail_fm :: FiniteMap OccName AvailInfo
+ avail_fm = listToFM [(nameOccName name, avail) | avail@(Avail name ns) <- avails]
+
+ new_avail NotAvailable = NotAvailable
+ new_avail avail@(Avail name _)
+ | not in_import_items && want_hiding = avail
+ | not in_import_items && not want_hiding = NotAvailable
+ | in_import_items && want_hiding = NotAvailable
+ | in_import_items && not want_hiding = filtered_avail
+ where
+ maybe_import_item = lookupFM import_fm (nameOccName name)
+ in_import_items = maybeToBool maybe_import_item
+ Just import_item = maybe_import_item
+ filtered_avail = filterAvail import_item avail
+
+ check_import_item :: RdrNameIE -> RnMG ()
+ check_import_item item
+ = checkRn (maybeToBool maybe_matching_avail && sub_names_ok item avail)
+ (badImportItemErr mod item)
+ where
+ item_name = ieOcc item
+ maybe_matching_avail = lookupFM avail_fm item_name
+ Just avail = maybe_matching_avail
+
+ sub_names_ok (IEVar _) _ = True
+ sub_names_ok (IEThingAbs _) _ = True
+ sub_names_ok (IEThingAll _) _ = True
+ sub_names_ok (IEThingWith _ wanted) (Avail _ has) = all ((`elem` has_list) . rdrNameOcc) wanted
+ where
+ has_list = map nameOccName has
+ sub_names_ok other1 other2 = False
+\end{code}
- explicit_prelude_imp
- = not (null [ () | (ImportDecl mod qual _ _ _) <- src_imps, mod == pRELUDE ])
- implicit_prel | opt_NoImplicitPrelude = []
- | explicit_prelude_imp = [ImportDecl pRELUDE True Nothing Nothing prel_loc]
- | otherwise = [ImportDecl pRELUDE False Nothing Nothing prel_loc]
- prel_loc = mkBuiltinSrcLoc
+%************************************************************************
+%* *
+\subsection{Qualifiying imports}
+%* *
+%************************************************************************
- (uniq_imps, imp_dups) = removeDups cmp_mod all_imps
- cmp_mod (ImportDecl m1 _ _ _ _) (ImportDecl m2 _ _ _ _) = cmpPString m1 m2
+@qualifyImports@ takes the @ExportEnv@ after filtering through the import spec
+of an import decl, and deals with producing an @RnEnv@ with the
+right qaulified names. It also turns the @Names@ in the @ExportEnv@ into
+fully fledged @Names@.
- qprel_imps = [ imp | imp@(ImportDecl mod True Nothing _ _) <- src_imps,
- mod == pRELUDE ]
+\begin{code}
+qualifyImports :: Module -- Improrted module
+ -> Bool -- True <=> qualified import
+ -> Maybe Module -- Optional "as M" part
+ -> ExportEnv -- What's imported
+ -> RnMG (RnEnv, ModuleAvails)
+
+qualifyImports this_mod qual as_mod (ExportEnv avails fixities)
+ = -- Make the qualified-name environments, checking of course for clashes
+ foldlRn add_name emptyNameEnv avails `thenRn` \ name_env ->
+ foldlRn (add_fixity name_env) emptyFixityEnv fixities `thenRn` \ fixity_env ->
+
+ -- Deal with the "qualified" part; if not qualifies then add unqualfied bindings
+ if qual then
+ returnRn (RnEnv name_env fixity_env, mod_avail_env)
+ else
+ returnRn (RnEnv (unQualify name_env) (unQualify fixity_env), mod_avail_env)
- qual_mods = [ (qual_name mod as_mod, imp) | imp@(ImportDecl mod True as_mod _ _) <- src_imps ]
- qual_name mod (Just as_mod) = as_mod
- qual_name mod Nothing = mod
+ where
+ mod_avail_env = unitFM this_mod avails
+
+ add_name name_env NotAvailable = returnRn name_env
+ add_name name_env (Avail n ns) = foldlRn add_one name_env (n : ns)
+
+ add_one :: NameEnv -> Name -> RnMG NameEnv
+ add_one env name = addOneToNameEnvRn env (Qual this_mod occ_name) name
+ where
+ occ_name = nameOccName name
+
+ add_fixity name_env fixity_env (occ_name, fixity, provenance)
+ | maybeToBool (lookupFM name_env qual_name) -- The name is imported
+ = addOneToFixityEnvRn fixity_env qual_name (fixity,provenance)
+ | otherwise -- It ain't imported
+ = returnRn fixity_env
+ where
+ qual_name = Qual this_mod occ_name
+\end{code}
- (_, qual_dups) = removeDups cmp_qual qual_mods
- bad_qual_dups = filter (not . all_same_mod) qual_dups
+unQualify adds an Unqual binding for every existing Qual binding.
- cmp_qual (q1,_) (q2,_) = cmpPString q1 q2
- all_same_mod ((q,ImportDecl mod _ _ _ _):rest)
- = all has_same_mod rest
- where
- has_same_mod (_,ImportDecl mod2 _ _ _ _) = mod == mod2
+\begin{code}
+unQualify :: FiniteMap RdrName elt -> FiniteMap RdrName elt
+unQualify fm = addListToFM fm [(Unqual occ, elt) | (Qual _ occ, elt) <- fmToList fm]
+\end{code}
- imp_mods = [ mod | ImportDecl mod _ _ _ _ <- uniq_imps ]
+%************************************************************************
+%* *
+\subsection{Local declarations}
+%* *
+%************************************************************************
- imp_warns = listToBag (map dupImportWarn imp_dups)
- `unionBags`
- listToBag (map qualPreludeImportWarn qprel_imps)
- imp_errs = listToBag (map dupQualImportErr bad_qual_dups)
+\begin{code}
+fixityFromFixDecl :: RdrNameFixityDecl -> RnMG (OccName, Fixity, Provenance)
------------------------
-doImports :: IfaceCache
- -> ImportNameInfo
- -> UniqSupply
- -> [RdrNameImportDecl] -- import declarations
- -> IO (Bag (RdrName,RnName), -- imported values in scope
- Bag (RdrName,RnName), -- imported tycons/classes in scope
- Bag (Module, RnName), -- unqualified import from module
- Bag RenamedFixityDecl, -- fixity info for imported names
- Bag Error,
- Bag Warning,
- Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
+fixityFromFixDecl (FixityDecl rdr_name fixity loc)
+ = returnRn (rdrNameOcc rdr_name, fixity, LocalDef (panic "export-flag") loc)
+\end{code}
-doImports iface_cache i_info us []
- = return (emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag, emptyBag)
-doImports iface_cache i_info@(g_info,done_vals,done_tcs,rec_imp_fn) us (imp:imps)
- = let
- (us1, us2) = splitUniqSupply us
- in
- doImport iface_cache i_info us1 imp
- >>= \ (vals1, tcs1, unquals1, fixes1, errs1, warns1, imps1) ->
- let
- ext_vals = foldl add_new_one done_vals (bagToList vals1)
- ext_tcs = foldl add_new_one done_tcs (bagToList tcs1)
- in
- doImports iface_cache (g_info,ext_vals,ext_tcs,rec_imp_fn) us2 imps
- >>= \ (vals2, tcs2, unquals2, fixes2, errs2, warns2, imps2) ->
- return (vals1 `unionBags` vals2,
- tcs1 `unionBags` tcs2,
- unquals1 `unionBags` unquals2,
- fixes1 `unionBags` fixes2,
- errs1 `unionBags` errs2,
- warns1 `unionBags` warns2,
- imps1 `unionBags` imps2)
- where
- add_new_one :: FiniteMap OrigName RnName -- ones done so far
- -> (dont_care, RnName)
- -> FiniteMap OrigName RnName -- extended
-
- add_new_one fm (_, rn)
- = let
- orig = origName "add_new_one" rn
- in
- case (lookupFM fm orig) of
- Just _ -> fm -- already there: no change
- Nothing -> addToFM fm orig rn
-
-----------------------
-doImport :: IfaceCache
- -> ImportNameInfo
- -> UniqSupply
- -> RdrNameImportDecl
- -> IO (Bag (RdrName,RnName), -- values
- Bag (RdrName,RnName), -- tycons/classes
- Bag (Module,RnName), -- unqual imports
- Bag RenamedFixityDecl,
- Bag Error,
- Bag Warning,
- Bag (RnName,(ExportFlag,Bag SrcLoc))) -- import flags and src locs
-
-doImport iface_cache info us (ImportDecl mod qual maybe_as maybe_spec src_loc)
- = --let
- -- (b_vals, b_tcs, maybe_spec')
- -- = (emptyBag, emptyBag, maybe_spec)
- --in
- --pprTrace "doImport:" (ppPStr mod) $
- cachedIface iface_cache False SLIT("doImport") mod >>= \ maybe_iface ->
- return (maybe_iface, \ iface -> getOrigIEs iface maybe_spec)
- >>= \ (maybe_iface, do_ies) ->
-
- case maybe_iface of
- Failed err ->
- return (emptyBag, emptyBag, emptyBag, emptyBag,
- unitBag err, emptyBag, emptyBag)
- Succeeded iface ->
- let
- (ies, chk_ies, get_errs) = do_ies iface
- in
- doOrigIEs iface_cache info mod src_loc us ies
- >>= \ (ie_vals, ie_tcs, imp_flags, errs, warns) ->
- accumulate (map (checkOrigIE iface_cache) chk_ies)
- >>= \ chk_errs_warns ->
- let
- fold_ies = foldBag unionBags pair_occ emptyBag
-
- final_vals = {-OLD:mapBag fst_occ b_vals `unionBags`-} fold_ies ie_vals
- final_tcs = {-OLD:mapBag fst_occ b_tcs `unionBags`-} fold_ies ie_tcs
- final_vals_list = bagToList final_vals
- in
- accumulate (map (getFixityDecl iface_cache . snd) final_vals_list)
- >>= \ fix_maybes_errs ->
- let
- (chk_errs, chk_warns) = unzip chk_errs_warns
- (fix_maybes, fix_errs) = unzip fix_maybes_errs
-
- unquals = if qual{-ified import-}
- then emptyBag
- else mapBag pair_as (ie_vals `unionBags` ie_tcs)
-
- final_fixes = listToBag (catMaybes fix_maybes)
-
- final_errs = mapBag (\ err -> err mod src_loc) (unionManyBags (get_errs:chk_errs))
- `unionBags` errs `unionBags` unionManyBags fix_errs
- final_warns = mapBag (\ warn -> warn mod src_loc) (unionManyBags chk_warns)
- `unionBags` warns
- imp_stuff = mapBag (\ (n,imp) -> (n,(imp,unitBag src_loc))) imp_flags
- in
- return (final_vals, final_tcs, unquals, final_fixes,
- final_errs, final_warns, imp_stuff)
- where
- as_mod :: Module
- as_mod = case maybe_as of {Nothing -> mod; Just as_this -> as_this}
-
- mk_occ :: FAST_STRING -> RdrName
- mk_occ str = if qual then Qual as_mod str else Unqual str
-
- fst_occ :: (FAST_STRING, RnName) -> (RdrName, RnName)
- fst_occ (str, rn) = (mk_occ str, rn)
-
- pair_occ :: RnName -> Bag (RdrName, RnName)
- pair_occ rn
- = let
- str = getLocalName rn
- qual_bag = unitBag (Qual as_mod str, rn)
- in
- if qual
- then qual_bag
- else qual_bag -- the qualified name is *also* visible
- `snocBag` (Unqual str, rn)
-
-
- pair_as :: RnName -> (Module, RnName)
- pair_as rn = (as_mod, rn)
-
------------------------------
-{-
-getBuiltins :: ImportNameInfo
- -> Module
- -> Maybe (Bool, [RdrNameIE])
- -> (Bag (FAST_STRING, RnName),
- Bag (FAST_STRING, RnName),
- Maybe (Bool, [RdrNameIE]) -- return IEs that had no effect
- )
-
-getBuiltins _ modname maybe_spec
--- | modname `notElem` modulesWithBuiltins
- = (emptyBag, emptyBag, maybe_spec)
-
-getBuiltins (((b_val_names,b_tc_names),_,_,_),_,_,_) modname maybe_spec
- = case maybe_spec of
- Nothing -> (all_vals, all_tcs, Nothing)
-
- Just (True, ies) -> -- hiding does not work for builtin names
- trace "NOTE: `import Prelude hiding ...' does not hide built-in names" $
- (all_vals, all_tcs, maybe_spec)
-
- Just (False, ies) -> let
- (vals,tcs,ies_left) = do_builtin ies
- in
- (vals, tcs, Just (False, ies_left))
- where
- all_vals = do_all_builtin (fmToList b_val_names)
- all_tcs = do_all_builtin (fmToList b_tc_names)
-
- do_all_builtin [] = emptyBag
- do_all_builtin (((OrigName mod str),rn):rest)
- = --pprTrace "do_all_builtin:" (ppCat [ppPStr modname, ppPStr mod, ppPStr str]) $
- (if mod == modname then consBag (str, rn) else id) (do_all_builtin rest)
-
- do_builtin [] = (emptyBag,emptyBag,[])
- do_builtin (ie:ies)
- = let
- (str, orig)
- = case (ie_name ie) of
- Unqual s -> (s, OrigName modname s)
- Qual m s -> --pprTrace "do_builtin:surprising qual!" (ppCat [ppPStr m, ppPStr s]) $
- (s, OrigName modname s)
- in
- case (lookupFM b_tc_names orig) of -- NB: we favour the tycon/class FM...
- Just rn -> case (ie,rn) of
- (IEThingAbs _, WiredInTyCon tc)
- -> (vals, (str, rn) `consBag` tcs, ies_left)
- (IEThingAll _, WiredInTyCon tc)
- -> (listToBag (map (\ id -> (getLocalName id, WiredInId id))
- (tyConDataCons tc))
- `unionBags` vals,
- (str,rn) `consBag` tcs, ies_left)
- (IEThingWith _ _, WiredInTyCon tc) -- No checking of With...
- -> (listToBag (map (\ id -> (nameOf (origName "IEThingWith" id), WiredInId id))
- (tyConDataCons tc))
- `unionBags` vals,
- (str,rn) `consBag` tcs, ies_left)
- _ -> panic "importing builtin names (1)"
-
- Nothing ->
- case (lookupFM b_val_names orig) of
- Nothing -> (vals, tcs, ie:ies_left)
- Just rn -> case (ie,rn) of
- (IEVar _, WiredInId _)
- -> ((str, rn) `consBag` vals, tcs, ies_left)
- _ -> panic "importing builtin names (2)"
- where
- (vals, tcs, ies_left) = do_builtin ies
--}
-
--------------------------
-getOrigIEs :: ParsedIface
- -> Maybe (Bool, [RdrNameIE]) -- "hiding" or not, blah, blah, blah
- -> ([IE OrigName],
- [(IE OrigName, ExportFlag)],
- Bag (Module -> SrcLoc -> Error))
-
-getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) Nothing -- import all
- = (map mkAllIE (eltsFM exps), [], emptyBag)
-
-getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (True, ies)) -- import hiding
- = (map mkAllIE (eltsFM exps_left), found_ies, errs)
- where
- (found_ies, errs) = lookupIEs exps ies
- exps_left = delListFromFM exps (map (getLocalName.ie_name.fst) found_ies)
+%************************************************************************
+%* *
+\subsection{Export list processing
+%* *
+%************************************************************************
-getOrigIEs (ParsedIface _ _ _ _ _ _ exps _ _ _ _ _ _) (Just (False, ies)) -- import these
- = (map fst found_ies, found_ies, errs)
- where
- (found_ies, errs) = lookupIEs exps ies
-
-------------------------------------------------
-mkAllIE :: (OrigName, ExportFlag) -> IE OrigName
-
-mkAllIE (orig,ExportAbs)
- = --ASSERT(isLexCon (nameOf orig))
- -- the ASSERT is correct, but it is too easy to
- -- trigger when writing .hi files by hand (e.g.
- -- when hackily breaking a module loop)
- IEThingAbs orig
-mkAllIE (orig, ExportAll)
- | isLexCon name_orig || isLexSpecialSym name_orig
- = IEThingAll orig
- | otherwise
- = IEVar orig
- where
- name_orig = nameOf orig
+The @AvailEnv@ type is just used internally in @exportsFromAvail@.
+When exporting we need to combine the availabilities for a particular
+exported thing, and we also need to check for name clashes -- that
+is: two exported things must have different @OccNames@.
-------------
-lookupIEs :: ExportsMap
- -> [RdrNameIE]
- -> ([(IE OrigName, ExportFlag)], -- IEs we found, orig-ified
- Bag (Module -> SrcLoc -> Error))
+\begin{code}
+type AvailEnv = FiniteMap OccName (RdrNameIE, AvailInfo)
+ -- The FM maps each OccName to the RdrNameIE that gave rise to it,
+ -- for error reporting, as well as to its AvailInfo
-lookupIEs exps ies
- = foldr go ([], emptyBag) ies
- where
- go ie (already, errs)
- = let
- str = case (ie_name ie) of
- Unqual s -> s
- Qual m s -> s
- in
- case (lookupFM exps str) of
- Nothing ->
- (already, unknownImpSpecErr ie `consBag` errs)
- Just (orig, flag) ->
- ((orig_ie orig ie, flag) : already,
- adderr_if (seen_ie orig already) (duplicateImpSpecErr ie) errs)
-
- orig_ie orig (IEVar n) = IEVar orig
- orig_ie orig (IEThingAbs n) = IEThingAbs orig
- orig_ie orig (IEThingAll n) = IEThingAll orig
- orig_ie orig (IEThingWith n ns) = IEThingWith orig (map re_orig ns)
- where
- (OrigName mod _) = orig
- re_orig (Unqual s) = OrigName mod s
-
- seen_ie orig seen_ies = any (\ (ie,_) -> orig == ie_name ie) seen_ies
-
---------------------------------------------
-doOrigIEs iface_cache info mod src_loc us []
- = return (emptyBag,emptyBag,emptyBag,emptyBag,emptyBag)
-
-doOrigIEs iface_cache info mod src_loc us (ie:ies)
- = let
- (us1, us2) = splitUniqSupply us
- in
- doOrigIE iface_cache info mod src_loc us1 ie
- >>= \ (vals1, tcs1, imps1, errs1, warns1) ->
- doOrigIEs iface_cache info mod src_loc us2 ies
- >>= \ (vals2, tcs2, imps2, errs2, warns2) ->
- return (vals1 `unionBags` vals2,
- tcs1 `unionBags` tcs2,
- imps1 `unionBags` imps2,
- errs1 `unionBags` errs2,
- warns1 `unionBags` warns2)
-
-----------------------
-doOrigIE :: IfaceCache
- -> ImportNameInfo
- -> Module
- -> SrcLoc
- -> UniqSupply
- -> IE OrigName
- -> IO (Bag RnName, -- values
- Bag RnName, -- tycons/classes
- Bag (RnName,ExportFlag), -- import flags
- Bag Error,
- Bag Warning)
-
-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 $
- pushSrcLocRn src_loc $
- 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@(WiredInId _))) -- a builtin value brought into scope
- = (unitBag rn, emptyBag, emptyBag, emptyBag, emptyBag)
- avoided_fn (Just (Right rn@(WiredInTyCon tc)))
- -- a builtin tc brought into scope; we also must bring its
- -- data constructors into scope
- = --pprTrace "avoided:Right:" (ppr PprDebug rn) $
- (listToBag [WiredInId dc | dc <- tyConDataCons tc], unitBag rn, emptyBag, emptyBag, emptyBag)
-
--------------------------
-checkOrigIE :: IfaceCache
- -> (IE OrigName, ExportFlag)
- -> IO (Bag (Module -> SrcLoc -> Error), Bag (Module -> SrcLoc -> Warning))
-
-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))
- other -> (unitBag (allWhenAbsImpSpecErr n), emptyBag))
-
-checkOrigIE iface_cache (IEThingWith n ns, ExportAbs)
- = return (unitBag (withWhenAbsImpSpecErr n), emptyBag)
-
-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)
- DataSig _ cons fields _ _ -> (check_with "constructors (and fields)" (cons++fields) ns, emptyBag)
- ClassSig _ ops _ _ -> (check_with "class ops" ops ns, emptyBag))
- where
- check_with str has origs
- | sortLt (<) (map getLocalName has) == sortLt (<) (map nameOf origs)
- = emptyBag
- | otherwise
- = unitBag (withImpSpecErr str n has origs)
-
-checkOrigIE iface_cache other
- = return (emptyBag, emptyBag)
-
------------------------
-with_decl :: IfaceCache
- -> OrigName
- -> (Maybe (Either RnName RnName) -> something) -- if avoided..
- -> (Error -> something) -- if an error...
- -> (RdrIfaceDecl -> something) -- if OK...
- -> IO something
-
-with_decl iface_cache n do_avoid do_err do_decl
- = cachedDecl iface_cache (isLexCon n_name || isLexSpecialSym n_name) n >>= \ maybe_decl ->
- case maybe_decl of
- CachingAvoided info -> return (do_avoid info)
- CachingFail err -> return (do_err err)
- CachingHit decl -> return (do_decl decl)
- where
- n_name = nameOf n
+emptyAvailEnv = emptyFM
--------------
-getFixityDecl :: IfaceCache
- -> RnName
- -> IO (Maybe RenamedFixityDecl, Bag Error)
+unitAvailEnv :: RdrNameIE -> AvailInfo -> AvailEnv
+unitAvailEnv ie NotAvailable
+ = emptyFM
+unitAvailEnv ie avail@(Avail n ns)
+ = unitFM (nameOccName n) (ie,avail)
-getFixityDecl iface_cache rn
- = let
- (OrigName mod str) = origName "getFixityDecl" rn
+plusAvailEnv a1 a2
+ = mapRn (addErrRn.availClashErr) (conflictsFM bad_avail a1 a2) `thenRn_`
+ returnRn (plusFM_C plus_avail a1 a2)
- succeeded infx i = return (Just (infx rn i), emptyBag)
- in
- cachedIface iface_cache True str mod >>= \ maybe_iface ->
- case maybe_iface of
- Failed err ->
- return (Nothing, unitBag err)
- Succeeded (ParsedIface _ _ _ _ _ _ _ _ fixes _ _ _ _) ->
- case lookupFM fixes str of
- Nothing -> return (Nothing, emptyBag)
- Just (InfixL _ i) -> succeeded InfixL i
- Just (InfixR _ i) -> succeeded InfixR i
- Just (InfixN _ i) -> succeeded InfixN i
-
-ie_name (IEVar n) = n
-ie_name (IEThingAbs n) = n
-ie_name (IEThingAll n) = n
-ie_name (IEThingWith n _) = n
-
-adderr_if True err errs = err `consBag` errs
-adderr_if False err errs = errs
+listToAvailEnv :: RdrNameIE -> [AvailInfo] -> RnM s d AvailEnv
+listToAvailEnv ie items
+ = foldlRn plusAvailEnv emptyAvailEnv (map (unitAvailEnv ie) items)
+
+bad_avail (ie1,Avail n1 _) (ie2,Avail n2 _) = n1 /= n2 -- Same OccName, different Name
+plus_avail (ie1,a1) (ie2,a2) = (ie1, a1 `plusAvail` a2)
\end{code}
-*********************************************************
-* *
-\subsection{Actually creating the imported names}
-* *
-*********************************************************
\begin{code}
-getIfaceDeclNames :: IE OrigName -> RdrIfaceDecl
- -> RnM_IInfo s (Bag RnName, -- values
- Bag RnName, -- tycons/classes
- Bag (RnName,ExportFlag)) -- import flags
-
-getIfaceDeclNames ie (ValSig val src_loc _)
- = newImportedName False src_loc Nothing Nothing val `thenRn` \ val_name ->
- returnRn (unitBag (RnName val_name),
- emptyBag,
- unitBag (RnName val_name, ExportAll))
-
-getIfaceDeclNames ie (TypeSig tycon src_loc _)
- = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
- returnRn (emptyBag,
- unitBag (RnSyn tycon_name),
- unitBag (RnSyn tycon_name, ExportAll))
-
-getIfaceDeclNames ie (NewTypeSig tycon con src_loc _)
- = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
- newImportedName False src_loc (Just (nameExportFlag tycon_name))
- (Just (nameImportFlag tycon_name))
- con `thenRn` \ con_name ->
- returnRn (if imp_all (imp_flag ie) then
- unitBag (RnConstr con_name tycon_name)
- else
- emptyBag,
- unitBag (RnData tycon_name [con_name] []),
- unitBag (RnData tycon_name [con_name] [], imp_flag ie))
-
-getIfaceDeclNames ie (DataSig tycon cons fields src_loc _)
- = newImportedName True src_loc Nothing Nothing tycon `thenRn` \ tycon_name ->
- let
- map_me = mapRn (newImportedName False src_loc
- (Just (nameExportFlag tycon_name))
- (Just (nameImportFlag tycon_name)))
- in
- map_me cons `thenRn` \ con_names ->
- map_me fields `thenRn` \ field_names ->
+exportsFromAvail :: Module
+ -> Maybe [RdrNameIE] -- Export spec
+ -> ModuleAvails
+ -> RnEnv
+ -> RnMG (Name -> ExportFlag, ExportEnv)
+ -- Complains if two distinct exports have same OccName
+ -- Complains about exports items not in scope
+exportsFromAvail this_mod Nothing all_avails rn_env
+ = exportsFromAvail this_mod (Just [IEModuleContents this_mod]) all_avails rn_env
+
+exportsFromAvail this_mod (Just export_items) all_avails (RnEnv name_env fixity_env)
+ = mapRn exports_from_item export_items `thenRn` \ avail_envs ->
+ foldlRn plusAvailEnv emptyAvailEnv avail_envs `thenRn` \ export_avail_env ->
let
- rn_tycon = RnData tycon_name con_names field_names
- rn_constrs = [ RnConstr name tycon_name | name <- con_names ]
- rn_fields = [ RnField name tycon_name | name <- field_names ]
+ export_avails = map snd (eltsFM export_avail_env)
+ export_fixities = mk_exported_fixities (availsToNameSet export_avails)
+ export_fn = mk_export_fn export_avails
in
- returnRn (if imp_all (imp_flag ie) then
- listToBag rn_constrs `unionBags` listToBag rn_fields
- else
- emptyBag,
- unitBag rn_tycon,
- unitBag (rn_tycon, imp_flag ie))
-
-getIfaceDeclNames ie (ClassSig cls ops src_loc _)
- = newImportedName True src_loc Nothing Nothing cls `thenRn` \ cls_name ->
- mapRn (newImportedName False src_loc (Just (nameExportFlag cls_name))
- (Just (nameImportFlag cls_name)))
- ops `thenRn` \ op_names ->
- returnRn (if imp_all (imp_flag ie) then
- listToBag (map (\ n -> RnClassOp n cls_name) op_names)
- else
- emptyBag,
- unitBag (RnClass cls_name op_names),
- unitBag (RnClass cls_name op_names, imp_flag ie))
-
-
-imp_all ExportAll = True
-imp_all _ = False
-
-imp_flag (IEThingAbs _) = ExportAbs
-imp_flag (IEThingAll _) = ExportAll
-imp_flag (IEThingWith _ _) = ExportAll
-\end{code}
+ returnRn (export_fn, ExportEnv export_avails export_fixities)
-*********************************************************
-* *
-\subsection{Creating a new imported name}
-* *
-*********************************************************
+ where
+ full_avail_env :: UniqFM AvailInfo
+ full_avail_env = addListToUFM_C plusAvail emptyUFM
+ [(name,avail) | avail@(Avail name _) <- concat (eltsFM all_avails)]
+ -- NB: full_avail_env won't contain bindings for data constructors and class ops,
+ -- which is right and proper; attempts to export them on their own will provoke an error
+
+ exports_from_item :: RdrNameIE -> RnMG AvailEnv
+ exports_from_item ie@(IEModuleContents mod)
+ = case lookupFM all_avails mod of
+ Nothing -> failWithRn emptyAvailEnv (modExportErr mod)
+ Just avails -> addOccurrenceNames Compulsory [n | Avail n _ <- avails] `thenRn_`
+ listToAvailEnv ie avails
+
+ exports_from_item ie
+ | not (maybeToBool maybe_in_scope)
+ = failWithRn emptyAvailEnv (unknownNameErr (ieName ie))
+
+#ifdef DEBUG
+ -- I can't see why this should ever happen; if the thing is in scope
+ -- at all it ought to have some availability
+ | not (maybeToBool maybe_avail)
+ = pprTrace "exportsFromAvail: curious Nothing:" (ppr PprDebug name)
+ returnRn emptyAvailEnv
+#endif
+
+ | not enough_avail
+ = failWithRn emptyAvailEnv (exportItemErr ie export_avail)
+
+ | otherwise -- Phew! It's OK!
+ = addOccurrenceName Compulsory name `thenRn_`
+ returnRn (unitAvailEnv ie export_avail)
+ where
+ maybe_in_scope = lookupNameEnv name_env (ieName ie)
+ Just name = maybe_in_scope
+ maybe_avail = lookupUFM full_avail_env name
+ Just avail = maybe_avail
+ export_avail = filterAvail ie avail
+ enough_avail = case export_avail of {NotAvailable -> False; other -> True}
+
+ -- We export a fixity iff we export a thing with the same (qualified) RdrName
+ mk_exported_fixities :: NameSet -> [(OccName, Fixity, Provenance)]
+ mk_exported_fixities exports
+ = [ (rdrNameOcc rdr_name, fixity, prov)
+ | (rdr_name, (fixity, prov)) <- fmToList fixity_env,
+ export_fixity name_env exports rdr_name
+ ]
+
+mk_export_fn :: [AvailInfo] -> (Name -> ExportFlag)
+mk_export_fn avails
+ = \name -> if name `elemNameSet` exported_names
+ then Exported
+ else NotExported
+ where
+ exported_names :: NameSet
+ exported_names = availsToNameSet avails
+
+export_fixity :: NameEnv -> NameSet -> RdrName -> Bool
+export_fixity name_env exports (Unqual _)
+ = False -- The qualified fixity is always there as well
+export_fixity name_env exports rdr_name@(Qual _ occ)
+ = case lookupFM name_env rdr_name of
+ Just fixity_name -> fixity_name `elemNameSet` exports
+ -- Check whether the exported thing is
+ -- the one to which the fixity attaches
+ other -> False -- Not even in scope
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Errors}
+%* *
+%************************************************************************
\begin{code}
-newImportedName :: Bool -- True => tycon or class
- -> SrcLoc
- -> Maybe ExportFlag -- maybe export flag
- -> Maybe ExportFlag -- maybe import flag
- -> RdrName -- orig name
- -> RnM_IInfo s Name
-
-newImportedName tycon_or_class locn maybe_exp maybe_imp rdr
- = let
- orig = qualToOrigName rdr
- in
- getExtraRn `thenRn` \ ((_,b_keys,rec_exp_fn,rec_occ_fn),done_vals,done_tcs,rec_imp_fn) ->
- case ((if tycon_or_class
- then lookupFM done_tcs
- else lookupFM done_vals) orig) of
-
- Just rn -> returnRn (getName rn)
- Nothing ->
- rnGetUnique `thenRn` \ u ->
- let
- uniq = case lookupFM b_keys orig of
- Nothing -> u
- Just (key,_) -> key
-
- exp = case maybe_exp of
- Just xx -> xx
- Nothing -> rec_exp_fn n
-
- imp = case maybe_imp of
- Just xx -> xx
- Nothing -> imp_flag
-
- (imp_flag, imp_locs) = rec_imp_fn n
-
- n = mkImportedName uniq orig imp locn imp_locs exp (rec_occ_fn n) -- NB: two "n"s
- in
- returnRn n
-\end{code}
+ieOcc ie = rdrNameOcc (ieName ie)
-\begin{code}
-globalDupNamesErr rdr rns sty
- = ppAboves (message : map pp_dup rns)
- where
- message = ppBesides [ppStr "multiple declarations of `", pprNonSym sty rdr, ppStr "'"]
-
- pp_dup rn = addShortErrLocLine (get_loc rn) (\ sty ->
- ppCat [pp_descrip rn, pprNonSym sty rn]) sty
-
- get_loc rn = case getImpLocs rn of
- [] -> getSrcLoc rn
- locs -> head locs
-
- pp_descrip (RnName _) = ppStr "as a value:"
- pp_descrip (RnSyn _) = ppStr "as a type synonym:"
- pp_descrip (RnData _ _ _) = ppStr "as a data type:"
- pp_descrip (RnConstr _ _) = ppStr "as a data constructor:"
- pp_descrip (RnField _ _) = ppStr "as a record field:"
- pp_descrip (RnClass _ _) = ppStr "as a class:"
- pp_descrip (RnClassOp _ _) = ppStr "as a class method:"
- pp_descrip _ = ppNil
-
-dupImportWarn (ImportDecl m1 _ _ _ locn1 : dup_imps) sty
- = ppAboves (item1 : map dup_item dup_imps)
- where
- item1 = addShortWarnLocLine locn1 (\ sty ->
- ppCat [ppStr "multiple imports from module", ppPStr m1]) sty
+badImportItemErr mod ie sty
+ = ppSep [ppStr "Module", pprModule sty mod, ppStr "does not export", ppr sty ie]
- dup_item (ImportDecl m _ _ _ locn)
- = addShortWarnLocLine locn (\ sty ->
- ppCat [ppStr "here was another import from module", ppPStr m]) sty
+modExportErr mod sty
+ = ppCat [ ppStr "Unknown module in export list: module", ppPStr mod]
-qualPreludeImportWarn (ImportDecl m _ _ _ locn)
- = addShortWarnLocLine locn (\ sty ->
- ppCat [ppStr "qualified import of prelude module", ppPStr m])
+exportItemErr export_item NotAvailable sty
+ = ppSep [ ppStr "Export item not in scope:", ppr sty export_item ]
-dupQualImportErr ((q1,ImportDecl _ _ _ _ locn1):dup_quals) sty
- = ppAboves (item1 : map dup_item dup_quals)
- where
- item1 = addShortErrLocLine locn1 (\ sty ->
- ppCat [ppStr "multiple imports (from different modules) with same qualified name", ppPStr q1]) sty
-
- dup_item (q,ImportDecl _ _ _ _ locn)
- = addShortErrLocLine locn (\ sty ->
- ppCat [ppStr "here was another import with qualified name", ppPStr q]) sty
-
-unknownImpSpecErr ie imp_mod locn
- = addShortErrLocLine locn (\ sty ->
- ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " does not export `", ppr sty (ie_name ie), ppStr "'"])
-
-duplicateImpSpecErr ie imp_mod locn
- = addShortErrLocLine locn (\ sty ->
- ppBesides [ppStr "`", ppr sty (ie_name ie), ppStr "' already seen in import list"])
-
-allWhenSynImpSpecWarn n imp_mod locn
- = addShortWarnLocLine locn (\ sty ->
- ppBesides [ppStr "type synonym `", ppr sty n, ppStr "' should not be imported with (..)"])
-
-allWhenAbsImpSpecErr n imp_mod locn
- = addShortErrLocLine locn (\ sty ->
- ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"])
-
-withWhenAbsImpSpecErr n imp_mod locn
- = addShortErrLocLine locn (\ sty ->
- ppBesides [ppStr "module ", ppPStr imp_mod, ppStr " only exports `", ppr sty n, ppStr "' abstractly"])
-
-withImpSpecErr str n has ns imp_mod locn
- = addErrLoc locn "" (\ sty ->
- ppAboves [ ppBesides [ppStr "inconsistent list of", ppStr str, ppStr "in import list for `", ppr sty n, ppStr "'"],
- ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)],
- ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) ns)] ])
-
-dupFieldErr con locn (dup:rest)
- = addShortErrLocLine locn (\ sty ->
- ppBesides [ppStr "record field `", ppr sty dup, ppStr "declared multiple times in `", ppr sty con, ppStr "'"])
+exportItemErr export_item avail sty
+ = ppHang (ppStr "Export item not fully in scope:")
+ 4 (ppAboves [ppCat [ppStr "Wanted: ", ppr sty export_item],
+ ppCat [ppStr "Available: ", ppr sty (ieOcc export_item), pprAvail sty avail]])
+
+availClashErr (occ_name, ((ie1,avail1), (ie2,avail2))) sty
+ = ppHang (ppCat [ppStr "Conflicting exports for local name: ", ppr sty occ_name])
+ 4 (ppAboves [ppr sty ie1, ppr sty ie2])
\end{code}
+
\begin{code}
#include "HsVersions.h"
-module RnSource ( rnSource, rnTyDecl, rnClassDecl, rnInstDecl, rnPolyType ) where
+module RnSource ( rnDecl, rnHsType ) where
IMP_Ubiq()
IMPORT_DELOOPER(RnLoop) -- *check* the RnPass/RnExpr/RnBinds loop-breaking
-IMPORT_1_3(List(partition))
import HsSyn
+import HsDecls ( HsIdInfo(..) )
import HsPragmas
+import HsTypes ( getTyVarName )
import RdrHsSyn
import RnHsSyn
-import RnMonad
+import HsCore
+
import RnBinds ( rnTopBinds, rnMethodBinds )
-import RnUtils ( getLocalsFromRnEnv, lookupGlobalRnEnv, lubExportFlag )
+import RnEnv ( bindTyVarsRn, lookupRn, lookupOccRn, lookupImplicitOccRn, bindLocalsRn,
+ lookupOptionalOccRn, newDfunName,
+ listType_RDR, tupleType_RDR )
+import RnMonad
-import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
-import Class ( derivableClassKeys )
-import CmdLineOpts ( opt_CompilingGhcInternals )
+import Name ( Name, isLocallyDefined, isTvOcc, pprNonSym,
+ Provenance,
+ SYN_IE(NameSet), unionNameSets, emptyNameSet, mkNameSet, unitNameSet,
+ elemNameSet
+ )
import ErrUtils ( addErrLoc, addShortErrLocLine, addShortWarnLocLine )
import FiniteMap ( emptyFM, lookupFM, addListToFM_C )
-import Id ( isDataCon, GenId{-instance NamedThing-} )
+import Id ( GenId{-instance NamedThing-} )
+import IdInfo ( IdInfo, StrictnessInfo(..), FBTypeInfo, DemandInfo, ArgUsageInfo )
+import SpecEnv ( SpecEnv )
+import CoreUnfold ( Unfolding(..), SimpleUnfolding )
+import MagicUFs ( MagicUnfoldingFun )
+import PrelInfo ( derivingOccurrences, evalClass_RDR, numClass_RDR )
import ListSetOps ( unionLists, minusList )
import Maybes ( maybeToBool, catMaybes )
-import Name ( isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..),
- nameImportFlag, RdrName, pprNonSym, Name )
+import Bag ( emptyBag, unitBag, consBag, unionManyBags, unionBags, listToBag, bagToList )
import Outputable ( Outputable(..){-instances-} )
--import PprStyle -- ToDo:rm
import Pretty
import SrcLoc ( SrcLoc )
-import TyCon ( tyConDataCons, TyCon{-instance NamedThing-} )
+-- import TyCon ( TyCon{-instance NamedThing-} )
import Unique ( Unique )
-import UniqFM ( emptyUFM, addListToUFM_C, listToUFM, plusUFM, lookupUFM, eltsUFM )
import UniqSet ( SYN_IE(UniqSet) )
-import Util ( isIn, isn'tIn, thenCmp, sortLt, removeDups, mapAndUnzip3, cmpPString,
+import UniqFM ( UniqFM, lookupUFM )
+import Util ( isIn, isn'tIn, thenCmp, removeDups, cmpPString,
panic, assertPanic{- , pprTrace ToDo:rm-} )
\end{code}
-rnSource `renames' the source module and export list.
+rnDecl `renames' declarations.
It simultaneously performs dependency analysis and precedence parsing.
It also does the following error checks:
\begin{enumerate}
\end{enumerate}
-\begin{code}
-rnSource :: [Module] -- imported modules
- -> Bag (Module,RnName) -- unqualified imports from module
- -> Bag RenamedFixityDecl -- fixity info for imported names
- -> RdrNameHsModule
- -> RnM s (RenamedHsModule,
- Name -> ExportFlag, -- export info
- ([(Name, ExportFlag)], -- export module X stuff
- [(Name, ExportFlag)]),
- Bag (RnName, RdrName)) -- occurrence info
-
-rnSource imp_mods unqual_imps imp_fixes
- (HsModule mod version exports _ fixes
- ty_decls specdata_sigs class_decls
- inst_decls specinst_sigs defaults
- binds _ src_loc)
-
- = pushSrcLocRn src_loc $
-
- rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ (exported_fn, module_dotdots) ->
- rnFixes fixes `thenRn` \ src_fixes ->
- let
- all_fixes = src_fixes ++ bagToList imp_fixes
- all_fixes_fm = listToUFM (map pair_name all_fixes)
-
- pair_name inf = (fixDeclName inf, inf)
- in
- setExtraRn all_fixes_fm $
-
- mapRn rnTyDecl ty_decls `thenRn` \ new_ty_decls ->
- mapRn rnSpecDataSig specdata_sigs `thenRn` \ new_specdata_sigs ->
- mapRn rnClassDecl class_decls `thenRn` \ new_class_decls ->
- mapRn rnInstDecl inst_decls `thenRn` \ new_inst_decls ->
- mapRn rnSpecInstSig specinst_sigs `thenRn` \ new_specinst_sigs ->
- rnDefaultDecl defaults `thenRn` \ new_defaults ->
- rnTopBinds binds `thenRn` \ new_binds ->
-
- getOccurrenceUpRn `thenRn` \ occ_info ->
-
- returnRn (
- HsModule mod version
- trashed_exports trashed_imports all_fixes
- new_ty_decls new_specdata_sigs new_class_decls
- new_inst_decls new_specinst_sigs new_defaults
- new_binds [] src_loc,
- exported_fn, module_dotdots,
- occ_info
- )
- where
- trashed_exports = {-trace "rnSource:trashed_exports"-} Nothing
- trashed_imports = {-trace "rnSource:trashed_imports"-} []
-\end{code}
-
-
%*********************************************************
%* *
-\subsection{Export list}
+\subsection{Value declarations}
%* *
%*********************************************************
\begin{code}
-rnExports :: [Module]
- -> Bag (Module,RnName)
- -> Maybe [RdrNameIE]
- -> RnM s (Name -> ExportFlag, -- main export-flag fun
- ([(Name,ExportFlag)], -- info about "module X" exports
- [(Name,ExportFlag)])
- )
-
-rnExports mods unqual_imps Nothing
- = returnRn (\n -> if isLocallyDefined n then ExportAll else NotExported
- , ([], [])
- )
-
-rnExports mods unqual_imps (Just exps)
- = 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)
- val_names = bagToList (unionManyBags val_bags)
- exp_mods = catMaybes mod_maybes
-
- -- Warn for duplicate names and modules
- (_, dup_tc_names) = removeDups cmp_fst tc_names
- (_, dup_val_names) = removeDups cmp_fst val_names
- 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 "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 expmods_imps of
- (tcs, vals, emptys) -> (concat tcs, concat vals, catMaybes emptys)
-
- (unqual_tcs, unqual_vals) = partition (isRnTyConOrClass.snd) (bagToList unqual_imps)
-
- get_mod_names mod
- = --pprTrace "get_mod_names" (ppAboves [ppPStr mod, interpp'SP PprDebug (map fst tcs), interpp'SP PprDebug (map fst vals)]) $
- (tcs, vals, empty_mod)
- where
- tcs = [(getName rn, nameImportFlag (getName rn))
- | (mod',rn) <- unqual_tcs, mod == mod']
- vals = [(getName rn, nameImportFlag (getName rn))
- | (mod',rn) <- unqual_vals, mod == mod', fun_looking rn]
- empty_mod = if null tcs && null vals
- then Just mod
- else Nothing
-
- -- fun_looking: must avoid class ops and data constructors
- -- and record fieldnames
- fun_looking (RnName _) = True
- fun_looking (WiredInId i) = not (isDataCon i)
- fun_looking _ = False
-
- -- Build finite map of exported names to export flag
- tc_map0 = addListToUFM_C lub_expflag emptyUFM (map pair_fst tc_names)
- 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_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 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
- tc_locals = [(getLocalName n, n) | (n,_) <- eltsUFM tc_map]
- val_locals = [(getLocalName n, n) | (n,_) <- eltsUFM val_map]
- (_, dup_tc_locals) = removeDups cmp_local tc_locals
- (_, dup_val_locals) = removeDups cmp_local val_locals
- cmp_local (x,_) (y,_) = x `cmpPString` y
-
- -- 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
- in
- getSrcLocRn `thenRn` \ src_loc ->
- mapRn (addWarnRn . dupNameExportWarn src_loc) dup_tc_names `thenRn_`
- mapRn (addWarnRn . dupNameExportWarn src_loc) dup_val_names `thenRn_`
- mapRn (addWarnRn . dupModExportWarn src_loc) dup_mods `thenRn_`
- mapRn (addWarnRn . emptyModExportWarn src_loc) empty_mods `thenRn_`
- mapRn (addErrRn . dupLocalsExportErr src_loc) dup_tc_locals `thenRn_`
- mapRn (addErrRn . dupLocalsExportErr src_loc) dup_val_locals `thenRn_`
- returnRn (exp_fn, (mod_vals, mod_tcs))
-
-------------------------------------
--- rename an "IE" in the export list
-
-rnIE :: [Module] -- this module and all the (directly?) imported modules
- -> RdrNameIE
- -> RnM s (
- Maybe Module, -- Just m => a "module X" export item
- (Bag (Name, ExportFlag), -- Exported tycons/classes
- Bag (Name, ExportFlag))) -- Exported values
-
-rnIE mods (IEVar name)
- = lookupValue name `thenRn` \ rn ->
- checkIEVar rn `thenRn` \ exps ->
- returnRn (Nothing, exps)
- where
- 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@(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 (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 ->
- checkIEAll rn `thenRn` \ exps ->
- 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 (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)
-
-rnIE mods (IEThingWith name names)
- = lookupTyConOrClass name `thenRn` \ rn ->
- mapRn lookupValue names `thenRn` \ rns ->
- checkIEWith rn rns `thenRn` \ exps ->
- checkImportAll rn `thenRn_`
- returnRn (Nothing, exps)
- where
- checkIEWith rn@(RnData n cons fields) rns
- | same_names (cons++fields) rns
- = returnRn (unitBag (exp_all n), listToBag (map exp_all cons)
- `unionBags`
- listToBag (map exp_all fields))
- | otherwise
- = rnWithErr "constructors (and fields)" rn (cons++fields) rns
- checkIEWith rn@(RnClass n ops) rns
- | same_names ops rns
- = returnRn (unitBag (exp_all n), listToBag (map exp_all ops))
- | otherwise
- = rnWithErr "class ops" rn ops rns
- 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
- = --pprTrace "rnIE:IEWith:panic? ToDo?:" (ppr PprDebug rn) $
- returnRn (emptyBag, emptyBag)
-
- exp_all n = (n, ExportAll)
-
- same_names has rns
- = all (not.isRnUnbound) rns &&
- sortLt (<) (map uniqueOf has) == sortLt (<) (map uniqueOf rns)
-
- rnWithErr str rn has rns
- = getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn (emptyBag, emptyBag) (withExportErr str rn has rns src_loc)
-
-rnIE mods (IEModuleContents mod)
- | isIn "rnIE:IEModule" mod mods
- = returnRn (Just mod, (emptyBag, emptyBag))
- | otherwise
- = getSrcLocRn `thenRn` \ src_loc ->
- failButContinueRn (Nothing, (emptyBag, emptyBag)) (badModExportErr mod src_loc)
-
-
-checkImportAll rn
- = case nameImportFlag (getName rn) of
- ExportAll -> returnRn ()
- exp -> getSrcLocRn `thenRn` \ src_loc ->
- addErrRn (importAllErr rn src_loc)
+rnDecl :: RdrNameHsDecl -> RnMS s RenamedHsDecl
+
+rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ new_binds ->
+ returnRn (ValD new_binds)
+
+
+rnDecl (SigD (IfaceSig name ty id_infos loc))
+ = pushSrcLocRn loc $
+ lookupRn name `thenRn` \ name' ->
+ rnHsType ty `thenRn` \ ty' ->
+ mapRn rnIdInfo id_infos `thenRn` \ id_infos' ->
+ returnRn (SigD (IfaceSig name' ty' id_infos' loc))
\end{code}
%*********************************************************
checks at the same time.
\begin{code}
-rnTyDecl :: RdrNameTyDecl -> RnM_Fixes s RenamedTyDecl
-
-rnTyDecl (TyData context tycon tyvars condecls derivings pragmas src_loc)
+rnDecl (TyD (TyData context tycon tyvars condecls derivings pragmas src_loc))
= pushSrcLocRn src_loc $
- lookupTyCon tycon `thenRn` \ tycon' ->
- mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
- rnContext tv_env src_loc context `thenRn` \ context' ->
- rnConDecls tv_env condecls `thenRn` \ condecls' ->
- rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
+ lookupRn tycon `thenRn` \ tycon' ->
+ bindTyVarsRn "data declaration" tyvars $ \ tyvars' ->
+ rnContext context `thenRn` \ context' ->
+ mapRn rnConDecl condecls `thenRn` \ condecls' ->
+ rnDerivs derivings `thenRn` \ derivings' ->
ASSERT(isNoDataPragmas pragmas)
- returnRn (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc)
+ returnRn (TyD (TyData context' tycon' tyvars' condecls' derivings' noDataPragmas src_loc))
-rnTyDecl (TyNew context tycon tyvars condecl derivings pragmas src_loc)
+rnDecl (TyD (TyNew context tycon tyvars condecl derivings pragmas src_loc))
= pushSrcLocRn src_loc $
- lookupTyCon tycon `thenRn` \ tycon' ->
- mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
- rnContext tv_env src_loc context `thenRn` \ context' ->
- rnConDecls tv_env condecl `thenRn` \ condecl' ->
- rn_derivs tycon' src_loc derivings `thenRn` \ derivings' ->
+ lookupRn tycon `thenRn` \ tycon' ->
+ bindTyVarsRn "newtype declaration" tyvars $ \ tyvars' ->
+ rnContext context `thenRn` \ context' ->
+ rnConDecl condecl `thenRn` \ condecl' ->
+ rnDerivs derivings `thenRn` \ derivings' ->
ASSERT(isNoDataPragmas pragmas)
- returnRn (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc)
+ returnRn (TyD (TyNew context' tycon' tyvars' condecl' derivings' noDataPragmas src_loc))
-rnTyDecl (TySynonym name tyvars ty src_loc)
+rnDecl (TyD (TySynonym name tyvars ty src_loc))
= pushSrcLocRn src_loc $
- lookupTyCon name `thenRn` \ name' ->
- mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env, tyvars') ->
- rnMonoType tv_env ty `thenRn` \ ty' ->
- returnRn (TySynonym name' tyvars' ty' src_loc)
-
-rn_derivs tycon2 locn Nothing -- derivs not specified
- = returnRn Nothing
-
-rn_derivs tycon2 locn (Just ds)
- = mapRn (rn_deriv tycon2 locn) ds `thenRn` \ derivs ->
- returnRn (Just derivs)
- where
- rn_deriv tycon2 locn clas
- = lookupClass clas `thenRn` \ clas_name ->
- addErrIfRn (uniqueOf clas_name `not_elem` derivableClassKeys)
- (derivingNonStdClassErr clas_name locn)
- `thenRn_`
- returnRn clas_name
- where
- not_elem = isn'tIn "rn_deriv"
-\end{code}
-
-@rnConDecls@ uses the `global name function' to create a new
-constructor in which local names have been replaced by their original
-names, reporting any unknown names.
-
-\begin{code}
-rnConDecls :: TyVarNamesEnv
- -> [RdrNameConDecl]
- -> RnM_Fixes s [RenamedConDecl]
-
-rnConDecls tv_env con_decls
- = mapRn rn_decl con_decls
- where
- rn_decl (ConDecl name tys src_loc)
- = pushSrcLocRn src_loc $
- lookupConstr name `thenRn` \ new_name ->
- mapRn rn_bang_ty tys `thenRn` \ new_tys ->
- returnRn (ConDecl new_name new_tys src_loc)
-
- rn_decl (ConOpDecl ty1 op ty2 src_loc)
- = pushSrcLocRn src_loc $
- lookupConstr op `thenRn` \ new_op ->
- rn_bang_ty ty1 `thenRn` \ new_ty1 ->
- rn_bang_ty ty2 `thenRn` \ new_ty2 ->
- returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
-
- rn_decl (NewConDecl name ty src_loc)
- = pushSrcLocRn src_loc $
- lookupConstr name `thenRn` \ new_name ->
- rn_mono_ty ty `thenRn` \ new_ty ->
- returnRn (NewConDecl new_name new_ty src_loc)
-
- rn_decl (RecConDecl name fields src_loc)
- = pushSrcLocRn src_loc $
- lookupConstr name `thenRn` \ new_name ->
- mapRn rn_field fields `thenRn` \ new_fields ->
- returnRn (RecConDecl new_name new_fields src_loc)
-
- rn_field (names, ty)
- = mapRn lookupField names `thenRn` \ new_names ->
- rn_bang_ty ty `thenRn` \ new_ty ->
- returnRn (new_names, new_ty)
-
- rn_mono_ty = rnMonoType tv_env
- rn_poly_ty = rnPolyType tv_env
-
- rn_bang_ty (Banged ty)
- = rn_poly_ty ty `thenRn` \ new_ty ->
- returnRn (Banged new_ty)
- rn_bang_ty (Unbanged ty)
- = rn_poly_ty ty `thenRn` \ new_ty ->
- returnRn (Unbanged new_ty)
-\end{code}
-
-%*********************************************************
-%* *
-\subsection{SPECIALIZE data pragmas}
-%* *
-%*********************************************************
-
-\begin{code}
-rnSpecDataSig :: RdrNameSpecDataSig
- -> RnM_Fixes s RenamedSpecDataSig
-
-rnSpecDataSig (SpecDataSig tycon ty src_loc)
- = pushSrcLocRn src_loc $
- let
- tyvars = extractMonoTyNames is_tyvar_name ty
- in
- mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
- lookupTyCon tycon `thenRn` \ tycon' ->
- rnMonoType tv_env ty `thenRn` \ ty' ->
- returnRn (SpecDataSig tycon' ty' src_loc)
-
-is_tyvar_name n = isLexVarId (getLocalName n)
+ lookupRn name `thenRn` \ name' ->
+ bindTyVarsRn "type declaration" tyvars $ \ tyvars' ->
+ rnHsType ty `thenRn` \ ty' ->
+ returnRn (TyD (TySynonym name' tyvars' ty' src_loc))
\end{code}
%*********************************************************
original names, reporting any unknown names.
\begin{code}
-rnClassDecl :: RdrNameClassDecl -> RnM_Fixes s RenamedClassDecl
-
-rnClassDecl (ClassDecl context cname tyvar sigs mbinds pragmas src_loc)
+rnDecl (ClD (ClassDecl context cname tyvar sigs mbinds pragmas src_loc))
= pushSrcLocRn src_loc $
- mkTyVarNamesEnv src_loc [tyvar] `thenRn` \ (tv_env, [tyvar']) ->
- rnContext tv_env src_loc context `thenRn` \ context' ->
- lookupClass cname `thenRn` \ cname' ->
- mapRn (rn_op cname' tyvar' tv_env) sigs `thenRn` \ sigs' ->
- rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
+ bindTyVarsRn "class declaration" [tyvar] $ \ [tyvar'] ->
+ rnContext context `thenRn` \ context' ->
+ lookupRn cname `thenRn` \ cname' ->
+ mapRn (rn_op cname' (getTyVarName tyvar')) sigs `thenRn` \ sigs' ->
+ rnMethodBinds mbinds `thenRn` \ mbinds' ->
ASSERT(isNoClassPragmas pragmas)
- returnRn (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc)
+ returnRn (ClD (ClassDecl context' cname' tyvar' sigs' mbinds' NoClassPragmas src_loc))
where
- rn_op clas clas_tyvar tv_env sig@(ClassOpSig op ty pragmas locn)
+ rn_op clas clas_tyvar sig@(ClassOpSig op ty pragmas locn)
= pushSrcLocRn locn $
- lookupClassOp clas op `thenRn` \ op_name ->
- rnPolyType tv_env ty `thenRn` \ new_ty ->
+ lookupRn op `thenRn` \ op_name ->
+ rnHsType ty `thenRn` \ new_ty ->
let
- (HsForAllTy tvs ctxt op_ty) = new_ty
- ctxt_tvs = extractCtxtTyNames ctxt
- op_tvs = extractMonoTyNames is_tyvar_name op_ty
+ (ctxt, op_ty) = case new_ty of
+ HsForAllTy tvs ctxt op_ty -> (ctxt, op_ty)
+ other -> ([], new_ty)
+ ctxt_fvs = extractCtxtTyNames ctxt
+ op_ty_fvs = extractHsTyNames op_ty -- Includes tycons/classes but we
+ -- don't care about that
in
-- check that class tyvar appears in op_ty
- ( if isIn "rn_op" clas_tyvar op_tvs
- then returnRn ()
- else addErrRn (classTyVarNotInOpTyErr clas_tyvar sig locn)
- ) `thenRn_`
+ checkRn (clas_tyvar `elemNameSet` op_ty_fvs)
+ (classTyVarNotInOpTyErr clas_tyvar sig)
+ `thenRn_`
-- check that class tyvar *doesn't* appear in the sig's context
- ( if isIn "rn_op(2)" clas_tyvar ctxt_tvs
- then addErrRn (classTyVarInOpCtxtErr clas_tyvar sig locn)
- else returnRn ()
- ) `thenRn_`
+ checkRn (not (clas_tyvar `elemNameSet` ctxt_fvs))
+ (classTyVarInOpCtxtErr clas_tyvar sig)
+ `thenRn_`
ASSERT(isNoClassOpPragmas pragmas)
returnRn (ClassOpSig op_name new_ty noClassOpPragmas locn)
%* *
%*********************************************************
-
-@rnInstDecl@ uses the `global name function' to create a new of
-instance declaration in which local names have been replaced by their
-original names, reporting any unknown names.
-
\begin{code}
-rnInstDecl :: RdrNameInstDecl -> RnM_Fixes s RenamedInstDecl
-
-rnInstDecl (InstDecl cname ty mbinds from_here modname uprags pragmas src_loc)
+rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun_name src_loc))
= pushSrcLocRn src_loc $
- lookupClass cname `thenRn` \ cname' ->
-
- rnPolyType [] ty `thenRn` \ ty' ->
- -- [] tv_env ensures that tyvars will be foralled
+ rnHsType inst_ty `thenRn` \ inst_ty' ->
+ rnMethodBinds mbinds `thenRn` \ mbinds' ->
+ mapRn rn_uprag uprags `thenRn` \ new_uprags ->
+ rn_dfun maybe_dfun_name `thenRn` \ dfun_name' ->
- rnMethodBinds cname' mbinds `thenRn` \ mbinds' ->
- mapRn (rn_uprag cname') uprags `thenRn` \ new_uprags ->
-
- ASSERT(isNoInstancePragmas pragmas)
- returnRn (InstDecl cname' ty' mbinds'
- from_here modname new_uprags noInstancePragmas src_loc)
+ returnRn (InstD (InstDecl inst_ty' mbinds' new_uprags dfun_name' src_loc))
where
- rn_uprag class_name (SpecSig op ty using locn)
+ rn_dfun Nothing = newDfunName src_loc `thenRn` \ n' ->
+ returnRn (Just n')
+ rn_dfun (Just n) = lookupOptionalOccRn n `thenRn` \ n' ->
+ returnRn (Just n')
+
+ rn_uprag (SpecSig op ty using locn)
= pushSrcLocRn src_loc $
- lookupClassOp class_name op `thenRn` \ op_name ->
- rnPolyType nullTyVarNamesEnv ty `thenRn` \ new_ty ->
+ lookupRn op `thenRn` \ op_name ->
+ rnHsType ty `thenRn` \ new_ty ->
rn_using using `thenRn` \ new_using ->
returnRn (SpecSig op_name new_ty new_using locn)
- rn_uprag class_name (InlineSig op locn)
+ rn_uprag (InlineSig op locn)
= pushSrcLocRn locn $
- lookupClassOp class_name op `thenRn` \ op_name ->
+ lookupRn op `thenRn` \ op_name ->
returnRn (InlineSig op_name locn)
- rn_uprag class_name (DeforestSig op locn)
+ rn_uprag (DeforestSig op locn)
= pushSrcLocRn locn $
- lookupClassOp class_name op `thenRn` \ op_name ->
+ lookupRn op `thenRn` \ op_name ->
returnRn (DeforestSig op_name locn)
- rn_uprag class_name (MagicUnfoldingSig op str locn)
+ rn_uprag (MagicUnfoldingSig op str locn)
= pushSrcLocRn locn $
- lookupClassOp class_name op `thenRn` \ op_name ->
+ lookupRn op `thenRn` \ op_name ->
returnRn (MagicUnfoldingSig op_name str locn)
- rn_using Nothing
- = returnRn Nothing
- rn_using (Just v)
- = lookupValue v `thenRn` \ new_v ->
- returnRn (Just new_v)
+ rn_using Nothing = returnRn Nothing
+ rn_using (Just v) = lookupOccRn v `thenRn` \ new_v ->
+ returnRn (Just new_v)
\end{code}
%*********************************************************
%* *
-\subsection{@SPECIALIZE instance@ user-pragmas}
+\subsection{Default declarations}
%* *
%*********************************************************
\begin{code}
-rnSpecInstSig :: RdrNameSpecInstSig
- -> RnM_Fixes s RenamedSpecInstSig
-
-rnSpecInstSig (SpecInstSig clas ty src_loc)
+rnDecl (DefD (DefaultDecl tys src_loc))
= pushSrcLocRn src_loc $
- let
- tyvars = extractMonoTyNames is_tyvar_name ty
- in
- mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
- lookupClass clas `thenRn` \ new_clas ->
- rnMonoType tv_env ty `thenRn` \ new_ty ->
- returnRn (SpecInstSig new_clas new_ty src_loc)
+ mapRn rnHsType tys `thenRn` \ tys' ->
+ lookupImplicitOccRn numClass_RDR `thenRn_`
+ returnRn (DefD (DefaultDecl tys' src_loc))
\end{code}
%*********************************************************
%* *
-\subsection{Default declarations}
+\subsection{Support code for type/data declarations}
%* *
%*********************************************************
-@rnDefaultDecl@ uses the `global name function' to create a new set
-of default declarations in which local names have been replaced by
-their original names, reporting any unknown names.
+\begin{code}
+rnDerivs :: Maybe [RdrName] -> RnMS s (Maybe [Name])
+
+rnDerivs Nothing -- derivs not specified
+ = lookupImplicitOccRn evalClass_RDR `thenRn_`
+ returnRn Nothing
+
+rnDerivs (Just ds)
+ = lookupImplicitOccRn evalClass_RDR `thenRn_`
+ mapRn rn_deriv ds `thenRn` \ derivs ->
+ returnRn (Just derivs)
+ where
+ rn_deriv clas
+ = lookupOccRn clas `thenRn` \ clas_name ->
+
+ -- Now add extra "occurrences" for things that
+ -- the deriving mechanism will later need in order to
+ -- generate code for this class.
+ case lookupUFM derivingOccurrences clas_name of
+ Nothing -> addErrRn (derivingNonStdClassErr clas_name) `thenRn_`
+ returnRn clas_name
+
+ Just occs -> mapRn lookupImplicitOccRn occs `thenRn_`
+ returnRn clas_name
+\end{code}
\begin{code}
-rnDefaultDecl :: [RdrNameDefaultDecl] -> RnM_Fixes s [RenamedDefaultDecl]
+rnConDecl :: RdrNameConDecl -> RnMS s RenamedConDecl
-rnDefaultDecl [] = returnRn []
-rnDefaultDecl [DefaultDecl tys src_loc]
+rnConDecl (ConDecl name tys src_loc)
= pushSrcLocRn src_loc $
- mapRn (rnMonoType nullTyVarNamesEnv) tys `thenRn` \ tys' ->
- returnRn [DefaultDecl tys' src_loc]
-rnDefaultDecl defs@(d:ds)
- = addErrRn (dupDefaultDeclErr defs) `thenRn_`
- rnDefaultDecl [d]
-\end{code}
+ lookupRn name `thenRn` \ new_name ->
+ mapRn rnBangTy tys `thenRn` \ new_tys ->
+ returnRn (ConDecl new_name new_tys src_loc)
-%*************************************************************************
-%* *
-\subsection{Fixity declarations}
-%* *
-%*************************************************************************
+rnConDecl (ConOpDecl ty1 op ty2 src_loc)
+ = pushSrcLocRn src_loc $
+ lookupRn op `thenRn` \ new_op ->
+ rnBangTy ty1 `thenRn` \ new_ty1 ->
+ rnBangTy ty2 `thenRn` \ new_ty2 ->
+ returnRn (ConOpDecl new_ty1 new_op new_ty2 src_loc)
-\begin{code}
-rnFixes :: [RdrNameFixityDecl] -> RnM s [RenamedFixityDecl]
+rnConDecl (NewConDecl name ty src_loc)
+ = pushSrcLocRn src_loc $
+ lookupRn name `thenRn` \ new_name ->
+ rnHsType ty `thenRn` \ new_ty ->
+ returnRn (NewConDecl new_name new_ty src_loc)
-rnFixes fixities
- = getSrcLocRn `thenRn` \ src_loc ->
- let
- (_, dup_fixes) = removeDups cmp_fix fixities
- cmp_fix fix1 fix2 = fixDeclName fix1 `cmp` fixDeclName fix2
-
- rn_fixity fix@(InfixL name i)
- = rn_fixity_pieces InfixL name i fix
- rn_fixity fix@(InfixR name i)
- = rn_fixity_pieces InfixR name i fix
- rn_fixity fix@(InfixN name i)
- = rn_fixity_pieces InfixN name i fix
-
- rn_fixity_pieces mk_fixity name i fix
- = getRnEnv `thenRn` \ env ->
- case lookupGlobalRnEnv env name of
- 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))
- _ -> failButContinueRn Nothing (undefinedFixityDeclErr src_loc fix)
- in
- mapRn (addErrRn . dupFixityDeclErr src_loc) dup_fixes `thenRn_`
- mapRn rn_fixity fixities `thenRn` \ fixes_maybe ->
- returnRn (catMaybes fixes_maybe)
+rnConDecl (RecConDecl name fields src_loc)
+ = pushSrcLocRn src_loc $
+ lookupRn name `thenRn` \ new_name ->
+ mapRn rnField fields `thenRn` \ new_fields ->
+ returnRn (RecConDecl new_name new_fields src_loc)
+
+rnField (names, ty)
+ = mapRn lookupRn names `thenRn` \ new_names ->
+ rnBangTy ty `thenRn` \ new_ty ->
+ returnRn (new_names, new_ty)
+
+rnBangTy (Banged ty)
+ = rnHsType ty `thenRn` \ new_ty ->
+ returnRn (Banged new_ty)
+
+rnBangTy (Unbanged ty)
+ = rnHsType ty `thenRn` \ new_ty ->
+ returnRn (Unbanged new_ty)
\end{code}
+
%*********************************************************
%* *
\subsection{Support code to rename types}
%*********************************************************
\begin{code}
-rnPolyType :: TyVarNamesEnv
- -> RdrNamePolyType
- -> RnM_Fixes s RenamedPolyType
+rnHsType :: RdrNameHsType -> RnMS s RenamedHsType
-rnPolyType tv_env (HsForAllTy tvs ctxt ty)
- = rn_poly_help tv_env tvs ctxt ty
+rnHsType (HsForAllTy tvs ctxt ty)
+ = rn_poly_help tvs ctxt ty
-rnPolyType tv_env (HsPreForAllTy ctxt ty)
- = rn_poly_help tv_env forall_tyvars ctxt ty
- where
- mentioned_tyvars = extractCtxtTyNames ctxt `unionLists` extractMonoTyNames is_tyvar_name ty
- forall_tyvars = {-
- pprTrace "mentioned:" (ppCat (map (ppr PprShowAll) mentioned_tyvars)) $
- pprTrace "from_ty:" (ppCat (map (ppr PprShowAll) (extractMonoTyNames is_tyvar_name ty))) $
- -}
- mentioned_tyvars `minusList` domTyVarNamesEnv tv_env
-
-------------
-rn_poly_help :: TyVarNamesEnv
- -> [RdrName]
- -> RdrNameContext
- -> RdrNameMonoType
- -> RnM_Fixes s RenamedPolyType
-
-rn_poly_help tv_env tyvars ctxt ty
- = {-
- pprTrace "rnPolyType:"
- (ppCat [ppCat (map (ppr PprShowAll . snd) tv_env),
- ppStr ";tvs=", ppCat (map (ppr PprShowAll) tyvars),
- ppStr ";ctxt=", ppCat (map (ppr PprShowAll) ctxt),
- ppStr ";ty=", ppr PprShowAll ty]) $
- -}
- getSrcLocRn `thenRn` \ src_loc ->
- mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env1, new_tyvars) ->
+rnHsType full_ty@(HsPreForAllTy ctxt ty)
+ = getNameEnv `thenRn` \ name_env ->
let
- tv_env2 = catTyVarNamesEnvs tv_env1 tv_env
+ mentioned_tyvars = extractHsTyVars full_ty
+ forall_tyvars = filter not_in_scope mentioned_tyvars
+ not_in_scope tv = case lookupFM name_env tv of
+ Nothing -> True
+ Just _ -> False
in
- rnContext tv_env2 src_loc ctxt `thenRn` \ new_ctxt ->
- rnMonoType tv_env2 ty `thenRn` \ new_ty ->
- returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
-\end{code}
-
-\begin{code}
-rnMonoType :: TyVarNamesEnv
- -> RdrNameMonoType
- -> RnM_Fixes s RenamedMonoType
+ rn_poly_help (map UserTyVar forall_tyvars) ctxt ty
-rnMonoType tv_env (MonoTyVar tyvar)
- = lookupTyVarName tv_env tyvar `thenRn` \ tyvar' ->
+rnHsType (MonoTyVar tyvar)
+ = lookupOccRn tyvar `thenRn` \ tyvar' ->
returnRn (MonoTyVar tyvar')
-rnMonoType tv_env (MonoListTy ty)
- = rnMonoType tv_env ty `thenRn` \ ty' ->
- returnRn (MonoListTy ty')
+rnHsType (MonoFunTy ty1 ty2)
+ = andRn MonoFunTy (rnHsType ty1) (rnHsType ty2)
-rnMonoType tv_env (MonoFunTy ty1 ty2)
- = andRn MonoFunTy (rnMonoType tv_env ty1)
- (rnMonoType tv_env ty2)
+rnHsType (MonoListTy _ ty)
+ = lookupImplicitOccRn listType_RDR `thenRn` \ tycon_name ->
+ rnHsType ty `thenRn` \ ty' ->
+ returnRn (MonoListTy tycon_name ty')
-rnMonoType tv_env (MonoTupleTy tys)
- = mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
- returnRn (MonoTupleTy tys')
+rnHsType (MonoTupleTy _ tys)
+ = lookupImplicitOccRn (tupleType_RDR (length tys)) `thenRn` \ tycon_name ->
+ mapRn rnHsType tys `thenRn` \ tys' ->
+ returnRn (MonoTupleTy tycon_name tys')
-rnMonoType tv_env (MonoTyApp name tys)
- = let
- lookup_fn = if isLexVarId (getLocalName name)
- then lookupTyVarName tv_env
- else lookupTyCon
- in
- lookup_fn name `thenRn` \ name' ->
- mapRn (rnMonoType tv_env) tys `thenRn` \ tys' ->
+rnHsType (MonoTyApp name tys)
+ = lookupOccRn name `thenRn` \ name' ->
+ mapRn rnHsType tys `thenRn` \ tys' ->
returnRn (MonoTyApp name' tys')
+
+rnHsType (MonoDictTy clas ty)
+ = lookupOccRn clas `thenRn` \ clas' ->
+ rnHsType ty `thenRn` \ ty' ->
+ returnRn (MonoDictTy clas' ty')
+
+
+rn_poly_help :: [HsTyVar RdrName] -- Universally quantified tyvars
+ -> RdrNameContext
+ -> RdrNameHsType
+ -> RnMS s RenamedHsType
+
+rn_poly_help tyvars ctxt ty
+ = bindTyVarsRn "type signature" tyvars $ \ new_tyvars ->
+ rnContext ctxt `thenRn` \ new_ctxt ->
+ rnHsType ty `thenRn` \ new_ty ->
+ returnRn (HsForAllTy new_tyvars new_ctxt new_ty)
\end{code}
+
\begin{code}
-rnContext :: TyVarNamesEnv -> SrcLoc -> RdrNameContext -> RnM_Fixes s RenamedContext
+rnContext :: RdrNameContext -> RnMS s RenamedContext
-rnContext tv_env locn ctxt
+rnContext ctxt
= mapRn rn_ctxt ctxt `thenRn` \ result ->
let
(_, dup_asserts) = removeDups cmp_assert result
in
-- If this isn't an error, then it ought to be:
- mapRn (addWarnRn . dupClassAssertWarn result locn) dup_asserts `thenRn_`
+ mapRn (addWarnRn . dupClassAssertWarn result) dup_asserts `thenRn_`
returnRn result
where
- rn_ctxt (clas, tyvar)
- = lookupClass clas `thenRn` \ clas_name ->
- lookupTyVarName tv_env tyvar `thenRn` \ tyvar_name ->
- returnRn (clas_name, tyvar_name)
+ rn_ctxt (clas, ty)
+ = lookupOccRn clas `thenRn` \ clas_name ->
+ rnHsType ty `thenRn` \ ty' ->
+ returnRn (clas_name, ty')
- cmp_assert (c1,tv1) (c2,tv2)
- = (c1 `cmp` c2) `thenCmp` (tv1 `cmp` tv2)
+ cmp_assert (c1,ty1) (c2,ty2)
+ = (c1 `cmp` c2) `thenCmp` (cmpHsType cmp ty1 ty2)
\end{code}
+%*********************************************************
+%* *
+\subsection{IdInfo}
+%* *
+%*********************************************************
+
\begin{code}
-dupNameExportWarn locn names@((n,_):_)
- = addShortWarnLocLine locn $ \ sty ->
- ppCat [pprNonSym sty n, ppStr "exported", ppInt (length names), ppStr "times"]
-
-dupLocalsExportErr locn locals@((str,_):_)
- = addErrLoc locn "exported names have same local name" $ \ sty ->
- ppInterleave ppSP (map (pprNonSym sty . snd) locals)
-
-classOpExportErr op locn
- = addShortErrLocLine locn $ \ sty ->
- 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 ->
- ppBesides [ppStr "type synonym `", ppr sty syn, ppStr "' should be exported abstractly"]
-
-withExportErr str rn has rns locn
- = addErrLoc locn "" $ \ sty ->
- ppAboves [ ppBesides [ppStr "inconsistent list of ", ppStr str, ppStr " in export list for `", ppr sty rn, ppStr "'"],
- ppCat [ppStr " expected:", ppInterleave ppComma (map (ppr sty) has)],
- ppCat [ppStr " found: ", ppInterleave ppComma (map (ppr sty) rns)] ]
-
-importAllErr rn locn
- = addShortErrLocLine locn $ \ sty ->
- ppBesides [ ppStr "`", pprNonSym sty rn, ppStr "' has been exported with (..), but is only imported abstractly"]
-
-badModExportErr mod locn
- = addShortErrLocLine locn $ \ sty ->
- ppCat [ ppStr "unknown module in export list: module", ppPStr mod]
-
-emptyModExportWarn locn mod
- = addShortWarnLocLine locn $ \ sty ->
- ppCat [ppStr "module", ppPStr mod, ppStr "has no unqualified imports to export"]
-
-dupModExportWarn locn mods@(mod:_)
- = addShortWarnLocLine locn $ \ sty ->
- ppCat [ppStr "module", ppPStr mod, ppStr "appears", ppInt (length mods), ppStr "times in export list"]
-
-derivingNonStdClassErr clas locn
- = addShortErrLocLine locn $ \ sty ->
- ppCat [ppStr "non-standard class in deriving:", ppr sty clas]
-
-dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
- = ppAboves (item1 : map dup_item dup_things)
+rnIdInfo (HsStrictness strict)
+ = rnStrict strict `thenRn` \ strict' ->
+ returnRn (HsStrictness strict')
+
+rnIdInfo (HsUnfold expr) = rnCoreExpr expr `thenRn` \ expr' ->
+ returnRn (HsUnfold expr')
+rnIdInfo (HsArity arity) = returnRn (HsArity arity)
+rnIdInfo (HsUpdate update) = returnRn (HsUpdate update)
+rnIdInfo (HsFBType fb) = returnRn (HsFBType fb)
+rnIdInfo (HsArgUsage au) = returnRn (HsArgUsage au)
+rnIdInfo (HsDeforest df) = returnRn (HsDeforest df)
+
+rnStrict (StrictnessInfo demands (Just worker))
+ = lookupOptionalOccRn worker `thenRn` \ worker' ->
+ returnRn (StrictnessInfo demands (Just worker'))
+
+-- Boring, but necessary for the type checker.
+rnStrict (StrictnessInfo demands Nothing) = returnRn (StrictnessInfo demands Nothing)
+rnStrict BottomGuaranteed = returnRn BottomGuaranteed
+rnStrict NoStrictnessInfo = returnRn NoStrictnessInfo
+\end{code}
+
+UfCore expressions.
+
+\begin{code}
+rnCoreExpr (UfVar v)
+ = lookupOptionalOccRn v `thenRn` \ v' ->
+ returnRn (UfVar v')
+
+rnCoreExpr (UfLit lit) = returnRn (UfLit lit)
+
+rnCoreExpr (UfCon con args)
+ = lookupOptionalOccRn con `thenRn` \ con' ->
+ mapRn rnCoreArg args `thenRn` \ args' ->
+ returnRn (UfCon con' args')
+
+rnCoreExpr (UfPrim prim args)
+ = rnCorePrim prim `thenRn` \ prim' ->
+ mapRn rnCoreArg args `thenRn` \ args' ->
+ returnRn (UfPrim prim' args')
+
+rnCoreExpr (UfApp fun arg)
+ = rnCoreExpr fun `thenRn` \ fun' ->
+ rnCoreArg arg `thenRn` \ arg' ->
+ returnRn (UfApp fun' arg')
+
+rnCoreExpr (UfCase scrut alts)
+ = rnCoreExpr scrut `thenRn` \ scrut' ->
+ rnCoreAlts alts `thenRn` \ alts' ->
+ returnRn (UfCase scrut' alts')
+
+rnCoreExpr (UfSCC cc expr)
+ = rnCoreExpr expr `thenRn` \ expr' ->
+ returnRn (UfSCC cc expr')
+
+rnCoreExpr(UfCoerce coercion ty body)
+ = rnCoercion coercion `thenRn` \ coercion' ->
+ rnHsType ty `thenRn` \ ty' ->
+ rnCoreExpr body `thenRn` \ body' ->
+ returnRn (UfCoerce coercion' ty' body')
+
+rnCoreExpr (UfLam bndr body)
+ = rnCoreBndr bndr $ \ bndr' ->
+ rnCoreExpr body `thenRn` \ body' ->
+ returnRn (UfLam bndr' body')
+
+rnCoreExpr (UfLet (UfNonRec bndr rhs) body)
+ = rnCoreExpr rhs `thenRn` \ rhs' ->
+ rnCoreBndr bndr $ \ bndr' ->
+ rnCoreExpr body `thenRn` \ body' ->
+ returnRn (UfLet (UfNonRec bndr' rhs') body')
+
+rnCoreExpr (UfLet (UfRec pairs) body)
+ = rnCoreBndrs bndrs $ \ bndrs' ->
+ mapRn rnCoreExpr rhss `thenRn` \ rhss' ->
+ rnCoreExpr body `thenRn` \ body' ->
+ returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body')
where
- item1
- = addShortErrLocLine locn1 (\ sty ->
- ppStr "multiple default declarations") sty
+ (bndrs, rhss) = unzip pairs
+\end{code}
+
+\begin{code}
+rnCoreBndr (UfValBinder name ty) thing_inside
+ = rnHsType ty `thenRn` \ ty' ->
+ bindLocalsRn "unfolding value" [name] $ \ [name'] ->
+ thing_inside (UfValBinder name' ty')
+
+rnCoreBndr (UfTyBinder name kind) thing_inside
+ = bindLocalsRn "unfolding tyvar" [name] $ \ [name'] ->
+ thing_inside (UfTyBinder name' kind)
+
+rnCoreBndr (UfUsageBinder name) thing_inside
+ = bindLocalsRn "unfolding usage" [name] $ \ [name'] ->
+ thing_inside (UfUsageBinder name')
+
+rnCoreBndrs bndrs thing_inside -- Expect them all to be ValBinders
+ = mapRn rnHsType tys `thenRn` \ tys' ->
+ bindLocalsRn "unfolding value" names $ \ names' ->
+ thing_inside (zipWith UfValBinder names' tys')
+ where
+ names = map (\ (UfValBinder name _) -> name) bndrs
+ tys = map (\ (UfValBinder _ ty) -> ty) bndrs
+\end{code}
+
+\begin{code}
+rnCoreArg (UfVarArg v) = lookupOptionalOccRn v `thenRn` \ v' -> returnRn (UfVarArg v')
+rnCoreArg (UfUsageArg u) = lookupOptionalOccRn u `thenRn` \ u' -> returnRn (UfUsageArg u')
+rnCoreArg (UfTyArg ty) = rnHsType ty `thenRn` \ ty' -> returnRn (UfTyArg ty')
+rnCoreArg (UfLitArg lit) = returnRn (UfLitArg lit)
+
+rnCoreAlts (UfAlgAlts alts deflt)
+ = mapRn rn_alt alts `thenRn` \ alts' ->
+ rnCoreDefault deflt `thenRn` \ deflt' ->
+ returnRn (UfAlgAlts alts' deflt')
+ where
+ rn_alt (con, bndrs, rhs) = lookupOptionalOccRn con `thenRn` \ con' ->
+ rnCoreBndrs bndrs $ \ bndrs' ->
+ rnCoreExpr rhs `thenRn` \ rhs' ->
+ returnRn (con', bndrs', rhs')
+
+rnCoreAlts (UfPrimAlts alts deflt)
+ = mapRn rn_alt alts `thenRn` \ alts' ->
+ rnCoreDefault deflt `thenRn` \ deflt' ->
+ returnRn (UfPrimAlts alts' deflt')
+ where
+ rn_alt (lit, rhs) = rnCoreExpr rhs `thenRn` \ rhs' ->
+ returnRn (lit, rhs')
+
+rnCoreDefault UfNoDefault = returnRn UfNoDefault
+rnCoreDefault (UfBindDefault bndr rhs) = rnCoreBndr bndr $ \ bndr' ->
+ rnCoreExpr rhs `thenRn` \ rhs' ->
+ returnRn (UfBindDefault bndr' rhs')
+
+rnCoercion (UfIn n) = lookupOptionalOccRn n `thenRn` \ n' -> returnRn (UfIn n')
+rnCoercion (UfOut n) = lookupOptionalOccRn n `thenRn` \ n' -> returnRn (UfOut n')
+
+rnCorePrim (UfOtherOp op)
+ = lookupOptionalOccRn op `thenRn` \ op' ->
+ returnRn (UfOtherOp op')
- dup_item (DefaultDecl _ locn)
- = addShortErrLocLine locn (\ sty ->
- ppStr "here was another default declaration") sty
+rnCorePrim (UfCCallOp str casm gc arg_tys res_ty)
+ = mapRn rnHsType arg_tys `thenRn` \ arg_tys' ->
+ rnHsType res_ty `thenRn` \ res_ty' ->
+ returnRn (UfCCallOp str casm gc arg_tys' res_ty')
+\end{code}
-undefinedFixityDeclErr locn decl
- = addErrLoc locn "fixity declaration for unknown operator" $ \ sty ->
- ppr sty decl
+%*********************************************************
+%* *
+\subsection{Errors}
+%* *
+%*********************************************************
-dupFixityDeclErr locn dups
- = addErrLoc locn "multiple fixity declarations for same operator" $ \ sty ->
- ppAboves (map (ppr sty) dups)
+\begin{code}
+derivingNonStdClassErr clas sty
+ = ppCat [ppStr "non-standard class in deriving:", ppr sty clas]
-classTyVarNotInOpTyErr clas_tyvar sig locn
- = addShortErrLocLine locn $ \ sty ->
- ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"])
+classTyVarNotInOpTyErr clas_tyvar sig sty
+ = ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' does not appear in method signature:"])
4 (ppr sty sig)
-classTyVarInOpCtxtErr clas_tyvar sig locn
- = addShortErrLocLine locn $ \ sty ->
- ppHang (ppBesides [ppStr "Class type variable `", ppr sty clas_tyvar, ppStr "' present in method's local overloading context:"])
+classTyVarInOpCtxtErr clas_tyvar sig sty
+ = ppHang (ppBesides [ ppStr "Class type variable `", ppr sty clas_tyvar,
+ ppStr "' present in method's local overloading context:"])
4 (ppr sty sig)
-dupClassAssertWarn ctxt locn dups
- = addShortWarnLocLine locn $ \ sty ->
- ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"])
+dupClassAssertWarn ctxt dups sty
+ = ppHang (ppBesides [ppStr "Duplicate class assertion `", ppr sty dups, ppStr "' in context:"])
4 (ppr sty ctxt)
\end{code}
+
+
+
+
+
+=================== OLD STUFF ======================
+
+%*********************************************************
+%* *
+\subsection{SPECIALIZE data pragmas}
+%* *
+%*********************************************************
+
+\begin{pseudocode}
+rnSpecDataSig :: RdrNameSpecDataSig
+ -> RnMS s RenamedSpecDataSig
+
+rnSpecDataSig (SpecDataSig tycon ty src_loc)
+ = pushSrcLocRn src_loc $
+ let
+ tyvars = filter extractHsTyNames ty
+ in
+ mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
+ lookupOccRn tycon `thenRn` \ tycon' ->
+ rnHsType tv_env ty `thenRn` \ ty' ->
+ returnRn (SpecDataSig tycon' ty' src_loc)
+
+\end{pseudocode}
+
+%*********************************************************
+%* *
+\subsection{@SPECIALIZE instance@ user-pragmas}
+%* *
+%*********************************************************
+
+\begin{pseudocode}
+rnSpecInstSig :: RdrNameSpecInstSig
+ -> RnMS s RenamedSpecInstSig
+
+rnSpecInstSig (SpecInstSig clas ty src_loc)
+ = pushSrcLocRn src_loc $
+ let
+ tyvars = extractHsTyNames is_tyvar_name ty
+ in
+ mkTyVarNamesEnv src_loc tyvars `thenRn` \ (tv_env,_) ->
+ lookupOccRn clas `thenRn` \ new_clas ->
+ rnHsType tv_env ty `thenRn` \ new_ty ->
+ returnRn (SpecInstSig new_clas new_ty src_loc)
+\end{pseudocode}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[RnUtils]{Functions used by both renaming passes}
-
-\begin{code}
-#include "HsVersions.h"
-
-module RnUtils (
- SYN_IE(RnEnv), SYN_IE(QualNames),
- SYN_IE(UnqualNames), SYN_IE(ScopeStack),
- emptyRnEnv, initRnEnv, extendGlobalRnEnv, extendLocalRnEnv,
- lookupRnEnv, lookupGlobalRnEnv, lookupTcRnEnv,
- getLocalsFromRnEnv,
-
- lubExportFlag,
-
- qualNameErr,
- dupNamesErr,
- pprRnEnv -- debugging only
- ) where
-
-IMP_Ubiq(){-uitous-}
-IMPORT_1_3(List(partition))
-
-import Bag ( Bag, emptyBag, snocBag, unionBags )
-import CmdLineOpts ( opt_GlasgowExts )
-import ErrUtils ( addShortErrLocLine )
-import FiniteMap ( emptyFM, isEmptyFM, fmToList, listToFM, keysFM,
- lookupFM, addListToFM, addToFM, eltsFM, FiniteMap )
-import Maybes ( maybeToBool )
-import Name ( RdrName(..), ExportFlag(..),
- isQual, pprNonSym, getLocalName, isLocallyDefined )
-import PprStyle ( PprStyle(..) )
-import PrelInfo ( builtinValNamesMap, builtinTcNamesMap )
-import PrelMods ( gHC_BUILTINS )
-import Pretty
-import RnHsSyn ( RnName )
-import Util ( assertPanic )
-\end{code}
-
-*********************************************************
-* *
-\subsection{RnEnv: renaming environment}
-* *
-*********************************************************
-
-Separate FiniteMaps are kept for lookup up Qual names,
-Unqual names and Local names.
-
-\begin{code}
-type RnEnv = ((QualNames, UnqualNames, QualNames, UnqualNames), ScopeStack)
-
-type QualNames = FiniteMap (FAST_STRING,Module) RnName
-type UnqualNames = FiniteMap FAST_STRING RnName
-type ScopeStack = FiniteMap FAST_STRING RnName
-
-emptyRnEnv :: RnEnv
-initRnEnv :: RnEnv
-extendGlobalRnEnv :: RnEnv -> [(RdrName,RnName)] -> [(RdrName,RnName)]
- -> (RnEnv, Bag (RdrName, RnName, RnName))
-extendLocalRnEnv :: Bool -> RnEnv -> [RnName] -> (RnEnv, [RnName])
-lookupRnEnv :: RnEnv -> RdrName -> Maybe RnName
-lookupGlobalRnEnv :: RnEnv -> RdrName -> Maybe RnName
-lookupTcRnEnv :: RnEnv -> RdrName -> Maybe RnName
-
-getLocalsFromRnEnv :: RnEnv -> ([RnName], [RnName])
- -- grabs the locally defined names from the unqual envs
-\end{code}
-
-If the @RdrName@ is a @Qual@, @lookupValue@ looks it up in the global
-value QualNames. If it is @Unqual@, it looks it up first in the
-ScopeStack, and if it isn't found there, then in the global
-vaule Unqual Names.
-
-@lookupTcRnEnv@ looks up tycons/classes in the alternative global
-name space.
-
-@extendGlobalRnEnv@ adds global names to the RnEnv. It takes separate
-value and tycon/class name lists. It returns any duplicate names
-seperately.
-
-@extendRnEnv@ adds new local names to the ScopeStack in an RnEnv.
-It optionally reports any shadowed names.
-
-\begin{code}
-emptyRnEnv = ((emptyFM, emptyFM, emptyFM, emptyFM), emptyFM)
-
- -- an emptyRnEnv is empty; the initRnEnv may have
- -- primitive names already in it (both unqual and qual),
- -- and quals for all the other wired-in dudes.
-
-initRnEnv
- = if (not opt_GlasgowExts) then
- emptyRnEnv
- else
- ((listToFM qual, listToFM unqual, listToFM tc_qual, listToFM tc_unqual), emptyFM)
- where
- qual = [ ((n,m), rn) | (OrigName m n, rn) <- fmToList builtinValNamesMap ]
- tc_qual = [ ((n,m), rn) | (OrigName m n, rn) <- fmToList builtinTcNamesMap ]
-
- builtin_qual = filter (\ ((_,m),_) -> m == gHC_BUILTINS) qual
- builtin_tc_qual = filter (\ ((_,m),_) -> m == gHC_BUILTINS) tc_qual
-
- unqual = map (\ ((n,_),rn) -> (n,rn)) builtin_qual
- tc_unqual = map (\ ((n,_),rn) -> (n,rn)) builtin_tc_qual
-
------------------
-
-extendGlobalRnEnv ((qual, unqual, tc_qual, tc_unqual), stack) val_list tc_list
- = ASSERT(isEmptyFM stack)
- (((qual', unqual', tc_qual', tc_unqual'), stack), tc_dups `unionBags` dups)
- where
- (qual', unqual', dups) = extend_global qual unqual val_list
- (tc_qual', tc_unqual', tc_dups) = extend_global tc_qual tc_unqual tc_list
-
- extend_global qual unqual rdr_list = (qual', unqual', dups)
- where
- (qual_list, unqual_list) = partition (isQual.fst) rdr_list
- qual_in = map mk_qual qual_list
- unqual_in = map mk_unqual unqual_list
- mk_qual (Qual m s, rn) = ((s,m), rn)
- mk_unqual (Unqual s, rn) = (s, rn)
-
- (qual', qual_dups) = do_dups qual_in qual emptyBag (\ (s,m) -> Qual m s)
- (unqual', unqual_dups) = do_dups unqual_in unqual emptyBag Unqual
-
- dups = unqual_dups `unionBags` qual_dups
-
- do_dups [] fm dups to_rdr = (fm, dups)
- do_dups ((k,v):rest) fm dups to_rdr
- = case lookupFM fm k of
- Nothing -> do_dups rest (addToFM fm k v) dups to_rdr
- Just cur -> do_dups rest fm (dups `snocBag` (to_rdr k, cur, v)) to_rdr
-
-
-extendLocalRnEnv report_shadows (global, stack) new_local
- = ((global, new_stack), dups)
- where
- (new_stack, dups) = extend new_local stack
-
- extend names stack
- = if report_shadows then
- do_shadows names stack []
- else
- (addListToFM stack [ (getLocalName n, n) | n <- names], [])
-
- do_shadows [] stack dups = (stack, dups)
- do_shadows (name:names) stack dups
- = do_shadows names (addToFM stack str name) ext_dups
- where
- str = getLocalName name
- ext_dups = if maybeToBool (lookupFM stack str)
- then name:dups
- else dups
-\end{code}
-
-\begin{code}
-lookupRnEnv ((qual, unqual, _, _), stack) rdr
- = case rdr of
- Unqual str -> lookup stack str (lookupFM unqual str)
- Qual mod str -> lookupFM qual (str,mod)
- where
- lookup fm thing do_on_fail
- = case lookupFM fm thing of
- found@(Just name) -> found
- Nothing -> do_on_fail
-
-lookupGlobalRnEnv ((qual, unqual, _, _), _) rdr
- = case rdr of
- Unqual str -> lookupFM unqual str
- Qual mod str -> lookupFM qual (str,mod)
-
-lookupTcRnEnv ((_, _, tc_qual, tc_unqual), _) rdr
- = case rdr of
- Unqual str -> lookupFM tc_unqual str
- Qual mod str -> lookupFM tc_qual (str,mod)
-
-getLocalsFromRnEnv ((_, vals, _, tcs), _)
- = (filter isLocallyDefined (eltsFM vals),
- filter isLocallyDefined (eltsFM tcs))
-\end{code}
-
-*********************************************************
-* *
-\subsection{Export Flag Functions}
-* *
-*********************************************************
-
-\begin{code}
-lubExportFlag ExportAll ExportAll = ExportAll
-lubExportFlag ExportAll ExportAbs = ExportAll
-lubExportFlag ExportAbs ExportAll = ExportAll
-lubExportFlag ExportAbs ExportAbs = ExportAbs
-\end{code}
-
-*********************************************************
-* *
-\subsection{Errors used *more than once* in the renamer}
-* *
-*********************************************************
-
-\begin{code}
-qualNameErr descriptor (name,locn)
- = addShortErrLocLine locn ( \ sty ->
- ppBesides [ppStr "invalid use of qualified ", ppStr descriptor, ppStr ": ", pprNonSym sty name ] )
-
-dupNamesErr descriptor ((name1,locn1) : dup_things) sty
- = ppAboves (item1 : map dup_item dup_things)
- where
- item1
- = addShortErrLocLine locn1 (\ sty ->
- ppBesides [ppStr "multiple declarations of a ", ppStr descriptor, ppStr " `",
- pprNonSym sty name1, ppStr "'" ]) sty
-
- dup_item (name, locn)
- = addShortErrLocLine locn (\ sty ->
- ppBesides [ppStr "here was another declaration of `",
- pprNonSym sty name, ppStr "'" ]) sty
-
------------------
-pprRnEnv :: PprStyle -> RnEnv -> Pretty
-
-pprRnEnv sty ((qual, unqual, tc_qual, tc_unqual), stack)
- = ppAboves [ ppStr "Stack:"
- , ppCat (map ppPStr (keysFM stack))
- , ppStr "Val qual:"
- , ppAboves [ppBesides [ppPStr m, ppChar '.', ppPStr n] | (n,m) <- keysFM qual]
- , ppStr "Val unqual:"
- , ppCat (map ppPStr (keysFM unqual))
- , ppStr "Tc qual:"
- , ppAboves [ppBesides [ppPStr m, ppChar '.', ppPStr n] | (n,m) <- keysFM tc_qual]
- , ppStr "Tc unqual:"
- , ppCat (map ppPStr (keysFM tc_unqual))
- ]
-\end{code}
BinderInfo(..),
FunOrArg, DuplicationDanger, InsideSCC, -- NB: all abstract (yay!)
- inlineUnconditionally, okToInline,
-
addBinderInfo, orBinderInfo, andBinderInfo,
argOccurrence, funOccurrence, dangerousArgOcc, noBinderInfo,
IMP_Ubiq(){-uitous-}
-import CoreUnfold ( FormSummary(..) )
import Pretty
import Util ( panic )
\end{code}
\end{code}
-Predicates
-~~~~~~~~~~
\begin{code}
-okToInline
- :: FormSummary -- What the thing to be inlined is like
- -> BinderInfo -- How the thing to be inlined occurs
- -> Bool -- True => it's small enough to inline
- -> Bool -- True => yes, inline it
-
--- Always inline bottoms
-okToInline BottomForm occ_info small_enough
- = True -- Unless one of the type args is unboxed??
- -- This used to be checked for, but I can't
- -- see why so I've left it out.
-
--- A WHNF can be inlined if it occurs once, or is small
-okToInline form occ_info small_enough
- | is_whnf_form form
- = small_enough || one_occ
- where
- one_occ = case occ_info of
- OneOcc _ _ _ n_alts _ -> n_alts <= 1
- other -> False
-
- is_whnf_form VarForm = True
- is_whnf_form ValueForm = True
- is_whnf_form other = False
-
--- A non-WHNF can be inlined if it doesn't occur inside a lambda,
--- and occurs exactly once or
--- occurs once in each branch of a case and is small
-okToInline OtherForm (OneOcc _ NoDupDanger _ n_alts _) small_enough
- = n_alts <= 1 || small_enough
-
-okToInline form any_occ small_enough = False
+isFun :: FunOrArg -> Bool
+isFun FunOcc = True
+isFun _ = False
+
+isDupDanger :: DuplicationDanger -> Bool
+isDupDanger DupDanger = True
+isDupDanger _ = False
\end{code}
@inlineUnconditionally@ decides whether a let-bound thing can
definitely be inlined.
\begin{code}
+{- NOT USED
+
inlineUnconditionally :: Bool -> BinderInfo -> Bool
--inlineUnconditionally ok_to_dup DeadCode = True
-- damage, e.g., limit to M alternatives.
inlineUnconditionally _ _ = False
-\end{code}
-
-\begin{code}
-isFun :: FunOrArg -> Bool
-isFun FunOcc = True
-isFun _ = False
-
-isDupDanger :: DuplicationDanger -> Bool
-isDupDanger DupDanger = True
-isDupDanger _ = False
+-}
\end{code}
IMP_Ubiq(){-uitous-}
import CoreSyn
-import CoreUnfold ( Unfolding(..), SimpleUnfolding )
+import CoreUnfold ( Unfolding, SimpleUnfolding )
import Id ( idType )
import Literal ( mkMachInt, mkMachWord, Literal(..) )
-import MagicUFs ( MagicUnfoldingFun )
+-- import MagicUFs ( MagicUnfoldingFun )
import PrimOp ( PrimOp(..) )
import SimplEnv
import SimplMonad
-- )
--import IdInfo
--import Maybes
---import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
+--import SrcLoc ( noSrcLoc, SrcLoc )
--import Util
\end{code}
-- right function to use ..
-- Now the bodies
- c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty mkUnknownSrcLoc
- n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty mkUnknownSrcLoc
+ c_id = mkSysLocal SLIT("fbww") c_new_uq c_ty noSrcLoc
+ n_id = mkSysLocal SLIT("fbww") n_new_uq n_ty noSrcLoc
worker_rhs
= mkTyLam [] (big_args ++ [alphaTyVar]) (args++[c_id,n_id]) worker_body
{- LATER: to end of file:
import CoreUnfold ( UnfoldingGuidance(..) )
-import Id ( localiseId, toplevelishId{-debugging-} )
+import Id ( localiseId )
import Maybes
import Outputable
import Pretty
-- Why "localiseId" above? Because we're creating a new local
-- copy of the original binding. In particular, the original
- -- binding might have been for a TopLevId, and this copy clearly
+ -- binding might have been for a top-level, and this copy clearly
-- will not be top-level!
-- It is enough to change just the binder, because subsequent
-- to think that something is top-level when it isn't.
rhs_small_enough rhs
- = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE cON_DISCOUNT rhs) of
+ = case (calcUnfoldingGuidance True{-sccs OK-} lIBERATE_BOMB_SIZE rhs) of
UnfoldNever -> False
_ -> True -- we didn't BOMB, so it must be OK
lIBERATE_BOMB_SIZE = bombOutSize env
- cON_DISCOUNT = error "libCaseBind"
\end{code}
scruts' = (scrut_var, lvl) : scruts
bind_lvl = case lookupIdEnv lvl_env scrut_var of
Just lvl -> lvl
- Nothing -> --false: ASSERT(toplevelishId scrut_var)
- topLevel
+ Nothing -> topLevel
lookupRecId :: LibCaseEnv -> Id -> Maybe CoreBinding
lookupRecId (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
#else
= case (lookupIdEnv rec_env id) of
xxx@(Just _) -> xxx
- xxx -> --false: ASSERT(toplevelishId id)
- xxx
+ xxx -> xxx
#endif
lookupLevel :: LibCaseEnv -> Id -> LibCaseLevel
lookupLevel (LibCaseEnv bomb lvl lvl_env rec_env scruts) id
= case lookupIdEnv lvl_env id of
Just lvl -> lvl
- Nothing -> ASSERT(toplevelishId id)
- topLevel
+ Nothing -> topLevel
freeScruts :: LibCaseEnv
-> LibCaseLevel -- Level of the recursive Id
import CoreSyn
import Digraph ( stronglyConnComp )
import Id ( idWantsToBeINLINEd, isConstMethodId,
- externallyVisibleId,
emptyIdSet, unionIdSets, mkIdSet,
unitIdSet, elementOfIdSet,
addOneToIdSet, SYN_IE(IdSet),
mapIdEnv, lookupIdEnv, SYN_IE(IdEnv),
GenId{-instance Eq-}
)
+import Name ( isExported )
import Maybes ( maybeToBool )
import Outputable ( Outputable(..){-instance * (,) -} )
import PprCore
)
usage_of usage binder
- | externallyVisibleId binder = ManyOcc 0 -- Visible-elsewhere things count as many
+ | isExported binder = ManyOcc 0 -- Visible-elsewhere things count as many
| otherwise
= case (lookupIdEnv usage binder) of
Nothing -> DeadCode
InstTyEnv(..)
)
import Id ( mkSysLocal, idType )
-import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
+import SrcLoc ( SrcLoc, noSrcLoc )
import UniqSupply
import Util
newSATName :: Id -> Type -> SatM Id
newSATName id ty us env
= case (getUnique us) of { unique ->
- (mkSysLocal new_str unique ty mkUnknownSrcLoc, env) }
+ (mkSysLocal new_str unique ty noSrcLoc, env) }
where
- new_str = panic "SATMonad.newSATName (ToDo)" -- getOccName id _APPEND_ SLIT("_sat")
+ new_str = getOccName id _APPEND_ SLIT("_sat")
getArgLists :: CoreExpr -> ([Arg Type],[Arg Id])
getArgLists expr
(getOccName binder _APPEND_ SLIT("_fsat"))
(uniqueOf binder)
(idType binder)
- mkUnknownSrcLoc
+ noSrcLoc
rec_body = mkValLam non_static_args
( Let (NonRec fake_binder nonrec_rhs)
{-in-} (dropArgs rhs))
import CoreUtils ( coreExprType )
import CoreUnfold ( whnfOrBottom )
import FreeVars -- all of it
-import Id ( idType, mkSysLocal, toplevelishId,
+import Id ( idType, mkSysLocal,
nullIdEnv, addOneToIdEnv, growIdEnvList,
unionManyIdSets, minusIdSet, mkIdSet,
idSetToList,
lookupIdEnv, SYN_IE(IdEnv)
)
import Pretty ( ppStr, ppBesides, ppChar, ppInt )
-import SrcLoc ( mkUnknownSrcLoc )
+import SrcLoc ( noSrcLoc )
import Type ( isPrimType, mkTyVarTys, mkForAllTys )
import TyVar ( nullTyVarEnv, addOneToTyVarEnv,
growTyVarEnvList, lookupTyVarEnv,
= lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
returnLvl (Coerce c ty expr')
+-- We don't split adjacent lambdas. That is, given
+-- \x y -> (x+1,y)
+-- we don't float to give
+-- \x -> let v = x+y in \y -> (v,y)
+-- Why not? Because partial applications are fairly rare, and splitting
+-- lambdas makes them more expensive.
+
lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnLam (ValBinder arg) rhs)
- = lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
- returnLvl (Lam (ValBinder (arg,incd_lvl)) rhs')
+ = lvlMFE incd_lvl (new_venv, tenv) body `thenLvl` \ body' ->
+ returnLvl (foldr (Lam . ValBinder) body' lvld_args)
where
- incd_lvl = incMajorLvl ctxt_lvl
- new_venv = growIdEnvList venv [(arg,incd_lvl)]
+ incd_lvl = incMajorLvl ctxt_lvl
+ (args, body) = annCollectValBinders rhs
+ lvld_args = [(a,incd_lvl) | a <- (arg:args)]
+ new_venv = growIdEnvList venv lvld_args
+
+-- We don't need to play such tricks for type lambdas, because
+-- they don't get annotated
-lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) e)
- = lvlExpr incd_lvl (venv, new_tenv) e `thenLvl` \ e' ->
- returnLvl (Lam (TyBinder tyvar) e')
+lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (TyBinder tyvar) body)
+ = lvlExpr incd_lvl (venv, new_tenv) body `thenLvl` \ body' ->
+ returnLvl (Lam (TyBinder tyvar) body')
where
- incd_lvl = incMinorLvl ctxt_lvl
- new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl
+ incd_lvl = incMinorLvl ctxt_lvl
+ new_tenv = addOneToTyVarEnv tenv tyvar incd_lvl
lvlExpr ctxt_lvl (venv, tenv) (_, AnnLam (UsageBinder u) e)
= panic "SetLevels.lvlExpr:AnnLam UsageBinder"
idLevel venv v
= case lookupIdEnv venv v of
Just level -> level
- Nothing -> ASSERT(toplevelishId v)
- tOP_LEVEL
+ Nothing -> tOP_LEVEL
tyvarLevel :: TyVarEnv Level -> TyVar -> Level
tyvarLevel tenv tyvar
Nothing -> tOP_LEVEL
\end{code}
+\begin{code}
+annCollectValBinders (_, (AnnLam (ValBinder arg) rhs))
+ = (arg:args, body)
+ where
+ (args, body) = annCollectValBinders rhs
+
+annCollectValBinders body
+ = ([], body)
+\end{code}
+
%************************************************************************
%* *
\subsection{Free-To-Level Monad}
newLvlVar :: Type -> LvlM Id
newLvlVar ty us
- = mkSysLocal SLIT("lvl") (getUnique us) ty mkUnknownSrcLoc
+ = mkSysLocal SLIT("lvl") (getUnique us) ty noSrcLoc
\end{code}
import BinderInfo -- too boring to try to select things...
import CmdLineOpts ( SimplifierSwitch(..) )
import CoreSyn
-import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
- SimpleUnfolding, FormSummary
- )
+import CoreUnfold ( Unfolding, SimpleUnfolding )
import CoreUtils ( coreAltsType, nonErrorRHSs, maybeErrorApp,
unTagBindersAlts
)
import AnalFBWW ( analFBWW )
import Bag ( isEmptyBag, foldBag )
import BinderInfo ( BinderInfo{-instance Outputable-} )
-import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD,
- uNFOLDING_USE_THRESHOLD,
- uNFOLDING_OVERRIDE_THRESHOLD,
- uNFOLDING_CON_DISCOUNT_WEIGHT
- )
import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), switchIsOn,
opt_D_show_passes,
opt_D_simplifier_stats,
opt_FoldrBuildOn,
opt_ReportWhyUnfoldingsDisallowed,
opt_ShowImportSpecs,
- opt_UnfoldingCreationThreshold,
- opt_UnfoldingOverrideThreshold,
- opt_UnfoldingUseThreshold
+ opt_LiberateCaseThreshold
)
import CoreLint ( lintCoreBindings )
import CoreSyn
+import CoreUtils ( coreExprType )
import CoreUnfold
-import CoreUtils ( substCoreBindings )
+import Literal ( Literal(..), literalType, mkMachInt )
import ErrUtils ( ghcExit )
import FiniteMap ( FiniteMap )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import FoldrBuildWW ( mkFoldrBuildWW )
-import Id ( idType, toplevelishId, idWantsToBeINLINEd,
- unfoldingUnfriendlyId, isWrapperId,
+import Id ( mkSysLocal, setIdVisibility,
nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
- lookupIdEnv, SYN_IE(IdEnv),
+ lookupIdEnv, SYN_IE(IdEnv),
GenId{-instance Outputable-}
)
-import IdInfo ( mkUnfolding )
+import Name ( isExported, isLocallyDefined )
+import TyCon ( TyCon )
+import PrimOp ( PrimOp(..) )
+import PrelVals ( unpackCStringId, unpackCString2Id,
+ integerZeroId, integerPlusOneId,
+ integerPlusTwoId, integerMinusOneId
+ )
+import Type ( maybeAppDataTyCon, getAppDataTyConExpandingDicts, maybeAppSpecDataTyConExpandingDicts )
+import TysWiredIn ( stringTy )
import LiberateCase ( liberateCase )
import MagicUFs ( MagicUnfoldingFun )
-import Maybes ( maybeToBool )
import Outputable ( Outputable(..){-instance * (,) -} )
import PprCore
import PprStyle ( PprStyle(..) )
import SpecUtils ( pprSpecErrs )
import StrictAnal ( saWwTopBinds )
import TyVar ( nullTyVarEnv, GenTyVar{-instance Eq-} )
-import Unique ( Unique{-instance Eq-} )
-import UniqSupply ( splitUniqSupply )
-import Util ( panic{-ToDo:rm-} )
+import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
+import UniqSupply ( splitUniqSupply, getUnique )
+import Util ( mapAccumL, assertPanic, panic{-ToDo:rm-}, pprTrace, pprPanic )
+import SrcLoc ( noSrcLoc )
+import Constants ( tARGET_MIN_INT, tARGET_MAX_INT )
+import Bag
+import Maybes
+
#ifndef OMIT_DEFORESTER
import Deforest ( deforestProgram )
import DefUtils ( deforestable )
#endif
-isWrapperFor = panic "SimplCore.isWrapperFor (ToDo)"
\end{code}
\begin{code}
-> FiniteMap TyCon [(Bool, [Maybe Type])]
-> [CoreBinding] -- input...
-> IO
- ([CoreBinding], -- results: program, plus...
- IdEnv Unfolding, -- unfoldings to be exported from here
+ ([CoreBinding], -- results: program, plus...
SpecialiseData) -- specialisation data
core2core core_todos module_name ppr_style us local_tycons tycon_specs binds
- = if null core_todos then -- very rare, I suspect...
- -- well, we still must do some renumbering
- return (
- (substCoreBindings nullIdEnv nullTyVarEnv binds us,
- nullIdEnv,
- init_specdata)
- )
- else
- (if do_verbose_core2core then
+ = -- Print heading
+ (if opt_D_verbose_core2core then
hPutStr stderr "VERBOSE CORE-TO-CORE:\n"
- else return ()) >>
+ else return ()) >>
- -- better do the main business
- foldl_mn do_core_pass
- (binds, us, nullIdEnv, init_specdata, zeroSimplCount)
+ -- Do the main business
+ foldl_mn do_core_pass
+ (binds, us1, init_specdata, zeroSimplCount)
core_todos
- >>= \ (processed_binds, _, inline_env, spec_data, simpl_stats) ->
-
- (if opt_D_simplifier_stats
- then hPutStr stderr ("\nSimplifier Stats:\n")
- >>
- hPutStr stderr (showSimplCount simpl_stats)
- >>
- hPutStr stderr "\n"
- else return ()
- ) >>
-
- return (processed_binds, inline_env, spec_data)
+ >>= \ (processed_binds, _, spec_data, simpl_stats) ->
+
+ -- Do the final tidy-up
+ let
+ final_binds = tidyCorePgm module_name us2 processed_binds
+ in
+
+ -- Report statistics
+ (if opt_D_simplifier_stats then
+ hPutStr stderr ("\nSimplifier Stats:\n") >>
+ hPutStr stderr (showSimplCount simpl_stats) >>
+ hPutStr stderr "\n"
+ else return ()) >>
+
+ --
+ return (final_binds, spec_data)
where
+ (us1, us2) = splitUniqSupply us
init_specdata = initSpecData local_tycons tycon_specs
- do_verbose_core2core = opt_D_verbose_core2core
-
- lib_case_threshold -- ToDo: HACK HACK HACK : FIX ME FIX ME FIX ME
- -- Use 4x a known threshold
- = case opt_UnfoldingOverrideThreshold of
- Nothing -> 4 * uNFOLDING_USE_THRESHOLD
- Just xx -> 4 * xx
-
-------------
core_linter = if opt_DoCoreLinting
then lintCoreBindings ppr_style
else ( \ whodunnit spec_done binds -> binds )
--------------
- do_core_pass info@(binds, us, inline_env, spec_data, simpl_stats) to_do
+ do_core_pass info@(binds, us, spec_data, simpl_stats) to_do
= let
(us1, us2) = splitUniqSupply us
in
then " (foldr/build)" else "") >>
case (simplifyPgm binds simpl_sw_chkr simpl_stats us1) of
(p, it_cnt, simpl_stats2)
- -> end_pass False us2 p inline_env spec_data simpl_stats2
+ -> end_pass False us2 p spec_data simpl_stats2
("Simplify (" ++ show it_cnt ++ ")"
++ if switchIsOn simpl_sw_chkr SimplDoFoldrBuild
then " foldr/build" else "")
-> _scc_ "CoreDoFoldrBuildWorkerWrapper"
begin_pass "FBWW" >>
case (mkFoldrBuildWW us1 binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "FBWW" }
+ end_pass False us2 binds2 spec_data simpl_stats "FBWW" }
CoreDoFoldrBuildWWAnal
-> _scc_ "CoreDoFoldrBuildWWAnal"
begin_pass "AnalFBWW" >>
case (analFBWW binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "AnalFBWW" }
+ end_pass False us2 binds2 spec_data simpl_stats "AnalFBWW" }
CoreLiberateCase
-> _scc_ "LiberateCase"
begin_pass "LiberateCase" >>
- case (liberateCase lib_case_threshold binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "LiberateCase" }
-
- CoreDoCalcInlinings1 -- avoid inlinings w/ cost-centres
- -> _scc_ "CoreInlinings1"
- begin_pass "CalcInlinings" >>
- case (calcInlinings False inline_env binds) of { inline_env2 ->
- end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" }
-
- CoreDoCalcInlinings2 -- allow inlinings w/ cost-centres
- -> _scc_ "CoreInlinings2"
- begin_pass "CalcInlinings" >>
- case (calcInlinings True inline_env binds) of { inline_env2 ->
- end_pass False us2 binds inline_env2 spec_data simpl_stats "CalcInlinings" }
+ case (liberateCase opt_LiberateCaseThreshold binds) of { binds2 ->
+ end_pass False us2 binds2 spec_data simpl_stats "LiberateCase" }
CoreDoFloatInwards
-> _scc_ "FloatInwards"
begin_pass "FloatIn" >>
case (floatInwards binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatIn" }
+ end_pass False us2 binds2 spec_data simpl_stats "FloatIn" }
CoreDoFullLaziness
-> _scc_ "CoreFloating"
begin_pass "FloatOut" >>
case (floatOutwards us1 binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "FloatOut" }
+ end_pass False us2 binds2 spec_data simpl_stats "FloatOut" }
CoreDoStaticArgs
-> _scc_ "CoreStaticArgs"
begin_pass "StaticArgs" >>
case (doStaticArgs binds us1) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "StaticArgs" }
+ end_pass False us2 binds2 spec_data simpl_stats "StaticArgs" }
-- Binds really should be dependency-analysed for static-
-- arg transformation... Not to worry, they probably are.
-- (I don't think it *dies* if they aren't [WDP 94/04/15])
-> _scc_ "CoreStranal"
begin_pass "StrAnal" >>
case (saWwTopBinds us1 binds) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "StrAnal" }
+ end_pass False us2 binds2 spec_data simpl_stats "StrAnal" }
CoreDoSpecialising
-> _scc_ "Specialise"
else
return ()) >>
- end_pass False us2 p inline_env spec_data2 simpl_stats "Specialise"
+ end_pass False us2 p spec_data2 simpl_stats "Specialise"
}
CoreDoDeforest
-> _scc_ "Deforestation"
begin_pass "Deforestation" >>
case (deforestProgram binds us1) of { binds2 ->
- end_pass False us2 binds2 inline_env spec_data simpl_stats "Deforestation" }
+ end_pass False us2 binds2 spec_data simpl_stats "Deforestation" }
#endif
CoreDoPrintCore -- print result of last pass
- -> end_pass True us2 binds inline_env spec_data simpl_stats "Print"
+ -> end_pass True us2 binds spec_data simpl_stats "Print"
-------------------------------------------------
then \ what -> hPutStr stderr ("*** Core2Core: "++what++"\n")
else \ what -> return ()
- end_pass print us2 binds2 inline_env2
+ end_pass print us2 binds2
spec_data2@(SpecData spec_done _ _ _ _ _ _ _)
simpl_stats2 what
= -- report verbosely, if required
- (if (do_verbose_core2core && not print) ||
- (print && not do_verbose_core2core)
+ (if (opt_D_verbose_core2core && not print) ||
+ (print && not opt_D_verbose_core2core)
then
hPutStr stderr ("\n*** "++what++":\n")
>>
return
(linted_binds, -- processed binds, possibly run thru CoreLint
us2, -- UniqueSupply for the next guy
- inline_env2, -- possibly-updated inline env
spec_data2, -- possibly-updated specialisation info
simpl_stats2 -- accumulated simplifier stats
)
-- here so it can be inlined...
foldl_mn f z [] = return z
foldl_mn f z (x:xs) = f z x >>= \ zz ->
- foldl_mn f zz xs
+ foldl_mn f zz xs
\end{code}
---- ToDo: maybe move elsewhere ---
-For top-level, exported binders that either (a)~have been INLINEd by
-the programmer or (b)~are sufficiently ``simple'' that they should be
-inlined, we want to record this info in a suitable IdEnv.
-But: if something has a ``wrapper unfolding,'' we do NOT automatically
-give it a regular unfolding (exception below). We usually assume its
-worker will get a ``regular'' unfolding. We can then treat these two
-levels of unfolding separately (we tend to be very friendly towards
-wrapper unfoldings, for example), giving more fine-tuned control.
+%************************************************************************
+%* *
+\subsection[SimplCore-indirections]{Eliminating indirections in Core code, and globalising}
+%* *
+%************************************************************************
+
+Several tasks are done by @tidyCorePgm@
+
+1. Eliminate indirections. The point here is to transform
+ x_local = E
+ x_exported = x_local
+ ==>
+ x_exported = E
+
+2. Make certain top-level bindings into Globals. The point is that
+ Global things get externally-visible labels at code generation
+ time
+
+3. Make the representation of NoRep literals explicit, and
+ float their bindings to the top level
+
+4. Convert
+ case x of {...; x' -> ...x'...}
+ ==>
+ case x of {...; _ -> ...x... }
+ See notes in SimplCase.lhs, near simplDefault for the reasoning here.
+
+5. *Mangle* cases involving fork# and par# in the discriminant. The
+ original templates for these primops (see @PrelVals.lhs@) constructed
+ case expressions with boolean results solely to fool the strictness
+ analyzer, the simplifier, and anyone else who might want to fool with
+ the evaluation order. At this point in the compiler our evaluation
+ order is safe. Therefore, we convert expressions of the form:
+
+ case par# e of
+ True -> rhs
+ False -> parError#
+ ==>
+ case par# e of
+ _ -> rhs
+
+6. Eliminate polymorphic case expressions. We can't generate code for them yet.
+
+Eliminate indirections
+~~~~~~~~~~~~~~~~~~~~~~
+In @elimIndirections@, we look for things at the top-level of the form...
+\begin{verbatim}
+ x_local = ....
+ x_exported = x_local
+\end{verbatim}
+In cases we find like this, we go {\em backwards} and replace
+\tr{x_local} with \tr{x_exported}. This save a gratuitous jump
+(from \tr{x_exported} to \tr{x_local}), and makes strictness
+information propagate better.
+
+We rely on prior eta reduction to simplify things like
+\begin{verbatim}
+ x_exported = /\ tyvars -> x_local tyvars
+==>
+ x_exported = x_local
+\end{verbatim}
+
+If more than one exported thing is equal to a local thing (i.e., the
+local thing really is shared), then we do one only:
+\begin{verbatim}
+ x_local = ....
+ x_exported1 = x_local
+ x_exported2 = x_local
+==>
+ x_exported1 = ....
+
+ x_exported2 = x_exported1
+\end{verbatim}
+
+There's a possibility of leaving unchanged something like this:
+\begin{verbatim}
+ x_local = ....
+ x_exported1 = x_local Int
+\end{verbatim}
+By the time we've thrown away the types in STG land this
+could be eliminated. But I don't think it's very common
+and it's dangerous to do this fiddling in STG land
+because we might elminate a binding that's mentioned in the
+unfolding for something.
+
+General Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
+Then blast the whole program (LHSs as well as RHSs) with it.
-The exception is: If the ``regular unfolding'' mentions no other
-global Ids (i.e., it's all PrimOps and cases and local Ids) then we
-assume it must be really good and we take it anyway.
-We also need to check that everything in the RHS (values and types)
-will be visible on the other side of an interface, too.
\begin{code}
-calcInlinings :: Bool -- True => inlinings with _scc_s are OK
- -> IdEnv Unfolding
- -> [CoreBinding]
- -> IdEnv Unfolding
-
-calcInlinings scc_s_OK inline_env_so_far top_binds
- = let
- result = foldl calci inline_env_so_far top_binds
- in
- --pprTrace "inline env:\n" (ppAboves (map pp_item (getIdEnvMapping result)))
- result
+tidyCorePgm :: Module -> UniqSupply -> [CoreBinding] -> [CoreBinding]
+
+tidyCorePgm mod us binds_in
+ = initTM mod indirection_env us $
+ tidyTopBindings (catMaybes reduced_binds) `thenTM` \ binds ->
+ returnTM (bagToList binds)
where
- pp_item (binder, details)
- = ppCat [ppr PprDebug binder, ppStr "=>", pp_det details]
- where
- pp_det NoUnfolding = ppStr "_N_"
---LATER: pp_det (IWantToBeINLINEd _) = ppStr "INLINE"
- pp_det (CoreUnfolding (SimpleUnfolding _ guide expr))
- = ppAbove (ppr PprDebug guide) (ppr PprDebug expr)
- pp_det other = ppStr "???"
-
- ------------
- my_trace = if opt_ReportWhyUnfoldingsDisallowed
- then trace
- else \ msg stuff -> stuff
-
- (unfolding_creation_threshold, explicit_creation_threshold)
- = case opt_UnfoldingCreationThreshold of
- Nothing -> (uNFOLDING_CREATION_THRESHOLD, False)
- Just xx -> (xx, True)
-
- unfold_use_threshold
- = case opt_UnfoldingUseThreshold of
- Nothing -> uNFOLDING_USE_THRESHOLD
- Just xx -> xx
-
- unfold_override_threshold
- = case opt_UnfoldingOverrideThreshold of
- Nothing -> uNFOLDING_OVERRIDE_THRESHOLD
- Just xx -> xx
-
- con_discount_weight = uNFOLDING_CON_DISCOUNT_WEIGHT
-
- calci inline_env (Rec pairs)
- = foldl (calc True{-recursive-}) inline_env pairs
-
- calci inline_env bind@(NonRec binder rhs)
- = calc False{-not recursive-} inline_env (binder, rhs)
-
- ---------------------------------------
-
- calc is_recursive inline_env (binder, rhs)
- | not (toplevelishId binder)
- = --pprTrace "giving up on not top-level:" (ppr PprDebug binder)
- ignominious_defeat
-
- | rhs_mentions_an_unmentionable
- || (not explicit_INLINE_requested
- && (rhs_looks_like_a_caf || guidance_size_too_big))
- = let
- my_my_trace
- = if explicit_INLINE_requested
- && not (isWrapperId binder) -- these always claim to be INLINEd
- && not have_inlining_already
- then trace -- we'd better have a look...
- else my_trace
-
- which = if scc_s_OK then " (late):" else " (early):"
- in
- my_my_trace ("unfolding disallowed for"++which++(ppShow 80 (ppr PprDebug binder))) (
- ignominious_defeat
- )
+ (indirection_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
+
+ try_bind :: IdEnv Id -> CoreBinding -> (IdEnv Id, Maybe CoreBinding)
+ try_bind env_so_far
+ (NonRec exported_binder (Var local_id))
+ | isExported exported_binder && -- Only if this is exported
+ isLocallyDefined local_id && -- Only if this one is defined in this
+ not (isExported local_id) && -- module, so that we *can* change its
+ -- binding to be the exported thing!
+ not (maybeToBool (lookupIdEnv env_so_far local_id))
+ -- Only if not already substituted for
+ = (addOneToIdEnv env_so_far local_id exported_binder, Nothing)
+
+ try_bind env_so_far bind
+ = (env_so_far, Just bind)
+\end{code}
+
+Top level bindings
+~~~~~~~~~~~~~~~~~~
+\begin{code}
+tidyTopBindings [] = returnTM emptyBag
+tidyTopBindings (b:bs)
+ = tidyTopBinding b $
+ tidyTopBindings bs
+
+tidyTopBinding :: CoreBinding
+ -> TidyM (Bag CoreBinding)
+ -> TidyM (Bag CoreBinding)
+
+tidyTopBinding (NonRec bndr rhs) thing_inside
+ = getFloats (tidyCoreExpr rhs) `thenTM` \ (rhs',floats) ->
+ mungeTopBinder bndr $ \ bndr' ->
+ thing_inside `thenTM` \ binds ->
+ returnTM ((floats `snocBag` NonRec bndr' rhs') `unionBags` binds)
+
+tidyTopBinding (Rec pairs) thing_inside
+ = mungeTopBinders binders $ \ binders' ->
+ getFloats (mapTM tidyCoreExpr rhss) `thenTM` \ (rhss', floats) ->
+ thing_inside `thenTM` \ binds_inside ->
+ returnTM ((floats `snocBag` Rec (binders' `zip` rhss')) `unionBags` binds_inside)
+ where
+ (binders, rhss) = unzip pairs
+\end{code}
+
+
+Local Bindings
+~~~~~~~~~~~~~~
+\begin{code}
+tidyCoreBinding (NonRec bndr rhs)
+ = tidyCoreExpr rhs `thenTM` \ rhs' ->
+ returnTM (NonRec bndr rhs')
+
+tidyCoreBinding (Rec pairs)
+ = mapTM do_one pairs `thenTM` \ pairs' ->
+ returnTM (Rec pairs')
+ where
+ do_one (bndr,rhs) = tidyCoreExpr rhs `thenTM` \ rhs' ->
+ returnTM (bndr, rhs')
+
+\end{code}
- | rhs `isWrapperFor` binder
- -- Don't add an explicit "unfolding"; let the worker/wrapper
- -- stuff do its thing. INLINE things don't get w/w'd, so
- -- they will be OK.
- = ignominious_defeat
-
-#if ! OMIT_DEFORESTER
- -- For the deforester: bypass the barbed wire for recursive
- -- functions that want to be inlined and are tagged deforestable
- -- by the user, allowing these things to be communicated
- -- across module boundaries.
-
- | is_recursive &&
- explicit_INLINE_requested &&
- deforestable binder &&
- scc_s_OK -- hack, only get them in
- -- calc_inlinings2
- = glorious_success UnfoldAlways
-#endif
- | is_recursive && not rhs_looks_like_a_data_val
- -- The only recursive defns we are prepared to tolerate at the
- -- moment is top-level very-obviously-a-data-value ones.
- -- We *need* these for dictionaries to be exported!
- = --pprTrace "giving up on rec:" (ppr PprDebug binder)
- ignominious_defeat
-
- -- Not really interested unless it's exported, but doing it
- -- this way (not worrying about export-ness) gets us all the
- -- workers/specs, etc., too; which we will need for generating
- -- interfaces. We are also not interested if this binder is
- -- in the environment we already have (perhaps from a previous
- -- run of calcInlinings -- "earlier" is presumed to mean
- -- "better").
-
- | explicit_INLINE_requested
- = glorious_success UnfoldAlways
-
- | otherwise
- = glorious_success guidance
-
- where
- guidance
- = calcUnfoldingGuidance scc_s_OK max_out_threshold rhs
- where
- max_out_threshold = if explicit_INLINE_requested
- then 100000 -- you asked for it, you got it
- else unfolding_creation_threshold
-
- guidance_size
- = case guidance of
- UnfoldAlways -> 0 -- *extremely* small
- UnfoldIfGoodArgs _ _ _ size -> size
-
- guidance_size_too_big
- -- Does the guidance suggest that this unfolding will
- -- be of no use *no matter* the arguments given to it?
- -- Could be more sophisticated...
- = not (couldBeSmallEnoughToInline con_discount_weight unfold_use_threshold guidance)
-
-
- rhs_looks_like_a_caf = not (whnfOrBottom rhs)
-
- rhs_looks_like_a_data_val
- = case (collectBinders rhs) of
- (_, _, [], Con _ _) -> True
- other -> False
-
- rhs_arg_tys
- = case (collectBinders rhs) of
- (_, _, val_binders, _) -> map idType val_binders
-
- (mentioned_ids, _, _, mentions_litlit)
- = mentionedInUnfolding (\x -> x) rhs
-
- rhs_mentions_an_unmentionable
- = foldBag (||) unfoldingUnfriendlyId False mentioned_ids
- || mentions_litlit
- -- ToDo: probably need to chk tycons/classes...
-
- mentions_no_other_ids = isEmptyBag mentioned_ids
-
- explicit_INLINE_requested
- -- did it come from a user {-# INLINE ... #-}?
- -- (Warning: must avoid including wrappers.)
- = idWantsToBeINLINEd binder
- && not (rhs `isWrapperFor` binder)
-
- have_inlining_already = maybeToBool (lookupIdEnv inline_env binder)
-
- ignominious_defeat = inline_env -- just give back what we got
-
- {-
- "glorious_success" is ours if we've found a suitable unfolding.
-
- But we check for a couple of fine points.
-
- (1) If this Id already has an inlining in the inline_env,
- we don't automatically take it -- the earlier one is
- "likely" to be better.
-
- But if the new one doesn't mention any other global
- Ids, and it's pretty small (< UnfoldingOverrideThreshold),
- then we take the chance that the new one *is* better.
-
- (2) If we have an Id w/ a worker/wrapper split (with
- an unfolding for the wrapper), we tend to want to keep
- it -- and *nuke* any inlining that we conjured up
- earlier.
-
- But, again, if this unfolding doesn't mention any
- other global Ids (and small enough), then it is
- probably better than the worker/wrappery, so we take
- it.
- -}
- glorious_success guidance
- = let
- new_env = addOneToIdEnv inline_env binder (mkUnfolding guidance rhs)
-
- foldr_building = opt_FoldrBuildOn
- in
- if (not have_inlining_already) then
- -- Not in env: we take it no matter what
- -- NB: we could check for worker/wrapper-ness,
- -- but the truth is we probably haven't run
- -- the strictness analyser yet.
- new_env
-
- else if explicit_INLINE_requested then
- -- If it was a user INLINE, then we know it's already
- -- in the inline_env; we stick with what we already
- -- have.
- --pprTrace "giving up on INLINE:" (ppr PprDebug binder)
- ignominious_defeat
-
- else if isWrapperId binder then
- -- It's in the env, but we have since worker-wrapperised;
- -- we either take this new one (because it's so good),
- -- or we *undo* the one in the inline_env, so the
- -- wrapper-inlining will take over.
-
- if mentions_no_other_ids {- *** && size <= unfold_override_threshold -} then
- new_env
- else
- delOneFromIdEnv inline_env binder
-
- else
- -- It's in the env, nothing to do w/ worker wrapper;
- -- we'll take it if it is better.
-
- if not foldr_building -- ANDY hates us... (see below)
- && mentions_no_other_ids
- && guidance_size <= unfold_override_threshold then
- new_env
- else
- --pprTrace "giving up on final hurdle:" (ppCat [ppr PprDebug binder, ppInt guidance_size, ppInt unfold_override_threshold])
- ignominious_defeat -- and at the last hurdle, too!
+Expressions
+~~~~~~~~~~~
+\begin{code}
+tidyCoreExpr (Var v) = lookupTM v `thenTM` \ v' ->
+ returnTM (Var v')
+
+tidyCoreExpr (Lit lit)
+ = litToRep lit `thenTM` \ (_, lit_expr) ->
+ returnTM lit_expr
+
+tidyCoreExpr (App fun arg)
+ = tidyCoreExpr fun `thenTM` \ fun' ->
+ tidyCoreArg arg `thenTM` \ arg' ->
+ returnTM (App fun' arg')
+
+tidyCoreExpr (Con con args)
+ = mapTM tidyCoreArg args `thenTM` \ args' ->
+ returnTM (Con con args')
+
+tidyCoreExpr (Prim prim args)
+ = mapTM tidyCoreArg args `thenTM` \ args' ->
+ returnTM (Prim prim args')
+
+tidyCoreExpr (Lam bndr body)
+ = tidyCoreExpr body `thenTM` \ body' ->
+ returnTM (Lam bndr body')
+
+tidyCoreExpr (Let bind body)
+ = tidyCoreBinding bind `thenTM` \ bind' ->
+ tidyCoreExpr body `thenTM` \ body' ->
+ returnTM (Let bind' body')
+
+tidyCoreExpr (SCC cc body)
+ = tidyCoreExpr body `thenTM` \ body' ->
+ returnTM (SCC cc body')
+
+tidyCoreExpr (Coerce coercion ty body)
+ = tidyCoreExpr body `thenTM` \ body' ->
+ returnTM (Coerce coercion ty body')
+
+-- Wierd case for par, seq, fork etc. See notes above.
+tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
+ | funnyParallelOp op
+ = tidyCoreExpr scrut `thenTM` \ scrut' ->
+ tidyCoreExpr rhs `thenTM` \ rhs' ->
+ returnTM (Case scrut' (PrimAlts [] (BindDefault binder rhs')))
+
+-- Eliminate polymorphic case, for which we can't generate code just yet
+tidyCoreExpr (Case scrut (AlgAlts [] (BindDefault deflt_bndr rhs)))
+ | not (maybeToBool (maybeAppSpecDataTyConExpandingDicts (coreExprType scrut)))
+ = pprTrace "Warning: discarding polymophic case:" (ppr PprDebug scrut) $
+ case scrut of
+ Var v -> extendEnvTM deflt_bndr v (tidyCoreExpr rhs)
+ other -> tidyCoreExpr (Let (NonRec deflt_bndr scrut) rhs)
+
+tidyCoreExpr (Case scrut alts)
+ = tidyCoreExpr scrut `thenTM` \ scrut' ->
+ tidy_alts alts `thenTM` \ alts' ->
+ returnTM (Case scrut' alts')
+ where
+ tidy_alts (AlgAlts alts deflt)
+ = mapTM tidy_alg_alt alts `thenTM` \ alts' ->
+ tidy_deflt deflt `thenTM` \ deflt' ->
+ returnTM (AlgAlts alts' deflt')
+
+ tidy_alts (PrimAlts alts deflt)
+ = mapTM tidy_prim_alt alts `thenTM` \ alts' ->
+ tidy_deflt deflt `thenTM` \ deflt' ->
+ returnTM (PrimAlts alts' deflt')
+
+ tidy_alg_alt (con,bndrs,rhs) = tidyCoreExpr rhs `thenTM` \ rhs' ->
+ returnTM (con,bndrs,rhs')
+
+ tidy_prim_alt (lit,rhs) = tidyCoreExpr rhs `thenTM` \ rhs' ->
+ returnTM (lit,rhs')
+
+ -- We convert case x of {...; x' -> ...x'...}
+ -- to
+ -- case x of {...; _ -> ...x... }
+ --
+ -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
+ -- It's quite easily done: simply extend the environment to bind the
+ -- default binder to the scrutinee.
+
+ tidy_deflt NoDefault = returnTM NoDefault
+ tidy_deflt (BindDefault bndr rhs)
+ = extend_env (tidyCoreExpr rhs) `thenTM` \ rhs' ->
+ returnTM (BindDefault bndr rhs')
+ where
+ extend_env = case scrut of
+ Var v -> extendEnvTM bndr v
+ other -> \x -> x
\end{code}
-ANDY, on the hatred of the check above; why obliterate it? Consider
+Arguments
+~~~~~~~~~
+\begin{code}
+tidyCoreArg :: CoreArg -> TidyM CoreArg
+
+tidyCoreArg (VarArg v)
+ = lookupTM v `thenTM` \ v' ->
+ returnTM (VarArg v')
+
+tidyCoreArg (LitArg lit)
+ = litToRep lit `thenTM` \ (lit_ty, lit_expr) ->
+ case lit_expr of
+ Var v -> returnTM (VarArg v)
+ Lit l -> returnTM (LitArg l)
+ other -> addTopFloat lit_ty lit_expr `thenTM` \ v ->
+ returnTM (VarArg v)
+
+tidyCoreArg (TyArg ty) = returnTM (TyArg ty)
+tidyCoreArg (UsageArg u) = returnTM (UsageArg u)
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[coreToStg-lits]{Converting literals}
+%* *
+%************************************************************************
+
+Literals: the NoRep kind need to be de-no-rep'd.
+We always replace them with a simple variable, and float a suitable
+binding out to the top level.
+
+\begin{code}
+
+litToRep :: Literal -> TidyM (Type, CoreExpr)
+
+litToRep (NoRepStr s)
+ = returnTM (stringTy, rhs)
+ where
+ rhs = if (any is_NUL (_UNPK_ s))
+
+ then -- Must cater for NULs in literal string
+ mkGenApp (Var unpackCString2Id)
+ [LitArg (MachStr s),
+ LitArg (mkMachInt (toInteger (_LENGTH_ s)))]
+
+ else -- No NULs in the string
+ App (Var unpackCStringId) (LitArg (MachStr s))
+
+ is_NUL c = c == '\0'
+\end{code}
+
+If an Integer is small enough (Haskell implementations must support
+Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
+otherwise, wrap with @litString2Integer@.
+
+\begin{code}
+litToRep (NoRepInteger i integer_ty)
+ = returnTM (integer_ty, rhs)
+ where
+ rhs | i == 0 = Var integerZeroId -- Extremely convenient to look out for
+ | i == 1 = Var integerPlusOneId -- a few very common Integer literals!
+ | i == 2 = Var integerPlusTwoId
+ | i == (-1) = Var integerMinusOneId
+
+ | i > tARGET_MIN_INT && -- Small enough, so start from an Int
+ i < tARGET_MAX_INT
+ = Prim Int2IntegerOp [LitArg (mkMachInt i)]
+
+ | otherwise -- Big, so start from a string
+ = Prim Addr2IntegerOp [LitArg (MachStr (_PK_ (show i)))]
+
+
+litToRep (NoRepRational r rational_ty)
+ = tidyCoreArg (LitArg (NoRepInteger (numerator r) integer_ty)) `thenTM` \ num_arg ->
+ tidyCoreArg (LitArg (NoRepInteger (denominator r) integer_ty)) `thenTM` \ denom_arg ->
+ returnTM (rational_ty, Con ratio_data_con [num_arg, denom_arg])
+ where
+ (ratio_data_con, integer_ty)
+ = case (maybeAppDataTyCon rational_ty) of
+ Just (tycon, [i_ty], [con])
+ -> ASSERT(is_integer_ty i_ty && uniqueOf tycon == ratioTyConKey)
+ (con, i_ty)
+
+ _ -> (panic "ratio_data_con", panic "integer_ty")
+
+ is_integer_ty ty
+ = case (maybeAppDataTyCon ty) of
+ Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey
+ _ -> False
+
+litToRep other_lit = returnTM (literalType other_lit, Lit other_lit)
+\end{code}
+
+\begin{code}
+funnyParallelOp SeqOp = True
+funnyParallelOp ParOp = True
+funnyParallelOp ForkOp = True
+funnyParallelOp _ = False
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The monad}
+%* *
+%************************************************************************
+
+\begin{code}
+type TidyM a = Module
+ -> IdEnv Id
+ -> (UniqSupply, Bag CoreBinding)
+ -> (a, (UniqSupply, Bag CoreBinding))
+
+initTM mod env us m
+ = case m mod env (us,emptyBag) of
+ (result, (us',floats)) -> result
+
+returnTM v mod env usf = (v, usf)
+thenTM m k mod env usf = case m mod env usf of
+ (r, usf') -> k r mod env usf'
+
+mapTM f [] = returnTM []
+mapTM f (x:xs) = f x `thenTM` \ r ->
+ mapTM f xs `thenTM` \ rs ->
+ returnTM (r:rs)
+\end{code}
+
+
+\begin{code}
+getFloats :: TidyM a -> TidyM (a, Bag CoreBinding)
+getFloats m mod env (us,floats)
+ = case m mod env (us,emptyBag) of
+ (r, (us',floats')) -> ((r, floats'), (us',floats))
+
+
+-- Need to extend the environment when we munge a binder, so that occurrences
+-- of the binder will print the correct way (i.e. as a global not a local)
+mungeTopBinder :: Id -> (Id -> TidyM a) -> TidyM a
+mungeTopBinder id thing_inside mod env usf
+ = case lookupIdEnv env id of
+ Just global -> thing_inside global mod env usf
+ Nothing -> thing_inside new_global mod new_env usf
+ where
+ new_env = addOneToIdEnv env id new_global
+ new_global = setIdVisibility mod id
+
+mungeTopBinders [] k = k []
+mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' ->
+ mungeTopBinders bs $ \ bs' ->
+ k (b' : bs')
+
+addTopFloat :: Type -> CoreExpr -> TidyM Id
+addTopFloat lit_ty lit_rhs mod env (us, floats)
+ = (lit_id, (us', floats `snocBag` NonRec lit_id lit_rhs))
+ where
+ lit_local = mkSysLocal SLIT("nrlit") uniq lit_ty noSrcLoc
+ lit_id = setIdVisibility mod lit_local
+ (us', us1) = splitUniqSupply us
+ uniq = getUnique us1
+
+lookupTM v mod env usf
+ = case lookupIdEnv env v of
+ Nothing -> (v, usf)
+ Just v' -> (v', usf)
+
+extendEnvTM v v' m mod env usf
+ = m mod (addOneToIdEnv env v v') usf
+\end{code}
- head xs = foldr (\ x _ -> x) (_|_) xs
-This then is exported via a pragma. However,
-*if* you include the extra code above, you will
-export the non-foldr/build version.
import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo,
BinderInfo(..){-instances, too-}, FunOrArg, DuplicationDanger, InsideSCC
)
-import CgCompInfo ( uNFOLDING_CREATION_THRESHOLD )
-import CmdLineOpts ( switchIsOn, intSwitchSet, SimplifierSwitch(..), SwitchResult(..) )
+import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold,
+ SimplifierSwitch(..), SwitchResult(..)
+ )
import CoreSyn
import CoreUnfold ( mkFormSummary, exprSmallEnoughToDup,
- Unfolding(..), SimpleUnfolding(..), FormSummary(..),
- mkSimpleUnfolding,
+ Unfolding(..), UfExpr, RdrName,
+ SimpleUnfolding(..), FormSummary(..),
calcUnfoldingGuidance, UnfoldingGuidance(..)
)
import CoreUtils ( coreExprCc, unTagBinders )
nullIdEnv, growIdEnvList, rngIdEnv, lookupIdEnv,
addOneToIdEnv, modifyIdEnv, mkIdSet, modifyIdEnv_Directly,
SYN_IE(IdEnv), SYN_IE(IdSet), GenId )
-import IdInfo ( bottomIsGuaranteed, StrictnessInfo )
import Literal ( isNoRepLit, Literal{-instances-} )
import Maybes ( maybeToBool, expectJust )
import Name ( isLocallyDefined )
in
...t...
-(The t in the body doesn't get inlined because by the time the recursive
-group is done we see that t's RHS isn't an atom.)
+Bad news! (f x) is duplicated! (The t in the body doesn't get
+inlined because by the time the recursive group is done we see that
+t's RHS isn't an atom.)
+
+Our solution is this:
+ (a) we inline un-simplified RHSs, and then simplify
+ them in a clone-only environment.
+ (b) we inline only variables and values
+This means taht
+
+
+ r = f x ==> r = f x
+ t = r ==> t = r
+ x = ...t... ==> x = ...r...
+ in in
+ t r
-Bad news! (f x) is duplicated! Our solution is to only be prepared to
-inline RHSs in their own RHSs if they are *values* (lambda or constructor).
+Now t is dead, and we're home.
-This means that silly x=y bindings in recursive group will never go away. Sigh. ToDo!
+Most silly x=y bindings in recursive group will go away. But not all:
+
+ let y = 1:x
+ x = y
+
+Here, we can't inline x because it's in an argument position. so we'll just replace
+with a clone of y. Instead we'll probably inline y (a small value) to give
+
+ let y = 1:x
+ x = 1:y
+
+which is OK if not clever.
-}
extendEnvForRecBinding env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
= SimplEnv chkr encl_cc ty_env in_id_env new_out_id_env con_apps
where
new_out_id_env = case (form_summary, guidance) of
- (ValueForm, UnfoldNever) -> out_id_env -- No new stuff to put in
- (ValueForm, _) -> out_id_env_with_unfolding
- other -> out_id_env -- Not a value
+ (_, UnfoldNever) -> out_id_env -- No new stuff to put in
+ (ValueForm, _) -> out_id_env_with_unfolding
+ (VarForm, _) -> out_id_env_with_unfolding
+ other -> out_id_env -- Not a value or variable
-- If there is an unfolding, we add rhs-info for out_id,
-- No need to modify occ info because RHS is pre-simplification
(out_id, occ_info, rhs_info)
-- Compute unfolding details
+ -- Note that we use the "old" environment, that just has clones of the rec-bound vars,
+ -- in the InUnfolding. So if we ever use the InUnfolding we'll just inline once.
+ -- Only if the thing is still small enough next time round will we inline again.
rhs_info = InUnfolding env (SimpleUnfolding form_summary guidance old_rhs)
form_summary = mkFormSummary old_rhs
guidance = mkSimplUnfoldingGuidance chkr out_id (unTagBinders old_rhs)
mkSimplUnfoldingGuidance chkr out_id rhs
- | not (switchIsOn chkr IgnoreINLINEPragma) && idWantsToBeINLINEd out_id
- = UnfoldAlways
-
- | otherwise
- = calcUnfoldingGuidance True{-sccs OK-} bOMB_OUT_SIZE rhs
+ = calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold rhs
where
- bOMB_OUT_SIZE = getSimplIntSwitch chkr SimplUnfoldingCreationThreshold
+ inline_prag = not (switchIsOn chkr IgnoreINLINEPragma) && idWantsToBeINLINEd out_id
extendEnvGivenRhsInfo :: SimplEnv -> OutId -> BinderInfo -> RhsInfo -> SimplEnv
extendEnvGivenRhsInfo env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps)
import Id ( mkSysLocal, mkIdWithNewUniq )
import CoreUnfold ( SimpleUnfolding )
import SimplEnv
-import SrcLoc ( mkUnknownSrcLoc )
+import SrcLoc ( noSrcLoc )
import TyVar ( cloneTyVar )
import UniqSupply ( getUnique, getUniques, splitUniqSupply,
UniqSupply
\begin{code}
newId :: Type -> SmplM Id
newId ty us sc
- = (mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc, sc)
+ = (mkSysLocal SLIT("s") uniq ty noSrcLoc, sc)
where
uniq = getUnique us
= (zipWithEqual "newIds" mk_id tys uniqs, sc)
where
uniqs = getUniques (length tys) us
- mk_id ty uniq = mkSysLocal SLIT("s") uniq ty mkUnknownSrcLoc
+ mk_id ty uniq = mkSysLocal SLIT("s") uniq ty noSrcLoc
cloneTyVarSmpl :: TyVar -> SmplM TyVar
import CoreSyn
import CoreUnfold ( SimpleUnfolding )
import CoreUtils ( substCoreExpr )
-import Id ( externallyVisibleId,
- mkIdEnv, lookupIdEnv, SYN_IE(IdEnv),
+import Id ( mkIdEnv, lookupIdEnv, SYN_IE(IdEnv),
GenId{-instance Ord3-}
)
import Maybes ( catMaybes )
simplifyPgm binds s_sw_chkr simpl_stats us
= case (splitUniqSupply us) of { (s1, s2) ->
case (initSmpl s1 (simpl_pgm 0 1 binds)) of { ((pgm2, it_count, simpl_stats2), _) ->
- case (tidy_top pgm2 s2) of { pgm3 ->
- (pgm3, it_count, combineSimplCounts simpl_stats simpl_stats2) }}}
+ (pgm2, it_count, combineSimplCounts simpl_stats simpl_stats2) }}
where
simpl_switch_is_on = switchIsOn s_sw_chkr
)
\end{code}
-In @tidy_top@, we look for things at the top-level of the form...
-\begin{verbatim}
-x_local = ....
-
-x_exported = x_local -- or perhaps...
-
-x_exported = /\ tyvars -> x_local tyvars -- where this is eta-reducible
-\end{verbatim}
-In cases we find like this, we go {\em backwards} and replace
-\tr{x_local} with \tr{x_exported}. This save a gratuitous jump
-(from \tr{x_exported} to \tr{x_local}), and makes strictness
-information propagate better.
-
-If more than one exported thing is equal to a local thing (i.e., the
-local thing really is shared), then obviously we give up.
-
-Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
-Then blast the whole program (LHSs as well as RHSs) with it.
-
-\begin{code}
-type BlastEnv = IdEnv Id -- domain is local Ids; range is exported Ids
-
-not_elem = isn'tIn "undup"
-
-tidy_top :: [CoreBinding] -> UniqSM [CoreBinding]
-
-tidy_top binds_in
- = if null blast_alist then
- returnUs binds_in -- no joy there
- else
- mapUs blast binds_in `thenUs` \ binds_maybe ->
- returnUs (catMaybes binds_maybe)
- where
- blast_alist = undup (foldl find_cand [] binds_in)
- blast_id_env = mkIdEnv blast_alist
- blast_val_env= mkIdEnv [ (l, Var e) | (l,e) <- blast_alist ]
- blast_all_exps = map snd blast_alist
-
- ---------
- find_cand blast_list (Rec _) = blast_list -- recursively paranoid, as usual
-
- find_cand blast_list (NonRec binder rhs)
- = if not (externallyVisibleId binder) then
- blast_list
- else
- case rhs_equiv_to_local_var rhs of
- Nothing -> blast_list
- Just local -> (local, binder) : blast_list -- tag it on
-
- ------------------------------------------
- -- if an Id appears >1 time in the domain,
- -- *all* occurrences must be expunged.
- undup :: [(Id, Id)] -> [(Id, Id)]
-
- undup blast_list
- = let
- (singles, dups) = removeDups compare blast_list
- list_of_dups = concat dups
- in
- [ s | s <- singles, s `not_elem` list_of_dups ]
- where
- compare (x,_) (y,_) = x `cmp` y
-
- ------------------------------------------
- rhs_equiv_to_local_var (Var x)
- = if externallyVisibleId x then Nothing else Just x
-
- rhs_equiv_to_local_var expr = Nothing
-
- ------------------------------------------
- -- "blast" does the substitution:
- -- returns Nothing if a binding goes away
- -- returns "Just b" to give back a fixed-up binding
-
- blast :: CoreBinding -> UniqSM (Maybe CoreBinding)
-
- blast (Rec pairs)
- = mapUs blast_pr pairs `thenUs` \ blasted_pairs ->
- returnUs (Just (Rec blasted_pairs))
- where
- blast_pr (binder, rhs)
- = substCoreExpr blast_val_env nullTyVarEnv rhs `thenUs` \ new_rhs ->
- returnUs (
- case (lookupIdEnv blast_id_env binder) of
- Just exportee -> (exportee, new_rhs)
- Nothing -> (binder, new_rhs)
- )
-
- blast (NonRec binder rhs)
- = if binder `is_elem` blast_all_exps then
- returnUs Nothing -- this binding dies!
- else
- substCoreExpr blast_val_env nullTyVarEnv rhs `thenUs` \ new_rhs ->
- returnUs (Just (
- case (lookupIdEnv blast_id_env binder) of
- Just exportee -> NonRec exportee new_rhs
- Nothing -> NonRec binder new_rhs
- ))
- where
- is_elem = isIn "blast"
-\end{code}
import Id ( idType, isBottomingId, idWantsToBeINLINEd, dataConArgTys,
getIdArity, GenId{-instance Eq-}
)
-import IdInfo ( arityMaybe )
+import IdInfo ( ArityInfo(..) )
import Maybes ( maybeToBool )
import PrelVals ( augmentId, buildId )
import PrimOp ( primOpIsCheap )
| isBottomingId v -- Bottoming ids have "infinite arity"
= 10000 -- Blargh. Infinite enough!
-eta_fun expr@(Var v)
- | maybeToBool arity_maybe -- We know the arity
- = arity
- where
- arity_maybe = arityMaybe (getIdArity v)
- arity = case arity_maybe of { Just arity -> arity }
+eta_fun expr@(Var v) = idMinArity v
eta_fun other = 0 -- Give up
\end{code}
num_val_args == 0 || -- Just a type application of
-- a variable (f t1 t2 t3)
-- counts as WHNF
- case (arityMaybe (getIdArity f)) of
- Nothing -> False
- Just arity -> num_val_args < arity
+ num_val_args < idMinArity f
_ -> False
}
+
\end{code}
Eta reduction on type lambdas
then False
else idWantsToBeINLINEd id
+idMinArity id = case getIdArity id of
+ UnknownArity -> 0
+ ArityAtLeast n -> n
+ ArityExactly n -> n
+
type_ok_for_let_to_case :: Type -> Bool
type_ok_for_let_to_case ty
IMP_Ubiq(){-uitous-}
IMPORT_DELOOPER(SmplLoop) ( simplExpr )
-import CgCompInfo ( uNFOLDING_USE_THRESHOLD,
+import Constants ( uNFOLDING_USE_THRESHOLD,
uNFOLDING_CON_DISCOUNT_WEIGHT
)
import CmdLineOpts ( switchIsOn, SimplifierSwitch(..) )
import CoreSyn
-import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding(..),
+import CoreUnfold ( Unfolding(..), UfExpr, RdrName, UnfoldingGuidance(..), SimpleUnfolding(..),
FormSummary,
- smallEnoughToInline )
-import BinderInfo ( BinderInfo, noBinderInfo, okToInline )
+ okToInline, smallEnoughToInline )
+import BinderInfo ( BinderInfo, noBinderInfo )
import CostCentre ( CostCentre, noCostCentreAttached )
import Id ( idType, getIdInfo, getIdUnfolding, getIdSpecialisation,
- GenId{-instance Outputable-}
+ idMustBeINLINEd, GenId{-instance Outputable-}
)
import SpecEnv ( SpecEnv, lookupSpecEnv )
import IdInfo ( DeforestInfo(..) )
| not do_deforest &&
maybeToBool maybe_unfolding_info &&
- (always_inline || (ok_to_inline && not essential_unfoldings_only)) &&
+ (not essential_unfoldings_only || idMustBeINLINEd var) &&
+ ok_to_inline &&
+ -- If "essential_unfolds_only" is true we do no inlinings at all,
+ -- EXCEPT for things that absolutely have to be done
+ -- (see comments with idMustBeINLINEd)
+ --
+ -- Need to be careful: the RHS of INLINE functions is protected against inlining
+ -- by essential_unfoldings_only being set true; we must not inline workers back into
+ -- wrappers, even thouth the former have an unfold-always guidance.
costCentreOk (getEnclosingCC env) (getEnclosingCC unfold_env)
= tick UnfoldingDone `thenSmpl_`
simplExpr unfold_env unf_template args
ok_to_inline = okToInline form
occ_info
small_enough
- small_enough = smallEnoughToInline con_disc unf_thresh arg_evals guidance
+ small_enough = smallEnoughToInline arg_evals guidance
arg_evals = [is_evald arg | arg <- args, isValArg arg]
is_evald (VarArg v) = isEvaluated (lookupRhsInfo env v)
is_evald (LitArg l) = True
- con_disc = getSimplIntSwitch sw_chkr SimplUnfoldingConDiscount
- unf_thresh = getSimplIntSwitch sw_chkr SimplUnfoldingUseThreshold
-
#if OMIT_DEFORESTER
do_deforest = False
#else
- do_deforest = case (getInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
+ do_deforest = case (getDeforestInfo (getIdInfo var)) of { DoDeforest -> True; _ -> False }
#endif
import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp,
unTagBinders, squashableDictishCcExpr
)
-import Id ( idType, idWantsToBeINLINEd,
- externallyVisibleId,
+import Id ( idType, idWantsToBeINLINEd, addIdArity,
getIdDemandInfo, addIdDemandInfo,
GenId{-instance NamedThing-}
)
-import IdInfo ( willBeDemanded, DemandInfo )
+import Name ( isExported )
+import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..),
+ atLeastArity, unknownArity )
import Literal ( isNoRepLit )
import Maybes ( maybeToBool )
--import Name ( isExported )
splitFunTy, getFunTy_maybe, eqTy
)
import TysWiredIn ( realWorldStateTy )
-import Util ( isSingleton, zipEqual, panic, pprPanic, assertPanic )
+import Util ( isSingleton, zipEqual, zipWithEqual, panic, pprPanic, assertPanic )
\end{code}
The controlling flags, and what they do
simplTopBinds env (NonRec binder@(in_id,occ_info) rhs : binds)
= -- No cloning necessary at top level
-- Process the binding
- simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
- completeNonRec env binder in_id rhs' `thenSmpl` \ (new_env, binds1') ->
+ simplRhsExpr env binder rhs `thenSmpl` \ (rhs',arity) ->
+ completeNonRec env binder (in_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') ->
-- Process the other bindings
simplTopBinds new_env binds `thenSmpl` \ binds2' ->
new_env = markDangerousOccs env (take n orig_args)
in
simplValLam new_env expr 0 {- Guaranteed applied to at least 0 args! -}
+ `thenSmpl` \ (expr', arity) ->
+ returnSmpl expr'
go n env non_val_lam_expr args -- The lambda had enough arguments
= simplExpr env non_val_lam_expr args
:: SimplEnv
-> InBinder
-> InExpr
- -> SmplM OutExpr
+ -> SmplM (OutExpr, ArityInfo)
simplRhsExpr env binder@(id,occ_info) rhs
| dont_eta_expand rhs
- = simplExpr rhs_env rhs []
+ = simplExpr rhs_env rhs [] `thenSmpl` \ rhs' ->
+ returnSmpl (rhs', unknownArity)
| otherwise -- Have a go at eta expansion
= -- Deal with the big lambda part
-- Deal with the little lambda part
-- Note that we call simplLam even if there are no binders,
-- in case it can do arity expansion.
- simplValLam lam_env body (getBinderInfoArity occ_info) `thenSmpl` \ lambda' ->
+ simplValLam lam_env body (getBinderInfoArity occ_info) `thenSmpl` \ (lambda', arity) ->
-- Put it back together
returnSmpl (
(if switchIsSet env SimplDoEtaReduction
then mkTyLamTryingEta
- else mkTyLam) tyvars' lambda'
+ else mkTyLam) tyvars' lambda',
+ arity
)
where
- rhs_env | not (switchIsSet env IgnoreINLINEPragma) &&
+ rhs_env | -- not (switchIsSet env IgnoreINLINEPragma) &&
+ -- No! Don't ever inline in a INLINE thing's rhs, because
+ -- doing so will inline a worker straight back into its wrapper!
idWantsToBeINLINEd id
= switchOffInlining env
| otherwise
\begin{code}
simplValLam env expr min_no_of_args
| not (switchIsSet env SimplDoLambdaEtaExpansion) || -- Bale out if eta expansion off
- null binders || -- or it's a thunk
+
+-- We used to disable eta expansion for thunks, but I don't see why.
+-- null binders || -- or it's a thunk
+
null potential_extra_binder_tys || -- or ain't a function
no_of_extra_binders <= 0 -- or no extra binders needed
= cloneIds env binders `thenSmpl` \ binders' ->
returnSmpl (
(if switchIsSet new_env SimplDoEtaReduction
then mkValLamTryingEta
- else mkValLam) binders' body'
+ else mkValLam) binders' body',
+ atLeastArity no_of_binders
)
| otherwise -- Eta expansion possible
returnSmpl (
(if switchIsSet new_env SimplDoEtaReduction
then mkValLamTryingEta
- else mkValLam) (binders' ++ extra_binders') body'
+ else mkValLam) (binders' ++ extra_binders') body',
+ atLeastArity (no_of_binders + no_of_extra_binders)
)
where
(binders,body) = collectValBinders expr
+ no_of_binders = length binders
(potential_extra_binder_tys, res_ty)
= splitFunTy (simplTy env (coreExprType (unTagBinders body)))
-- Note: it's possible that simplValLam will be applied to something
extra_binder_tys = take no_of_extra_binders potential_extra_binder_tys
no_of_extra_binders = -- First, use the info about how many args it's
- -- always applied to in its scope
- (min_no_of_args - length binders)
+ -- always applied to in its scope; but ignore this
+ -- if it's a thunk! To see why we ignore it for thunks,
+ -- consider let f = lookup env key in (f 1, f 2)
+ -- We'd better not eta expand f just because it is
+ -- always applied!
+ (if null binders
+ then 0
+ else min_no_of_args - no_of_binders)
-- Next, try seeing if there's a lambda hidden inside
-- something cheap
case potential_extra_binder_tys of
[ty] | ty `eqTy` realWorldStateTy -> 1
other -> 0
-
\end{code}
-- Dead code is now discarded by the occurrence analyser,
simplBind env (NonRec binder@(id,occ_info) rhs) body_c body_ty
+ | idWantsToBeINLINEd id
+ = complete_bind env rhs -- Don't messa bout with floating or let-to-case on
+ -- INLINE things
+ | otherwise
= simpl_bind env rhs
where
-- Try let-to-case; see notes below about let-to-case
simpl_bind env rhs = complete_bind env rhs
complete_bind env rhs
- = simplRhsExpr env binder rhs `thenSmpl` \ rhs' ->
+ = simplRhsExpr env binder rhs `thenSmpl` \ (rhs',arity) ->
cloneId env binder `thenSmpl` \ new_id ->
- completeNonRec env binder new_id rhs' `thenSmpl` \ (new_env, binds) ->
+ completeNonRec env binder
+ (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) ->
body_c new_env `thenSmpl` \ body' ->
returnSmpl (mkCoLetsAny binds body')
(pairs', body') = do_float body
do_float other = ([], other)
+
+-- The env passed to simplRecursiveGroup already has
+-- bindings that clone the variables of the group.
simplRecursiveGroup env new_ids pairs
= -- Add unfoldings to the new_ids corresponding to their RHS
let
env new_ids_w_pairs
in
- mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss ->
+ mapSmpl (\(binder,rhs) -> simplRhsExpr rhs_env binder rhs) pairs `thenSmpl` \ new_rhss_w_arities ->
let
- new_pairs = zipEqual "simplRecGp" new_ids new_rhss
+ new_pairs = zipWithEqual "simplRecGp" mk_new_pair new_ids new_rhss_w_arities
+ mk_new_pair id (rhs,arity) = (id `withArity` arity, rhs)
+ -- NB: the new arity isn't used when processing its own
+ -- right hand sides, nor in the subsequent code
+ -- The latter is something of a pity, and not hard to fix; but
+ -- the info will percolate on the next iteration anyway
+
+{- THE NEXT FEW LINES ARE PLAIN WRONG
occs_w_new_pairs = zipEqual "simplRecGp" occs new_pairs
new_env = foldl add_binding env occs_w_new_pairs
add_binding env (occ_info,(new_id,new_rhs))
= extendEnvGivenBinding env occ_info new_id new_rhs
+
+Here's why it's wrong: consider
+ let f x = ...f x'...
+ in
+ f 3
+
+If the RHS is small we'll inline f in the body of the let, then
+again, then again...URK
+-}
in
- returnSmpl (Rec new_pairs, new_env)
+ returnSmpl (Rec new_pairs, rhs_env)
\end{code}
completeNonRec env binder new_id rhs@(Con con con_args)
| switchIsSet env SimplReuseCon &&
maybeToBool maybe_existing_con &&
- not (externallyVisibleId new_id) -- Don't bother for exported things
- -- because we won't be able to drop
- -- its binding.
+ not (isExported new_id) -- Don't bother for exported things
+ -- because we won't be able to drop
+ -- its binding.
= tick ConReused `thenSmpl_`
returnSmpl (extendIdEnvWithAtom env binder (VarArg it), [NonRec new_id rhs])
where
fix_up_demandedness False {- May not be demanded -} (Rec pairs)
= Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
-un_demandify (id, occ_info) = (id `addIdDemandInfo` noInfo, occ_info)
+un_demandify (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
is_cheap_prim_app other = False
go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
Just (_, res_ty) -> go res_ty args
Nothing -> panic "computeResultType"
+
+var `withArity` UnknownArity = var
+var `withArity` arity = var `addIdArity` arity
\end{code}
import StgSyn
import Bag ( emptyBag, unionBags, unitBag, snocBag, bagToList )
-import Id ( idType, mkSysLocal, addIdArity,
+import Id ( idType, mkSysLocal, addIdArity,
mkIdSet, unitIdSet, minusIdSet,
unionManyIdSets, idSetToList, SYN_IE(IdSet),
nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv)
)
-import SrcLoc ( mkUnknownSrcLoc )
+import IdInfo ( ArityInfo, exactArity )
+import SrcLoc ( noSrcLoc )
import Type ( splitForAllTy, mkForAllTys, mkFunTys )
import UniqSupply ( getUnique, splitUniqSupply )
import Util ( zipEqual, panic, assertPanic )
-> LiftM Id
newSupercombinator ty arity ci us idenv
- = (mkSysLocal SLIT("sc") uniq ty mkUnknownSrcLoc) -- ToDo: improve location
- `addIdArity` arity
+ = (mkSysLocal SLIT("sc") uniq ty noSrcLoc) -- ToDo: improve location
+ `addIdArity` exactArity arity
-- ToDo: rm the addIdArity? Just let subsequent stg-saturation pass do it?
where
uniq = getUnique us
nullIdEnv, addOneToIdEnv, growIdEnvList,
lookupIdEnv, SYN_IE(IdEnv)
)
-import IdInfo ( arityMaybe )
-import SrcLoc ( mkUnknownSrcLoc )
+import SrcLoc ( noSrcLoc )
import Type ( splitSigmaTy, splitForAllTy, splitFunTyExpandingDicts )
import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
import Util ( panic, assertPanic )
\begin{code}
satStgRhs :: [StgBinding] -> UniqSM [StgBinding]
+satStgRhs = panic "satStgRhs"
+
+{- NUKED FOR NOW SLPJ Dec 96
+
satStgRhs p = satProgram nullIdEnv p
newName :: Type -> UniqSM Id
newName ut
= getUnique `thenUs` \ uniq ->
- returnUs (mkSysLocal SLIT("sat") uniq ut mkUnknownSrcLoc)
+ returnUs (mkSysLocal SLIT("sat") uniq ut noSrcLoc)
+
+-}
\end{code}
import SCCfinal ( stgMassageForProfiling )
import SatStgRhs ( satStgRhs )
import StgLint ( lintStgBindings )
-import StgSAT ( doStaticArgs )
import StgStats ( showStgStats )
import StgVarInfo ( setStgVarInfo )
import UpdAnal ( updateAnalyse )
opt_StgDoLetNoEscapes, opt_D_verbose_stg2stg,
StgToDo(..)
)
-import Id ( externallyVisibleId,
- nullIdEnv, lookupIdEnv, addOneToIdEnv,
+import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv,
growIdEnvList, isNullIdEnv, SYN_IE(IdEnv),
GenId{-instance Eq/Outputable -}
)
import UniqSupply ( splitUniqSupply )
import Util ( mapAccumL, panic, assertPanic )
-unlocaliseId = panic "SimplStg.unlocaliseId (ToDo)"
\end{code}
\begin{code}
-- Do the main business!
foldl_mn do_stg_pass (binds, us4now, ([],[])) stg_todos
>>= \ (processed_binds, _, cost_centres) ->
- -- Do essential wind-up: part (a) is SatStgRhs
- -- Not optional, because correct arity information is used by
- -- the code generator. Afterwards do setStgVarInfo; it gives
- -- the wrong answers if arities are subsequently changed,
- -- which stgSatRhs might do. Furthermore, setStgVarInfo
- -- decides about let-no-escape things, which in turn do a
- -- better job if arities are correct, which is done by
- -- satStgRhs.
+ -- Do essential wind-up
- case (satStgRhs processed_binds us4later) of { saturated_binds ->
-
- -- Essential wind-up: part (b), eliminate indirections
-
- let no_ind_binds = elimIndirections saturated_binds in
+{- Nuked for now SLPJ Dec 96
+ -- Essential wind-up: part (a), saturate RHSs
+ -- This must occur *after* elimIndirections, because elimIndirections
+ -- can change things' arities. Consider:
+ -- x_local = f x
+ -- x_global = \a -> x_local a
+ -- Then elimIndirections will change the program to
+ -- x_global = f x
+ -- and lo and behold x_global's arity has changed!
+ case (satStgRhs processed_binds us4later) of { saturated_binds ->
+-}
- -- Essential wind-up: part (c), do setStgVarInfo. It has to
+ -- Essential wind-up: part (b), do setStgVarInfo. It has to
-- happen regardless, because the code generator uses its
-- decorations.
--
-- things, which in turn do a better job if arities are
-- correct, which is done by satStgRhs.
--
+
+{- Done in Core now. Nuke soon. SLPJ Nov 96
let
-- ToDo: provide proper flag control!
binds_to_mangle
= if not do_unlocalising
- then no_ind_binds
+ then saturated_binds
else snd (unlocaliseStgBinds unlocal_tag nullIdEnv no_ind_binds)
in
- return (setStgVarInfo do_let_no_escapes binds_to_mangle, cost_centres)
- }}
+-}
+
+ return (setStgVarInfo do_let_no_escapes processed_binds, cost_centres)
+ }
where
do_let_no_escapes = opt_StgDoLetNoEscapes
do_verbose_stg2stg = opt_D_verbose_stg2stg
- (do_unlocalising, unlocal_tag)
- = case (opt_EnsureSplittableC) of
- Nothing -> (False, panic "tag")
- Just tag -> (True, _PK_ tag)
-
grp_name = case (opt_SccGroup) of
Just xx -> _PK_ xx
Nothing -> module_name -- default: module name
(us1, us2) = splitUniqSupply us
in
case to_do of
- StgDoStaticArgs ->
- ASSERT(null (fst ccs) && null (snd ccs))
- _scc_ "StgStaticArgs"
- let
- binds3 = doStaticArgs binds us1
- in
- end_pass us2 "StgStaticArgs" ccs binds3
+ StgDoStaticArgs -> panic "STG static argument transformation deleted"
StgDoUpdateAnalysis ->
ASSERT(null (fst ccs) && null (snd ccs))
foldl_mn f zz xs
\end{code}
-%************************************************************************
-%* *
-\subsection[SimplStg-unlocalise]{Unlocalisation in STG code}
-%* *
-%************************************************************************
-
-The idea of all this ``unlocalise'' stuff is that in certain (prelude
-only) modules we split up the .hc file into lots of separate little
-files, which are separately compiled by the C compiler. That gives
-lots of little .o files. The idea is that if you happen to mention
-one of them you don't necessarily pull them all in. (Pulling in a
-piece you don't need can be v bad, because it may mention other pieces
-you don't need either, and so on.)
-
-Sadly, splitting up .hc files means that local names (like s234) are
-now globally visible, which can lead to clashes between two .hc
-files. So unlocaliseWhatnot goes through making all the local things
-into global things, essentially by giving them full names so when they
-are printed they'll have their module name too. Pretty revolting
-really.
-\begin{code}
-type UnlocalEnv = IdEnv Id
-
-lookup_uenv :: UnlocalEnv -> Id -> Id
-lookup_uenv env id = case lookupIdEnv env id of
- Nothing -> id
- Just new_id -> new_id
-
-unlocaliseStgBinds :: FAST_STRING -> UnlocalEnv -> [StgBinding] -> (UnlocalEnv, [StgBinding])
-
-unlocaliseStgBinds mod uenv [] = (uenv, [])
-
-unlocaliseStgBinds mod uenv (b : bs)
- = case (unlocal_top_bind mod uenv b) of { (new_uenv, new_b) ->
- case (unlocaliseStgBinds mod new_uenv bs) of { (uenv3, new_bs) ->
- (uenv3, new_b : new_bs) }}
-
-------------------
-
-unlocal_top_bind :: FAST_STRING -> UnlocalEnv -> StgBinding -> (UnlocalEnv, StgBinding)
-
-unlocal_top_bind mod uenv bind@(StgNonRec binder _)
- = let new_uenv = case unlocaliseId mod binder of
- Nothing -> uenv
- Just new_binder -> addOneToIdEnv uenv binder new_binder
- in
- (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
-
-unlocal_top_bind mod uenv bind@(StgRec pairs)
- = let maybe_unlocaliseds = [ (b, unlocaliseId mod b) | (b, _) <- pairs ]
- new_uenv = growIdEnvList uenv [ (b,new_b)
- | (b, Just new_b) <- maybe_unlocaliseds]
- in
- (new_uenv, renameTopStgBind (lookup_uenv new_uenv) bind)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[SimplStg-indirections]{Eliminating indirections in STG code}
-%* *
-%************************************************************************
-
-In @elimIndirections@, we look for things at the top-level of the form...
-\begin{verbatim}
- x_local = ....rhs...
- ...
- x_exported = x_local
- ...
-\end{verbatim}
-In cases we find like this, we go {\em backwards} and replace
-\tr{x_local} with \tr{...rhs...}, to produce
-\begin{verbatim}
- x_exported = ...rhs...
- ...
- ...
-\end{verbatim}
-This saves a gratuitous jump
-(from \tr{x_exported} to \tr{x_local}), and makes strictness
-information propagate better.
-
-If more than one exported thing is equal to a local thing (i.e., the
-local thing really is shared), then we eliminate only the first one. Thus:
-\begin{verbatim}
- x_local = ....rhs...
- ...
- x_exported1 = x_local
- ...
- x_exported2 = x_local
- ...
-\end{verbatim}
-becomes
-\begin{verbatim}
- x_exported1 = ....rhs...
- ...
- ...
- x_exported2 = x_exported1
- ...
-\end{verbatim}
-
-We also have to watch out for
-
- f = \xyz -> g x y z
-
-This can arise post lambda lifting; the original might have been
-
- f = \xyz -> letrec g = [xy] \ [k] -> e
- in
- g z
-
-Strategy: first collect the info; then make a \tr{Id -> Id} mapping.
-Then blast the whole program (LHSs as well as RHSs) with it.
-
-\begin{code}
-elimIndirections :: [StgBinding] -> [StgBinding]
-
-elimIndirections binds_in
- = if isNullIdEnv blast_env then
- binds_in -- Nothing to do
- else
- [renameTopStgBind lookup_fn bind | Just bind <- reduced_binds]
- where
- lookup_fn id = case lookupIdEnv blast_env id of
- Just new_id -> new_id
- Nothing -> id
-
- (blast_env, reduced_binds) = mapAccumL try_bind nullIdEnv binds_in
-
- try_bind :: IdEnv Id -> StgBinding -> (IdEnv Id, Maybe StgBinding)
- try_bind env_so_far
- (StgNonRec exported_binder
- (StgRhsClosure _ _ _ _
- lambda_args
- (StgApp (StgVarArg local_binder) fun_args _)
- ))
- | 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
- args_match lambda_args fun_args -- Just an eta-expansion
-
- = (addOneToIdEnv env_so_far local_binder exported_binder,
- Nothing)
- where
- args_match [] [] = True
- args_match (la:las) (StgVarArg fa:fas) = la == fa && args_match las fas
- args_match _ _ = False
-
- try_bind env_so_far bind
- = (env_so_far, Just bind)
-
- in_dom env id = maybeToBool (lookupIdEnv env id)
-\end{code}
-
-@renameTopStgBind@ renames top level binders and all occurrences thereof.
-
-\begin{code}
-renameTopStgBind :: (Id -> Id) -> StgBinding -> StgBinding
-
-renameTopStgBind fn (StgNonRec b rhs) = StgNonRec (fn b) (mapStgBindeesRhs fn rhs)
-renameTopStgBind fn (StgRec pairs) = StgRec [ (fn b, mapStgBindeesRhs fn r) | (b, r) <- pairs ]
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-%************************************************************************
-%* *
-\section[SAT]{Static Argument Transformation pass}
-%* *
-%************************************************************************
-
-May be seen as removing invariants from loops:
-Arguments of recursive functions that do not change in recursive
-calls are removed from the recursion, which is done locally
-and only passes the arguments which effectively change.
-
-Example:
-map = /\ ab -> \f -> \xs -> case xs of
- [] -> []
- (a:b) -> f a : map f b
-
-as map is recursively called with the same argument f (unmodified)
-we transform it to
-
-map = /\ ab -> \f -> \xs -> let map' ys = case ys of
- [] -> []
- (a:b) -> f a : map' b
- in map' xs
-
-Notice that for a compiler that uses lambda lifting this is
-useless as map' will be transformed back to what map was.
-
-\begin{code}
-#include "HsVersions.h"
-
-module StgSAT ( doStaticArgs ) where
-
-IMP_Ubiq(){-uitous-}
-
-import StgSyn
-import UniqSupply ( SYN_IE(UniqSM) )
-import Util ( panic )
-\end{code}
-
-\begin{code}
-doStaticArgs :: [StgBinding] -> UniqSupply -> [StgBinding]
-
-doStaticArgs = panic "StgSAT.doStaticArgs"
-
-{- LATER: to end of file:
-doStaticArgs binds
- = initSAT (mapSAT sat_bind binds)
- where
- sat_bind (StgNonRec binder expr)
- = emptyEnvSAT `thenSAT_`
- satRhs expr `thenSAT` (\ expr' ->
- returnSAT (StgNonRec binder expr'))
- sat_bind (StgRec [(binder,rhs)])
- = emptyEnvSAT `thenSAT_`
- insSAEnv binder (getArgLists rhs) `thenSAT_`
- satRhs rhs `thenSAT` (\ rhs' ->
- saTransform binder rhs')
- sat_bind (StgRec pairs)
- = emptyEnvSAT `thenSAT_`
- mapSAT satRhs rhss `thenSAT` \ rhss' ->
- returnSAT (StgRec (binders `zip` rhss'))
- where
- (binders, rhss) = unzip pairs
-\end{code}
-
-\begin{code}
-satAtom (StgVarArg v)
- = updSAEnv (Just (v,([],[]))) `thenSAT_`
- returnSAT ()
-
-satAtom _ = returnSAT ()
-\end{code}
-
-\begin{code}
-satExpr :: StgExpr -> SatM StgExpr
-
-satExpr e@(StgCon con args lvs)
- = mapSAT satAtom args `thenSAT_`
- returnSAT e
-
-satExpr e@(StgPrim op args lvs)
- = mapSAT satAtom args `thenSAT_`
- returnSAT e
-
-satExpr e@(StgApp (StgLitArg _) _ _)
- = returnSAT e
-
-satExpr e@(StgApp (StgVarArg v) args _)
- = updSAEnv (Just (v,([],map tagArg args))) `thenSAT_`
- mapSAT satAtom args `thenSAT_`
- returnSAT e
- where
- tagArg (StgVarArg v) = Static v
- tagArg _ = NotStatic
-
-satExpr (StgCase expr lv1 lv2 uniq alts)
- = satExpr expr `thenSAT` \ expr' ->
- sat_alts alts `thenSAT` \ alts' ->
- returnSAT (StgCase expr' lv1 lv2 uniq alts')
- where
- sat_alts (StgAlgAlts ty alts deflt)
- = mapSAT satAlgAlt alts `thenSAT` \ alts' ->
- sat_default deflt `thenSAT` \ deflt' ->
- returnSAT (StgAlgAlts ty alts' deflt')
- where
- satAlgAlt (con, params, use_mask, rhs)
- = satExpr rhs `thenSAT` \ rhs' ->
- returnSAT (con, params, use_mask, rhs')
-
- sat_alts (StgPrimAlts ty alts deflt)
- = mapSAT satPrimAlt alts `thenSAT` \ alts' ->
- sat_default deflt `thenSAT` \ deflt' ->
- returnSAT (StgPrimAlts ty alts' deflt')
- where
- satPrimAlt (lit, rhs)
- = satExpr rhs `thenSAT` \ rhs' ->
- returnSAT (lit, rhs')
-
- sat_default StgNoDefault
- = returnSAT StgNoDefault
- sat_default (StgBindDefault binder used rhs)
- = satExpr rhs `thenSAT` \ rhs' ->
- returnSAT (StgBindDefault binder used rhs')
-
-satExpr (StgLetNoEscape lv1 lv2 (StgNonRec binder rhs) body)
- = satExpr body `thenSAT` \ body' ->
- satRhs rhs `thenSAT` \ rhs' ->
- returnSAT (StgLetNoEscape lv1 lv2 (StgNonRec binder rhs') body')
-
-satExpr (StgLetNoEscape lv1 lv2 (StgRec [(binder,rhs)]) body)
- = satExpr body `thenSAT` \ body' ->
- insSAEnv binder (getArgLists rhs) `thenSAT_`
- satRhs rhs `thenSAT` \ rhs' ->
- saTransform binder rhs' `thenSAT` \ binding ->
- returnSAT (StgLetNoEscape lv1 lv2 binding body')
-
-satExpr (StgLetNoEscape lv1 lv2 (StgRec binds) body)
- = let (binders, rhss) = unzip binds
- in
- satExpr body `thenSAT` \ body' ->
- mapSAT satRhs rhss `thenSAT` \ rhss' ->
- returnSAT (StgLetNoEscape lv1 lv2 (StgRec (binders `zip` rhss')) body')
-
-satExpr (StgLet (StgNonRec binder rhs) body)
- = satExpr body `thenSAT` \ body' ->
- satRhs rhs `thenSAT` \ rhs' ->
- returnSAT (StgLet (StgNonRec binder rhs') body')
-
-satExpr (StgLet (StgRec [(binder,rhs)]) body)
- = satExpr body `thenSAT` \ body' ->
- insSAEnv binder (getArgLists rhs) `thenSAT_`
- satRhs rhs `thenSAT` \ rhs' ->
- saTransform binder rhs' `thenSAT` \ binding ->
- returnSAT (StgLet binding body')
-
-satExpr (StgLet (StgRec binds) body)
- = let (binders, rhss) = unzip binds
- in
- satExpr body `thenSAT` \ body' ->
- mapSAT satRhs rhss `thenSAT` \ rhss' ->
- returnSAT (StgLet (StgRec (binders `zip` rhss')) body')
-
-satExpr (StgSCC ty cc expr)
- = satExpr expr `thenSAT` \ expr' ->
- returnSAT (StgSCC ty cc expr')
-\end{code}
-
-\begin{code}
-satRhs rhs@(StgRhsCon cc v args) = returnSAT rhs
-
-satRhs (StgRhsClosure cc bi fvs upd args body)
- = satExpr body `thenSAT` \ body' ->
- returnSAT (StgRhsClosure cc bi fvs upd args body')
--}
-\end{code}
+++ /dev/null
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
-%
-%************************************************************************
-%* *
-\section[SATMonad]{The Static Argument Transformation pass Monad}
-%* *
-%************************************************************************
-
-\begin{code}
-#include "HsVersions.h"
-
-module StgSATMonad ( getArgLists, saTransform ) where
-
-IMP_Ubiq(){-uitous-}
-
-import Util ( panic )
-
-getArgLists = panic "StgSATMonad.getArgLists"
-saTransform = panic "StgSATMonad.saTransform"
-\end{code}
-
-%************************************************************************
-%* *
-\subsection{Utility Functions}
-%* *
-%************************************************************************
-
-\begin{code}
-{- LATER: to end of file:
-
-newSATNames :: [Id] -> SatM [Id]
-newSATNames [] = returnSAT []
-newSATNames (id:ids) = newSATName id (idType id) `thenSAT` \ id' ->
- newSATNames ids `thenSAT` \ ids' ->
- returnSAT (id:ids)
-
-getArgLists :: StgRhs -> ([Arg Type],[Arg Id])
-getArgLists (StgRhsCon _ _ _)
- = ([],[])
-getArgLists (StgRhsClosure _ _ _ _ args _)
- = ([], [Static v | v <- args])
-
-\end{code}
-
-\begin{code}
-saTransform :: Id -> StgRhs -> SatM StgBinding
-saTransform binder rhs
- = getSATInfo binder `thenSAT` \ r ->
- case r of
- Just (_,args) | any isStatic args
- -- [Andre] test: do it only if we have more than one static argument.
- --Just (_,args) | length (filter isStatic args) > 1
- -> newSATName binder (new_ty args) `thenSAT` \ binder' ->
- let non_static_args = get_nsa args (snd (getArgLists rhs))
- in
- newSATNames non_static_args `thenSAT` \ non_static_args' ->
- mkNewRhs binder binder' args rhs non_static_args' non_static_args
- `thenSAT` \ new_rhs ->
- trace ("SAT(STG) "++ show (length (filter isStatic args))) (
- returnSAT (StgNonRec binder new_rhs)
- )
- _ -> returnSAT (StgRec [(binder, rhs)])
-
- where
- get_nsa :: [Arg a] -> [Arg a] -> [a]
- get_nsa [] _ = []
- get_nsa _ [] = []
- get_nsa (NotStatic:args) (Static v:as) = v:get_nsa args as
- get_nsa (_:args) (_:as) = get_nsa args as
-
- mkNewRhs binder binder' args rhs@(StgRhsClosure cc bi fvs upd rhsargs body) non_static_args' non_static_args
- = let
- local_body = StgApp (StgVarArg binder')
- [StgVarArg a | a <- non_static_args] emptyUniqSet
-
- rec_body = StgRhsClosure cc bi fvs upd non_static_args'
- (doStgSubst binder args subst_env body)
-
- subst_env = mkIdEnv
- ((binder,binder'):zip non_static_args non_static_args')
- in
- returnSAT (
- StgRhsClosure cc bi fvs upd rhsargs
- (StgLet (StgRec [(binder',rec_body)]) {-in-} local_body)
- )
-
- new_ty args
- = instantiateTy [] (mkSigmaTy [] dict_tys' tau_ty')
- where
- -- get type info for the local function:
- (tv_tmpl, dict_tys, tau_ty) = (splitSigmaTy . idType) binder
- (reg_arg_tys, res_type) = splitFunTy tau_ty
-
- -- now, we drop the ones that are
- -- static, that is, the ones we will not pass to the local function
- l = length dict_tys
- dict_tys' = dropStatics (take l args) dict_tys
- reg_arg_tys' = dropStatics (drop l args) reg_arg_tys
- tau_ty' = glueTyArgs reg_arg_tys' res_type
-\end{code}
-
-NOTE: This does not keep live variable/free variable information!!
-
-\begin{code}
-doStgSubst binder orig_args subst_env body
- = substExpr body
- where
- substExpr (StgCon con args lvs)
- = StgCon con (map substAtom args) emptyUniqSet
- substExpr (StgPrim op args lvs)
- = StgPrim op (map substAtom args) emptyUniqSet
- substExpr expr@(StgApp (StgLitArg _) [] _)
- = expr
- substExpr (StgApp atom@(StgVarArg v) args lvs)
- | v `eqId` binder
- = StgApp (StgVarArg (lookupNoFailIdEnv subst_env v))
- (remove_static_args orig_args args) emptyUniqSet
- | otherwise
- = StgApp (substAtom atom) (map substAtom args) lvs
- substExpr (StgCase scrut lv1 lv2 uniq alts)
- = StgCase (substExpr scrut) emptyUniqSet emptyUniqSet uniq (subst_alts alts)
- where
- subst_alts (StgAlgAlts ty alg_alts deflt)
- = StgAlgAlts ty (map subst_alg_alt alg_alts) (subst_deflt deflt)
- subst_alts (StgPrimAlts ty prim_alts deflt)
- = StgPrimAlts ty (map subst_prim_alt prim_alts) (subst_deflt deflt)
- subst_alg_alt (con, args, use_mask, rhs)
- = (con, args, use_mask, substExpr rhs)
- subst_prim_alt (lit, rhs)
- = (lit, substExpr rhs)
- subst_deflt StgNoDefault
- = StgNoDefault
- subst_deflt (StgBindDefault var used rhs)
- = StgBindDefault var used (substExpr rhs)
- substExpr (StgLetNoEscape fv1 fv2 b body)
- = StgLetNoEscape emptyUniqSet emptyUniqSet (substBinding b) (substExpr body)
- substExpr (StgLet b body)
- = StgLet (substBinding b) (substExpr body)
- substExpr (StgSCC ty cc expr)
- = StgSCC ty cc (substExpr expr)
- substRhs (StgRhsCon cc v args)
- = StgRhsCon cc v (map substAtom args)
- substRhs (StgRhsClosure cc bi fvs upd args body)
- = StgRhsClosure cc bi [] upd args (substExpr body)
-
- substBinding (StgNonRec binder rhs)
- = StgNonRec binder (substRhs rhs)
- substBinding (StgRec pairs)
- = StgRec (zip binders (map substRhs rhss))
- where
- (binders,rhss) = unzip pairs
-
- substAtom atom@(StgLitArg lit) = atom
- substAtom atom@(StgVarArg v)
- = case lookupIdEnv subst_env v of
- Just v' -> StgVarArg v'
- Nothing -> atom
-
- remove_static_args _ []
- = []
- remove_static_args (Static _:origs) (_:as)
- = remove_static_args origs as
- remove_static_args (NotStatic:origs) (a:as)
- = substAtom a:remove_static_args origs as
--}
-\end{code}
> --import Id
> --import IdInfo
> --import Pretty
-> --import SrcLoc ( mkUnknownSrcLoc )
+> --import SrcLoc ( noSrcLoc )
> --import StgSyn
> --import UniqSet
> --import Unique ( getBuiltinUniques )
> where
> (c,b,_) = foldl doApp f ids
> ids = map mkid (getBuiltinUniques arity)
-> mkid u = mkSysLocal SLIT("upd") u noType mkUnknownSrcLoc
+> mkid u = mkSysLocal SLIT("upd") u noType noSrcLoc
> countUses u = if u `elemRefs` b then 2 else min (lookupc c u) 2
> noType = panic "UpdAnal: no type!"
>
IMP_Ubiq(){-uitous-}
import Bag ( isEmptyBag, bagToList )
-import Class ( classOpString, GenClass{-instance NamedThing-} )
+import Class ( GenClass{-instance NamedThing-}, GenClassOp {- instance NamedThing -} )
import FiniteMap ( emptyFM, addListToFM_C, plusFM_C, keysFM,
lookupWithDefaultFM
)
GenId {-instance NamedThing -}
)
import Maybes ( maybeToBool, catMaybes, firstJust )
-import Name ( origName, isLexVarSym, isLexSpecialSym, pprNonSym )
+import Name ( OccName, pprNonSym, pprOccName, modAndOcc )
import PprStyle ( PprStyle(..) )
import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
TyCon{-ditto-}, GenType{-ditto-}, GenTyVar
where
(mod_name, id_name) = get_id_name id
+
get_id_name id
+
+{- Don't understand this -- and looks TURGID. SLPJ 4 Nov 96
| maybeToBool (isDefaultMethodId_maybe id)
= (this_mod, _NIL_)
in (use_mod, _NIL_)
| otherwise
- = case (origName "get_id_name" id) of { OrigName m n -> (m, n) }
+-}
+ = modAndOcc id
get_ty_data (ty, tys)
= (mod_name, [(ty_name, ty, tys)])
where
- (OrigName mod_name ty_name) = origName "get_ty_data" ty
+ (mod_name, ty_name) = modAndOcc ty
module_names = concat [keysFM idspecs_fm, keysFM tyspecs_fm]
mods = map head (equivClasses _CMP_STRING_ module_names)
pp_module mod
= ppBesides [ppPStr mod, ppStr ":"]
-pp_tyspec :: PprStyle -> Pretty -> (FAST_STRING, TyCon, [Maybe Type]) -> Pretty
+pp_tyspec :: PprStyle -> Pretty -> (OccName, TyCon, [Maybe Type]) -> Pretty
pp_tyspec sty pp_mod (_, tycon, tys)
= ppCat [pp_mod,
choose_ty (tv, Nothing) = (mkTyVarTy tv, Just tv)
choose_ty (tv, Just ty) = (ty, Nothing)
-pp_idspec :: PprStyle -> Pretty -> (FAST_STRING, Id, [Maybe Type], Bool) -> Pretty
+pp_idspec :: PprStyle -> Pretty -> (OccName, Id, [Maybe Type], Bool) -> Pretty
pp_idspec sty pp_mod (_, id, tys, is_err)
| isDictFunId id
| is_const_method_id
= let
Just (cls, clsty, clsop) = const_method_maybe
- (OrigName _ cls_str) = origName "pp_idspec" cls
- clsop_str = classOpString clsop
in
ppCat [pp_mod,
ppStr "{-# SPECIALIZE",
- pp_clsop clsop_str, ppStr "::",
+ pprNonSym sty clsop, ppStr "::",
pprGenType sty spec_ty,
ppStr "#-} {- IN instance",
- ppPStr cls_str, pprParendGenType sty clsty,
+ pprOccName sty (getOccName cls), pprParendGenType sty clsty,
ppStr "-}", pp_essential ]
| is_default_method_id
= let
Just (cls, clsop, _) = default_method_maybe
- (OrigName _ cls_str) = origName "pp_idspec2" cls
- clsop_str = classOpString clsop
in
ppCat [pp_mod,
ppStr "{- instance",
- ppPStr cls_str,
+ pprOccName sty (getOccName cls),
ppStr "EXPLICIT METHOD REQUIRED",
- pp_clsop clsop_str, ppStr "::",
+ pprNonSym sty clsop, ppStr "::",
pprGenType sty spec_ty,
ppStr "-}", pp_essential ]
default_method_maybe = isDefaultMethodId_maybe id
is_default_method_id = maybeToBool default_method_maybe
-
- pp_clsop str | isLexVarSym str && not (isLexSpecialSym str)
- = ppParens (ppPStr str)
- | otherwise
- = ppPStr str
-
\end{code}
-- Don't clone if it is a top-level thing. Why not?
-- (a) we don't want to change the uniques
- -- on such things (see TopLevId in Id.lhs)
+ -- on such things
-- (b) we don't have to be paranoid about name capture
-- (c) the thing is polymorphic so no need to subst
import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList )
import CoreUtils ( coreExprType )
import CostCentre ( noCostCentre )
-import Id ( mkSysLocal, idType, isBottomingId,
+import Id ( mkSysLocal, idType, isBottomingId, addIdArity,
externallyVisibleId,
- nullIdEnv, addOneToIdEnv, lookupIdEnv,
+ nullIdEnv, addOneToIdEnv, lookupIdEnv, growIdEnvList,
SYN_IE(IdEnv), GenId{-instance NamedThing-}
)
+import IdInfo ( ArityInfo, exactArity )
import Literal ( mkMachInt, Literal(..) )
import PrelVals ( unpackCStringId, unpackCString2Id,
integerZeroId, integerPlusOneId,
)
import PrimOp ( PrimOp(..) )
import SpecUtils ( mkSpecialisedCon )
-import SrcLoc ( mkUnknownSrcLoc )
+import SrcLoc ( noSrcLoc )
import TyCon ( TyCon{-instance Uniquable-} )
import Type ( maybeAppDataTyCon, getAppDataTyConExpandingDicts )
import TysWiredIn ( stringTy )
import Unique ( integerTyConKey, ratioTyConKey, Unique{-instance Eq-} )
import UniqSupply -- all of it, really
-import Util ( panic, assertPanic{-, pprTrace ToDo:rm-} )
+import Util ( zipLazy, panic, assertPanic{-, pprTrace ToDo:rm-} )
--import Pretty--ToDo:rm
--import PprStyle--ToDo:rm
--import PprType --ToDo:rm
x = y t1 t2
where t1, t2 are types
-* We make the representation of NoRep literals explicit, and
- float their bindings to the top level
+* We pin correct arities on each let(rec)-bound binder, and propagate them
+ to their uses. This is used
+ a) when emitting arity info into interface files
+ b) in the code generator, when deciding if a right-hand side
+ is a saturated application so we can generate a VAP closure.
+ (b) is rather untidy, but the easiest compromise was to propagate arities here.
* We do *not* pin on the correct free/live var info; that's done later.
Instead we use bOGUS_LVS and _FVS as a placeholder.
-* We convert case x of {...; x' -> ...x'...}
- to
- case x of {...; _ -> ...x... }
-
- See notes in SimplCase.lhs, near simplDefault for the reasoning here.
+[Quite a bit of stuff that used to be here has moved
+ to tidyCorePgm (SimplCore.lhs) SLPJ Nov 96]
%************************************************************************
-> [StgBinding] -- output
topCoreBindsToStg us core_binds
- = case (initUs us (binds_to_stg nullIdEnv core_binds)) of
+ = case (initUs us (coreBindsToStg nullIdEnv core_binds)) of
(_, stuff) -> stuff
where
- binds_to_stg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
-
- binds_to_stg env [] = returnUs []
- binds_to_stg env (b:bs)
- = do_top_bind env b `thenUs` \ (new_b, new_env, float_binds) ->
- binds_to_stg new_env bs `thenUs` \ new_bs ->
- returnUs (bagToList float_binds ++ -- Literals
- new_b ++
- new_bs)
-
- do_top_bind env bind@(Rec pairs)
- = coreBindToStg env bind
-
- do_top_bind env bind@(NonRec var rhs)
- = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds) ->
-{- TESTING:
- let
- ppr_blah xs = ppInterleave ppComma (map pp_x xs)
- pp_x (u,x) = ppBesides [pprUnique u, ppStr ": ", ppr PprDebug x]
- in
- pprTrace "do_top_bind:" (ppAbove (ppr PprDebug stg_binds) (ppr_blah (ufmToList new_env))) $
--}
- case stg_binds of
- [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body)] ->
- -- Mega-special case; there's still a binding there
- -- no fvs (of course), *no args*, "let" rhs
- let
- (extra_float_binds, rhs_body') = seek_liftable [] rhs_body
- in
- returnUs (extra_float_binds ++
- [StgNonRec var (StgRhsClosure cc bi fvs u [] rhs_body')],
- new_env,
- float_binds)
-
- other -> returnUs (stg_binds, new_env, float_binds)
-
- --------------------
- -- HACK: look for very simple, obviously-liftable bindings
- -- that can come up to the top level; those that couldn't
- -- 'cause they were big-lambda constrained in the Core world.
-
- seek_liftable :: [StgBinding] -- accumulator...
- -> StgExpr -- look for top-lev liftables
- -> ([StgBinding], StgExpr) -- result
-
- seek_liftable acc expr@(StgLet inner_bind body)
- | is_liftable inner_bind
- = seek_liftable (inner_bind : acc) body
-
- seek_liftable acc other_expr = (reverse acc, other_expr) -- Finished
-
- --------------------
- is_liftable (StgNonRec binder (StgRhsClosure _ _ _ _ args body))
- = not (null args) -- it's manifestly a function...
- || isLeakFreeType [] (idType binder)
- || is_whnf body
- -- ToDo: use a decent manifestlyWHNF function for STG?
- where
- is_whnf (StgCon _ _ _) = True
- is_whnf (StgApp (StgVarArg v) _ _) = isBottomingId v
- is_whnf other = False
-
- is_liftable (StgRec [(_, StgRhsClosure _ _ _ _ args body)])
- = not (null args) -- it's manifestly a (recursive) function...
+ coreBindsToStg :: StgEnv -> [CoreBinding] -> UniqSM [StgBinding]
- is_liftable anything_else = False
+ coreBindsToStg env [] = returnUs []
+ coreBindsToStg env (b:bs)
+ = coreBindToStg env b `thenUs` \ (new_b, new_env) ->
+ coreBindsToStg new_env bs `thenUs` \ new_bs ->
+ returnUs (new_b ++ new_bs)
\end{code}
%************************************************************************
coreBindToStg :: StgEnv
-> CoreBinding
-> UniqSM ([StgBinding], -- Empty or singleton
- StgEnv, -- New envt
- Bag StgBinding) -- Floats
+ StgEnv) -- Floats
coreBindToStg env (NonRec binder rhs)
- = coreRhsToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
-
+ = coreRhsToStg env rhs `thenUs` \ stg_rhs ->
let
-- Binds to return if RHS is trivial
- 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
+ triv_binds | externallyVisibleId binder = [StgNonRec binder stg_rhs] -- Retain it
+ | otherwise = [] -- Discard it
in
case stg_rhs of
StgRhsClosure cc bi fvs upd [] (StgApp atom [] lvs) ->
-- Trivial RHS, so augment envt, and ditch the binding
- returnUs (triv_binds, new_env, rhs_binds)
+ returnUs (triv_binds, new_env)
where
new_env = addOneToIdEnv env binder atom
StgRhsCon cc con_id [] ->
-- Trivial RHS, so augment envt, and ditch the binding
- returnUs (triv_binds, new_env, rhs_binds)
+ returnUs (triv_binds, new_env)
where
new_env = addOneToIdEnv env binder (StgVarArg con_id)
other -> -- Non-trivial RHS, so don't augment envt
- returnUs ([StgNonRec binder stg_rhs], env, rhs_binds)
+ returnUs ([StgNonRec binder_w_arity stg_rhs], new_env)
+ where
+ binder_w_arity = binder `addIdArity` (rhsArity stg_rhs)
+ new_env = addOneToIdEnv env binder (StgVarArg binder_w_arity)
+ -- new_env propagates the arity
coreBindToStg env (Rec pairs)
= -- NB: *** WE DO NOT CHECK FOR TRIV_BINDS in REC BIND ****
let
(binders, rhss) = unzip pairs
in
- mapAndUnzipUs (coreRhsToStg env) rhss `thenUs` \ (stg_rhss, rhs_binds) ->
- returnUs ([StgRec (binders `zip` stg_rhss)], env, unionManyBags rhs_binds)
+ mapUs (coreRhsToStg env) rhss `thenUs` \ stg_rhss ->
+ let
+ binders_w_arities = [ b `addIdArity` rhsArity rhs
+ | (b,rhs) <- binders `zip` stg_rhss]
+ in
+ returnUs ([StgRec (binders_w_arities `zip` stg_rhss)], env)
+
+rhsArity (StgRhsClosure _ _ _ _ args _) = exactArity (length args)
+rhsArity (StgRhsCon _ _ _) = exactArity 0
\end{code}
%************************************************************************
\begin{code}
-coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM (StgRhs, Bag StgBinding)
+coreRhsToStg :: StgEnv -> CoreExpr -> UniqSM StgRhs
coreRhsToStg env core_rhs
- = coreExprToStg env core_rhs `thenUs` \ (stg_expr, stg_binds) ->
+ = coreExprToStg env core_rhs `thenUs` \ stg_expr ->
let stg_rhs = case stg_expr of
StgLet (StgNonRec var1 rhs) (StgApp (StgVarArg var2) [] _)
| var1 == var2 -> rhs
-- This curious stuff is to unravel what a lambda turns into
-- We have to do it this way, rather than spot a lambda in the
- -- incoming rhs
+ -- incoming rhs. Why? Because trivial bindings might conceal
+ -- what the rhs is actually like.
StgCon con args _ -> StgRhsCon noCostCentre con args
[]
stg_expr
in
- returnUs (stg_rhs, stg_binds)
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection[coreToStg-lits]{Converting literals}
-%* *
-%************************************************************************
-
-Literals: the NoRep kind need to be de-no-rep'd.
-We always replace them with a simple variable, and float a suitable
-binding out to the top level.
-
-If an Integer is small enough (Haskell implementations must support
-Ints in the range $[-2^29+1, 2^29-1]$), wrap it up in @int2Integer@;
-otherwise, wrap with @litString2Integer@.
-
-\begin{code}
-tARGET_MIN_INT, tARGET_MAX_INT :: Integer
-tARGET_MIN_INT = -536870912
-tARGET_MAX_INT = 536870912
-
-litToStgArg :: Literal -> UniqSM (StgArg, Bag StgBinding)
-
-litToStgArg (NoRepStr s)
- = newStgVar stringTy `thenUs` \ var ->
- let
- rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
- stgArgOcc -- safe
- bOGUS_FVs
- Updatable -- WAS: ReEntrant (see note below)
- [] -- No arguments
- val
-
--- We used not to update strings, so that they wouldn't clog up the heap,
--- but instead be unpacked each time. But on some programs that costs a lot
--- [eg hpg], so now we update them.
-
- val = if (any is_NUL (_UNPK_ s)) then -- must cater for NULs in literal string
- StgApp (StgVarArg unpackCString2Id)
- [StgLitArg (MachStr s),
- StgLitArg (mkMachInt (toInteger (_LENGTH_ s)))]
- bOGUS_LVs
- else
- StgApp (StgVarArg unpackCStringId)
- [StgLitArg (MachStr s)]
- bOGUS_LVs
- in
- returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
- where
- is_NUL c = c == '\0'
-
-litToStgArg (NoRepInteger i integer_ty)
- -- extremely convenient to look out for a few very common
- -- Integer literals!
- | i == 0 = returnUs (StgVarArg integerZeroId, emptyBag)
- | i == 1 = returnUs (StgVarArg integerPlusOneId, emptyBag)
- | i == 2 = returnUs (StgVarArg integerPlusTwoId, emptyBag)
- | i == (-1) = returnUs (StgVarArg integerMinusOneId, emptyBag)
-
- | otherwise
- = newStgVar integer_ty `thenUs` \ var ->
- let
- rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
- stgArgOcc -- safe
- bOGUS_FVs
- Updatable -- Update an integer
- [] -- No arguments
- val
-
- val
- | i > tARGET_MIN_INT && i < tARGET_MAX_INT
- = -- Start from an Int
- StgPrim Int2IntegerOp [StgLitArg (mkMachInt i)] bOGUS_LVs
-
- | otherwise
- = -- Start from a string
- StgPrim Addr2IntegerOp [StgLitArg (MachStr (_PK_ (show i)))] bOGUS_LVs
- in
- returnUs (StgVarArg var, unitBag (StgNonRec var rhs))
-
-litToStgArg (NoRepRational r rational_ty)
- = --ASSERT(is_rational_ty)
- --(if is_rational_ty then \x->x else pprTrace "litToStgArg:not rational?" (pprType PprDebug rational_ty)) $
- litToStgArg (NoRepInteger (numerator r) integer_ty) `thenUs` \ (num_atom, binds1) ->
- litToStgArg (NoRepInteger (denominator r) integer_ty) `thenUs` \ (denom_atom, binds2) ->
- newStgVar rational_ty `thenUs` \ var ->
- let
- rhs = StgRhsCon noCostCentre -- No cost centre (ToDo?)
- ratio_data_con -- Constructor
- [num_atom, denom_atom]
- in
- returnUs (StgVarArg var, binds1 `unionBags`
- binds2 `unionBags`
- unitBag (StgNonRec var rhs))
- where
- (is_rational_ty, ratio_data_con, integer_ty)
- = case (maybeAppDataTyCon rational_ty) of
- Just (tycon, [i_ty], [con])
- -> ASSERT(is_integer_ty i_ty)
- (uniqueOf tycon == ratioTyConKey, con, i_ty)
-
- _ -> (False, panic "ratio_data_con", panic "integer_ty")
-
- is_integer_ty ty
- = case (maybeAppDataTyCon ty) of
- Just (tycon, [], _) -> uniqueOf tycon == integerTyConKey
- _ -> False
-
-litToStgArg other_lit = returnUs (StgLitArg other_lit, emptyBag)
+ returnUs stg_rhs
\end{code}
%************************************************************************
\begin{code}
-coreArgsToStg :: StgEnv -> [CoreArg] -> UniqSM ([Type], [StgArg], Bag StgBinding)
+coreArgsToStg :: StgEnv -> [CoreArg] -> ([Type], [StgArg])
-coreArgsToStg env [] = returnUs ([], [], emptyBag)
+coreArgsToStg env [] = ([], [])
coreArgsToStg env (a:as)
- = coreArgsToStg env as `thenUs` \ (tys, args, binds) ->
- do_arg a tys args binds
+ = case a of
+ TyArg t -> (t:trest, vrest)
+ UsageArg u -> (trest, vrest)
+ VarArg v -> (trest, stgLookup env v : vrest)
+ LitArg l -> (trest, StgLitArg l : vrest)
where
- do_arg a trest vrest binds
- = case a of
- TyArg t -> returnUs (t:trest, vrest, binds)
- UsageArg u -> returnUs (trest, vrest, binds)
- VarArg v -> returnUs (trest, stgLookup env v : vrest, binds)
- LitArg i -> litToStgArg i `thenUs` \ (v, bs) ->
- returnUs (trest, v:vrest, bs `unionBags` binds)
+ (trest,vrest) = coreArgsToStg env as
\end{code}
-There's not anything interesting we can ASSERT about \tr{var} if it
-isn't in the StgEnv. (WDP 94/06)
-\begin{code}
-stgLookup :: StgEnv -> Id -> StgArg
-
-stgLookup env var = case (lookupIdEnv env var) of
- Nothing -> StgVarArg var
- Just atom -> atom
-\end{code}
%************************************************************************
%* *
%************************************************************************
\begin{code}
-coreExprToStg :: StgEnv
- -> CoreExpr
- -> UniqSM (StgExpr, -- Result
- Bag StgBinding) -- Float these to top level
-\end{code}
+coreExprToStg :: StgEnv -> CoreExpr -> UniqSM StgExpr
-\begin{code}
coreExprToStg env (Lit lit)
- = litToStgArg lit `thenUs` \ (atom, binds) ->
- returnUs (StgApp atom [] bOGUS_LVs, binds)
+ = returnUs (StgApp (StgLitArg lit) [] bOGUS_LVs)
coreExprToStg env (Var var)
- = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs, emptyBag)
+ = returnUs (StgApp (stgLookup env var) [] bOGUS_LVs)
coreExprToStg env (Con con args)
- = coreArgsToStg env args `thenUs` \ (types, stg_atoms, stg_binds) ->
- let
+ = let
+ (types, stg_atoms) = coreArgsToStg env args
spec_con = mkSpecialisedCon con types
in
- returnUs (StgCon spec_con stg_atoms bOGUS_LVs, stg_binds)
+ returnUs (StgCon spec_con stg_atoms bOGUS_LVs)
coreExprToStg env (Prim op args)
- = coreArgsToStg env args `thenUs` \ (_, stg_atoms, stg_binds) ->
- returnUs (StgPrim op stg_atoms bOGUS_LVs, stg_binds)
+ = let
+ (types, stg_atoms) = coreArgsToStg env args
+ in
+ returnUs (StgPrim op stg_atoms bOGUS_LVs)
\end{code}
%************************************************************************
= let
(_,_, binders, body) = collectBinders expr
in
- coreExprToStg env body `thenUs` \ stuff@(stg_body, binds) ->
+ coreExprToStg env body `thenUs` \ stg_body ->
if null binders then -- it was all type/usage binders; tossed
- returnUs stuff
+ returnUs stg_body
else
newStgVar (coreExprType expr) `thenUs` \ var ->
returnUs
- (StgLet (StgNonRec var (StgRhsClosure noCostCentre
+ (StgLet (StgNonRec (var `addIdArity` exactArity (length binders))
+ (StgRhsClosure noCostCentre
stgArgOcc
bOGUS_FVs
ReEntrant -- binders is non-empty
binders
stg_body))
- (StgApp (StgVarArg var) [] bOGUS_LVs),
- binds)
+ (StgApp (StgVarArg var) [] bOGUS_LVs))
\end{code}
%************************************************************************
\begin{code}
coreExprToStg env expr@(App _ _)
= let
- (fun,args) = collect_args expr []
+ (fun,args) = collect_args expr []
+ (_, stg_args) = coreArgsToStg env args
in
- -- Deal with the arguments
- coreArgsToStg env args `thenUs` \ (_, stg_args, arg_binds) ->
-
-- Now deal with the function
case (fun, args) of
(Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
-- there are no arguments.
- returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs, arg_binds)
+ returnUs (StgApp (stgLookup env fun_id) stg_args bOGUS_LVs)
(non_var_fun, []) -> -- No value args, so recurse into the function
coreExprToStg env non_var_fun
other -> -- A non-variable applied to things; better let-bind it.
newStgVar (coreExprType fun) `thenUs` \ fun_id ->
- coreExprToStg env fun `thenUs` \ (stg_fun, fun_binds) ->
+ coreExprToStg env fun `thenUs` \ (stg_fun) ->
let
fun_rhs = StgRhsClosure noCostCentre -- No cost centre (ToDo?)
stgArgOcc
stg_fun
in
returnUs (StgLet (StgNonRec fun_id fun_rhs)
- (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs),
- arg_binds `unionBags` fun_binds)
+ (StgApp (StgVarArg fun_id) stg_args bOGUS_LVs))
where
-- Collect arguments, discarding type/usage applications
collect_args (App e (TyArg _)) args = collect_args e args
%* *
%************************************************************************
-At this point, we *mangle* cases involving fork# and par# in the
-discriminant. The original templates for these primops (see
-@PrelVals.lhs@) constructed case expressions with boolean results
-solely to fool the strictness analyzer, the simplifier, and anyone
-else who might want to fool with the evaluation order. Now, we
-believe that once the translation to STG code is performed, our
-evaluation order is safe. Therefore, we convert expressions of the
-form:
-
- case par# e of
- True -> rhs
- False -> parError#
-
-to
-
- case par# e of
- _ -> rhs
-
\begin{code}
-
-coreExprToStg env (Case discrim@(Prim op _) alts)
- | funnyParallelOp op
- = getUnique `thenUs` \ uniq ->
- coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) ->
- alts_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
- returnUs (
- StgCase stg_discrim
- bOGUS_LVs
- bOGUS_LVs
- uniq
- stg_alts,
- discrim_binds `unionBags` alts_binds
- )
- where
- funnyParallelOp SeqOp = True
- funnyParallelOp ParOp = True
- funnyParallelOp ForkOp = True
- funnyParallelOp _ = False
-
- discrim_ty = coreExprType discrim
-
- alts_to_stg (PrimAlts _ (BindDefault binder rhs))
- = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
- let
- stg_deflt = StgBindDefault binder False stg_rhs
- in
- returnUs (StgPrimAlts discrim_ty [] stg_deflt, rhs_binds)
-
--- OK, back to real life...
-
coreExprToStg env (Case discrim alts)
- = coreExprToStg env discrim `thenUs` \ (stg_discrim, discrim_binds) ->
- alts_to_stg discrim alts `thenUs` \ (stg_alts, alts_binds) ->
+ = coreExprToStg env discrim `thenUs` \ stg_discrim ->
+ alts_to_stg discrim alts `thenUs` \ stg_alts ->
getUnique `thenUs` \ uniq ->
returnUs (
StgCase stg_discrim
bOGUS_LVs
bOGUS_LVs
uniq
- stg_alts,
- discrim_binds `unionBags` alts_binds
+ stg_alts
)
where
discrim_ty = coreExprType discrim
(_, discrim_ty_args, _) = getAppDataTyConExpandingDicts discrim_ty
alts_to_stg discrim (AlgAlts alts deflt)
- = default_to_stg discrim deflt `thenUs` \ (stg_deflt, deflt_binds) ->
- mapAndUnzipUs boxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
- returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt,
- deflt_binds `unionBags` unionManyBags alts_binds)
+ = default_to_stg discrim deflt `thenUs` \ stg_deflt ->
+ mapUs boxed_alt_to_stg alts `thenUs` \ stg_alts ->
+ returnUs (StgAlgAlts discrim_ty stg_alts stg_deflt)
where
boxed_alt_to_stg (con, bs, rhs)
- = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
- returnUs ((spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs),
- rhs_binds)
+ = coreExprToStg env rhs `thenUs` \ stg_rhs ->
+ returnUs (spec_con, bs, [ True | b <- bs ]{-bogus use mask-}, stg_rhs)
where
spec_con = mkSpecialisedCon con discrim_ty_args
alts_to_stg discrim (PrimAlts alts deflt)
- = default_to_stg discrim deflt `thenUs` \ (stg_deflt,deflt_binds) ->
- mapAndUnzipUs unboxed_alt_to_stg alts `thenUs` \ (stg_alts, alts_binds) ->
- returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt,
- deflt_binds `unionBags` unionManyBags alts_binds)
+ = default_to_stg discrim deflt `thenUs` \ stg_deflt ->
+ mapUs unboxed_alt_to_stg alts `thenUs` \ stg_alts ->
+ returnUs (StgPrimAlts discrim_ty stg_alts stg_deflt)
where
unboxed_alt_to_stg (lit, rhs)
- = coreExprToStg env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
- returnUs ((lit, stg_rhs), rhs_binds)
+ = coreExprToStg env rhs `thenUs` \ stg_rhs ->
+ returnUs (lit, stg_rhs)
default_to_stg discrim NoDefault
- = returnUs (StgNoDefault, emptyBag)
+ = returnUs StgNoDefault
default_to_stg discrim (BindDefault binder rhs)
- = coreExprToStg new_env rhs `thenUs` \ (stg_rhs, rhs_binds) ->
- returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs,
- rhs_binds)
- where
- --
- -- We convert case x of {...; x' -> ...x'...}
- -- to
- -- case x of {...; _ -> ...x... }
- --
- -- See notes in SimplCase.lhs, near simplDefault for the reasoning.
- -- It's quite easily done: simply extend the environment to bind the
- -- default binder to the scrutinee.
- --
- new_env = case discrim of
- Var v -> addOneToIdEnv env binder (stgLookup env v)
- other -> env
+ = coreExprToStg env rhs `thenUs` \ stg_rhs ->
+ returnUs (StgBindDefault binder True{-used? no it is lying-} stg_rhs)
\end{code}
%************************************************************************
\begin{code}
coreExprToStg env (Let bind body)
- = coreBindToStg env bind `thenUs` \ (stg_binds, new_env, float_binds1) ->
- coreExprToStg new_env body `thenUs` \ (stg_body, float_binds2) ->
- returnUs (mkStgLets stg_binds stg_body, float_binds1 `unionBags` float_binds2)
+ = coreBindToStg env bind `thenUs` \ (stg_binds, new_env) ->
+ coreExprToStg new_env body `thenUs` \ stg_body ->
+ returnUs (mkStgLets stg_binds stg_body)
\end{code}
Covert core @scc@ expression directly to STG @scc@ expression.
\begin{code}
coreExprToStg env (SCC cc expr)
- = coreExprToStg env expr `thenUs` \ (stg_expr, binds) ->
- returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
+ = coreExprToStg env expr `thenUs` \ stg_expr ->
+ returnUs (StgSCC (coreExprType expr) cc stg_expr)
\end{code}
\begin{code}
%* *
%************************************************************************
-Utilities.
+There's not anything interesting we can ASSERT about \tr{var} if it
+isn't in the StgEnv. (WDP 94/06)
+
+\begin{code}
+stgLookup :: StgEnv -> Id -> StgArg
+stgLookup env var = case (lookupIdEnv env var) of
+ Nothing -> StgVarArg var
+ Just atom -> atom
+\end{code}
Invent a fresh @Id@:
\begin{code}
newStgVar :: Type -> UniqSM Id
newStgVar ty
= getUnique `thenUs` \ uniq ->
- returnUs (mkSysLocal SLIT("stg") uniq ty mkUnknownSrcLoc)
+ returnUs (mkSysLocal SLIT("stg") uniq ty noSrcLoc)
\end{code}
\begin{code}
IMP_Ubiq(){-uitous-}
import CostCentre ( showCostCentre )
-import Id ( externallyVisibleId, idPrimRep, GenId{-instance NamedThing-} )
+import Id ( idPrimRep, GenId{-instance NamedThing-} )
import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} )
-import Name ( isSymLexeme )
+import Name ( pprNonSym )
import Outputable ( ifPprDebug, interppSP, interpp'SP,
Outputable(..){-instance * Bool-}
)
\begin{code}
collectFinalStgBinders
:: [StgBinding] -- input program
- -> [Id] -- final externally-visible top-level Ids
+ -> [Id]
-collectFinalStgBinders binds
- = ex [] binds
- where
- ex es [] = es
-
- ex es ((StgNonRec b _) : binds)
- = if not (externallyVisibleId b) then
- ex es binds
- else
- ex (b:es) binds
-
- ex es ((StgRec []) : binds) = ex es binds
-
- ex es ((StgRec ((b, rhs) : pairs)) : binds)
- = ex es (StgNonRec b rhs : (StgRec pairs : binds))
- -- OK, a total hack; laziness rules
+collectFinalStgBinders [] = []
+collectFinalStgBinders (StgNonRec b _ : binds) = b : collectFinalStgBinders binds
+collectFinalStgBinders (StgRec bs : binds) = map fst bs ++ collectFinalStgBinders binds
\end{code}
%************************************************************************
ppNest 2 (ppr_alts sty alts),
ppStr "}"]
where
+ ppr_default sty StgNoDefault = ppNil
+ ppr_default sty (StgBindDefault bndr used expr)
+ = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr)
+ where
+ pp_binder = if used then ppr sty bndr else ppChar '_'
+
pp_ty (StgAlgAlts ty _ _) = ppr sty ty
pp_ty (StgPrimAlts ty _ _) = ppr sty ty
ppr_default sty deflt ]
where
ppr_bxd_alt sty (con, params, use_mask, expr)
- = ppHang (ppCat [ppr_con sty con, interppSP sty params, ppStr "->"])
+ = ppHang (ppCat [pprNonSym sty con, interppSP sty params, ppStr "->"])
4 (ppBeside (ppr sty expr) ppSemi)
- where
- ppr_con sty con
- = if isSymLexeme con
- then ppBesides [ppLparen, ppr sty con, ppRparen]
- else ppr sty con
ppr_alts sty (StgPrimAlts ty alts deflt)
= ppAboves [ ppAboves (map (ppr_ubxd_alt sty) alts),
ppr_ubxd_alt sty (lit, expr)
= ppHang (ppCat [ppr sty lit, ppStr "->"])
4 (ppBeside (ppr sty expr) ppSemi)
-
- ppr_default sty StgNoDefault = ppNil
- ppr_default sty (StgBindDefault bndr used expr)
- = ppHang (ppCat [pp_binder, ppStr "->"]) 4 (ppr sty expr)
- where
- pp_binder = if used then ppr sty bndr else ppChar '_'
\end{code}
\begin{code}
\begin{code}
#include "HsVersions.h"
-module StgUtils ( mapStgBindeesRhs ) where
+module StgUtils
+ -- ( mapStgBindeesRhs ) Dead code SLPJ Nov 96
+ where
+{- DEAD CODE SLPJ Nov 96
IMP_Ubiq(){-uitous-}
bindee in the program.
\begin{code}
+
mapStgBindeesBind :: (Id -> Id) -> StgBinding -> StgBinding
mapStgBindeesBind fn (StgNonRec b rhs) = StgNonRec b (mapStgBindeesRhs fn rhs)
mapStgBindeesArg fn a@(StgLitArg _) = a
mapStgBindeesArg fn a@(StgVarArg id) = StgVarArg (fn id)
+
+-}
\end{code}
IMP_Ubiq(){-uitous-}
import CoreSyn
-import CoreUnfold ( Unfolding(..), SimpleUnfolding(..), FormSummary )
+import CoreUnfold ( Unfolding(..), UfExpr, RdrName, SimpleUnfolding(..), FormSummary )
import CoreUtils ( unTagBinders )
import Id ( idType, getIdStrictness, getIdUnfolding,
dataConTyCon, dataConArgTys
)
-import IdInfo ( StrictnessInfo(..), Demand(..),
+import IdInfo ( StrictnessInfo(..),
wwPrim, wwStrict, wwEnum, wwUnpack
)
+import Demand ( Demand(..) )
import MagicUFs ( MagicUnfoldingFun )
import Maybes ( maybeToBool )
import Outputable ( Outputable(..){-instance * []-} )
(Just abs_val, _, _) ->
abs_val -- Bound in the environment
- (Nothing, NoStrictnessInfo, CoreUnfolding (SimpleUnfolding _ _ unfolding)) ->
+ (Nothing, noStrictnessInfo, CoreUnfolding (SimpleUnfolding _ _ unfolding)) ->
-- We have an unfolding for the expr
-- Assume the unfolding has no free variables since it
-- came from inside the Id
lookupIdEnv, SYN_IE(IdEnv),
GenId{-instance Outputable-}
)
-import IdInfo ( StrictnessInfo(..), Demand{-instance Outputable-} )
+import IdInfo ( StrictnessInfo(..) )
+import Demand ( Demand{-instance Outputable-} )
import Outputable ( Outputable(..){-instance * []-} )
import PprType ( GenType{-instance Outputable-} )
import Pretty ( ppStr, ppCat )
\end{code}
\begin{code}
-absValFromStrictness :: AnalysisKind -> StrictnessInfo -> AbsVal
+absValFromStrictness :: AnalysisKind -> StrictnessInfo bdee -> AbsVal
absValFromStrictness anal NoStrictnessInfo = AbsTop
addStrictnessInfoToId strflags str_val abs_val binder body
-{- SCHEDULED FOR NUKING
- | isWrapperId binder
- = binder -- Avoid clobbering existing strictness info
- -- (and, more importantly, worker info).
- -- Deeply suspicious (SLPJ)
--}
-
| isBot str_val
= binder `addIdStrictness` mkBottomStrictnessInfo
IMP_Ubiq(){-uitous-}
import CoreSyn
-import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding )
-import MagicUFs ( MagicUnfoldingFun )
+import CoreUnfold ( Unfolding, certainlySmallEnoughToInline, calcUnfoldingGuidance )
+import CmdLineOpts ( opt_UnfoldingCreationThreshold )
import CoreUtils ( coreExprType )
import Id ( idWantsToBeINLINEd, getIdStrictness, mkWorkerId,
addIdStrictness, addInlinePragma,
GenId
)
-import IdInfo ( noIdInfo, addInfo_UF, indicatesWorker,
- mkStrictnessInfo, StrictnessInfo(..)
+import IdInfo ( noIdInfo, addUnfoldInfo,
+ mkStrictnessInfo, addStrictnessInfo, StrictnessInfo(..)
)
import SaLib
import UniqSupply ( returnUs, thenUs, mapUs, getUnique, SYN_IE(UniqSM) )
-- if two, then a worker and a
-- wrapper.
tryWW fn_id rhs
- | idWantsToBeINLINEd fn_id
+ | certainlySmallEnoughToInline $
+ calcUnfoldingGuidance (idWantsToBeINLINEd fn_id)
+ opt_UnfoldingCreationThreshold
+ rhs
-- No point in worker/wrappering something that is going to be
-- INLINEd wholesale anyway. If the strictness analyser is run
-- twice, this test also prevents wrappers (which are INLINEd)
NoStrictnessInfo -> do_nothing
BottomGuaranteed -> do_nothing
- StrictnessInfo [] _ -> do_nothing -- V weird (but possible?)
StrictnessInfo args_info _ ->
- if not (indicatesWorker args_info) then
- do_nothing
- else
-
- -- OK, it looks as if a worker is worth a try
let
(uvars, tyvars, args, body) = collectBinders rhs
body_ty = coreExprType body
mkWwBodies body_ty tyvars args args_info `thenUs` \ result ->
case result of
- Nothing -> -- Very peculiar. This can only happen if we hit an
- -- abstract type, which we shouldn't have since we've
- -- constructed the args_info in this module!
-
- -- False. We might hit the all-args-absent-and-the-
- -- body-is-unboxed case. A Nothing is legit. (WDP 94/10)
+ Nothing -> -- We've hit the all-args-absent-and-the-body-is-unboxed case,
+ -- or there are too many args for a w/w split,
+ -- or there's no benefit from w/w (e.g. SSS)
do_nothing
Just (wrapper_w_hole, worker_w_hole, worker_strictness, worker_ty_w_hole) ->
worker_ty = worker_ty_w_hole body_ty
worker_id = mkWorkerId worker_uniq fn_id worker_ty
- (noIdInfo `addInfo` worker_strictness)
+ (noIdInfo `addStrictnessInfo` worker_strictness)
wrapper_rhs = wrapper_w_hole worker_id
worker_rhs = worker_w_hole body
import Id ( idType, mkSysLocal, dataConArgTys )
import IdInfo ( mkStrictnessInfo, nonAbsentArgs, Demand(..) )
import PrelVals ( aBSENT_ERROR_ID )
-import SrcLoc ( mkUnknownSrcLoc )
+import SrcLoc ( noSrcLoc )
import Type ( isPrimType, mkTyVarTys, mkForAllTys, mkFunTys,
maybeAppDataTyConExpandingDicts
)
-- hole for worker id
CoreExpr -> CoreExpr, -- Worker expr w/ hole
-- for original fn body
- StrictnessInfo, -- Worker strictness info
+ StrictnessInfo Id, -- Worker strictness info
Type -> Type) -- Worker type w/ hole
) -- for type of original fn body
then returnUs Nothing
else -- the rest...
- mk_ww_arg_processing args arg_infos (mAX_WORKER_ARGS - nonAbsentArgs arg_infos)
+ mk_ww_arg_processing args arg_infos
+ False -- Initialise the "useful-split" flag
+ (mAX_WORKER_ARGS - nonAbsentArgs arg_infos)
`thenMaybeUs` \ (wrap_frag, work_args_info, work_frag) ->
let
(work_args, wrkr_demands) = unzip work_args_info
-> [Demand] -- Strictness info for those args
-- must be at least as long as args
+ -> Bool -- False <=> we've done nothing useful in an enclosing call
+ -- If this is False when we hit the end of the arg list, we
+ -- don't want to do a w/w split... the wrapper would be the identity fn!
+ -- So we return Nothing
+
-> Int -- Number of extra args we are prepared to add.
-- This prevents over-eager unpacking, leading
-- to huge-arity functions.
-> UniqSM (Maybe -- Nothing iff any unpack on abstract type
+ -- or if the wrapper would be the identity fn (can happen if we unpack
+ -- a huge structure, and decide not to do it)
+
(CoreExpr -> CoreExpr, -- Wrapper expr w/
-- hole for worker id
-- applied to types
CoreExpr -> CoreExpr) -- Worker body expr w/ hole
) -- for original fn body
-mk_ww_arg_processing [] _ _ = returnUs (Just (id, [], id))
+mk_ww_arg_processing [] _ useful_split _ = if useful_split then
+ returnUs (Just (id, [], id))
+ else
+ returnUs Nothing
-mk_ww_arg_processing (arg : args) (WwLazy True : infos) max_extra_args
+mk_ww_arg_processing (arg : args) (WwLazy True : infos) useful_split max_extra_args
= -- Absent argument
-- So, finish args to the right...
--pprTrace "Absent; num_wrkr_args=" (ppInt num_wrkr_args) (
let
arg_ty = idType arg
in
- mk_ww_arg_processing args infos max_extra_args
- -- we've already discounted for absent args,
+ mk_ww_arg_processing args infos True {- useful split -} max_extra_args
+ -- We've already discounted for absent args,
-- so we don't change max_extra_args
`thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
panic "WwLib: haven't done mk_absent_let for primitives yet"
-mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args
+mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) useful_split max_extra_args
| new_max_extra_args > 0 -- Check that we are prepared to add arguments
= -- this is the complicated one.
--pprTrace "Unpack; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr "; new_max=", ppInt new_num_wrkr_args, ppStr "; arg=", ppr PprDebug arg, ppr PprDebug (WwUnpack cmpnt_infos)]) $
Just (_, _, []) -> -- An abstract type
-- We have to give up on the whole idea
returnUs Nothing
+
Just (_, _, (_:_:_)) -> -- Two or more constructors; that's odd
panic "mk_ww_arg_processing: multi-constr"
let
unpk_args = zipWithEqual "mk_ww_arg_processing"
- (\ u t -> mkSysLocal SLIT("upk") u t mkUnknownSrcLoc)
+ (\ u t -> mkSysLocal SLIT("upk") u t noSrcLoc)
uniqs inst_con_arg_tys
in
-- In processing the rest, push the sub-component args
-- and infos on the front of the current bunch
- mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) new_max_extra_args
+ mk_ww_arg_processing (unpk_args ++ args) (cmpnt_infos ++ infos) True {- useful split -} new_max_extra_args
`thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
returnUs (Just (
(map TyArg con_tys ++ map VarArg unpk_args)))
body
-mk_ww_arg_processing (arg : args) (arg_demand : infos) max_extra_args
+mk_ww_arg_processing (arg : args) (arg_demand : infos) useful_split max_extra_args
| otherwise
= -- For all others at the moment, we just
-- pass them to the worker unchanged.
--pprTrace "Other; num_wrkr_args=" (ppCat [ppInt num_wrkr_args, ppStr ";arg=", ppr PprDebug arg, ppr PprDebug arg_demand]) (
-- Finish args to the right...
- mk_ww_arg_processing args infos max_extra_args
+ mk_ww_arg_processing args infos useful_split max_extra_args
`thenMaybeUs` \ (wrap_rest, work_args_info, work_rest) ->
returnUs (Just (
\ hole -> work_rest hole
))
--)
+
+nonAbsentArgs :: [Demand] -> Int
+nonAbsentArgs cmpts = length [() | WwLazy True <- cmpts]
\end{code}
IMP_Ubiq()
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import Inst ( Inst, InstOrigin(..), SYN_IE(LIE), plusLIE,
newDicts, tyVarsOfInst, instToId )
import TcEnv ( tcGetGlobalTyVars, tcExtendGlobalTyVars )
import Bag ( Bag, foldBag, bagToList, listToBag, isEmptyBag )
import Class ( GenClass )
import Id ( GenId, SYN_IE(Id), mkUserId, idType )
-import Kind ( isUnboxedKind, isTypeKind, mkBoxedTypeKind )
+import Kind ( isUnboxedTypeKind, isTypeKind, mkBoxedTypeKind )
import ListSetOps ( minusList, unionLists, intersectLists )
import Maybes ( allMaybes )
import Name ( Name{--O only-} )
let
tyvars = tyVarSetToList reduced_tyvars_to_gen -- Commit to a particular order
- unboxed_kind_tyvars = filter (isUnboxedKind . tyVarKind) tyvars
+ unboxed_kind_tyvars = filter (isUnboxedTypeKind . tyVarKind) tyvars
unresolved_kind_tyvars = filter (isTypeKind . tyVarKind) tyvars
box_it tyvar = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ boxed_ty ->
import HsSyn ( HsLit(..), HsExpr(..), HsBinds,
InPat, OutPat, Stmt, Qualifier, Match,
- ArithSeqInfo, PolyType, Fake )
-import RnHsSyn ( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr),
- RnName{-instance NamedThing-}
- )
+ ArithSeqInfo, HsType, Fake )
+import RnHsSyn ( SYN_IE(RenamedArithSeqInfo), SYN_IE(RenamedHsExpr) )
import TcHsSyn ( TcIdOcc(..), SYN_IE(TcExpr), SYN_IE(TcIdBndr),
mkHsTyApp, mkHsDictApp, tcIdTyVars )
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import TcEnv ( tcLookupGlobalValueByKey, tcLookupTyConByKey )
import TcType ( SYN_IE(TcType), SYN_IE(TcRhoType), TcMaybe, SYN_IE(TcTyVarSet),
tcInstType, zonkTcType )
import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag )
-import Class ( isCcallishClass, isNoDictClass, classInstEnv,
+import Class ( classInstEnv,
SYN_IE(Class), GenClass, SYN_IE(ClassInstEnv), SYN_IE(ClassOp)
)
import ErrUtils ( addErrLoc, SYN_IE(Error) )
import Id ( GenId, idType, mkInstId )
+import PrelInfo ( isCcallishClass, isNoDictClass )
import MatchEnv ( lookupMEnv, insertMEnv )
-import Name ( mkLocalName, getLocalName, Name )
+import Name ( OccName(..), Name, mkLocalName, mkSysLocalName, occNameString )
import Outputable
import PprType ( GenClass, TyCon, GenType, GenTyVar, pprParendGenType )
import PprStyle ( PprStyle(..) )
import Pretty
import SpecEnv ( SpecEnv )
-import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
+import SrcLoc ( SrcLoc, noSrcLoc )
import Type ( GenType, eqSimpleTy, instantiateTy,
isTyVarTy, mkDictTy, splitForAllTy, splitSigmaTy,
splitRhoTy, matchTy, tyVarsOfType, tyVarsOfTypes,
\begin{code}
instToId :: Inst s -> TcIdOcc s
instToId (Dict u clas ty orig loc)
- = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u str False{-emph name-} loc))
+ = TcId (mkInstId u (mkDictTy clas ty) (mkLocalName u str loc))
where
- str = SLIT("d.") _APPEND_ (getLocalName clas)
+ str = VarOcc (SLIT("d.") _APPEND_ (occNameString (getOccName clas)))
+
instToId (Method u id tys rho_ty orig loc)
- = TcId (mkInstId u tau_ty (mkLocalName u str False{-emph name-} loc))
+ = TcId (mkInstId u tau_ty (mkLocalName u str loc))
where
(_, tau_ty) = splitRhoTy rho_ty -- NB The method Id has just the tau type
- str = SLIT("m.") _APPEND_ (getLocalName id)
+ str = VarOcc (SLIT("m.") _APPEND_ (occNameString (getOccName id)))
instToId (LitInst u list ty orig loc)
- = TcId (mkInstId u ty (mkLocalName u SLIT("lit") True{-emph uniq-} loc))
+ = TcId (mkInstId u ty (mkSysLocalName u SLIT("lit") loc))
\end{code}
\begin{code}
IMP_Ubiq()
import HsSyn ( HsBinds(..), Bind(..), Sig(..), MonoBinds(..),
- HsExpr, Match, PolyType, InPat, OutPat(..),
+ HsExpr, Match, HsType, InPat, OutPat(..),
GRHSsAndBinds, ArithSeqInfo, HsLit, Fake,
collectBinders )
import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedBind), RenamedSig(..),
- SYN_IE(RenamedMonoBinds), RnName(..)
+ SYN_IE(RenamedMonoBinds)
)
import TcHsSyn ( SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcMonoBinds),
TcIdOcc(..), SYN_IE(TcIdBndr) )
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import GenSpecEtc ( checkSigTyVars, genBinds, TcSigInfo(..) )
import Inst ( Inst, SYN_IE(LIE), emptyLIE, plusLIE, InstOrigin(..) )
import TcEnv ( tcExtendLocalValEnv, tcLookupLocalValueOK, newMonoIds )
import SpecEnv ( SpecEnv )
IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
import TcMatches ( tcMatchesFun )
-import TcMonoType ( tcPolyType )
+import TcMonoType ( tcHsType )
import TcPat ( tcPat )
import TcSimplify ( bindInstsOfLocalFuns )
-import TcType ( newTcTyVar, tcInstSigType )
+import TcType ( newTcTyVar, tcInstSigType, newTyVarTys )
import Unify ( unifyTauTy )
import Kind ( mkBoxedTypeKind, mkTypeKind )
-import Id ( GenId, idType, mkUserId )
+import Id ( GenId, idType, mkUserLocal, mkUserId )
import IdInfo ( noIdInfo )
import Maybes ( assocMaybe, catMaybes )
-import Name ( pprNonSym, Name )
+import Name ( pprNonSym, getOccName, getSrcLoc, Name )
import PragmaInfo ( PragmaInfo(..) )
import Pretty
import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy,
mkSigmaTy, splitSigmaTy,
splitRhoTy, mkForAllTy, splitForAllTy )
-import Util ( isIn, zipEqual, panic )
+import Bag ( bagToList )
+import Util ( isIn, zipEqual, zipWith3Equal, panic )
\end{code}
%************************************************************************
) `thenTc` \ (_, result) ->
returnTc result
where
- binder_names = collectBinders bind
+ binder_names = map fst (bagToList (collectBinders bind))
-tcBindAndSigs binder_rn_names bind sigs prag_info_fn
- = let
- binder_names = map de_rn binder_rn_names
- de_rn (RnName n) = n
- in
- recoverTc (
+tcBindAndSigs binder_names bind sigs prag_info_fn
+ = recoverTc (
-- If typechecking the binds fails, then return with each
-- binder given type (forall a.a), to minimise subsequent
-- error messages
) $
-- Create a new identifier for each binder, with each being given
- -- a type-variable type.
- newMonoIds binder_rn_names kind (\ mono_ids ->
+ -- a fresh unique, and a type-variable type.
+ tcGetUniques no_of_binders `thenNF_Tc` \ uniqs ->
+ newTyVarTys no_of_binders kind `thenNF_Tc` \ tys ->
+ let
+ mono_ids = zipWith3Equal "tcBindAndSigs" mk_id binder_names uniqs tys
+ mk_id name uniq ty = mkUserLocal (getOccName name) uniq ty (getSrcLoc name)
+ in
+ tcExtendLocalValEnv binder_names mono_ids (
tcTySigs sigs `thenTc` \ sig_info ->
tc_bind bind `thenTc` \ (bind', lie) ->
- returnTc (mono_ids, bind', lie, sig_info)
+ returnTc (bind', lie, sig_info)
)
- `thenTc` \ (mono_ids, bind', lie, sig_info) ->
+ `thenTc` \ (bind', lie, sig_info) ->
-- Notice that genBinds gets the old (non-extended) environment
genBinds binder_names mono_ids bind' lie sig_info prag_info_fn
where
+ no_of_binders = length binder_names
kind = case bind of
NonRecBind _ -> mkTypeKind -- Recursive, so no unboxed types
RecBind _ -> mkBoxedTypeKind -- Non-recursive, so we permit unboxed types
{-
data SigInfo
- = SigInfo RnName
+ = SigInfo Name
(TcIdBndr s) -- Polymorpic version
(TcIdBndr s) -- Monomorphic verstion
[TcType s] [TcIdOcc s] -- Instance information for the monomorphic version
-- Typecheck the binding group
tcExtendLocalEnv poly_sigs (
- newMonoIds nosig_binders kind (\ nosig_local_ids ->
+ newLocalIds nosig_binders kind (\ nosig_local_ids ->
tcMonoBinds mono_sigs mono_binds `thenTc` \ binds_w_lies ->
returnTc (nosig_local_ids, binds_w_lies)
)) `thenTc` \ (nosig_local_ids, binds_w_lies) ->
\begin{code}
tcTySigs :: [RenamedSig] -> TcM s [TcSigInfo s]
-tcTySigs (Sig v ty _ src_loc : other_sigs)
+tcTySigs (Sig v ty src_loc : other_sigs)
= tcAddSrcLoc src_loc (
- tcPolyType ty `thenTc` \ sigma_ty ->
+ tcHsType ty `thenTc` \ sigma_ty ->
tcInstSigType sigma_ty `thenNF_Tc` \ sigma_ty' ->
let
(tyvars', theta', tau') = splitSigmaTy sigma_ty'
\begin{code}
tcPragmaSig (DeforestSig name loc)
- = returnTc ((name, addInfo DoDeforest),EmptyBinds,emptyLIE)
+ = returnTc ((name, addDeforestInfo DoDeforest),EmptyBinds,emptyLIE)
tcPragmaSig (InlineSig name loc)
- = returnTc ((name, addInfo_UF (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
+ = returnTc ((name, addUnfoldInfo (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
tcPragmaSig (MagicUnfoldingSig name string loc)
- = returnTc ((name, addInfo_UF (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
+ = returnTc ((name, addUnfoldInfo (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
\end{code}
The interesting case is for SPECIALISE pragmas. There are two forms.
tcAddErrCtxt (valSpecSigCtxt name spec_ty) $
-- Get and instantiate its alleged specialised type
- tcPolyType poly_ty `thenTc` \ sig_sigma ->
+ tcHsType poly_ty `thenTc` \ sig_sigma ->
tcInstSigType sig_sigma `thenNF_Tc` \ sig_ty ->
let
(sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id))
spec_info = SpecInfo spec_tys (length main_theta) local_spec_id
in
- returnTc ((name, addInfo spec_info), spec_binds, spec_lie)
+ returnTc ((name, addSpecInfo spec_info), spec_binds, spec_lie)
-}
\end{code}
Not exported:
\begin{code}
+{- In GenSpec at the moment
+
isUnRestrictedGroup :: [TcIdBndr s] -- Signatures given for these
-> TcBind s
-> Bool
isUnResMono sigs (AndMonoBinds mb1 mb2) = isUnResMono sigs mb1 &&
isUnResMono sigs mb2
isUnResMono sigs EmptyMonoBinds = True
+-}
\end{code}
IMP_Ubiq()
-import HsSyn ( ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
- Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
- HsLit(..), OutPat(..), Sig(..), PolyType(..), MonoType,
+import HsSyn ( HsDecl(..), ClassDecl(..), HsBinds(..), Bind(..), MonoBinds(..),
+ Match(..), GRHSsAndBinds(..), GRHS(..), HsExpr(..),
+ DefaultDecl, TyDecl, InstDecl, IfaceSig,
+ HsLit(..), OutPat(..), Sig(..), HsType(..), HsTyVar,
Stmt, Qualifier, ArithSeqInfo, InPat, Fake )
+import HsTypes ( getTyVarName )
import HsPragmas ( ClassPragmas(..) )
import RnHsSyn ( RenamedClassDecl(..), RenamedClassPragmas(..),
RenamedClassOpSig(..), SYN_IE(RenamedMonoBinds),
- RenamedGenPragmas(..), RenamedContext(..),
- RnName{-instance Uniquable-}
+ RenamedGenPragmas(..), RenamedContext(..), SYN_IE(RenamedHsDecl)
)
import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds), SYN_IE(TcMonoBinds), SYN_IE(TcExpr),
mkHsTyApp, mkHsTyLam, mkHsDictApp, mkHsDictLam, tcIdType )
import TcEnv ( tcLookupClass, tcLookupTyVar, tcLookupTyCon, newLocalIds, tcExtendGlobalTyVars )
import TcInstDcls ( processInstBinds )
import TcKind ( unifyKind, TcKind )
-import TcMonad hiding ( rnMtoTcM )
-import TcMonoType ( tcPolyType, tcMonoType, tcContext )
+import TcMonad
+import TcMonoType ( tcHsType, tcContext )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), tcInstType, tcInstSigTyVars, tcInstSigType )
import Bag ( foldBag, unionManyBags )
-import Class ( GenClass, mkClass, mkClassOp, classBigSig,
+import Class ( GenClass, GenClassOp, mkClass, mkClassOp, classBigSig,
classOps, classOpString, classOpLocalType,
- classOpTagByString, SYN_IE(ClassOp)
+ classOpTagByOccName, SYN_IE(ClassOp)
)
-import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId,
+import Id ( GenId, mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId, getIdUnfolding,
idType )
+import CoreUnfold ( getUnfoldingTemplate )
import IdInfo
-import Name ( isLocallyDefined, origName, getLocalName )
+import Name ( Name, isLocallyDefined, moduleString, modAndOcc, nameString )
import PrelVals ( nO_DEFAULT_METHOD_ERROR_ID )
import PprStyle
import Pretty
-- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
tcGenPragmas ty id ps = returnNF_Tc noIdInfo
-tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addInfo` spec,
+tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addSpecInfo` spec,
noIdInfo)
\end{code}
tcAddErrCtxt (classDeclCtxt class_name) $
-- LOOK THINGS UP IN THE ENVIRONMENT
- tcLookupClass class_name `thenNF_Tc` \ (class_kind, rec_class) ->
- tcLookupTyVar tyvar_name `thenNF_Tc` \ (tyvar_kind, rec_tyvar) ->
+ tcLookupClass class_name `thenTc` \ (class_kind, rec_class) ->
+ tcLookupTyVar (getTyVarName tyvar_name) `thenNF_Tc` \ (tyvar_kind, rec_tyvar) ->
let
(rec_class_inst_env, rec_class_op_inst_fn) = rec_inst_mapper rec_class
in
in
-- Make super-class selector ids
- mapTc (mk_super_id rec_class)
- (super_classes `zip` maybe_pragmas) `thenTc` \ sc_sel_ids ->
- -- NB: we worry about matching list lengths below
+ mapTc (mk_super_id rec_class) super_classes `thenTc` \ sc_sel_ids ->
-- Done
returnTc (super_classes, sc_sel_ids)
where
- mk_super_id rec_class (super_class, maybe_pragma)
- = fixTc ( \ rec_super_id ->
- tcGetUnique `thenNF_Tc` \ uniq ->
-
- -- GET THE PRAGMA INFO FOR THE SUPERCLASS
- (case maybe_pragma of
- Nothing -> returnNF_Tc noIdInfo
- Just prag -> tcGenPragmas Nothing{-ty unknown-} rec_super_id prag
- ) `thenNF_Tc` \ id_info ->
- let
- rec_tyvar_ty = mkTyVarTy rec_tyvar
+ rec_tyvar_ty = mkTyVarTy rec_tyvar
+
+ mk_super_id rec_class super_class
+ = tcGetUnique `thenNF_Tc` \ uniq ->
+ let
ty = mkForAllTy rec_tyvar $
mkFunTy (mkDictTy rec_class rec_tyvar_ty)
(mkDictTy super_class rec_tyvar_ty)
- in
- -- BUILD THE SUPERCLASS ID
- returnTc (mkSuperDictSelId uniq rec_class super_class ty id_info)
- )
-
- maybe_pragmas :: [Maybe RenamedGenPragmas]
- maybe_pragmas = case pragmas of
- NoClassPragmas -> repeat Nothing
- SuperDictPragmas prags -> ASSERT(length prags == length context)
- map Just prags
- -- If there are any pragmas there should
- -- be one for each superclass
-
+ in
+ returnTc (mkSuperDictSelId uniq rec_class super_class ty)
tcClassSig :: Class -- Knot tying only!
-- NB: Renamer checks that the class type variable is mentioned in local_ty,
-- and that it is not constrained by theta
- tcPolyType op_ty `thenTc` \ local_ty ->
+ tcHsType op_ty `thenTc` \ local_ty ->
let
global_ty = mkSigmaTy [rec_clas_tyvar]
[(rec_clas, mkTyVarTy rec_clas_tyvar)]
local_ty
- class_op_nm = getLocalName op_name
+ class_op_nm = getOccName op_name
class_op = mkClassOp class_op_nm
- (classOpTagByString rec_clas{-yeeps!-} class_op_nm)
+ (classOpTagByOccName rec_clas{-yeeps!-} class_op_nm)
local_ty
in
- -- Munch the pragmas
- tcClassOpPragmas
- global_ty
- rec_sel_id rec_defm_id
- (rec_classop_spec_fn class_op)
- pragmas `thenNF_Tc` \ (op_info, defm_info) ->
-
-- Build the selector id and default method id
tcGetUnique `thenNF_Tc` \ d_uniq ->
let
- op_uniq = uniqueOf op_name
- sel_id = mkMethodSelId op_uniq rec_clas class_op global_ty op_info
- defm_id = mkDefaultMethodId d_uniq rec_clas class_op False global_ty defm_info
+ sel_id = mkMethodSelId op_name rec_clas class_op global_ty
+ defm_id = mkDefaultMethodId op_name d_uniq rec_clas class_op False global_ty
-- ToDo: improve the "False"
in
returnTc (class_op, sel_id, defm_id)
each local class decl.
\begin{code}
-tcClassDecls2 :: Bag RenamedClassDecl
+tcClassDecls2 :: [RenamedHsDecl]
-> NF_TcM s (LIE s, TcHsBinds s)
tcClassDecls2 decls
- = foldBag combine
- tcClassDecl2
- (returnNF_Tc (emptyLIE, EmptyBinds))
- decls
+ = foldr combine
+ (returnNF_Tc (emptyLIE, EmptyBinds))
+ [tcClassDecl2 cls_decl | ClD cls_decl <- decls]
where
combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
tc2 `thenNF_Tc` \ (lie2, binds2) ->
tcAddSrcLoc src_loc $
-- Get the relevant class
- tcLookupClass class_name `thenNF_Tc` \ (_, clas) ->
+ tcLookupClass class_name `thenTc` \ (_, clas) ->
let
(tyvar, scs, sc_sel_ids, ops, op_sel_ids, defm_ids)
= classBigSig clas
+
+ -- The selector binds are already in the selector Id's unfoldings
+ sel_binds = SingleBind $ NonRecBind $ foldr AndMonoBinds EmptyMonoBinds $
+ [ CoreMonoBind (RealId sel_id) (getUnfoldingTemplate (getIdUnfolding sel_id))
+ | sel_id <- sc_sel_ids ++ op_sel_ids,
+ isLocallyDefined sel_id
+ ]
in
+ -- Generate bindings for the default methods
tcInstSigTyVars [tyvar] `thenNF_Tc` \ ([clas_tyvar], _, _) ->
-
- -- Generate bindings for the selector functions
- buildSelectors clas tyvar clas_tyvar scs sc_sel_ids ops op_sel_ids
- `thenNF_Tc` \ sel_binds ->
- -- Ditto for the methods
buildDefaultMethodBinds clas clas_tyvar defm_ids default_binds
`thenTc` \ (const_insts, meth_binds) ->
%************************************************************************
%* *
-\subsection[ClassDcl-bld-sels]{Building the selector functions for methods and superclasses}
-%* *
-%************************************************************************
-
-\begin{code}
-buildSelectors :: Class -- The class object
- -> TyVar -- Class type variable
- -> TcTyVar s -- Instantiated class type variable (TyVarTy)
- -> [Class] -> [Id] -- Superclasses and selectors
- -> [ClassOp] -> [Id] -- Class ops and selectors
- -> NF_TcM s (TcHsBinds s)
-
-buildSelectors clas clas_tyvar clas_tc_tyvar scs sc_sel_ids ops op_sel_ids
- =
- -- Make new Ids for the components of the dictionary
- let
- clas_tyvar_ty = mkTyVarTy clas_tc_tyvar
- mk_op_ty = tcInstType [(clas_tyvar, clas_tyvar_ty)] . classOpLocalType
- in
- mapNF_Tc mk_op_ty ops `thenNF_Tc` \ op_tys ->
- newLocalIds (map classOpString ops) op_tys `thenNF_Tc` \ method_ids ->
-
- newDicts ClassDeclOrigin
- [ (super_clas, clas_tyvar_ty)
- | super_clas <- scs ] `thenNF_Tc` \ (_,dict_ids) ->
-
- newDicts ClassDeclOrigin
- [ (clas, clas_tyvar_ty) ] `thenNF_Tc` \ (_,[clas_dict]) ->
-
- -- Make suitable bindings for the selectors
- let
- mk_sel sel_id method_or_dict
- = mkSelBind sel_id clas_tc_tyvar clas_dict dict_ids method_ids method_or_dict
- in
- listNF_Tc (zipWithEqual "mk_sel1" mk_sel op_sel_ids method_ids) `thenNF_Tc` \ op_sel_binds ->
- listNF_Tc (zipWithEqual "mk_sel2" mk_sel sc_sel_ids dict_ids) `thenNF_Tc` \ sc_sel_binds ->
-
- returnNF_Tc (SingleBind (
- NonRecBind (
- foldr AndMonoBinds
- (foldr AndMonoBinds EmptyMonoBinds op_sel_binds)
- sc_sel_binds
- )))
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[ClassDcl-misc]{Miscellaneous}
-%* *
-%************************************************************************
-
-Make a selector expression for @sel_id@ from a dictionary @clas_dict@
-consisting of @dicts@ and @methods@.
-
-====================== OLD ============================
-We have to do a bit of jiggery pokery to get the type variables right.
-Suppose we have the class decl:
-\begin{verbatim}
- class Foo a where
- op1 :: Ord b => a -> b -> a
- op2 :: ...
-\end{verbatim}
-Then the method selector for \tr{op1} is like this:
-\begin{verbatim}
- op1_sel = /\a b -> \dFoo dOrd -> case dFoo of
- (op1_method,op2_method) -> op1_method b dOrd
-\end{verbatim}
-Note that the type variable for \tr{b} and the (Ord b) dictionary
-are lifted to the top lambda, and
-\tr{op1_method} is applied to them. This is preferable to the alternative:
-\begin{verbatim}
- op1_sel' = /\a -> \dFoo -> case dFoo of
- (op1_method,op2_method) -> op1_method
-\end{verbatim}
-because \tr{op1_sel'} then has the rather strange type
-\begin{verbatim}
- op1_sel' :: forall a. Foo a -> forall b. Ord b -> a -> b -> a
-\end{verbatim}
-whereas \tr{op1_sel} (the one we use) has the decent type
-\begin{verbatim}
- op1_sel :: forall a b. Foo a -> Ord b -> a -> b -> a
-\end{verbatim}
-========================= END OF OLD ===========================
-
-NEW COMMENT: instead we now go for op1_sel' above. Seems tidier and
-the rest of the compiler darn well ought to cope.
-
-
-
-NOTE that we return a TcMonoBinds (which is later zonked) even though
-there's no real back-substitution to do. It's just simpler this way!
-
-NOTE ALSO that the selector has no free type variables, so we
-don't bother to instantiate the class-op's local type; instead
-we just use the variables inside it.
-
-\begin{code}
-mkSelBind :: Id -- the selector id
- -> TcTyVar s -> TcIdOcc s -- class tyvar and dict
- -> [TcIdOcc s] -> [TcIdOcc s] -- superclasses and methods in class dict
- -> TcIdOcc s -- the superclass/method being slected
- -> NF_TcM s (TcMonoBinds s)
-
-mkSelBind sel_id clas_tyvar clas_dict dicts methods method_or_dict@(TcId op)
- =
- -- sel_id = /\ clas_tyvar -> \ clas_dict ->
- -- case clas_dict of
- -- <dicts..methods> -> method_or_dict
-
- returnNF_Tc (VarMonoBind (RealId sel_id) (
- TyLam [clas_tyvar] (
- DictLam [clas_dict] (
- HsCase
- (HsVar clas_dict)
- ([PatMatch (DictPat dicts methods) (
- GRHSMatch (GRHSsAndBindsOut
- [OtherwiseGRHS
- (HsVar method_or_dict)
- mkGeneratedSrcLoc]
- EmptyBinds
- (idType op)))])
- mkGeneratedSrcLoc
- ))))
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection[Default methods]{Default methods}
%* *
%************************************************************************
returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tcIdType method_id])
(HsLitOut (HsString (_PK_ error_msg)) stringTy))
-{- OLD AND COMPLICATED
- tcInstSigType () `thenNF_Tc` \ method_ty ->
- let
- (tyvars, theta, tau) = splitSigmaTy method_ty
- in
- newDicts ClassDeclOrigin theta `thenNF_Tc` \ (lie, dict_ids) ->
-
- returnNF_Tc (mkHsTyLam tyvars (
- mkHsDictLam dict_ids (
- HsApp (mkHsTyApp (HsVar (RealId nO_DEFAULT_METHOD_ERROR_ID)) [tau])
- (HsLitOut (HsString (_PK_ error_msg)) stringTy))))
--}
-
where
- (OrigName clas_mod clas_name) = origName "makeClassDeclDefaultMethodRhs" clas
+ (clas_mod, clas_name) = modAndOcc clas
method_id = method_ids !! (tag-1)
class_op = (classOps clas) !! (tag-1)
- error_msg = _UNPK_ clas_mod ++ "." ++ _UNPK_ clas_name ++ "."
+ error_msg = _UNPK_ (nameString (getName clas))
++ (ppShow 80 (ppr PprForUser class_op))
- ++ "\""
+-- ++ "\"" Don't know what this trailing quote is for!
\end{code}
IMP_Ubiq()
-import HsSyn ( DefaultDecl(..), MonoType,
+import HsSyn ( HsDecl(..), TyDecl, ClassDecl, InstDecl, HsBinds,
+ DefaultDecl(..), HsType, IfaceSig,
HsExpr, HsLit, ArithSeqInfo, Fake, InPat)
-import RnHsSyn ( RenamedDefaultDecl(..) )
+import RnHsSyn ( RenamedHsDecl(..), RenamedDefaultDecl(..) )
import TcHsSyn ( TcIdOcc )
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import Inst ( InstOrigin(..) )
import TcEnv ( tcLookupClassByKey )
import SpecEnv ( SpecEnv )
-import TcMonoType ( tcMonoType )
+import TcMonoType ( tcHsType )
import TcSimplify ( tcSimplifyCheckThetas )
import TysWiredIn ( intTy, doubleTy, unitTy )
import Unique ( numClassKey )
+import Pretty ( ppStr, ppAboves )
+import ErrUtils ( addShortErrLocLine )
import Util
\end{code}
\begin{code}
-tcDefaults :: [RenamedDefaultDecl]
+default_default = [intTy, doubleTy] -- language-specified default `default'
+
+tcDefaults :: [RenamedHsDecl]
-> TcM s [Type] -- defaulting types to heave
-- into Tc monad for later use
-- in Disambig.
+tcDefaults decls = tc_defaults [default_decl | DefD default_decl <- decls]
-tcDefaults []
- = returnTc [intTy, doubleTy] -- language-specified default `default'
+tc_defaults [] = returnTc default_default
-tcDefaults [DefaultDecl mono_tys locn]
+tc_defaults [DefaultDecl mono_tys locn]
= tcAddSrcLoc locn $
- mapTc tcMonoType mono_tys `thenTc` \ tau_tys ->
+ mapTc tcHsType mono_tys `thenTc` \ tau_tys ->
case tau_tys of
[] -> returnTc [] -- no defaults
returnTc tau_tys
+tc_defaults decls
+ = failTc (dupDefaultDeclErr decls)
+
+
+dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) sty
+ = ppAboves (item1 : map dup_item dup_things)
+ where
+ item1
+ = addShortErrLocLine locn1 (\ sty ->
+ ppStr "multiple default declarations") sty
+
+ dup_item (DefaultDecl _ locn)
+ = addShortErrLocLine locn (\ sty ->
+ ppStr "here was another default declaration") sty
+
\end{code}
IMP_Ubiq()
-import HsSyn ( FixityDecl, Sig, HsBinds(..), Bind(..), MonoBinds(..),
+import HsSyn ( HsDecl, FixityDecl, Fixity, InstDecl,
+ Sig, HsBinds(..), Bind(..), MonoBinds(..),
GRHSsAndBinds, Match, HsExpr, HsLit, InPat,
- ArithSeqInfo, Fake, MonoType )
+ ArithSeqInfo, Fake, HsType
+ )
import HsPragmas ( InstancePragmas(..) )
-import RnHsSyn ( mkRnName, RnName(..), SYN_IE(RenamedHsBinds), RenamedFixityDecl(..) )
+import RdrHsSyn ( RdrName, SYN_IE(RdrNameMonoBinds) )
+import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds), SYN_IE(RenamedFixityDecl) )
import TcHsSyn ( TcIdOcc )
import TcMonad
import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
import TcSimplify ( tcSimplifyThetas )
-import RnMonad
-import RnUtils ( SYN_IE(RnEnv), extendGlobalRnEnv )
-import RnBinds ( rnMethodBinds, rnTopBinds )
+import RnBinds ( rnMethodBinds, rnTopMonoBinds )
+import RnEnv ( newDfunName )
+import RnMonad ( SYN_IE(RnM), RnDown, GDown, SDown, RnNameSupply(..),
+ setNameSupplyRn, renameSourceCode, thenRn, mapRn, returnRn )
import Bag ( Bag, isEmptyBag, unionBags, listToBag )
-import Class ( classKey, needsDataDeclCtxtClassKeys, GenClass )
+import Class ( classKey, GenClass )
import ErrUtils ( pprBagOfErrors, addErrLoc, SYN_IE(Error) )
import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId )
+import PrelInfo ( needsDataDeclCtxtClassKeys )
import Maybes ( maybeToBool )
-import Name ( isLocallyDefined, getSrcLoc,
- mkTopLevName, origName, mkImplicitName, ExportFlag(..),
- RdrName(..), Name{--O only-}
+import Name ( isLocallyDefined, getSrcLoc, ExportFlag(..), Provenance,
+ Name{--O only-}
)
import Outputable ( Outputable(..){-instances e.g., (,)-} )
import PprType ( GenType, GenTyVar, GenClass, TyCon )
\begin{code}
tcDeriving :: Module -- name of module under scrutiny
- -> RnEnv -- for "renaming" bits of generated code
+ -> RnNameSupply -- for "renaming" bits of generated code
-> Bag InstInfo -- What we already know about instances
- -> [RenamedFixityDecl] -- Fixity info; used by Read and Show
-> TcM s (Bag InstInfo, -- The generated "instance decls".
RenamedHsBinds, -- Extra generated bindings
PprStyle -> Pretty) -- Printable derived instance decls;
-- for debugging via -ddump-derivings.
-tcDeriving modname rn_env inst_decl_infos_in fixities
+tcDeriving modname rn_name_supply inst_decl_infos_in
= -- Fish the "deriving"-related information out of the TcEnv
-- and make the necessary "equations".
- makeDerivEqns `thenTc` \ eqns ->
+ makeDerivEqns `thenTc` \ eqns ->
-- Take the equation list and solve it, to deliver a list of
-- solutions, a.k.a. the contexts for the instance decls
-- required for the corresponding equations.
- solveDerivEqns inst_decl_infos_in eqns
- `thenTc` \ new_inst_infos ->
+ solveDerivEqns inst_decl_infos_in eqns `thenTc` \ new_inst_infos ->
-- Now augment the InstInfos, adding in the rather boring
-- actual-code-to-do-the-methods binds. We may also need to
-- "con2tag" and/or "tag2con" functions. We do these
-- separately.
- gen_taggery_Names new_inst_infos `thenTc` \ nm_alist_etc ->
- gen_tag_n_con_binds rn_env nm_alist_etc
- `thenTc` \ (extra_binds, deriver_rn_env) ->
+ gen_taggery_Names new_inst_infos `thenTc` \ nm_alist_etc ->
+
+
+ let
+ extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
+ extra_mbinds = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list
+ method_binds_s = map gen_bind new_inst_infos
+
+ -- Rename to get RenamedBinds.
+ -- The only tricky bit is that the extra_binds must scope over the
+ -- method bindings for the instances.
+ (dfun_names_w_method_binds, rn_extra_binds)
+ = renameSourceCode modname rn_name_supply (
+ rnTopMonoBinds extra_mbinds [] `thenRn` \ rn_extra_binds ->
+ mapRn rn_one method_binds_s `thenRn` \ dfun_names_w_method_binds ->
+ returnRn (dfun_names_w_method_binds, rn_extra_binds)
+ )
+ rn_one meth_binds = newDfunName mkGeneratedSrcLoc `thenRn` \ dfun_name ->
+ rnMethodBinds meth_binds `thenRn` \ rn_meth_binds ->
+ returnRn (dfun_name, rn_meth_binds)
+ in
- mapTc (gen_inst_info modname fixities deriver_rn_env) new_inst_infos
- `thenTc` \ really_new_inst_infos ->
+ mapTc (gen_inst_info modname)
+ (new_inst_infos `zip` dfun_names_w_method_binds) `thenTc` \ really_new_inst_infos ->
let
- ddump_deriv = ddump_deriving really_new_inst_infos extra_binds
+ ddump_deriv = ddump_deriving really_new_inst_infos rn_extra_binds
in
--pprTrace "derived:\n" (ddump_deriv PprDebug) $
returnTc (listToBag really_new_inst_infos,
- extra_binds,
+ rn_extra_binds,
ddump_deriv)
where
ddump_deriving :: [InstInfo] -> RenamedHsBinds -> (PprStyle -> Pretty)
ddump_deriving inst_infos extra_binds sty
= ppAboves ((map pp_info inst_infos) ++ [ppr sty extra_binds])
where
- pp_info (InstInfo clas tvs ty inst_decl_theta _ _ _ mbinds _ _ _ _)
+ pp_info (InstInfo clas tvs ty inst_decl_theta _ _ mbinds _ _)
= ppAbove (ppr sty (mkSigmaTy tvs inst_decl_theta (mkDictTy clas ty)))
(ppr sty mbinds)
\end{code}
makeDerivEqns
= tcGetEnv `thenNF_Tc` \ env ->
- tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
let
- tycons = filter isDataTyCon (getEnv_TyCons env)
+ local_data_tycons = filter (\tc -> isLocallyDefined tc && isDataTyCon tc)
+ (getEnv_TyCons env)
-- ToDo: what about newtypes???
- think_about_deriving = need_deriving eval_clas tycons
in
- mapTc chk_out think_about_deriving `thenTc_`
+ if null local_data_tycons then
+ -- Bale out now; evalClass may not be loaded if there aren't any
+ returnTc []
+ else
+ tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
let
- (derive_these, _) = removeDups cmp_deriv think_about_deriving
- eqns = map mk_eqn derive_these
+ think_about_deriving = need_deriving eval_clas local_data_tycons
+ (derive_these, _) = removeDups cmp_deriv think_about_deriving
+ eqns = map mk_eqn derive_these
in
+ mapTc chk_out think_about_deriving `thenTc_`
returnTc eqns
where
------------------------------------------------------------------
dummy_dfun_id
- (my_panic "const_meth_ids")
- (my_panic "binds") (my_panic "from_here")
- (my_panic "modname") mkGeneratedSrcLoc
+ (my_panic "binds") (getSrcLoc tycon)
(my_panic "upragmas")
where
dummy_dfun_id
- = mkDictFunId bottom bottom bottom dummy_dfun_ty
- bottom bottom bottom bottom
+ = mkDictFunId bottom dummy_dfun_ty bottom bottom
where
bottom = panic "dummy_dfun_id"
\end{itemize}
\begin{code}
-gen_inst_info :: Module -- Module name
- -> [RenamedFixityDecl] -- all known fixities;
- -- may be needed for Text
- -> RnEnv -- lookup stuff for names we may use
- -> InstInfo -- the main stuff to work on
- -> TcM s InstInfo -- the gen'd (filled-in) "instance decl"
-
-gen_inst_info modname fixities deriver_rn_env
- (InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
+-- Generate the method bindings for the required instance
+gen_bind :: InstInfo -> RdrNameMonoBinds
+gen_bind (InstInfo clas _ ty _ _ _ _ _ _)
+ | not from_here
+ = EmptyMonoBinds
+ | otherwise
+ = assoc "gen_inst_info:bad derived class"
+ [(eqClassKey, gen_Eq_binds)
+ ,(ordClassKey, gen_Ord_binds)
+ ,(enumClassKey, gen_Enum_binds)
+ ,(evalClassKey, gen_Eval_binds)
+ ,(boundedClassKey, gen_Bounded_binds)
+ ,(showClassKey, gen_Show_binds)
+ ,(readClassKey, gen_Read_binds)
+ ,(ixClassKey, gen_Ix_binds)
+ ]
+ (classKey clas)
+ tycon
+ where
+ from_here = isLocallyDefined tycon
+ (tycon,_,_) = getAppDataTyCon ty
+
+
+gen_inst_info :: Module -- Module name
+ -> (InstInfo, (Name, RenamedMonoBinds)) -- the main stuff to work on
+ -> TcM s InstInfo -- the gen'd (filled-in) "instance decl"
+
+gen_inst_info modname
+ (InstInfo clas tyvars ty inst_decl_theta _ _ _ locn _, (dfun_name, meth_binds))
=
-- Generate the various instance-related Ids
mkInstanceRelatedIds
- True {-from_here-} locn modname
- NoInstancePragmas
+ dfun_name
clas tyvars ty
inst_decl_theta
- [{-no user pragmas-}]
- `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
+ `thenNF_Tc` \ (dfun_id, dfun_theta) ->
- -- Generate the bindings for the new instance declaration,
- -- rename it, and check for errors
- let
- (tycon,_,_) = --pprTrace "gen_inst_info:ty" (ppCat[ppr PprDebug clas, ppr PprDebug ty]) $
- getAppDataTyCon ty
-
- proto_mbinds
- = assoc "gen_inst_info:bad derived class"
- [(eqClassKey, gen_Eq_binds)
- ,(ordClassKey, gen_Ord_binds)
- ,(enumClassKey, gen_Enum_binds)
- ,(evalClassKey, gen_Eval_binds)
- ,(boundedClassKey, gen_Bounded_binds)
- ,(showClassKey, gen_Show_binds fixities)
- ,(readClassKey, gen_Read_binds fixities)
- ,(ixClassKey, gen_Ix_binds)
- ]
- clas_key $ tycon
- in
-{-
- let
- ((qual, unqual, tc_qual, tc_unqual), stack) = deriver_rn_env
- in
- pprTrace "gen_inst:qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM qual]) $
- pprTrace "gen_inst:unqual:" (ppCat (map ppPStr (keysFM unqual))) $
- pprTrace "gen_inst:tc_qual:" (ppCat [ppBesides[ppPStr m,ppChar '.',ppPStr n] | (n,m) <- keysFM tc_qual]) $
- pprTrace "gen_inst:tc_unqual:" (ppCat (map ppPStr (keysFM tc_unqual))) $
--}
- -- pprTrace "derived binds:" (ppr PprDebug proto_mbinds) $
-
- rnMtoTcM deriver_rn_env (
- setExtraRn emptyUFM{-no fixities-} $
- rnMethodBinds clas_Name proto_mbinds
- ) `thenNF_Tc` \ (mbinds, errs) ->
-
- if not (isEmptyBag errs) then
- panic "gen_inst_info:renamer errs!\n"
--- pprPanic "gen_inst_info:renamer errs!\n"
--- (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug proto_mbinds))
- else
- -- All done
- let
- from_here = isLocallyDefined tycon -- If so, then from here
- in
returnTc (InstInfo clas tyvars ty inst_decl_theta
- dfun_theta dfun_id const_meth_ids
- (if from_here then mbinds else EmptyMonoBinds)
- from_here modname locn [])
+ dfun_theta dfun_id
+ meth_binds
+ locn [])
where
- clas_key = classKey clas
- clas_Name = RnImplicitClass (mkImplicitName clas_key (origName "gen_inst_info" clas))
+ from_here = isLocallyDefined tycon
+ (tycon,_,_) = getAppDataTyCon ty
\end{code}
+
%************************************************************************
%* *
-\subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
+\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
%* *
%************************************************************************
+
data Foo ... = ...
con2tag_Foo :: Foo ... -> Int#
tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
maxtag_Foo :: Int -- ditto (NB: not unboxed)
-\begin{code}
-gen_tag_n_con_binds :: RnEnv
- -> [(RdrName, TyCon, TagThingWanted)]
- -> TcM s (RenamedHsBinds,
- RnEnv) -- input one with any new names added
-
-gen_tag_n_con_binds rn_env nm_alist_etc
- =
- let
- -- We have the renamer's final "name funs" in our hands
- -- (they were passed in). So we can handle ProtoNames
- -- that refer to anything "out there". But our generated
- -- code may also mention "con2tag" (etc.). So we need
- -- to augment to "name funs" to include those.
-
- names_to_add = [ pn | (pn,_,_) <- nm_alist_etc ]
- in
- tcGetUniques (length names_to_add) `thenNF_Tc` \ uniqs ->
- let
- pairs_to_add = [ case pn of { Qual pnm pnn ->
- (pn, mkRnName (mkTopLevName u (OrigName pnm pnn) mkGeneratedSrcLoc ExportAll [])) }
- | (pn,u) <- zipEqual "gen_tag..." names_to_add uniqs ]
-
- deriver_rn_env
- = if null names_to_add
- then rn_env else added_rn_env
-
- (added_rn_env, errs_bag)
- = extendGlobalRnEnv rn_env pairs_to_add [{-no tycons-}]
-
- ----------------
- proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
- proto_mbinds = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
- in
- ASSERT(isEmptyBag errs_bag)
-
- rnMtoTcM deriver_rn_env (
- setExtraRn emptyUFM{-no fixities-} $
- rnTopBinds (SingleBind (RecBind proto_mbinds))
- ) `thenNF_Tc` \ (binds, errs) ->
-
- if not (isEmptyBag errs) then
- panic "gen_tag_n_con_binds:renamer errs!\n"
--- pprPanic "gen_tag_n_con_binds:renamer errs!\n"
--- (ppAbove (pprBagOfErrors PprDebug errs) (ppr PprDebug binds))
- else
- returnTc (binds, deriver_rn_env)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[TcDeriv-taggery-Names]{What con2tag/tag2con functions are available?}
-%* *
-%************************************************************************
We have a @con2tag@ function for a tycon if:
\begin{itemize}
foldlTc do_con2tag [] tycons_of_interest `thenTc` \ names_so_far ->
foldlTc do_tag2con names_so_far tycons_of_interest
where
- all_CTs = [ mk_CT c ty | (InstInfo c _ ty _ _ _ _ _ _ _ _ _) <- inst_infos ]
+ all_CTs = [ mk_CT c ty | (InstInfo c _ ty _ _ _ _ _ _) <- inst_infos ]
mk_CT c ty = (c, fst (getAppTyCon ty))
|| (we_are_deriving enumClassKey tycon)
|| (we_are_deriving ixClassKey tycon)
then
- returnTc ((con2tag_PN tycon, tycon, GenCon2Tag)
+ returnTc ((con2tag_RDR tycon, tycon, GenCon2Tag)
: acc_Names)
else
returnTc acc_Names
= if (we_are_deriving enumClassKey tycon)
|| (we_are_deriving ixClassKey tycon)
then
- returnTc ( (tag2con_PN tycon, tycon, GenTag2Con)
- : (maxtag_PN tycon, tycon, GenMaxTag)
+ returnTc ( (tag2con_RDR tycon, tycon, GenTag2Con)
+ : (maxtag_RDR tycon, tycon, GenMaxTag)
: acc_Names)
else
returnTc acc_Names
initEnv, getEnv_LocalIds, getEnv_TyCons, getEnv_Classes,
- tcTyVarScope, tcTyVarScopeGivenKinds, tcLookupTyVar,
+ tcExtendTyVarEnv, tcLookupTyVar,
tcExtendTyConEnv, tcLookupTyCon, tcLookupTyConByKey,
tcExtendClassEnv, tcLookupClass, tcLookupClassByKey,
tcExtendGlobalValEnv, tcExtendLocalValEnv,
tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey,
- tcLookupGlobalValue, tcLookupGlobalValueByKey,
+ tcLookupGlobalValue, tcLookupGlobalValueByKey, tcLookupGlobalValueMaybe,
newMonoIds, newLocalIds, newLocalId,
tcGetGlobalTyVars, tcExtendGlobalTyVars
IMP_Ubiq()
IMPORT_DELOOPER(TcMLoop) -- for paranoia checking
-import Id ( SYN_IE(Id), GenId, idType, mkUserLocal )
+import HsTypes ( HsTyVar(..) )
+import Id ( SYN_IE(Id), GenId, idType, mkUserLocal, mkUserId )
+import PragmaInfo ( PragmaInfo(..) )
import TcHsSyn ( SYN_IE(TcIdBndr), TcIdOcc(..) )
-import TcKind ( TcKind, newKindVars, tcDefaultKind, kindToTcKind )
+import TcKind ( TcKind, newKindVars, newKindVar, tcDefaultKind, kindToTcKind )
import TcType ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
newTyVarTys, tcInstTyVars, zonkTcTyVars
)
-import TyVar ( mkTyVar, tyVarKind, unionTyVarSets, emptyTyVarSet )
+import TyVar ( unionTyVarSets, emptyTyVarSet )
import Type ( tyVarsOfTypes, splitForAllTy )
import TyCon ( TyCon, tyConKind, synTyConArity )
import Class ( SYN_IE(Class), GenClass, classSig )
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
-import Name ( getOccName, getSrcLoc, Name{-instance NamedThing-} )
+import Name ( Name, OccName(..), getSrcLoc, occNameString,
+ maybeWiredInTyConName, maybeWiredInIdName, pprSym
+ )
import PprStyle
import Pretty
-import RnHsSyn ( RnName(..) )
import Unique ( pprUnique10{-, pprUnique ToDo:rm-} )
import UniqFM
import Util ( zipEqual, zipWithEqual, zipWith3Equal, zipLazy,
getEnv_Classes (TcEnv _ _ cs _ _ _) = [clas | (_, clas) <- eltsUFM cs]
\end{code}
-Making new TcTyVars, with knot tying!
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Type variable env
+~~~~~~~~~~~~~~~~~
\begin{code}
-tcTyVarScopeGivenKinds
- :: [Name] -- Names of some type variables
- -> [TcKind s]
- -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
- -> TcM s a -- Result
-
-tcTyVarScopeGivenKinds names kinds thing_inside
- = fixTc (\ ~(rec_tyvars, _) ->
- -- Ok to look at names, kinds, but not tyvars!
-
- tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- let
- tve' = addListToUFM tve (zipEqual "tcTyVarScopeGivenKinds" names (kinds `zipLazy` rec_tyvars))
- in
- tcSetEnv (TcEnv tve' tce ce gve lve gtvs)
- (thing_inside rec_tyvars) `thenTc` \ result ->
-
- -- Get the tyvar's Kinds from their TcKinds
- mapNF_Tc tcDefaultKind kinds `thenNF_Tc` \ kinds' ->
-
- -- Construct the real TyVars
- let
- tyvars = zipWithEqual "tcTyVarScopeGivenKinds" mkTyVar names kinds'
- in
- returnTc (tyvars, result)
- ) `thenTc` \ (_,result) ->
- returnTc result
-
-tcTyVarScope names thing_inside
- = newKindVars (length names) `thenNF_Tc` \ kinds ->
- tcTyVarScopeGivenKinds names kinds thing_inside
+tcExtendTyVarEnv :: [Name] -> [(TcKind s, TyVar)] -> TcM s r -> TcM s r
+tcExtendTyVarEnv names kinds_w_types scope
+ = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+ let
+ tve' = addListToUFM tve (zipEqual "tcTyVarScope" names kinds_w_types)
+ in
+ tcSetEnv (TcEnv tve' tce ce gve lve gtvs) scope
\end{code}
-
The Kind, TyVar, Class and TyCon envs
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
that the knot-tied TyVars, TyCons and Classes aren't looked at too early.
\begin{code}
-tcExtendTyConEnv :: [(RnName,Maybe Arity)] -> [TyCon] -> TcM s r -> TcM s r
+tcExtendTyConEnv :: [(Name,Maybe Arity)] -> [TyCon] -> TcM s r -> TcM s r
tcExtendTyConEnv names_w_arities tycons scope
= newKindVars (length names_w_arities) `thenNF_Tc` \ kinds ->
returnTc result
-tcExtendClassEnv :: [RnName] -> [Class] -> TcM s r -> TcM s r
+tcExtendClassEnv :: [Name] -> [Class] -> TcM s r -> TcM s r
tcExtendClassEnv names classes scope
= newKindVars (length names) `thenNF_Tc` \ kinds ->
tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
returnNF_Tc (lookupWithDefaultUFM tve (pprPanic "tcLookupTyVar:" (ppr PprShowAll name)) name)
-tcLookupTyCon (WiredInTyCon tc) -- wired in tycons
- = returnNF_Tc (kindToTcKind (tyConKind tc), synTyConArity tc, tc)
-
tcLookupTyCon name
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- returnNF_Tc (lookupWithDefaultUFM tce (pprPanic "tcLookupTyCon:" (ppr PprShowAll name)) name)
+ = case maybeWiredInTyConName name of
+ Just tc -> returnTc (kindToTcKind (tyConKind tc), synTyConArity tc, tc)
+ Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+ case lookupUFM tce name of
+ Just stuff -> returnTc stuff
+ Nothing -> -- Could be that he's using a class name as a type constructor
+ case lookupUFM ce name of
+ Just _ -> failTc (classAsTyConErr name)
+ Nothing -> pprPanic "tcLookupTyCon:" (ppr PprDebug name)
tcLookupTyConByKey uniq
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
-- pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique10 (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique10 . fst) (ufmToList ce))]) $
-- pprTrace "tcLookupClass:" (ppCat [ppStr "Uniq:", pprUnique (uniqueOf name), ppStr "; avail:", ppCat (map (pprUnique . fst) (ufmToList ce))]) $
- returnNF_Tc (lookupWithDefaultUFM ce (pprPanic "tcLookupClass:" (ppr PprShowAll name)) name)
+ case lookupUFM ce name of
+ Just stuff -> returnTc stuff
+ Nothing -> -- Could be that he's using a type constructor as a class
+ case lookupUFM tce name of
+ Just _ -> failTc (tyConAsClassErr name)
+ Nothing -> pprPanic "tcLookupClass:" (ppr PprShowAll name)
tcLookupClassByKey uniq
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
\end{code}
\begin{code}
-tcLookupLocalValue :: RnName -> NF_TcM s (Maybe (TcIdBndr s))
+tcLookupLocalValue :: Name -> NF_TcM s (Maybe (TcIdBndr s))
tcLookupLocalValue name
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
returnNF_Tc (lookupUFM lve name)
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
returnNF_Tc (lookupUFM_Directly lve uniq)
-tcLookupLocalValueOK :: String -> RnName -> NF_TcM s (TcIdBndr s)
+tcLookupLocalValueOK :: String -> Name -> NF_TcM s (TcIdBndr s)
tcLookupLocalValueOK err name
= tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
returnNF_Tc (lookupWithDefaultUFM lve (panic err) name)
-tcLookupGlobalValue :: RnName -> NF_TcM s Id
-
-tcLookupGlobalValue (WiredInId id) -- wired in ids
- = returnNF_Tc id
+tcLookupGlobalValue :: Name -> NF_TcM s Id
tcLookupGlobalValue name
- = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
- returnNF_Tc (lookupWithDefaultUFM gve def name)
+ = case maybeWiredInIdName name of
+ Just id -> returnNF_Tc id
+ Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+ returnNF_Tc (lookupWithDefaultUFM gve def name)
where
-#ifdef DEBUG
def = pprPanic "tcLookupGlobalValue:" (ppr PprDebug name)
-#else
- def = panic "tcLookupGlobalValue"
-#endif
+
+tcLookupGlobalValueMaybe :: Name -> NF_TcM s (Maybe Id)
+
+tcLookupGlobalValueMaybe name
+ = case maybeWiredInIdName name of
+ Just id -> returnNF_Tc (Just id)
+ Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) ->
+ returnNF_Tc (lookupUFM gve name)
+
tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id
tcLookupGlobalValueByKey uniq
~~~~~~~~~~~~~~~~~~~~
\begin{code}
-newMonoIds :: [RnName] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a
+-- Uses the Name as the Name of the Id
+newMonoIds :: [Name] -> Kind -> ([TcIdBndr s] -> TcM s a) -> TcM s a
newMonoIds names kind m
= newTyVarTys no_of_names kind `thenNF_Tc` \ tys ->
- tcGetUniques no_of_names `thenNF_Tc` \ uniqs ->
let
- new_ids = zipWith3Equal "newMonoIds" mk_id names uniqs tys
-
- mk_id name uniq ty
- = let
- name_str = case (getOccName name) of { Unqual n -> n; Qual m n -> n }
- in
- mkUserLocal name_str uniq ty (getSrcLoc name)
+ new_ids = zipWithEqual "newMonoIds" mk_id names tys
+ mk_id name ty = mkUserId name ty NoPragmaInfo
in
tcExtendLocalValEnv names new_ids (m new_ids)
where
no_of_names = length names
-newLocalId :: FAST_STRING -> TcType s -> NF_TcM s (TcIdOcc s)
+newLocalId :: OccName -> TcType s -> NF_TcM s (TcIdBndr s)
newLocalId name ty
= tcGetSrcLoc `thenNF_Tc` \ loc ->
tcGetUnique `thenNF_Tc` \ uniq ->
- returnNF_Tc (TcId (mkUserLocal name uniq ty loc))
+ returnNF_Tc (mkUserLocal name uniq ty loc)
-newLocalIds :: [FAST_STRING] -> [TcType s] -> NF_TcM s [TcIdOcc s]
+newLocalIds :: [OccName] -> [TcType s] -> NF_TcM s [TcIdBndr s]
newLocalIds names tys
= tcGetSrcLoc `thenNF_Tc` \ loc ->
tcGetUniques (length names) `thenNF_Tc` \ uniqs ->
let
new_ids = zipWith3Equal "newLocalIds" mk_id names uniqs tys
- mk_id name uniq ty = TcId (mkUserLocal name uniq ty loc)
+ mk_id name uniq ty = mkUserLocal name uniq ty loc
in
returnNF_Tc new_ids
\end{code}
+\begin{code}
+classAsTyConErr name sty
+ = ppBesides [ppStr "Class used as a type constructor: ", pprSym sty name]
+tyConAsClassErr name sty
+ = ppBesides [ppStr "Type constructor used as a class: ", pprSym sty name]
+\end{code}
import HsSyn ( HsExpr(..), Qualifier(..), Stmt(..),
HsBinds(..), Bind(..), MonoBinds(..),
ArithSeqInfo(..), HsLit(..), Sig, GRHSsAndBinds,
- Match, Fake, InPat, OutPat, PolyType,
+ Match, Fake, InPat, OutPat, HsType,
failureFreePat, collectPatBinders )
import RnHsSyn ( SYN_IE(RenamedHsExpr), SYN_IE(RenamedQual),
- SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds),
- RnName{-instance Outputable-}
+ SYN_IE(RenamedStmt), SYN_IE(RenamedRecordBinds)
)
import TcHsSyn ( SYN_IE(TcExpr), SYN_IE(TcQual), SYN_IE(TcStmt),
TcIdOcc(..), SYN_IE(TcRecordBinds),
mkHsTyApp
)
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
SYN_IE(LIE), emptyLIE, plusLIE, plusLIEs, newOverloadedLit,
newMethod, newMethodWithGivenTy, newDicts )
)
import SpecEnv ( SpecEnv )
import TcMatches ( tcMatchesCase, tcMatch )
-import TcMonoType ( tcPolyType )
+import TcMonoType ( tcHsType )
import TcPat ( tcPat )
import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 )
import TcType ( SYN_IE(TcType), TcMaybe(..),
\begin{code}
tcExpr in_expr@(ExprWithTySig expr poly_ty)
= tcExpr expr `thenTc` \ (texpr, lie, tau_ty) ->
- tcPolyType poly_ty `thenTc` \ sigma_sig ->
+ tcHsType poly_ty `thenTc` \ sigma_sig ->
-- Check the tau-type part
tcSetErrCtxt (exprSigCtxt in_expr) $
%************************************************************************
\begin{code}
-tcId :: RnName -> NF_TcM s (TcExpr s, LIE s, TcType s)
+tcId :: Name -> NF_TcM s (TcExpr s, LIE s, TcType s)
tcId name
= -- Look up the Id and instantiate its type
import RnHsSyn ( SYN_IE(RenamedGRHSsAndBinds), SYN_IE(RenamedGRHS) )
import TcHsSyn ( SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), TcIdOcc(..) )
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import Inst ( Inst, SYN_IE(LIE), plusLIE )
import TcBinds ( tcBindsAndThen )
import TcExpr ( tcExpr )
#include "HsVersions.h"
module TcGenDeriv (
- a_Expr,
- a_PN,
- a_Pat,
- ah_PN,
- b_Expr,
- b_PN,
- b_Pat,
- bh_PN,
- c_Expr,
- c_PN,
- c_Pat,
- ch_PN,
- cmp_eq_PN,
- d_Expr,
- d_PN,
- d_Pat,
- dh_PN,
- eqH_Int_PN,
- eqTag_Expr,
- eq_PN,
- error_PN,
- false_Expr,
- false_PN,
- geH_PN,
gen_Bounded_binds,
gen_Enum_binds,
gen_Eval_binds,
gen_Read_binds,
gen_Show_binds,
gen_tag_n_con_monobind,
- gtTag_Expr,
- gt_PN,
- leH_PN,
- ltH_Int_PN,
- ltTag_Expr,
- lt_PN,
- minusH_PN,
- mkInt_PN,
- rangeSize_PN,
- true_Expr,
- true_PN,
-
- con2tag_PN, tag2con_PN, maxtag_PN,
+
+ con2tag_RDR, tag2con_RDR, maxtag_RDR,
TagThingWanted(..)
) where
import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qualifier(..), Stmt,
- ArithSeqInfo, Sig, PolyType, FixityDecl, Fake )
-import RdrHsSyn ( SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat) )
-import RnHsSyn ( RenamedFixityDecl(..) )
---import RnUtils
+ ArithSeqInfo, Sig, HsType, FixityDecl, Fake )
+import RdrHsSyn ( RdrName(..), varQual, varUnqual,
+ SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat)
+ )
+-- import RnHsSyn ( RenamedFixityDecl(..) )
import Id ( GenId, dataConNumFields, isNullaryDataCon, dataConTag,
dataConRawArgTys, fIRST_TAG,
isDataCon, SYN_IE(DataCon), SYN_IE(ConTag) )
-import IdUtils ( primOpId )
import Maybes ( maybeToBool )
-import Name ( origName, preludeQual, nameOf, RdrName(..), OrigName(..) )
-import PrelMods ( pRELUDE, gHC__, iX )
-import PrelVals ( eRROR_ID )
+import Name ( getOccString, getSrcLoc, occNameString, modAndOcc, OccName, Name )
import PrimOp ( PrimOp(..) )
+import PrelInfo -- Lots of RdrNames
import SrcLoc ( mkGeneratedSrcLoc )
import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
import Type ( eqTy, isPrimType )
import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
floatPrimTy, doublePrimTy
)
-import TysWiredIn ( falseDataCon, trueDataCon, intDataCon )
---import Unique
import Util ( mapAccumL, zipEqual, zipWith3Equal, nOfThem, panic, assertPanic )
\end{code}
gen_Eq_binds tycon
= let
+ tycon_loc = getSrcLoc tycon
(nullary_cons, nonnullary_cons)
= partition isNullaryDataCon (tyConDataCons tycon)
[([a_Pat, b_Pat], false_Expr)]
else -- calc. and compare the tags
[([a_Pat, b_Pat],
- untag_Expr tycon [(a_PN,ah_PN), (b_PN,bh_PN)]
- (cmp_tags_Expr eqH_Int_PN ah_PN bh_PN true_Expr false_Expr))]
+ untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
+ (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
in
- mk_FunMonoBind eq_PN ((map pats_etc nonnullary_cons) ++ rest)
- `AndMonoBinds` boring_ne_method
+ mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
+ `AndMonoBinds`
+ mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
+ HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
where
------------------------------------------------------------------
pats_etc data_con
= let
- con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
- con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
+ con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
+ con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
- data_con_PN = qual_orig_name data_con
+ data_con_RDR = qual_orig_name data_con
con_arity = length tys_needed
- as_needed = take con_arity as_PNs
- bs_needed = take con_arity bs_PNs
+ as_needed = take con_arity as_RDRs
+ bs_needed = take con_arity bs_RDRs
tys_needed = dataConRawArgTys data_con
in
([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
= 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))
-
-boring_ne_method
- = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] $
- HsApp (HsVar not_PN) (HsPar (mk_easy_App eq_PN [a_PN, b_PN]))
\end{code}
%************************************************************************
gen_Ord_binds tycon
= defaulted `AndMonoBinds` compare
where
+ tycon_loc = getSrcLoc tycon
--------------------------------------------------------------------
- compare = mk_easy_FunMonoBind compare_PN
+ compare = mk_easy_FunMonoBind tycon_loc compare_RDR
[a_Pat, b_Pat]
[cmp_eq]
(if maybeToBool (maybeTyConSingleCon tycon) then
cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
else
- untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)]
- (cmp_tags_Expr eqH_Int_PN ah_PN bh_PN
+ untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
+ (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
-- True case; they are equal
-- If an enumeration type we are done; else
-- recursively compare their components
)
-- False case; they aren't equal
-- So we need to do a less-than comparison on the tags
- (cmp_tags_Expr ltH_Int_PN ah_PN bh_PN ltTag_Expr gtTag_Expr)))
+ (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
(nullary_cons, nonnullary_cons)
= partition isNullaryDataCon (tyConDataCons tycon)
cmp_eq
- = mk_FunMonoBind cmp_eq_PN (map pats_etc nonnullary_cons ++ deflt_pats_etc)
+ = mk_FunMonoBind tycon_loc cmp_eq_RDR (map pats_etc nonnullary_cons ++ deflt_pats_etc)
where
pats_etc data_con
= ([con1_pat, con2_pat],
nested_compare_expr tys_needed as_needed bs_needed)
where
- con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
- con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
+ con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
+ con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
- data_con_PN = qual_orig_name data_con
+ data_con_RDR = qual_orig_name data_con
con_arity = length tys_needed
- as_needed = take con_arity as_PNs
- bs_needed = take con_arity bs_PNs
+ as_needed = take con_arity as_RDRs
+ bs_needed = take con_arity bs_RDRs
tys_needed = dataConRawArgTys data_con
nested_compare_expr [ty] [a] [b]
defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
-lt = mk_easy_FunMonoBind lt_PN [a_Pat, b_Pat] [] (
+lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
-le = mk_easy_FunMonoBind le_PN [a_Pat, b_Pat] [] (
+le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
-ge = mk_easy_FunMonoBind ge_PN [a_Pat, b_Pat] [] (
+ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
-gt = mk_easy_FunMonoBind gt_PN [a_Pat, b_Pat] [] (
+gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
-max_ = mk_easy_FunMonoBind max_PN [a_Pat, b_Pat] [] (
+max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
-min_ = mk_easy_FunMonoBind min_PN [a_Pat, b_Pat] [] (
+min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
\end{code}
gen_Enum_binds :: TyCon -> RdrNameMonoBinds
gen_Enum_binds tycon
- = enum_from `AndMonoBinds` enum_from_then
+ = enum_from `AndMonoBinds`
+ enum_from_then `AndMonoBinds`
+ from_enum
where
+ tycon_loc = getSrcLoc tycon
enum_from
- = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] $
- untag_Expr tycon [(a_PN, ah_PN)] $
- HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
+ = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
+ untag_Expr tycon [(a_RDR, ah_RDR)] $
+ HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
HsPar (enum_from_to_Expr
- (mk_easy_App mkInt_PN [ah_PN])
- (HsVar (maxtag_PN tycon)))
+ (mk_easy_App mkInt_RDR [ah_RDR])
+ (HsVar (maxtag_RDR tycon)))
enum_from_then
- = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] $
- untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] $
- HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
+ = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
+ untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
+ HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
HsPar (enum_from_then_to_Expr
- (mk_easy_App mkInt_PN [ah_PN])
- (mk_easy_App mkInt_PN [bh_PN])
- (HsVar (maxtag_PN tycon)))
+ (mk_easy_App mkInt_RDR [ah_RDR])
+ (mk_easy_App mkInt_RDR [bh_RDR])
+ (HsVar (maxtag_RDR tycon)))
+
+ from_enum
+ = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
+ untag_Expr tycon [(a_RDR, ah_RDR)] $
+ (mk_easy_App mkInt_RDR [ah_RDR])
\end{code}
%************************************************************************
ASSERT(length data_cons == 1)
min_bound_1con `AndMonoBinds` max_bound_1con
where
- data_cons = tyConDataCons tycon
+ data_cons = tyConDataCons tycon
+ tycon_loc = getSrcLoc tycon
----- enum-flavored: ---------------------------
- min_bound_enum = mk_easy_FunMonoBind minBound_PN [] [] (HsVar data_con_1_PN)
- max_bound_enum = mk_easy_FunMonoBind maxBound_PN [] [] (HsVar data_con_N_PN)
+ min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
+ max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
data_con_1 = head data_cons
data_con_N = last data_cons
- data_con_1_PN = qual_orig_name data_con_1
- data_con_N_PN = qual_orig_name data_con_N
+ data_con_1_RDR = qual_orig_name data_con_1
+ data_con_N_RDR = qual_orig_name data_con_N
----- single-constructor-flavored: -------------
arity = dataConNumFields data_con_1
- min_bound_1con = mk_easy_FunMonoBind minBound_PN [] [] $
- mk_easy_App data_con_1_PN (nOfThem arity minBound_PN)
- max_bound_1con = mk_easy_FunMonoBind maxBound_PN [] [] $
- mk_easy_App data_con_1_PN (nOfThem arity maxBound_PN)
+ min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
+ mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
+ max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
+ mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
\end{code}
%************************************************************************
then enum_ixes
else single_con_ixes
where
- tycon_str = _UNPK_ (nameOf (origName "gen_Ix_binds" tycon))
+ tycon_str = getOccString tycon
+ tycon_loc = getSrcLoc tycon
--------------------------------------------------------------
enum_ixes = enum_range `AndMonoBinds`
enum_index `AndMonoBinds` enum_inRange
enum_range
- = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] $
- untag_Expr tycon [(a_PN, ah_PN)] $
- untag_Expr tycon [(b_PN, bh_PN)] $
- HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
+ = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [a_Pat, b_Pat]] [] $
+ untag_Expr tycon [(a_RDR, ah_RDR)] $
+ untag_Expr tycon [(b_RDR, bh_RDR)] $
+ HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
HsPar (enum_from_to_Expr
- (mk_easy_App mkInt_PN [ah_PN])
- (mk_easy_App mkInt_PN [bh_PN]))
+ (mk_easy_App mkInt_RDR [ah_RDR])
+ (mk_easy_App mkInt_RDR [bh_RDR]))
enum_index
- = mk_easy_FunMonoBind index_PN [AsPatIn c_PN (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
- HsIf (HsPar (mk_easy_App inRange_PN [c_PN, d_PN])) (
- untag_Expr tycon [(a_PN, ah_PN)] (
- untag_Expr tycon [(d_PN, dh_PN)] (
+ = mk_easy_FunMonoBind tycon_loc index_RDR [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
+ HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
+ untag_Expr tycon [(a_RDR, ah_RDR)] (
+ untag_Expr tycon [(d_RDR, dh_RDR)] (
let
- grhs = [OtherwiseGRHS (mk_easy_App mkInt_PN [c_PN]) mkGeneratedSrcLoc]
+ grhs = [OtherwiseGRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc]
in
HsCase
- (HsPar (OpApp (HsVar dh_PN) (HsVar minusH_PN) (HsVar ah_PN)))
- [PatMatch (VarPatIn c_PN)
+ (HsPar (OpApp (HsVar dh_RDR) (HsVar minusH_RDR) (HsVar ah_RDR)))
+ [PatMatch (VarPatIn c_RDR)
(GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
- mkGeneratedSrcLoc
+ tycon_loc
))
) {-else-} (
- HsApp (HsVar error_PN) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
+ HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
)
- mkGeneratedSrcLoc)
+ tycon_loc)
enum_inRange
- = mk_easy_FunMonoBind inRange_PN [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
- untag_Expr tycon [(a_PN, ah_PN)] (
- untag_Expr tycon [(b_PN, bh_PN)] (
- untag_Expr tycon [(c_PN, ch_PN)] (
- HsIf (HsPar (OpApp (HsVar ch_PN) (HsVar geH_PN) (HsVar ah_PN))) (
- (OpApp (HsVar ch_PN) (HsVar leH_PN) (HsVar bh_PN))
+ = mk_easy_FunMonoBind tycon_loc inRange_RDR [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
+ untag_Expr tycon [(a_RDR, ah_RDR)] (
+ untag_Expr tycon [(b_RDR, bh_RDR)] (
+ untag_Expr tycon [(c_RDR, ch_RDR)] (
+ HsIf (HsPar (OpApp (HsVar ch_RDR) (HsVar geH_RDR) (HsVar ah_RDR))) (
+ (OpApp (HsVar ch_RDR) (HsVar leH_RDR) (HsVar bh_RDR))
) {-else-} (
false_Expr
- ) mkGeneratedSrcLoc))))
+ ) tycon_loc))))
--------------------------------------------------------------
single_con_ixes = single_con_range `AndMonoBinds`
dc
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
+ data_con_RDR = qual_orig_name data_con
+ con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
+ con_expr xs = mk_easy_App data_con_RDR xs
- as_needed = take con_arity as_PNs
- bs_needed = take con_arity bs_PNs
- cs_needed = take con_arity cs_PNs
+ as_needed = take con_arity as_RDRs
+ bs_needed = take con_arity bs_RDRs
+ cs_needed = take con_arity cs_RDRs
--------------------------------------------------------------
single_con_range
- = mk_easy_FunMonoBind range_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] (
+ = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] (
ListComp (con_expr cs_needed) (zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed)
)
where
mk_qual a b c = GeneratorQual (VarPatIn c)
- (HsApp (HsVar range_PN) (ExplicitTuple [HsVar a, HsVar b]))
+ (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b]))
----------------
single_con_index
- = mk_easy_FunMonoBind index_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
+ = mk_easy_FunMonoBind tycon_loc index_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
where
mk_index multiply_by (l, u, i)
=OpApp (
- (HsApp (HsApp (HsVar index_PN) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
- ) (HsVar plus_PN) (
+ (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
+ ) (HsVar plus_RDR) (
OpApp (
- (HsApp (HsVar rangeSize_PN) (ExplicitTuple [HsVar l, HsVar u]))
- ) (HsVar times_PN) multiply_by
+ (HsApp (HsVar rangeSize_RDR) (ExplicitTuple [HsVar l, HsVar u]))
+ ) (HsVar times_RDR) multiply_by
)
range_size
- = mk_easy_FunMonoBind rangeSize_PN [TuplePatIn [a_Pat, b_Pat]] [] (
+ = mk_easy_FunMonoBind tycon_loc rangeSize_RDR [TuplePatIn [a_Pat, b_Pat]] [] (
OpApp (
- (HsApp (HsApp (HsVar index_PN) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
- ) (HsVar plus_PN) (HsLit (HsInt 1)))
+ (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
+ ) (HsVar plus_RDR) (HsLit (HsInt 1)))
------------------
single_con_inRange
- = mk_easy_FunMonoBind inRange_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [] (
+ = mk_easy_FunMonoBind tycon_loc inRange_RDR
+ [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed]
+ [] (
foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
where
- in_range a b c = HsApp (HsApp (HsVar inRange_PN) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
+ in_range a b c = HsApp (HsApp (HsVar inRange_RDR) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
\end{code}
%************************************************************************
Ignoring all the infix-ery mumbo jumbo (ToDo)
\begin{code}
-gen_Read_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
+gen_Read_binds :: TyCon -> RdrNameMonoBinds
-gen_Read_binds fixities tycon
+gen_Read_binds tycon
= reads_prec `AndMonoBinds` read_list
where
+ tycon_loc = getSrcLoc tycon
-----------------------------------------------------------------------
- read_list = mk_easy_FunMonoBind readList_PN [] []
- (HsApp (HsVar readList___PN) (HsPar (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0)))))
+ read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
+ (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
-----------------------------------------------------------------------
reads_prec
= let
read_con_comprehensions
= map read_con (tyConDataCons tycon)
in
- mk_easy_FunMonoBind readsPrec_PN [a_Pat, b_Pat] [] (
+ mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] (
foldl1 append_Expr read_con_comprehensions
)
where
read_con data_con -- note: "b" is the string being "read"
= let
- data_con_PN = qual_orig_name data_con
- data_con_str= nameOf (origName "gen_Read_binds" data_con)
+ data_con_RDR = qual_orig_name data_con
+ data_con_str= occNameString (getOccName 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
+ as_needed = take con_arity as_RDRs
+ bs_needed = take con_arity bs_RDRs
+ con_expr = mk_easy_App data_con_RDR as_needed
nullary_con = isNullaryDataCon data_con
con_qual
= GeneratorQual
(TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
- (HsApp (HsVar lex_PN) c_Expr)
+ (HsApp (HsVar lex_RDR) c_Expr)
field_quals = snd (mapAccumL mk_qual d_Expr (zipEqual "as_needed" as_needed bs_needed))
= if nullary_con then -- must be False (parens are surely optional)
false_Expr
else -- parens depend on precedence...
- HsPar (OpApp a_Expr (HsVar gt_PN) (HsLit (HsInt 9)))
+ HsPar (OpApp a_Expr (HsVar gt_RDR) (HsLit (HsInt 9)))
in
HsApp (
readParen_Expr read_paren_arg $ HsPar $
- HsLam (mk_easy_Match [c_Pat] [] (
+ HsLam (mk_easy_Match tycon_loc [c_Pat] [] (
ListComp (ExplicitTuple [con_expr,
if null bs_needed then d_Expr else HsVar (last bs_needed)])
(con_qual : field_quals)))
- ) (HsVar b_PN)
+ ) (HsVar b_RDR)
where
mk_qual draw_from (con_field, str_left)
= (HsVar str_left, -- what to draw from down the line...
GeneratorQual
(TuplePatIn [VarPatIn con_field, VarPatIn str_left])
- (HsApp (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 10))) draw_from))
+ (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from))
\end{code}
%************************************************************************
Ignoring all the infix-ery mumbo jumbo (ToDo)
\begin{code}
-gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
+gen_Show_binds :: TyCon -> RdrNameMonoBinds
-gen_Show_binds fixities tycon
+gen_Show_binds tycon
= shows_prec `AndMonoBinds` show_list
where
+ tycon_loc = getSrcLoc tycon
-----------------------------------------------------------------------
- show_list = mk_easy_FunMonoBind showList_PN [] []
- (HsApp (HsVar showList___PN) (HsPar (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0)))))
+ show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
+ (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
-----------------------------------------------------------------------
shows_prec
- = mk_FunMonoBind showsPrec_PN (map pats_etc (tyConDataCons tycon))
+ = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
where
pats_etc data_con
= let
- data_con_PN = qual_orig_name data_con
+ data_con_RDR = qual_orig_name data_con
con_arity = dataConNumFields data_con
- bs_needed = take con_arity bs_PNs
- con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
+ bs_needed = take con_arity bs_RDRs
+ con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
nullary_con = isNullaryDataCon data_con
show_con
- = let (OrigName mod nm) = origName "gen_Show_binds" data_con
+ = let nm = occNameString (getOccName data_con)
space_maybe = if nullary_con then _NIL_ else SLIT(" ")
in
- HsApp (HsVar showString_PN) (HsLit (HsString (nm _APPEND_ space_maybe)))
+ HsApp (HsVar showString_RDR) (HsLit (HsString (nm _APPEND_ space_maybe)))
show_thingies = show_con : (spacified real_show_thingies)
real_show_thingies
- = [ HsApp (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 10))) (HsVar b)
+ = [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
| b <- bs_needed ]
in
if nullary_con then -- skip the showParen junk...
([a_Pat, con_pat], show_con)
else
([a_Pat, con_pat],
- showParen_Expr (HsPar (OpApp a_Expr (HsVar ge_PN) (HsLit (HsInt 10))))
+ showParen_Expr (HsPar (OpApp a_Expr (HsVar ge_RDR) (HsLit (HsInt 10))))
(HsPar (nested_compose_Expr show_thingies)))
where
spacified [] = []
spacified [x] = [x]
- spacified (x:xs) = (x : (HsVar showSpace_PN) : spacified xs)
+ spacified (x:xs) = (x : (HsVar showSpace_RDR) : spacified xs)
\end{code}
%************************************************************************
TagThingWanted)
-> RdrNameMonoBinds
-gen_tag_n_con_monobind (pn, tycon, GenCon2Tag)
- = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
+gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
+ = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
where
mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
= ASSERT(isDataCon var)
([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
where
- pat = ConPatIn var_PN (nOfThem (dataConNumFields var) WildPatIn)
- var_PN = qual_orig_name var
+ pat = ConPatIn var_RDR (nOfThem (dataConNumFields var) WildPatIn)
+ var_RDR = qual_orig_name var
-gen_tag_n_con_monobind (pn, tycon, GenTag2Con)
- = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
+gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
+ = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
where
mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
mk_stuff var
= ASSERT(isDataCon var)
- ([lit_pat], HsVar var_PN)
+ ([lit_pat], HsVar var_RDR)
where
- lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
- var_PN = qual_orig_name var
+ lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
+ var_RDR = qual_orig_name var
-gen_tag_n_con_monobind (pn, tycon, GenMaxTag)
- = mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag)))
+gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
+ = mk_easy_FunMonoBind (getSrcLoc tycon)
+ rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
where
max_tag = case (tyConDataCons tycon) of
data_cons -> toInteger ((length data_cons) - fIRST_TAG)
\end{verbatim}
\begin{code}
-mk_easy_FunMonoBind :: RdrName -> [RdrNamePat]
+mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
-> [RdrNameMonoBinds] -> RdrNameHsExpr
-> RdrNameMonoBinds
-mk_easy_FunMonoBind fun pats binds expr
- = FunMonoBind fun False{-not infix-} [mk_easy_Match pats binds expr] mkGeneratedSrcLoc
+mk_easy_FunMonoBind loc fun pats binds expr
+ = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
-mk_easy_Match pats binds expr
- = mk_match pats expr (mkbind binds)
+mk_easy_Match loc pats binds expr
+ = mk_match loc pats expr (mkbind binds)
where
mkbind [] = EmptyBinds
mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs))
-- "recursive" MonoBinds, and it is its job to sort things out
-- from there.
-mk_FunMonoBind :: RdrName
+mk_FunMonoBind :: SrcLoc -> RdrName
-> [([RdrNamePat], RdrNameHsExpr)]
-> RdrNameMonoBinds
-mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind"
-mk_FunMonoBind fun pats_and_exprs
+mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
+mk_FunMonoBind loc fun pats_and_exprs
= FunMonoBind fun False{-not infix-}
- [ mk_match p e EmptyBinds | (p,e) <-pats_and_exprs ]
- mkGeneratedSrcLoc
+ [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
+ loc
-mk_match pats expr binds
+mk_match loc pats expr binds
= foldr PatMatch
- (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] binds))
+ (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr loc] binds))
(map paren pats)
where
paren p@(VarPatIn _) = p
mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
\end{code}
+ToDo: Better SrcLocs.
+
\begin{code}
compare_Case, cmp_eq_Expr ::
RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
-> RdrNameHsExpr -> RdrNameHsExpr
-> RdrNameHsExpr
-compare_Case = compare_gen_Case compare_PN
-cmp_eq_Expr = compare_gen_Case cmp_eq_PN
+compare_Case = compare_gen_Case compare_RDR
+cmp_eq_Expr = compare_gen_Case cmp_eq_RDR
compare_gen_Case fun lt eq gt a b
= HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
- [PatMatch (ConPatIn ltTag_PN [])
+ [PatMatch (ConPatIn ltTag_RDR [])
(GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
- PatMatch (ConPatIn eqTag_PN [])
+ PatMatch (ConPatIn eqTag_RDR [])
(GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)),
- PatMatch (ConPatIn gtTag_PN [])
+ PatMatch (ConPatIn gtTag_RDR [])
(GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))]
mkGeneratedSrcLoc
careful_compare_Case ty lt eq gt a b
= if not (isPrimType ty) then
- compare_gen_Case compare_PN lt eq gt a b
+ compare_gen_Case compare_RDR lt eq gt a b
else -- we have to do something special for primitive things...
HsIf (HsPar (OpApp a (HsVar relevant_eq_op) b))
res = [id | (ty',id) <- tyids, eqTy ty ty']
eq_op_tbl =
- [(charPrimTy, eqH_Char_PN)
- ,(intPrimTy, eqH_Int_PN)
- ,(wordPrimTy, eqH_Word_PN)
- ,(addrPrimTy, eqH_Addr_PN)
- ,(floatPrimTy, eqH_Float_PN)
- ,(doublePrimTy, eqH_Double_PN)
+ [(charPrimTy, eqH_Char_RDR)
+ ,(intPrimTy, eqH_Int_RDR)
+ ,(wordPrimTy, eqH_Word_RDR)
+ ,(addrPrimTy, eqH_Addr_RDR)
+ ,(floatPrimTy, eqH_Float_RDR)
+ ,(doublePrimTy, eqH_Double_RDR)
]
lt_op_tbl =
- [(charPrimTy, ltH_Char_PN)
- ,(intPrimTy, ltH_Int_PN)
- ,(wordPrimTy, ltH_Word_PN)
- ,(addrPrimTy, ltH_Addr_PN)
- ,(floatPrimTy, ltH_Float_PN)
- ,(doublePrimTy, ltH_Double_PN)
+ [(charPrimTy, ltH_Char_RDR)
+ ,(intPrimTy, ltH_Int_RDR)
+ ,(wordPrimTy, ltH_Word_RDR)
+ ,(addrPrimTy, ltH_Addr_RDR)
+ ,(floatPrimTy, ltH_Float_RDR)
+ ,(doublePrimTy, ltH_Double_RDR)
]
-----------------------------------------------------------------------
and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
-and_Expr a b = OpApp a (HsVar and_PN) b
-append_Expr a b = OpApp a (HsVar append_PN) b
+and_Expr a b = OpApp a (HsVar and_RDR) b
+append_Expr a b = OpApp a (HsVar append_RDR) b
-----------------------------------------------------------------------
eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
eq_Expr ty a b
= if not (isPrimType ty) then
- OpApp a (HsVar eq_PN) b
+ OpApp a (HsVar eq_RDR) b
else -- we have to do something special for primitive things...
OpApp a (HsVar relevant_eq_op) b
where
:: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
-> RdrNameHsExpr
-enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_PN) f) t2
-enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_PN) f) t) t2
+enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
+enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
showParen_Expr, readParen_Expr
:: RdrNameHsExpr -> RdrNameHsExpr
-> RdrNameHsExpr
-showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_PN) e1) e2
-readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_PN) e1) e2
+showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
+readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
nested_compose_Expr [e] = parenify e
nested_compose_Expr (e:es)
- = HsApp (HsApp (HsVar compose_PN) (parenify e)) (nested_compose_Expr es)
+ = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
parenify e@(HsVar _) = e
parenify e = HsPar e
\end{code}
\begin{code}
-qual_orig_name n = case (origName "qual_orig_name" n) of { OrigName m n -> Qual m n }
-
-a_PN = Unqual SLIT("a")
-b_PN = Unqual SLIT("b")
-c_PN = Unqual SLIT("c")
-d_PN = Unqual SLIT("d")
-ah_PN = Unqual SLIT("a#")
-bh_PN = Unqual SLIT("b#")
-ch_PN = Unqual SLIT("c#")
-dh_PN = Unqual SLIT("d#")
-cmp_eq_PN = Unqual SLIT("cmp_eq")
-rangeSize_PN = Qual iX SLIT("rangeSize")
-
-as_PNs = [ Unqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
-bs_PNs = [ Unqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
-cs_PNs = [ Unqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
-
-eq_PN = preludeQual {-SLIT("Eq")-} SLIT("==")
-ne_PN = preludeQual {-SLIT("Eq")-} SLIT("/=")
-le_PN = preludeQual {-SLIT("Ord")-} SLIT("<=")
-lt_PN = preludeQual {-SLIT("Ord")-} SLIT("<")
-ge_PN = preludeQual {-SLIT("Ord")-} SLIT(">=")
-gt_PN = preludeQual {-SLIT("Ord")-} SLIT(">")
-max_PN = preludeQual {-SLIT("Ord")-} SLIT("max")
-min_PN = preludeQual {-SLIT("Ord")-} SLIT("min")
-compare_PN = preludeQual {-SLIT("Ord")-} SLIT("compare")
-minBound_PN = preludeQual {-SLIT("Bounded")-} SLIT("minBound")
-maxBound_PN = preludeQual {-SLIT("Bounded")-} SLIT("maxBound")
-enumFrom_PN = preludeQual {-SLIT("Enum")-} SLIT("enumFrom")
-enumFromTo_PN = preludeQual {-SLIT("Enum")-} SLIT("enumFromTo")
-enumFromThen_PN = preludeQual {-SLIT("Enum")-} SLIT("enumFromThen")
-enumFromThenTo_PN= preludeQual {-SLIT("Enum")-} SLIT("enumFromThenTo")
-range_PN = Qual iX SLIT("range")
-index_PN = Qual iX SLIT("index")
-inRange_PN = Qual iX SLIT("inRange")
-readsPrec_PN = preludeQual {-SLIT("Read")-} SLIT("readsPrec")
-readList_PN = preludeQual {-SLIT("Read")-} SLIT("readList")
-showsPrec_PN = preludeQual {-SLIT("Show")-} SLIT("showsPrec")
-showList_PN = preludeQual {-SLIT("Show")-} SLIT("showList")
-plus_PN = preludeQual {-SLIT("Num")-} SLIT("+")
-times_PN = preludeQual {-SLIT("Num")-} SLIT("*")
-ltTag_PN = preludeQual SLIT("LT")
-eqTag_PN = preludeQual SLIT("EQ")
-gtTag_PN = preludeQual SLIT("GT")
-
-eqH_Char_PN = prelude_primop CharEqOp
-ltH_Char_PN = prelude_primop CharLtOp
-eqH_Word_PN = prelude_primop WordEqOp
-ltH_Word_PN = prelude_primop WordLtOp
-eqH_Addr_PN = prelude_primop AddrEqOp
-ltH_Addr_PN = prelude_primop AddrLtOp
-eqH_Float_PN = prelude_primop FloatEqOp
-ltH_Float_PN = prelude_primop FloatLtOp
-eqH_Double_PN = prelude_primop DoubleEqOp
-ltH_Double_PN = prelude_primop DoubleLtOp
-eqH_Int_PN = prelude_primop IntEqOp
-ltH_Int_PN = prelude_primop IntLtOp
-geH_PN = prelude_primop IntGeOp
-leH_PN = prelude_primop IntLeOp
-minusH_PN = prelude_primop IntSubOp
-
-prelude_primop o = case (origName "prelude_primop" (primOpId o)) of { OrigName m n -> Qual m n }
-
-false_PN = preludeQual SLIT("False")
-true_PN = preludeQual SLIT("True")
-and_PN = preludeQual SLIT("&&")
-not_PN = preludeQual SLIT("not")
-append_PN = preludeQual SLIT("++")
-map_PN = preludeQual SLIT("map")
-compose_PN = preludeQual SLIT(".")
-mkInt_PN = preludeQual SLIT("I#")
-error_PN = preludeQual SLIT("error")
-showString_PN = preludeQual SLIT("showString")
-showParen_PN = preludeQual SLIT("showParen")
-readParen_PN = preludeQual SLIT("readParen")
-lex_PN = Qual gHC__ SLIT("lex")
-showSpace_PN = Qual gHC__ SLIT("showSpace")
-showList___PN = Qual gHC__ SLIT("showList__")
-readList___PN = Qual gHC__ SLIT("readList__")
-
-a_Expr = HsVar a_PN
-b_Expr = HsVar b_PN
-c_Expr = HsVar c_PN
-d_Expr = HsVar d_PN
-ltTag_Expr = HsVar ltTag_PN
-eqTag_Expr = HsVar eqTag_PN
-gtTag_Expr = HsVar gtTag_PN
-false_Expr = HsVar false_PN
-true_Expr = HsVar true_PN
-
-con2tag_Expr tycon = HsVar (con2tag_PN tycon)
-
-a_Pat = VarPatIn a_PN
-b_Pat = VarPatIn b_PN
-c_Pat = VarPatIn c_PN
-d_Pat = VarPatIn d_PN
-
-con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> RdrName
-
-con2tag_PN tycon
- = let (OrigName mod nm) = origName "con2tag_PN" tycon
- con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
+qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n }
+
+a_RDR = varUnqual SLIT("a")
+b_RDR = varUnqual SLIT("b")
+c_RDR = varUnqual SLIT("c")
+d_RDR = varUnqual SLIT("d")
+ah_RDR = varUnqual SLIT("a#")
+bh_RDR = varUnqual SLIT("b#")
+ch_RDR = varUnqual SLIT("c#")
+dh_RDR = varUnqual SLIT("d#")
+cmp_eq_RDR = varUnqual SLIT("cmp_eq")
+rangeSize_RDR = varUnqual SLIT("rangeSize")
+
+as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
+bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
+cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
+
+a_Expr = HsVar a_RDR
+b_Expr = HsVar b_RDR
+c_Expr = HsVar c_RDR
+d_Expr = HsVar d_RDR
+ltTag_Expr = HsVar ltTag_RDR
+eqTag_Expr = HsVar eqTag_RDR
+gtTag_Expr = HsVar gtTag_RDR
+false_Expr = HsVar false_RDR
+true_Expr = HsVar true_RDR
+
+con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
+
+a_Pat = VarPatIn a_RDR
+b_Pat = VarPatIn b_RDR
+c_Pat = VarPatIn c_RDR
+d_Pat = VarPatIn d_RDR
+
+con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
+
+con2tag_RDR tycon
+ = let (mod, nm) = modAndOcc tycon
+ con2tag = SLIT("con2tag_") _APPEND_ occNameString nm _APPEND_ SLIT("#")
in
- Qual mod con2tag
+ varQual (mod, con2tag)
-tag2con_PN tycon
- = let (OrigName mod nm) = origName "tag2con_PN" tycon
- tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
+tag2con_RDR tycon
+ = let (mod, nm) = modAndOcc tycon
+ tag2con = SLIT("tag2con_") _APPEND_ occNameString nm _APPEND_ SLIT("#")
in
- Qual mod tag2con
+ varQual (mod, tag2con)
-maxtag_PN tycon
- = let (OrigName mod nm) = origName "maxtag_PN" tycon
- maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
+maxtag_RDR tycon
+ = let (mod, nm) = modAndOcc tycon
+ maxtag = SLIT("maxtag_") _APPEND_ occNameString nm _APPEND_ SLIT("#")
in
- Qual mod maxtag
+ varQual (mod, maxtag)
\end{code}
SYN_IE(TcMonoBinds), SYN_IE(TcHsBinds), SYN_IE(TcBind), SYN_IE(TcPat),
SYN_IE(TcExpr), SYN_IE(TcGRHSsAndBinds), SYN_IE(TcGRHS), SYN_IE(TcMatch),
SYN_IE(TcQual), SYN_IE(TcStmt), SYN_IE(TcArithSeqInfo), SYN_IE(TcRecordBinds),
- SYN_IE(TcHsModule),
+ SYN_IE(TcHsModule), SYN_IE(TcCoreExpr),
SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedBind),
SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedPat),
-- others:
import Name ( Name{--O only-} )
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import TcType ( SYN_IE(TcType), TcMaybe, SYN_IE(TcTyVar),
zonkTcTypeToType, zonkTcTyVarToTyVar
)
import TyVar ( GenTyVar {- instances -},
SYN_IE(TyVarEnv), growTyVarEnvList, emptyTyVarSet )
import TysPrim ( voidTy )
+import CoreSyn ( GenCoreExpr )
import Unique ( Unique ) -- instances
import UniqFM
import PprStyle
type TcRecordBinds s = HsRecordBinds (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
type TcHsModule s = HsModule (TcTyVar s) UVar (TcIdOcc s) (TcPat s)
+type TcCoreExpr s = GenCoreExpr (TcIdOcc s) (TcIdOcc s) (TcTyVar s) UVar
+
type TypecheckedPat = OutPat TyVar UVar Id
type TypecheckedMonoBinds = MonoBinds TyVar UVar Id TypecheckedPat
type TypecheckedHsBinds = HsBinds TyVar UVar Id TypecheckedPat
zonkExpr te ve expr `thenNF_Tc` \ new_expr ->
returnNF_Tc (VarMonoBind new_var new_expr, [new_var])
+zonkMonoBinds te ve (CoreMonoBind var core_expr)
+ = zonkIdBndr te var `thenNF_Tc` \ new_var ->
+ returnNF_Tc (CoreMonoBind new_var core_expr, [new_var])
+
zonkMonoBinds te ve (FunMonoBind var inf ms locn)
= zonkIdBndr te var `thenNF_Tc` \ new_var ->
mapNF_Tc (zonkMatch te ve) ms `thenNF_Tc` \ new_ms ->
IMP_Ubiq()
-import TcMonad hiding ( rnMtoTcM )
-import TcMonoType ( tcPolyType )
+import TcMonad
+import TcMonoType ( tcHsType )
+import TcEnv ( tcLookupGlobalValue, tcExtendTyVarEnv, tcExtendGlobalValEnv )
+import TcKind ( TcKind, kindToTcKind )
-import HsSyn ( Sig(..), PolyType )
-import RnHsSyn ( RenamedSig(..), RnName(..) )
+import HsSyn ( IfaceSig(..), HsDecl(..), TyDecl, ClassDecl, InstDecl, DefaultDecl, HsBinds,
+ Fake, InPat, HsType )
+import RnHsSyn ( RenamedHsDecl(..) )
+import HsCore
+import HsDecls ( HsIdInfo(..) )
+import CoreSyn
+import CoreUnfold
+import MagicUFs ( MagicUnfoldingFun )
+import SpecEnv ( SpecEnv )
+import PrimOp ( PrimOp(..) )
-import CmdLineOpts ( opt_CompilingGhcInternals )
-import Id ( mkImported )
---import Name ( Name(..) )
+import Id ( GenId, mkImported, mkUserId, isPrimitiveId_maybe )
+import TyVar ( mkTyVar )
+import Name ( Name )
+import PragmaInfo ( PragmaInfo(..) )
import Maybes ( maybeToBool )
import Pretty
-import Util ( panic )
-
-
---import TcPragmas ( tcGenPragmas )
-import IdInfo ( noIdInfo )
-tcGenPragmas ty id ps = returnNF_Tc noIdInfo
+import PprStyle ( PprStyle(..) )
+import Util ( zipWithEqual, panic, pprTrace, pprPanic )
+import IdInfo
\end{code}
Ultimately, type signatures in interfaces will have pragmatic
signatures.
\begin{code}
-tcInterfaceSigs :: [RenamedSig] -> TcM s [Id]
+tcInterfaceSigs :: [RenamedHsDecl] -> TcM s [Id]
+ -- Ignore non-sig-decls in these decls
+
+tcInterfaceSigs (SigD (IfaceSig name ty id_infos src_loc) : rest)
+ = tcAddSrcLoc src_loc $
+ tcHsType ty `thenTc` \ sigma_ty ->
+ tcIdInfo name noIdInfo id_infos `thenTc` \ id_info' ->
+ let
+ sig_id = mkImported name sigma_ty id_info'
+ in
+ tcInterfaceSigs rest `thenTc` \ sig_ids ->
+ returnTc (sig_id : sig_ids)
+
+tcInterfaceSigs (other_decl : rest) = tcInterfaceSigs rest
tcInterfaceSigs [] = returnTc []
+\end{code}
+
+Inside here we use only the Global environment, even for locally bound variables.
+Why? Because we know all the types and want to bind them to real Ids.
+
+\begin{code}
+tcIdInfo name info [] = returnTc info
+
+tcIdInfo name info (HsArity arity : rest)
+ = tcIdInfo name (info `addArityInfo` arity) rest
+
+tcIdInfo name info (HsUpdate upd : rest)
+ = tcIdInfo name (info `addUpdateInfo` upd) rest
+
+tcIdInfo name info (HsFBType fb : rest)
+ = tcIdInfo name (info `addFBTypeInfo` fb) rest
+
+tcIdInfo name info (HsArgUsage au : rest)
+ = tcIdInfo name (info `addArgUsageInfo` au) rest
+
+tcIdInfo name info (HsDeforest df : rest)
+ = tcIdInfo name (info `addDeforestInfo` df) rest
+
+tcIdInfo name info (HsUnfold expr : rest)
+ = tcUnfolding name expr `thenNF_Tc` \ unfold_info ->
+ tcIdInfo name (info `addUnfoldInfo` unfold_info) rest
+
+tcIdInfo name info (HsStrictness strict : rest)
+ = tcStrictness strict `thenTc` \ strict_info ->
+ tcIdInfo name (info `addStrictnessInfo` strict_info) rest
+\end{code}
+
+\begin{code}
+tcStrictness (StrictnessInfo demands (Just worker))
+ = tcLookupGlobalValue worker `thenNF_Tc` \ worker_id ->
+ returnTc (StrictnessInfo demands (Just worker_id))
+
+-- Boring to write these out, but the result type differe from the arg type...
+tcStrictness (StrictnessInfo demands Nothing) = returnTc (StrictnessInfo demands Nothing)
+tcStrictness NoStrictnessInfo = returnTc NoStrictnessInfo
+tcStrictness BottomGuaranteed = returnTc BottomGuaranteed
+\end{code}
+
+For unfoldings we try to do the job lazily, so that we never type check
+an unfolding that isn't going to be looked at.
+
+\begin{code}
+tcUnfolding name core_expr
+ = forkNF_Tc (
+ recoverNF_Tc (returnNF_Tc no_unfolding) (
+ tcCoreExpr core_expr `thenTc` \ core_expr' ->
+ returnTc (mkUnfolding False core_expr')
+ ))
+ where
+ no_unfolding = pprTrace "tcUnfolding failed:" (ppr PprDebug name) NoUnfolding
+\end{code}
+
+UfCore expressions.
+
+\begin{code}
+tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
+
+tcCoreExpr (UfVar name)
+ = tcLookupGlobalValue name `thenNF_Tc` \ id ->
+ returnTc (Var id)
+
+tcCoreExpr (UfLit lit) = returnTc (Lit lit)
+
+tcCoreExpr (UfCon con args)
+ = tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
+ mapTc tcCoreArg args `thenTc` \ args' ->
+ returnTc (Con con_id args')
+
+tcCoreExpr (UfPrim prim args)
+ = tcCorePrim prim `thenTc` \ primop ->
+ mapTc tcCoreArg args `thenTc` \ args' ->
+ returnTc (Prim primop args')
+
+tcCoreExpr (UfApp fun arg)
+ = tcCoreExpr fun `thenTc` \ fun' ->
+ tcCoreArg arg `thenTc` \ arg' ->
+ returnTc (App fun' arg')
+
+tcCoreExpr (UfCase scrut alts)
+ = tcCoreExpr scrut `thenTc` \ scrut' ->
+ tcCoreAlts alts `thenTc` \ alts' ->
+ returnTc (Case scrut' alts')
-tcInterfaceSigs (Sig name ty pragmas src_loc : sigs)
- | has_full_name
- = tcAddSrcLoc src_loc (
- tcPolyType ty `thenTc` \ sigma_ty ->
- fixTc ( \ rec_id ->
- tcGenPragmas (Just sigma_ty) rec_id pragmas
- `thenNF_Tc` \ id_info ->
- returnTc (mkImported full_name sigma_ty id_info)
- )) `thenTc` \ id ->
- tcInterfaceSigs sigs `thenTc` \ sigs' ->
- returnTc (id:sigs')
-
- | otherwise -- odd name...
- = case name of
- WiredInId _ | opt_CompilingGhcInternals
- -> tcInterfaceSigs sigs
- _ -> tcAddSrcLoc src_loc $
- failTc (ifaceSigNameErr name)
+tcCoreExpr (UfSCC cc expr)
+ = tcCoreExpr expr `thenTc` \ expr' ->
+ returnTc (SCC cc expr')
+
+tcCoreExpr(UfCoerce coercion ty body)
+ = tcCoercion coercion `thenTc` \ coercion' ->
+ tcHsType ty `thenTc` \ ty' ->
+ tcCoreExpr body `thenTc` \ body' ->
+ returnTc (Coerce coercion' ty' body')
+
+tcCoreExpr (UfLam bndr body)
+ = tcCoreLamBndr bndr $ \ bndr' ->
+ tcCoreExpr body `thenTc` \ body' ->
+ returnTc (Lam bndr' body')
+
+tcCoreExpr (UfLet (UfNonRec bndr rhs) body)
+ = tcCoreExpr rhs `thenTc` \ rhs' ->
+ tcCoreValBndr bndr $ \ bndr' ->
+ tcCoreExpr body `thenTc` \ body' ->
+ returnTc (Let (NonRec bndr' rhs') body')
+
+tcCoreExpr (UfLet (UfRec pairs) body)
+ = tcCoreValBndrs bndrs $ \ bndrs' ->
+ mapTc tcCoreExpr rhss `thenTc` \ rhss' ->
+ tcCoreExpr body `thenTc` \ body' ->
+ returnTc (Let (Rec (bndrs' `zip` rhss')) body')
where
- has_full_name = maybeToBool full_name_maybe
- (Just full_name) = full_name_maybe
- full_name_maybe = case name of
- RnName fn -> Just fn
- RnImplicit fn -> Just fn
- _ -> Nothing
-
-ifaceSigNameErr name sty
- = ppHang (ppStr "Bad name in an interface type signature (a Prelude name?)")
- 4 (ppr sty name)
+ (bndrs, rhss) = unzip pairs
\end{code}
+
+\begin{code}
+tcCoreLamBndr (UfValBinder name ty) thing_inside
+ = tcHsType ty `thenTc` \ ty' ->
+ let
+ id = mkUserId name ty' NoPragmaInfo
+ in
+ tcExtendGlobalValEnv [id] $
+ thing_inside (ValBinder id)
+
+tcCoreLamBndr (UfTyBinder name kind) thing_inside
+ = let
+ tyvar = mkTyVar name kind
+ in
+ tcExtendTyVarEnv [name] [(kindToTcKind kind, tyvar)] $
+ thing_inside (TyBinder tyvar)
+
+tcCoreLamBndr (UfUsageBinder name) thing_inside
+ = error "tcCoreLamBndr: usage"
+
+tcCoreValBndr (UfValBinder name ty) thing_inside
+ = tcHsType ty `thenTc` \ ty' ->
+ let
+ id = mkUserId name ty' NoPragmaInfo
+ in
+ tcExtendGlobalValEnv [id] $
+ thing_inside id
+
+tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders
+ = mapTc tcHsType tys `thenTc` \ tys' ->
+ let
+ ids = zipWithEqual "tcCoreValBndr" mk_id names tys'
+ mk_id name ty' = mkUserId name ty' NoPragmaInfo
+ in
+ tcExtendGlobalValEnv ids $
+ thing_inside ids
+ where
+ names = map (\ (UfValBinder name _) -> name) bndrs
+ tys = map (\ (UfValBinder _ ty) -> ty) bndrs
+\end{code}
+
+\begin{code}
+tcCoreArg (UfVarArg v) = tcLookupGlobalValue v `thenNF_Tc` \ v' -> returnTc (VarArg v')
+tcCoreArg (UfTyArg ty) = tcHsType ty `thenTc` \ ty' -> returnTc (TyArg ty')
+tcCoreArg (UfLitArg lit) = returnTc (LitArg lit)
+tcCoreArg (UfUsageArg u) = error "tcCoreArg: usage"
+
+tcCoreAlts (UfAlgAlts alts deflt)
+ = mapTc tc_alt alts `thenTc` \ alts' ->
+ tcCoreDefault deflt `thenTc` \ deflt' ->
+ returnTc (AlgAlts alts' deflt')
+ where
+ tc_alt (con, bndrs, rhs) = tcLookupGlobalValue con `thenNF_Tc` \ con' ->
+ tcCoreValBndrs bndrs $ \ bndrs' ->
+ tcCoreExpr rhs `thenTc` \ rhs' ->
+ returnTc (con', bndrs', rhs')
+
+tcCoreAlts (UfPrimAlts alts deflt)
+ = mapTc tc_alt alts `thenTc` \ alts' ->
+ tcCoreDefault deflt `thenTc` \ deflt' ->
+ returnTc (PrimAlts alts' deflt')
+ where
+ tc_alt (lit, rhs) = tcCoreExpr rhs `thenTc` \ rhs' ->
+ returnTc (lit, rhs')
+
+tcCoreDefault UfNoDefault = returnTc NoDefault
+tcCoreDefault (UfBindDefault bndr rhs) = tcCoreValBndr bndr $ \ bndr' ->
+ tcCoreExpr rhs `thenTc` \ rhs' ->
+ returnTc (BindDefault bndr' rhs')
+
+tcCoercion (UfIn n) = tcLookupGlobalValue n `thenNF_Tc` \ n' -> returnTc (CoerceIn n')
+tcCoercion (UfOut n) = tcLookupGlobalValue n `thenNF_Tc` \ n' -> returnTc (CoerceOut n')
+
+tcCorePrim (UfOtherOp op)
+ = tcLookupGlobalValue op `thenNF_Tc` \ op_id ->
+ case isPrimitiveId_maybe op_id of
+ Just prim_op -> returnTc prim_op
+ Nothing -> pprPanic "tcCorePrim" (ppr PprDebug op_id)
+
+tcCorePrim (UfCCallOp str casm gc arg_tys res_ty)
+ = mapTc tcHsType arg_tys `thenTc` \ arg_tys' ->
+ tcHsType res_ty `thenTc` \ res_ty' ->
+ returnTc (CCallOp str casm gc arg_tys' res_ty')
+\end{code}
+
IMP_Ubiq()
-import HsSyn ( InstDecl(..), FixityDecl, Sig(..),
+import HsSyn ( HsDecl(..), InstDecl(..), TyDecl, ClassDecl, DefaultDecl,
+ FixityDecl, IfaceSig, Sig(..),
SpecInstSig(..), HsBinds(..), Bind(..),
MonoBinds(..), GRHSsAndBinds, Match,
InPat(..), OutPat(..), HsExpr(..), HsLit(..),
Stmt, Qualifier, ArithSeqInfo, Fake,
- PolyType(..), MonoType )
+ HsType(..), HsTyVar )
import RnHsSyn ( SYN_IE(RenamedHsBinds), SYN_IE(RenamedMonoBinds),
- RenamedInstDecl(..), RenamedFixityDecl(..),
- RenamedSig(..), RenamedSpecInstSig(..),
- RnName(..){-incl instance Outputable-}
+ SYN_IE(RenamedInstDecl), SYN_IE(RenamedFixityDecl),
+ SYN_IE(RenamedSig), SYN_IE(RenamedSpecInstSig), SYN_IE(RenamedHsDecl)
)
import TcHsSyn ( TcIdOcc(..), SYN_IE(TcHsBinds),
SYN_IE(TcMonoBinds), SYN_IE(TcExpr), tcIdType,
mkHsDictLam, mkHsDictApp )
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
+import RnMonad ( SYN_IE(RnNameSupply) )
import GenSpecEtc ( checkSigTyVars )
import Inst ( Inst, InstOrigin(..), SYN_IE(InstanceMapper),
newDicts, newMethod, SYN_IE(LIE), emptyLIE, plusLIE )
import TcBinds ( tcPragmaSigs )
import TcDeriv ( tcDeriving )
-import TcEnv ( tcLookupClass, tcTyVarScope, newLocalId, tcExtendGlobalTyVars )
+import TcEnv ( tcLookupClass, newLocalId, tcExtendGlobalTyVars )
import SpecEnv ( SpecEnv )
import TcGRHSs ( tcGRHSsAndBinds )
import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
import TcKind ( TcKind, unifyKind )
import TcMatches ( tcMatchesFun )
-import TcMonoType ( tcContext, tcMonoTypeKind )
+import TcMonoType ( tcTyVarScope, tcContext, tcHsTypeKind )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( SYN_IE(TcType), SYN_IE(TcTyVar), SYN_IE(TcTyVarSet),
tcInstSigTyVars, tcInstType, tcInstTheta, tcInstTcType
opt_SpecialiseOverloaded
)
import Class ( GenClass, GenClassOp,
- isCcallishClass, classBigSig,
- classOps, classOpLocalType,
- classOpTagByString_maybe
+ classBigSig, classOps, classOpLocalType,
+ classOpTagByOccName_maybe
)
-import Id ( GenId, idType, isDefaultMethodId_maybe )
+import Id ( GenId, idType, isDefaultMethodId_maybe, isNullaryDataCon, dataConArgTys )
+import PrelInfo ( isCcallishClass )
import ListSetOps ( minusList )
import Maybes ( maybeToBool, expectJust )
-import Name ( getLocalName, origName, nameOf, Name{--O only-} )
+import Name ( getOccString, occNameString, moduleString, isLocallyDefined, OccName, Name{--O only-} )
import PrelVals ( nO_EXPLICIT_METHOD_ERROR_ID )
-import PrelMods ( pRELUDE )
import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
pprParendGenType
)
import PprStyle
+import SrcLoc ( SrcLoc )
import Pretty
-import RnUtils ( SYN_IE(RnEnv) )
import TyCon ( isSynTyCon, derivedFor )
import Type ( GenType(..), SYN_IE(ThetaType), mkTyVarTys,
splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
- getTyCon_maybe, maybeBoxedPrimType, splitRhoTy, eqTy
+ getTyCon_maybe, maybeAppTyCon,
+ maybeBoxedPrimType, maybeAppDataTyCon, splitRhoTy, eqTy
)
import TyVar ( GenTyVar, SYN_IE(GenTyVarSet), mkTyVarSet, unionTyVarSets )
+import TysPrim ( byteArrayPrimTyCon, mutableByteArrayPrimTyCon )
import TysWiredIn ( stringTy )
-import Unique ( Unique )
-import Util ( zipEqual, panic )
+import Unique ( Unique, cCallableClassKey, cReturnableClassKey )
+import Util ( zipEqual, panic, pprPanic, pprTrace )
\end{code}
Typechecking instance declarations is done in two passes. The first
\end{enumerate}
\begin{code}
-tcInstDecls1 :: Bag RenamedInstDecl
- -> [RenamedSpecInstSig]
+tcInstDecls1 :: [RenamedHsDecl]
-> Module -- module name for deriving
- -> RnEnv -- for renaming derivings
- -> [RenamedFixityDecl] -- fixities for deriving
+ -> RnNameSupply -- for renaming derivings
-> TcM s (Bag InstInfo,
RenamedHsBinds,
PprStyle -> Pretty)
-tcInstDecls1 inst_decls specinst_sigs mod_name rn_env fixities
+tcInstDecls1 decls mod_name rn_name_supply
= -- Do the ordinary instance declarations
- mapBagNF_Tc (tcInstDecl1 mod_name) inst_decls
- `thenNF_Tc` \ inst_info_bags ->
+ mapNF_Tc (tcInstDecl1 mod_name)
+ [inst_decl | InstD inst_decl <- decls] `thenNF_Tc` \ inst_info_bags ->
let
- decl_inst_info = concatBag inst_info_bags
+ decl_inst_info = unionManyBags inst_info_bags
in
-- Handle "derived" instances; note that we only do derivings
-- for things in this module; we ignore deriving decls from
-- interfaces! We pass fixities, because they may be used
-- in deriving Read and Show.
- tcDeriving mod_name rn_env decl_inst_info fixities
+ tcDeriving mod_name rn_name_supply decl_inst_info
`thenTc` \ (deriv_inst_info, deriv_binds, ddump_deriv) ->
let
- inst_info = deriv_inst_info `unionBags` decl_inst_info
- in
-{- LATER
- -- Handle specialise instance pragmas
- tcSpecInstSigs inst_info specinst_sigs
- `thenTc` \ spec_inst_info ->
--}
- let
- spec_inst_info = emptyBag -- For now
-
- full_inst_info = inst_info `unionBags` spec_inst_info
+ full_inst_info = deriv_inst_info `unionBags` decl_inst_info
in
returnTc (full_inst_info, deriv_binds, ddump_deriv)
-tcInstDecl1 :: FAST_STRING -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
+tcInstDecl1 :: Module -> RenamedInstDecl -> NF_TcM s (Bag InstInfo)
-tcInstDecl1 mod_name
- (InstDecl class_name
- poly_ty@(HsForAllTy tyvar_names context inst_ty)
- binds
- from_here inst_mod uprags pragmas src_loc)
+tcInstDecl1 mod_name (InstDecl poly_ty binds uprags (Just dfun_name) src_loc)
= -- Prime error recovery, set source location
recoverNF_Tc (returnNF_Tc emptyBag) $
tcAddSrcLoc src_loc $
-- Look things up
- tcLookupClass class_name `thenNF_Tc` \ (clas_kind, clas) ->
+ tcLookupClass class_name `thenTc` \ (clas_kind, clas) ->
- let
- de_rn (RnName n) = n
- in
-- Typecheck the context and instance type
- tcTyVarScope (map de_rn tyvar_names) (\ tyvars ->
+ tcTyVarScope tyvar_names (\ tyvars ->
tcContext context `thenTc` \ theta ->
- tcMonoTypeKind inst_ty `thenTc` \ (tau_kind, tau) ->
+ tcHsTypeKind inst_ty `thenTc` \ (tau_kind, tau) ->
unifyKind clas_kind tau_kind `thenTc_`
returnTc (tyvars, theta, tau)
) `thenTc` \ (inst_tyvars, inst_theta, inst_tau) ->
-- Check for respectable instance type
- scrutiniseInstanceType from_here clas inst_tau
+ scrutiniseInstanceType dfun_name clas inst_tau
`thenTc` \ (inst_tycon,arg_tys) ->
- -- Deal with the case where we are deriving
- -- and importing the same instance
- if (not from_here && (clas `derivedFor` inst_tycon)
- && all isTyVarTy arg_tys)
- then
- if mod_name == inst_mod
- then
- -- Imported instance came from this module;
- -- discard and derive fresh instance
- returnTc emptyBag
- else
- -- Imported instance declared in another module;
- -- report duplicate instance error
- failTc (derivingWhenInstanceImportedErr inst_mod clas inst_tycon)
- else
-
-- Make the dfun id and constant-method ids
- mkInstanceRelatedIds from_here src_loc inst_mod pragmas
- clas inst_tyvars inst_tau inst_theta uprags
- `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
+ mkInstanceRelatedIds dfun_name
+ clas inst_tyvars inst_tau inst_theta
+ `thenNF_Tc` \ (dfun_id, dfun_theta) ->
returnTc (unitBag (InstInfo clas inst_tyvars inst_tau inst_theta
- dfun_theta dfun_id const_meth_ids
- binds from_here inst_mod src_loc uprags))
+ dfun_theta dfun_id
+ binds src_loc uprags))
+ where
+ (tyvar_names, context, dict_ty) = case poly_ty of
+ HsForAllTy tvs cxt dict_ty -> (tvs, cxt, dict_ty)
+ other -> ([], [], poly_ty)
+ (class_name, inst_ty) = case dict_ty of
+ MonoDictTy cls ty -> (cls,ty)
+ other -> pprPanic "Malformed intance decl" (ppr PprDebug poly_ty)
\end{code}
tcInstDecl2 :: InstInfo
-> NF_TcM s (LIE s, TcHsBinds s)
-tcInstDecl2 (InstInfo _ _ _ _ _ _ _ _ False{-import-} _ _ _)
- = returnNF_Tc (emptyLIE, EmptyBinds)
-
tcInstDecl2 (InstInfo clas inst_tyvars inst_ty
inst_decl_theta dfun_theta
- dfun_id const_meth_ids monobinds
- True{-here-} inst_mod locn uprags)
+ dfun_id monobinds
+ locn uprags)
+ | not (isLocallyDefined dfun_id)
+ = returnNF_Tc (emptyLIE, EmptyBinds)
+
+ | otherwise
= -- Prime error recovery
recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyBinds)) $
tcAddSrcLoc locn $
= unionManyBags (this_dict : dfun_arg_dicts : meth_insts_s)
mk_method_expr
- = if opt_OmitDefaultInstanceMethods then
- makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty' clas inst_mod
- else
- makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty' this_dict_id
+ = makeInstanceDeclDefaultMethodExpr locn clas meth_ids defm_ids inst_ty' this_dict_id
in
tcExtendGlobalTyVars inst_tyvars_set' (
processInstBinds clas mk_method_expr avail_insts meth_ids monobinds
= AbsBinds
inst_tyvars'
dfun_arg_dicts_ids
- ((this_dict_id, RealId dfun_id)
- : (meth_ids `zip` map RealId const_meth_ids))
- -- NB: const_meth_ids will often be empty
+ [(this_dict_id, RealId dfun_id)]
super_binds
(RecBind dict_and_method_binds)
\begin{code}
makeInstanceDeclDefaultMethodExpr
- :: InstOrigin s
+ :: SrcLoc
+ -> Class
-> [TcIdOcc s]
-> [Id]
-> TcType s
-> Int
-> NF_TcM s (TcExpr s)
-makeInstanceDeclDefaultMethodExpr origin meth_ids defm_ids inst_ty this_dict tag
- =
- -- def_op_id = defm_id inst_ty this_dict
+makeInstanceDeclDefaultMethodExpr src_loc clas meth_ids defm_ids inst_ty this_dict tag
+ | not defm_is_err -- Not sure that the default method is just error message
+ = -- def_op_id = defm_id inst_ty this_dict
returnNF_Tc (mkHsDictApp (mkHsTyApp (HsVar (RealId defm_id)) [inst_ty]) [this_dict])
- where
- idx = tag - 1
- meth_id = meth_ids !! idx
- defm_id = defm_ids !! idx
-
-makeInstanceDeclNoDefaultExpr
- :: InstOrigin s
- -> [TcIdOcc s]
- -> [Id]
- -> TcType s
- -> Class
- -> Module
- -> Int
- -> NF_TcM s (TcExpr s)
-makeInstanceDeclNoDefaultExpr origin meth_ids defm_ids inst_ty clas inst_mod tag
- =
- -- Produce a warning if the default instance method
- -- has been omitted when one exists in the class
- warnTc (not err_defm_ok)
- (omitDefaultMethodWarn clas_op clas_name inst_ty)
+ | otherwise -- There's definitely no default decl in the class,
+ -- so we produce a warning, and a better run=time error message too
+ = warnTc True (omitDefaultMethodWarn clas_op clas_name inst_ty)
`thenNF_Tc_`
+
returnNF_Tc (HsApp (mkHsTyApp (HsVar (RealId nO_EXPLICIT_METHOD_ERROR_ID)) [tcIdType meth_id])
(HsLitOut (HsString (_PK_ error_msg)) stringTy))
where
idx = tag - 1
- meth_id = meth_ids !! idx
- clas_op = (classOps clas) !! idx
+ meth_id = meth_ids !! idx
defm_id = defm_ids !! idx
- Just (_, _, err_defm_ok) = isDefaultMethodId_maybe defm_id
+ Just (_, _, defm_is_err) = isDefaultMethodId_maybe defm_id
- error_msg = _UNPK_ inst_mod ++ "." ++ _UNPK_ clas_name ++ "."
- ++ (ppShow 80 (ppr PprForUser inst_ty)) ++ "."
- ++ (ppShow 80 (ppr PprForUser clas_op)) ++ "\""
+ error_msg = ppShow 80 (ppSep [ppr PprForUser clas_op, ppStr "at", ppr PprForUser src_loc])
- clas_name = nameOf (origName "makeInstanceDeclNoDefaultExpr" clas)
+ clas_op = (classOps clas) !! idx
+ clas_name = getOccString clas
\end{code}
+
%************************************************************************
%* *
\subsection{Processing each method}
FunMonoBind op _ _ locn -> (op, locn)
PatMonoBind (VarPatIn op) _ locn -> (op, locn)
- occ = getLocalName op
- origin = InstanceDeclOrigin
+ occ = getOccName op
+ origin = InstanceDeclOrigin
in
tcAddSrcLoc locn $
-- Make a method id for the method
let
- maybe_tag = classOpTagByString_maybe clas occ
+ maybe_tag = classOpTagByOccName_maybe clas occ
(Just tag) = maybe_tag
method_id = method_ids !! (tag-1)
method_ty = tcIdType method_id
newLocalId occ method_tau `thenNF_Tc` \ local_id ->
newLocalId occ method_ty `thenNF_Tc` \ copy_id ->
let
+ tc_local_id = TcId local_id
+ tc_copy_id = TcId copy_id
sig_tyvar_set = mkTyVarSet sig_tyvars
in
-- Typecheck the method
- tcMethodBind local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
+ tcMethodBind tc_local_id method_tau mbind `thenTc` \ (mbind', lieIop) ->
-- Check the overloading part of the signature.
(AbsBinds
method_tyvars
method_dict_ids
- [(local_id, copy_id)]
+ [(tc_local_id, tc_copy_id)]
dict_binds
(NonRecBind mbind'))
- (HsVar copy_id)))
+ (HsVar tc_copy_id)))
\end{code}
\begin{code}
clas = lookupCE ce class_name -- Renamer ensures this can't fail
-- Make some new type variables, named as in the specialised instance type
- ty_names = extractMonoTyNames ???is_tyvarish_name??? ty
+ ty_names = extractHsTyNames ???is_tyvarish_name??? ty
(tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names
in
babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty)
copyTyVars inst_tmpls `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) ->
let
Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta
- _ _ _ binds True{-from here-} mod _ uprag) = maybe_unspec_inst
+ _ _ binds _ uprag) = maybe_unspec_inst
subst = case matchTy unspec_inst_ty inst_ty of
Just subst -> subst
tv_tmpl_map = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys
tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv
in
- mkInstanceRelatedIds e True{-from here-} src_loc mod NoInstancePragmas
+ mkInstanceRelatedIds
clas inst_tmpls inst_ty simpl_theta uprag
- `thenTc` \ (dfun_id, dfun_theta, const_meth_ids) ->
+ `thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) ->
getSwitchCheckerTc `thenNF_Tc` \ sw_chkr ->
(if sw_chkr SpecialiseTrace then
else id) (
returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
- dfun_theta dfun_id const_meth_ids
- binds True{-from here-} mod src_loc uprag))
+ dfun_theta dfun_id
+ binds src_loc uprag))
)))
We can also have instances for functions: @instance Foo (a -> b) ...@.
\begin{code}
-scrutiniseInstanceType from_here clas inst_tau
+scrutiniseInstanceType dfun_name clas inst_tau
-- TYCON CHECK
| not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
= failTc (instTypeErr inst_tau)
-- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
- | not from_here
+ | not (isLocallyDefined dfun_name)
= returnTc (inst_tycon,arg_tys)
-- TYVARS CHECK
| -- CCALL CHECK
-- A user declaration of a CCallable/CReturnable instance
-- must be for a "boxed primitive" type.
- isCcallishClass clas
- && not (maybeToBool (maybeBoxedPrimType inst_tau)
- || opt_CompilingGhcInternals) -- this lets us get up to mischief;
- -- e.g., instance CCallable ()
+ (uniqueOf clas == cCallableClassKey && not (ccallable_type inst_tau)) ||
+ (uniqueOf clas == cReturnableClassKey && not (creturnable_type inst_tau))
= failTc (nonBoxedPrimCCallErr clas inst_tau)
| otherwise
(possible_tycon, arg_tys) = splitAppTy inst_tau
inst_tycon_maybe = getTyCon_maybe possible_tycon
inst_tycon = expectJust "tcInstDecls1:inst_tycon" inst_tycon_maybe
+
+-- These conditions come directly from what the DsCCall is capable of.
+-- Totally grotesque. Green card should solve this.
+
+ccallable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
+ ty `eqTy` stringTy ||
+ byte_arr_thing
+ where
+ byte_arr_thing = case maybeAppDataTyCon ty of
+ Just (tycon, ty_args, [data_con]) ->
+-- pprTrace "cc1" (ppSep [ppr PprDebug tycon, ppr PprDebug data_con,
+-- ppSep (map (ppr PprDebug) data_con_arg_tys)])(
+ length data_con_arg_tys == 2 &&
+ maybeToBool maybe_arg2_tycon &&
+-- pprTrace "cc2" (ppSep [ppr PprDebug arg2_tycon]) (
+ (arg2_tycon == byteArrayPrimTyCon ||
+ arg2_tycon == mutableByteArrayPrimTyCon)
+-- ))
+ where
+ data_con_arg_tys = dataConArgTys data_con ty_args
+ (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys
+ maybe_arg2_tycon = maybeAppTyCon data_con_arg_ty2
+ Just (arg2_tycon,_) = maybe_arg2_tycon
+
+ other -> False
+
+creturnable_type ty = maybeToBool (maybeBoxedPrimType ty) ||
+ -- Or, a data type with a single nullary constructor
+ case (maybeAppDataTyCon ty) of
+ Just (tycon, tys_applied, [data_con])
+ -> isNullaryDataCon data_con
+ other -> False
\end{code}
\begin{code}
pp_mod = ppBesides [ppStr "module `", ppPStr inst_mod, ppStr "'"]
nonBoxedPrimCCallErr clas inst_ty sty
- = ppHang (ppStr "Instance isn't for a `boxed-primitive' type")
+ = ppHang (ppStr "Unacceptable instance type for ccall-ish class")
4 (ppBesides [ ppStr "class `", ppr sty clas, ppStr "' type `",
ppr sty inst_ty, ppStr "'"])
omitDefaultMethodWarn clas_op clas_name inst_ty sty
= ppCat [ppStr "Warning: Omitted default method for",
ppr sty clas_op, ppStr "in instance",
- ppPStr clas_name, pprParendGenType sty inst_ty]
+ ppStr clas_name, pprParendGenType sty inst_ty]
instMethodNotInClassErr occ clas sty
= ppHang (ppStr "Instance mentions a method not in the class")
4 (ppBesides [ppStr "class `", ppr sty clas, ppStr "' method `",
- ppPStr occ, ppStr "'"])
+ ppr sty occ, ppStr "'"])
patMonoBindsCtxt pbind sty
= ppHang (ppStr "In a pattern binding:")
import RnHsSyn ( SYN_IE(RenamedMonoBinds), RenamedSig(..),
RenamedInstancePragmas(..) )
-import TcMonad hiding ( rnMtoTcM )
+import TcEnv ( tcLookupGlobalValueMaybe )
+import TcMonad
import Inst ( SYN_IE(InstanceMapper) )
import Bag ( bagToList )
SYN_IE(ClassOp)
)
import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp )
-import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal )
+import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal, replaceIdInfo, getIdInfo )
import MatchEnv ( nullMEnv, insertMEnv )
import Maybes ( MaybeErr(..), mkLookupFunDef )
import Name ( getSrcLoc, Name{--O only-} )
-- element for each superclass; the "Mark
-- Jones optimisation"
Id -- The dfun id
- [Id] -- Constant methods (either all or none)
RenamedMonoBinds -- Bindings, b
- Bool -- True <=> local instance decl
- Module -- Name of module where this instance defined
SrcLoc -- Source location assoc'd with this instance's defn
[RenamedSig] -- User pragmas recorded for generating specialised instances
\end{code}
%************************************************************************
\begin{code}
-mkInstanceRelatedIds :: Bool
- -> SrcLoc
- -> Module
- -> RenamedInstancePragmas
+mkInstanceRelatedIds :: Name -- Name to use for the dict fun;
-> Class
-> [TyVar]
-> Type
-> ThetaType
- -> [RenamedSig]
- -> TcM s (Id, ThetaType, [Id])
+ -> NF_TcM s (Id, ThetaType)
-mkInstanceRelatedIds from_here src_loc inst_mod inst_pragmas
- clas inst_tyvars inst_ty inst_decl_theta uprags
- = -- MAKE THE DFUN ID
+mkInstanceRelatedIds dfun_name clas inst_tyvars inst_ty inst_decl_theta
+ = tcLookupGlobalValueMaybe dfun_name `thenNF_Tc` \ maybe_id ->
let
- dfun_theta = case inst_decl_theta of
+ -- Extract the dfun's IdInfo from the interface file,
+ -- provided it's imported.
+ -- We have to be lazy here; people look at the dfun Id itself
+ dfun_info = case maybe_id of
+ Nothing -> noIdInfo
+ Just imported_dfun_id -> getIdInfo imported_dfun_id
+ in
+ returnNF_Tc (new_dfun_id `replaceIdInfo` dfun_info, dfun_theta)
+
+ where
+ (_, super_classes, _, _, _, _) = classBigSig clas
+ super_class_theta = super_classes `zip` repeat inst_ty
+
+ dfun_theta = case inst_decl_theta of
[] -> [] -- If inst_decl_theta is empty, then we don't
-- want to have any dict arguments, so that we can
-- expose the constant methods.
-- Otherwise we pass the superclass dictionaries to
-- the dictionary function; the Mark Jones optimisation.
- dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
- in
- tcGetUnique `thenNF_Tc` \ dfun_uniq ->
- fixTc ( \ rec_dfun_id ->
-
-{- LATER
- tcDictFunPragmas dfun_ty rec_dfun_id inst_pragmas
- `thenNF_Tc` \ dfun_pragma_info ->
- let
- dfun_specenv = mkInstSpecEnv clas inst_ty inst_tyvars dfun_theta
- dfun_id_info = dfun_pragma_info `addInfo` dfun_specenv
- in
--}
- let dfun_id_info = noIdInfo in -- For now
-
- returnTc (mkDictFunId dfun_uniq clas inst_ty dfun_ty from_here src_loc inst_mod dfun_id_info)
- ) `thenTc` \ dfun_id ->
-
--- pprTrace "DFUN: " (ppr PprDebug dfun_id) $
-
- -- MAKE THE CONSTANT-METHOD IDS
- -- if there are no type variables involved
- (if (null inst_decl_theta)
- then
- mapTc mk_const_meth_id class_ops
- else
- returnTc []
- ) `thenTc` \ const_meth_ids ->
-
- returnTc (dfun_id, dfun_theta, const_meth_ids)
- where
- (class_tyvar, super_classes, _, class_ops, _, _) = classBigSig clas
- tenv = [(class_tyvar, inst_ty)]
-
- super_class_theta = super_classes `zip` repeat inst_ty
+ dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_ty)
- mk_const_meth_id op
- = tcGetUnique `thenNF_Tc` \ uniq ->
- fixTc (\ rec_const_meth_id ->
-
-{- LATER
- -- Figure out the IdInfo from the pragmas
- (case assocMaybe opname_prag_pairs (getName op) of
- Nothing -> returnTc inline_info
- Just prag -> tcGenPragmas (Just meth_ty) rec_const_meth_id prag
- ) `thenNF_Tc` \ id_info ->
--}
- let id_info = noIdInfo -- For now
- in
- returnTc (mkConstMethodId uniq clas op inst_ty meth_ty
- from_here src_loc inst_mod id_info)
- )
- where
- op_ty = classOpLocalType op
- meth_ty = mkForAllTys inst_tyvars (instantiateTy tenv op_ty)
-{- LATER
- inline_me = isIn "mkInstanceRelatedIds" op ops_to_inline
- inline_info = if inline_me
- then noIdInfo `addInfo_UF` (iWantToBeINLINEd UnfoldAlways)
- else noIdInfo
-
- opname_prag_pairs = case inst_pragmas of
- ConstantInstancePragma _ name_prag_pairs -> name_prag_pairs
- other_inst_pragmas -> []
-
- ops_to_inline = [op | (InlineSig op _) <- uprags]
--}
+ new_dfun_id = mkDictFunId dfun_name dfun_ty clas inst_ty
\end{code}
buildInstanceEnvs info
= let
icmp :: InstInfo -> InstInfo -> TAG_
- (InstInfo c1 _ _ _ _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _ _ _ _)
+ (InstInfo c1 _ _ _ _ _ _ _ _) `icmp` (InstInfo c2 _ _ _ _ _ _ _ _)
= c1 `cmp` c2
info_by_class = equivClasses icmp (bagToList info)
buildInstanceEnv :: [InstInfo] -- Non-empty, and all for same class
-> TcM s (Class, (ClassInstEnv, (ClassOp -> SpecEnv)))
-buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _ _ _ _) : _)
+buildInstanceEnv inst_infos@((InstInfo clas _ _ _ _ _ _ _ _) : _)
= foldlTc addClassInstance
(nullMEnv, [(op, nullSpecEnv) | op <- classOps clas])
inst_infos
-> TcM s (ClassInstEnv, [(ClassOp,SpecEnv)])
addClassInstance
- (class_inst_env, op_spec_envs)
+ input_stuff@(class_inst_env, op_spec_envs)
(InstInfo clas inst_tyvars inst_ty _ _
- dfun_id const_meth_ids _ _ _ src_loc _)
+ dfun_id _ src_loc _)
=
-- We only add specialised/overlapped instances
-- Add the instance to the class's instance environment
case insertMEnv matchTy class_inst_env inst_ty dfun_id of {
- Failed (ty', dfun_id') -> dupInstFailure clas (inst_ty, src_loc)
+ Failed (ty', dfun_id') -> recoverTc (returnTc input_stuff) $
+ dupInstFailure clas (inst_ty, src_loc)
(ty', getSrcLoc dfun_id');
Succeeded class_inst_env' ->
+ returnTc (class_inst_env', op_spec_envs)
+
+{- OLD STUFF FOR CONSTANT METHODS
+
-- If there are any constant methods, then add them to
-- the SpecEnv of each class op (ie selector)
--
rhs = mkValLam [dict] (mkTyApp (Var meth_id) (mkTyVarTys inst_tyvars))
in
returnTc (class_inst_env', op_spec_envs')
+ END OF OLD STUFF -}
+
}
\end{code}
IMP_Ubiq(){-uitous-}
import Kind
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import Unique ( Unique, pprUnique10 )
import Pretty
import HsPat(InPat, OutPat)
import HsSyn(Fake)
import TcHsSyn(TcIdOcc)
-import RnHsSyn(RnName)
import TcType(TcMaybe)
import SST(FSST_R)
import Unique(Unique)
+import Name(Name)
import TyVar(GenTyVar)
import TcEnv(TcEnv)
import TcMonad(TcDown)
import Type(GenType)
import Inst(Inst)
-tcGRHSsAndBinds :: GRHSsAndBinds Fake Fake RnName (InPat RnName)
+tcGRHSsAndBinds :: GRHSsAndBinds Fake Fake Name (InPat Name)
-> TcDown a
-> TcEnv a
-> State# a
import HsSyn ( Match(..), GRHSsAndBinds(..), GRHS(..), InPat,
HsExpr, HsBinds, OutPat, Fake,
collectPatBinders, pprMatch )
-import RnHsSyn ( SYN_IE(RenamedMatch), RnName{-instance Outputable-} )
+import RnHsSyn ( SYN_IE(RenamedMatch) )
import TcHsSyn ( TcIdOcc(..), SYN_IE(TcMatch) )
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import Inst ( Inst, SYN_IE(LIE), plusLIE )
import TcEnv ( newMonoIds )
IMPORT_DELOOPER(TcLoop) ( tcGRHSsAndBinds )
import TcPat ( tcPat )
import TcType ( SYN_IE(TcType), TcMaybe, zonkTcType )
import Unify ( unifyTauTy, unifyTauTyList )
+import Name ( Name {- instance Outputable -} )
import Kind ( Kind, mkTypeKind )
import Pretty
same number of arguments before using @tcMatches@ to do the work.
\begin{code}
-tcMatchesFun :: RnName
+tcMatchesFun :: Name
-> TcType s -- Expected type
-> [RenamedMatch]
-> TcM s ([TcMatch s], LIE s)
\begin{code}
-data FunOrCase = MCase | MFun RnName -- Records whether doing fun or case rhss;
+data FunOrCase = MCase | MFun Name -- Records whether doing fun or case rhss;
-- used to produced better error messages
tcMatchesExpected :: TcType s
typecheckModule,
SYN_IE(TcResults),
SYN_IE(TcResultBinds),
- SYN_IE(TcIfaceInfo),
SYN_IE(TcSpecialiseRequests),
SYN_IE(TcDDumpDeriv)
) where
IMP_Ubiq(){-uitous-}
-import HsSyn ( HsModule(..), HsBinds(..), Bind, HsExpr,
- TyDecl, SpecDataSig, ClassDecl, InstDecl,
+import HsSyn ( HsDecl(..), HsModule(..), HsBinds(..), Bind, HsExpr,
+ TyDecl, SpecDataSig, ClassDecl, InstDecl, IfaceSig,
SpecInstSig, DefaultDecl, Sig, Fake, InPat,
FixityDecl, IE, ImportDecl
)
import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr),
TcIdOcc(..), zonkBinds, zonkDictBinds )
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import Inst ( Inst, plusLIE )
import TcBinds ( tcBindsAndThen )
import TcClassDcl ( tcClassDecls2 )
import TcTyClsDecls ( tcTyAndClassDecls1 )
import TcTyDecls ( mkDataBinds )
+import RnMonad ( RnNameSupply(..) )
import Bag ( listToBag )
import Class ( GenClass, classSelIds )
import ErrUtils ( SYN_IE(Warning), SYN_IE(Error) )
-import Id ( idType, isMethodSelId, isTopLevId, GenId, SYN_IE(IdEnv), nullIdEnv )
+import Id ( idType, GenId, SYN_IE(IdEnv), nullIdEnv )
import Maybes ( catMaybes )
import Name ( isLocallyDefined )
import Pretty
-import RnUtils ( SYN_IE(RnEnv) )
import TyCon ( TyCon )
import Type ( applyTyCon )
import TysWiredIn ( unitTy, mkPrimIoTy )
-- Convenient type synonyms first:
type TcResults
= (TcResultBinds,
- TcIfaceInfo,
+ [TyCon],
+ Bag InstInfo, -- Instance declaration information
TcSpecialiseRequests,
TcDDumpDeriv)
[(Id, TypecheckedHsExpr)]) -- constant instance binds
-type TcIfaceInfo -- things for the interface generator
- = ([Id], [TyCon], [Class], Bag InstInfo)
-
type TcSpecialiseRequests
= FiniteMap TyCon [(Bool, [Maybe Type])]
-- source tycon specialisation requests
---------------
typecheckModule
:: UniqSupply
- -> RnEnv -- for renaming derivings
+ -> RnNameSupply
-> RenamedHsModule
-> MaybeErr
(TcResults, -- if all goes well...
(Bag Error, -- if we had errors...
Bag Warning)
-typecheckModule us rn_env mod
- = initTc us (tcModule rn_env mod)
+typecheckModule us rn_name_supply mod
+ = initTc us (tcModule rn_name_supply mod)
\end{code}
The internal monster:
\begin{code}
-tcModule :: RnEnv -- for renaming derivings
+tcModule :: RnNameSupply -- for renaming derivings
-> RenamedHsModule -- input
-> TcM s TcResults -- output
-tcModule rn_env
- (HsModule mod_name verion exports imports fixities
- ty_decls specdata_sigs cls_decls inst_decls specinst_sigs
- default_decls val_decls sigs src_loc)
-
- = ASSERT(null imports)
-
- tcAddSrcLoc src_loc $ -- record where we're starting
+tcModule rn_name_supply
+ (HsModule mod_name verion exports imports fixities decls src_loc)
+ = tcAddSrcLoc src_loc $ -- record where we're starting
-- Tie the knot for inteface-file value declaration signatures
-- This info is only used inside the knot for type-checking the
fixTc ( \ ~(rec_inst_mapper, _, _, _, _) ->
-- Type-check the type and class decls
- --trace "tcTyAndClassDecls:" $
- tcTyAndClassDecls1 rec_inst_mapper ty_decls_bag cls_decls_bag
- `thenTc` \ env ->
+ -- trace "tcTyAndClassDecls:" $
+ tcTyAndClassDecls1 rec_inst_mapper decls `thenTc` \ env ->
- --trace "tc3" $
+ -- trace "tc3" $
-- Typecheck the instance decls, includes deriving
tcSetEnv env (
- --trace "tcInstDecls:" $
- tcInstDecls1 inst_decls_bag specinst_sigs
- mod_name rn_env fixities
- ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
+ -- trace "tcInstDecls:" $
+ tcInstDecls1 decls mod_name rn_name_supply
+ ) `thenTc` \ (inst_info, deriv_binds, ddump_deriv) ->
- --trace "tc4" $
+ -- trace "tc4" $
buildInstanceEnvs inst_info `thenTc` \ inst_mapper ->
returnTc (inst_mapper, env, inst_info, deriv_binds, ddump_deriv)
) `thenTc` \ (_, env, inst_info, deriv_binds, ddump_deriv) ->
- --trace "tc5" $
+ -- trace "tc5" $
tcSetEnv env (
-- Default declarations
- tcDefaults default_decls `thenTc` \ defaulting_tys ->
+ tcDefaults decls `thenTc` \ defaulting_tys ->
tcSetDefaultTys defaulting_tys ( -- for the iface sigs...
-- Create any necessary record selector Ids and their bindings
-- What we rely on is that pragmas are typechecked lazily; if
-- any type errors are found (ie there's an inconsistency)
-- we silently discard the pragma
- tcInterfaceSigs sigs `thenTc` \ sig_ids ->
+ tcInterfaceSigs decls `thenTc` \ sig_ids ->
tcGetEnv `thenNF_Tc` \ env ->
- --trace "tc6" $
+ -- trace "tc6" $
returnTc (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, sig_ids)
)))) `thenTc` \ (env, inst_info, data_binds, deriv_binds, ddump_deriv, defaulting_tys, _) ->
- --trace "tc7" $
+ -- trace "tc7" $
tcSetEnv env ( -- to the end...
tcSetDefaultTys defaulting_tys ( -- ditto
-- Value declarations next.
-- We also typecheck any extra binds that came out of the "deriving" process
- --trace "tcBinds:" $
+ -- trace "tcBinds:" $
tcBindsAndThen
(\ binds1 (binds2, thing) -> (binds1 `ThenBinds` binds2, thing))
- (val_decls `ThenBinds` deriv_binds)
+ (get_val_decls decls `ThenBinds` deriv_binds)
( -- Second pass over instance declarations,
-- to compile the bindings themselves.
- --trace "tc8" $
+ -- trace "tc8" $
tcInstDecls2 inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
- tcClassDecls2 cls_decls_bag `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
+ tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
tcGetEnv `thenNF_Tc` \ env ->
returnTc ( (EmptyBinds, (inst_binds, cls_binds, env)),
lie_instdecls `plusLIE` lie_clasdecls,
-- restriction, and no subsequent decl instantiates its
-- type. (Usually, ambiguous type variables are resolved
-- during the generalisation step.)
- --trace "tc9" $
+ -- trace "tc9" $
tcSimplifyTop lie_alldecls `thenTc` \ const_insts ->
-- Backsubstitution. Monomorphic top-level decls may have
local_tycons = filter isLocallyDefined tycons
local_classes = filter isLocallyDefined classes
- local_vals = [ v | v <- eltsUFM ve2, isLocallyDefined v && isTopLevId v ]
- -- the isTopLevId is doubtful...
in
-- FINISHED AT LAST
returnTc (
(data_binds', cls_binds', inst_binds', val_binds', const_insts'),
- -- the next collection is just for mkInterface
- (local_vals, local_tycons, local_classes, inst_info),
-
- tycon_specs,
+ local_tycons, inst_info, tycon_specs,
ddump_deriv
)))
- where
- ty_decls_bag = listToBag ty_decls
- cls_decls_bag = listToBag cls_decls
- inst_decls_bag = listToBag inst_decls
+
+get_val_decls decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
\end{code}
foldrTc, foldlTc, mapAndUnzipTc, mapAndUnzip3Tc,
mapBagTc, fixTc, tryTc,
- returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc,
+ returnNF_Tc, thenNF_Tc, thenNF_Tc_, mapNF_Tc, fixNF_Tc, forkNF_Tc,
+
listNF_Tc, mapAndUnzipNF_Tc, mapBagNF_Tc,
checkTc, checkTcM, checkMaybeTc, checkMaybeTcM,
tcNewMutVar, tcReadMutVar, tcWriteMutVar,
- rnMtoTcM,
-
SYN_IE(TcError), SYN_IE(TcWarning),
mkTcErr, arityErr,
import ErrUtils ( SYN_IE(Error), SYN_IE(Message), SYN_IE(Warning) )
import SST
-import RnMonad ( SYN_IE(RnM), RnDown, initRn, setExtraRn,
- returnRn, thenRn, getImplicitUpRn
- )
-import RnUtils ( SYN_IE(RnEnv) )
-
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
import FiniteMap ( FiniteMap, emptyFM, isEmptyFM{-, keysFM ToDo:rm-} )
---import Outputable ( Outputable(..), NamedThing(..), ExportFlag )
import Maybes ( MaybeErr(..) )
---import Name ( Name )
-import SrcLoc ( SrcLoc, mkUnknownSrcLoc )
+import SrcLoc ( SrcLoc, noSrcLoc )
import UniqFM ( UniqFM, emptyUFM )
import UniqSupply ( UniqSupply, getUnique, getUniques, splitUniqSupply )
import Unique ( Unique )
newMutVarSST emptyUFM `thenSST` \ tvs_var ->
let
init_down = TcDown [] us_var
- mkUnknownSrcLoc
+ noSrcLoc
[] errs_var
init_env = initEnv tvs_var
in
fixTc m env down = fixFSST (\ loop -> m loop env down)
\end{code}
-@forkNF_Tc@ runs a sub-typecheck action in a separate state thread.
-This elegantly ensures that it can't zap any type variables that
-belong to the main thread. We throw away any error messages!
+@forkNF_Tc@ runs a sub-typecheck action *lazily* in a separate state
+thread. Ideally, this elegantly ensures that it can't zap any type
+variables that belong to the main thread. But alas, the environment
+contains TyCon and Class environments that include (TcKind s) stuff,
+which is a Royal Pain. By the time this fork stuff is used they'll
+have been unified down so there won't be any kind variables, but we
+can't express that in the current typechecker framework.
+
+So we compromise and use unsafeInterleaveSST.
-\begin{pseudocode}
-forkNF_Tc :: NF_TcM s' r -> NF_TcM s r
+We throw away any error messages!
+
+\begin{code}
+forkNF_Tc :: NF_TcM s r -> NF_TcM s r
forkNF_Tc m (TcDown deflts u_var src_loc err_cxt err_var) env
= -- Get a fresh unique supply
readMutVarSST u_var `thenSST` \ us ->
(us1, us2) = splitUniqSupply us
in
writeMutVarSST u_var us1 `thenSST_`
- returnSST ( runSST (
- newMutVarSST us2 `thenSST` \ u_var' ->
+
+ unsafeInterleaveSST (
+ newMutVarSST us2 `thenSST` \ us_var' ->
newMutVarSST (emptyBag,emptyBag) `thenSST` \ err_var' ->
newMutVarSST emptyUFM `thenSST` \ tv_var' ->
let
- down' = TcDown deflts us_var src_loc err_cxt err_var'
- env' = forkEnv env tv_var'
+ down' = TcDown deflts us_var' src_loc err_cxt err_var'
in
- m down' env'
-
+ m down' env
-- ToDo: optionally dump any error messages
- ))
-\end{pseudocode}
-
-@forkTcDown@ makes a new "down" blob for a lazily-computed fork
-of the type checker.
-
-\begin{pseudocode}
-forkTcDown (TcDown deflts u_var src_loc err_cxt err_var)
- = -- Get a fresh unique supply
- readMutVarSST u_var `thenSST` \ us ->
- let
- (us1, us2) = splitUniqSupply us
- in
- writeMutVarSST u_var us1 `thenSST_`
-
- -- Make fresh MutVars for the unique supply and errors
- newMutVarSST us2 `thenSST` \ u_var' ->
- newMutVarSST (emptyBag, emptyBag) `thenSST` \ err_var' ->
-
- -- Done
- returnSST (TcDown deflts u_var' src_loc err_cxt err_var')
-\end{pseudocode}
+ )
+\end{code}
Error handling
\end{code}
-\section{rn4MtoTcM}
-%~~~~~~~~~~~~~~~~~~
-
-\begin{code}
-rnMtoTcM :: RnEnv -> RnM REAL_WORLD a -> NF_TcM s (a, Bag Error)
-
-rnMtoTcM rn_env rn_action down env
- = readMutVarSST u_var `thenSST` \ uniq_supply ->
- let
- (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply
- in
- writeMutVarSST u_var new_uniq_supply `thenSST_`
- let
- (rn_result, rn_errs, rn_warns)
- = initRn False{-*interface* mode! so we can see the builtins-}
- (panic "rnMtoTcM:module")
- rn_env uniq_s (
- rn_action `thenRn` \ result ->
-
- -- Though we are in "interface mode", we must
- -- not have added anything to the ImplicitEnv!
- getImplicitUpRn `thenRn` \ implicit_env@(v_env,tc_env) ->
- if (isEmptyFM v_env && isEmptyFM tc_env)
- then returnRn result
- else panic "rnMtoTcM: non-empty ImplicitEnv!"
--- (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)
- where
- u_var = getUniqSupplyVar down
-\end{code}
TypeChecking Errors
\begin{code}
#include "HsVersions.h"
-module TcMonoType ( tcPolyType, tcMonoType, tcMonoTypeKind, tcContext ) where
+module TcMonoType ( tcHsType, tcHsTypeKind, tcContext, tcTyVarScope ) where
IMP_Ubiq(){-uitous-}
-import HsSyn ( PolyType(..), MonoType(..), Fake )
-import RnHsSyn ( RenamedPolyType(..), RenamedMonoType(..),
- RenamedContext(..), RnName(..),
- isRnLocal, isRnClass, isRnTyCon
- )
+import HsSyn ( HsType(..), HsTyVar(..), Fake )
+import RnHsSyn ( RenamedHsType(..), RenamedContext(..) )
-import TcMonad hiding ( rnMtoTcM )
-import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon,
- tcTyVarScope, tcTyVarScopeGivenKinds
- )
+import TcMonad
+import TcEnv ( tcLookupTyVar, tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv )
import TcKind ( TcKind, mkTcTypeKind, mkBoxedTypeKind,
mkTcArrowKind, unifyKind, newKindVar,
- kindToTcKind
+ kindToTcKind, tcDefaultKind
)
import Type ( GenType, SYN_IE(Type), SYN_IE(ThetaType),
mkTyVarTy, mkTyConTy, mkFunTy, mkAppTy, mkSynTy,
mkSigmaTy, mkDictTy
)
-import TyVar ( GenTyVar, SYN_IE(TyVar) )
-import Class ( cCallishClassKeys )
+import TyVar ( GenTyVar, SYN_IE(TyVar), mkTyVar )
+import PrelInfo ( cCallishClassKeys )
import TyCon ( TyCon )
+import Name ( Name, OccName, isTvOcc )
import TysWiredIn ( mkListTy, mkTupleTy )
import Unique ( Unique )
import PprStyle
import Pretty
-import Util ( zipWithEqual, panic{-, pprPanic ToDo:rm-} )
+import Util ( zipWithEqual, zipLazy, panic{-, pprPanic ToDo:rm-} )
\end{code}
-tcMonoType and tcMonoTypeKind
+tcHsType and tcHsTypeKind
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-tcMonoType checks that the type really is of kind Type!
+tcHsType checks that the type really is of kind Type!
\begin{code}
-tcMonoType :: RenamedMonoType -> TcM s Type
+tcHsType :: RenamedHsType -> TcM s Type
-tcMonoType ty
- = tcMonoTypeKind ty `thenTc` \ (kind,ty) ->
+tcHsType ty
+ = tcHsTypeKind ty `thenTc` \ (kind,ty) ->
unifyKind kind mkTcTypeKind `thenTc_`
returnTc ty
\end{code}
-tcMonoTypeKind does the real work. It returns a kind and a type.
+tcHsTypeKind does the real work. It returns a kind and a type.
\begin{code}
-tcMonoTypeKind :: RenamedMonoType -> TcM s (TcKind s, Type)
+tcHsTypeKind :: RenamedHsType -> TcM s (TcKind s, Type)
-tcMonoTypeKind (MonoTyVar name)
+tcHsTypeKind (MonoTyVar name)
= tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
returnTc (kind, mkTyVarTy tyvar)
-tcMonoTypeKind (MonoListTy ty)
- = tcMonoType ty `thenTc` \ tau_ty ->
+tcHsTypeKind (MonoListTy _ ty)
+ = tcHsType ty `thenTc` \ tau_ty ->
returnTc (mkTcTypeKind, mkListTy tau_ty)
-tcMonoTypeKind (MonoTupleTy tys)
- = mapTc tcMonoType tys `thenTc` \ tau_tys ->
+tcHsTypeKind (MonoTupleTy _ tys)
+ = mapTc tcHsType tys `thenTc` \ tau_tys ->
returnTc (mkTcTypeKind, mkTupleTy (length tys) tau_tys)
-tcMonoTypeKind (MonoFunTy ty1 ty2)
- = tcMonoType ty1 `thenTc` \ tau_ty1 ->
- tcMonoType ty2 `thenTc` \ tau_ty2 ->
+tcHsTypeKind (MonoFunTy ty1 ty2)
+ = tcHsType ty1 `thenTc` \ tau_ty1 ->
+ tcHsType ty2 `thenTc` \ tau_ty2 ->
returnTc (mkTcTypeKind, mkFunTy tau_ty1 tau_ty2)
-tcMonoTypeKind (MonoTyApp name tys)
- | isRnLocal name -- Must be a type variable
+tcHsTypeKind (MonoTyApp name tys)
+ | isTvOcc (getOccName name) -- Must be a type variable
= tcLookupTyVar name `thenNF_Tc` \ (kind,tyvar) ->
tcMonoTyApp kind (mkTyVarTy tyvar) tys
- | otherwise {-isRnTyCon name-} -- Must be a type constructor
- = tcLookupTyCon name `thenNF_Tc` \ (kind,maybe_arity,tycon) ->
+ | otherwise -- Must be a type constructor
+ = tcLookupTyCon name `thenTc` \ (kind,maybe_arity,tycon) ->
case maybe_arity of
Just arity -> tcSynApp name kind arity tycon tys -- synonum
Nothing -> tcMonoTyApp kind (mkTyConTy tycon) tys -- newtype or data
--- | otherwise
--- = pprPanic "tcMonoTypeKind:" (ppr PprDebug name)
-
--- for unfoldings only:
-tcMonoTypeKind (MonoForAllTy tyvars_w_kinds ty)
- = tcTyVarScopeGivenKinds names tc_kinds (\ tyvars ->
- tcMonoTypeKind ty `thenTc` \ (kind, ty') ->
- unifyKind kind mkTcTypeKind `thenTc_`
- returnTc (mkTcTypeKind, ty')
- )
- where
- (rn_names, kinds) = unzip tyvars_w_kinds
- names = map de_rn rn_names
- tc_kinds = map kindToTcKind kinds
- de_rn (RnName n) = n
+tcHsTypeKind (HsForAllTy tv_names context ty)
+ = tcTyVarScope tv_names $ \ tyvars ->
+ tcContext context `thenTc` \ theta ->
+ tcHsType ty `thenTc` \ tau ->
+ -- For-all's are of kind type!
+ returnTc (mkTcTypeKind, mkSigmaTy tyvars theta tau)
-- for unfoldings only:
-tcMonoTypeKind (MonoDictTy class_name ty)
- = tcMonoTypeKind ty `thenTc` \ (arg_kind, arg_ty) ->
- tcLookupClass class_name `thenNF_Tc` \ (class_kind, clas) ->
+tcHsTypeKind (MonoDictTy class_name ty)
+ = tcHsTypeKind ty `thenTc` \ (arg_kind, arg_ty) ->
+ tcLookupClass class_name `thenTc` \ (class_kind, clas) ->
unifyKind class_kind arg_kind `thenTc_`
returnTc (mkTcTypeKind, mkDictTy clas arg_ty)
\end{code}
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
tcMonoTyApp fun_kind fun_ty tys
- = mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
+ = mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
newKindVar `thenNF_Tc` \ result_kind ->
unifyKind fun_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_`
returnTc (result_kind, foldl mkAppTy fun_ty arg_tys)
tcSynApp name syn_kind arity tycon tys
- = mapAndUnzipTc tcMonoTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
+ = mapAndUnzipTc tcHsTypeKind tys `thenTc` \ (arg_kinds, arg_tys) ->
newKindVar `thenNF_Tc` \ result_kind ->
unifyKind syn_kind (foldr mkTcArrowKind result_kind arg_kinds) `thenTc_`
tcContext :: RenamedContext -> TcM s ThetaType
tcContext context = mapTc tcClassAssertion context
-tcClassAssertion (class_name, tyvar_name)
+tcClassAssertion (class_name, ty)
= checkTc (canBeUsedInContext class_name)
(naughtyCCallContextErr class_name) `thenTc_`
- tcLookupClass class_name `thenNF_Tc` \ (class_kind, clas) ->
- tcLookupTyVar tyvar_name `thenNF_Tc` \ (tyvar_kind, tyvar) ->
+ tcLookupClass class_name `thenTc` \ (class_kind, clas) ->
+ tcHsTypeKind ty `thenTc` \ (ty_kind, ty) ->
- unifyKind class_kind tyvar_kind `thenTc_`
+ unifyKind class_kind ty_kind `thenTc_`
- returnTc (clas, mkTyVarTy tyvar)
+ returnTc (clas, ty)
\end{code}
HACK warning: Someone discovered that @CCallable@ and @CReturnable@
classes so we specifically check that this isn't being done.
\begin{code}
-canBeUsedInContext :: RnName -> Bool
-canBeUsedInContext n
- = isRnClass n && not (uniqueOf n `elem` cCallishClassKeys)
+canBeUsedInContext :: Name -> Bool
+canBeUsedInContext n = not (uniqueOf n `elem` cCallishClassKeys)
\end{code}
-Polytypes
-~~~~~~~~~
+Type variables, with knot tying!
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-tcPolyType :: RenamedPolyType -> TcM s Type
-tcPolyType (HsForAllTy tyvar_names context ty)
- = tcTyVarScope names (\ tyvars ->
- tcContext context `thenTc` \ theta ->
- tcMonoType ty `thenTc` \ tau ->
- returnTc (mkSigmaTy tyvars theta tau)
- )
- where
- names = map de_rn tyvar_names
- de_rn (RnName n) = n
+tcTyVarScope
+ :: [HsTyVar Name] -- Names of some type variables
+ -> ([TyVar] -> TcM s a) -- Thing to type check in their scope
+ -> TcM s a -- Result
+
+tcTyVarScope tyvar_names thing_inside
+ = mapAndUnzipNF_Tc tcHsTyVar tyvar_names `thenNF_Tc` \ (names, kinds) ->
+
+ fixTc (\ ~(rec_tyvars, _) ->
+ -- Ok to look at names, kinds, but not tyvars!
+
+ tcExtendTyVarEnv names (kinds `zipLazy` rec_tyvars)
+ (thing_inside rec_tyvars) `thenTc` \ result ->
+
+ -- Get the tyvar's Kinds from their TcKinds
+ mapNF_Tc tcDefaultKind kinds `thenNF_Tc` \ kinds' ->
+
+ -- Construct the real TyVars
+ let
+ tyvars = zipWithEqual "tcTyVarScope" mkTyVar names kinds'
+ in
+ returnTc (tyvars, result)
+ ) `thenTc` \ (_,result) ->
+ returnTc result
+
+tcHsTyVar (UserTyVar name)
+ = newKindVar `thenNF_Tc` \ tc_kind ->
+ returnNF_Tc (name, tc_kind)
+tcHsTyVar (IfaceTyVar name kind)
+ = returnNF_Tc (name, kindToTcKind kind)
\end{code}
Errors and contexts
IMP_Ubiq(){-uitous-}
import HsSyn ( InPat(..), OutPat(..), HsExpr(..), HsLit(..),
- Match, HsBinds, Qualifier, PolyType,
+ Match, HsBinds, Qualifier, HsType,
ArithSeqInfo, Stmt, Fake )
-import RnHsSyn ( SYN_IE(RenamedPat), RnName{-instance Outputable-} )
+import RnHsSyn ( SYN_IE(RenamedPat) )
import TcHsSyn ( SYN_IE(TcPat), TcIdOcc(..) )
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import Inst ( Inst, OverloadedLit(..), InstOrigin(..),
emptyLIE, plusLIE, plusLIEs, SYN_IE(LIE),
newMethod, newOverloadedLit
)
+import Name ( Name {- instance Outputable -} )
import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey,
tcLookupLocalValueOK )
import SpecEnv ( SpecEnv )
unifies the actual args against the expected ones.
\begin{code}
-matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s)
+matchConArgTys :: Name -> [TcType s] -> TcM s (Id, TcType s)
matchConArgTys con arg_tys
= tcLookupGlobalValue con `thenNF_Tc` \ con_id ->
IMP_Ubiq()
import HsSyn ( MonoBinds(..), HsExpr(..), InPat, OutPat, HsLit,
- Match, HsBinds, Qualifier, PolyType, ArithSeqInfo,
+ Match, HsBinds, Qualifier, HsType, ArithSeqInfo,
GRHSsAndBinds, Stmt, Fake )
import TcHsSyn ( TcIdOcc(..), SYN_IE(TcIdBndr), SYN_IE(TcExpr), SYN_IE(TcMonoBinds) )
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import Inst ( lookupInst, lookupSimpleInst,
tyVarsOfInst, isTyVarDict, isDict,
matchesInst, instToId, instBindingRequired,
import Bag ( Bag, unitBag, listToBag, foldBag, filterBag, emptyBag, bagToList,
snocBag, consBag, unionBags, isEmptyBag )
import Class ( GenClass, SYN_IE(Class), SYN_IE(ClassInstEnv),
- isNumericClass, isStandardClass, isCcallishClass,
isSuperClassOf, classSuperDictSelId, classInstEnv
)
import Id ( GenId )
+import PrelInfo ( isNumericClass, isStandardClass, isCcallishClass )
+
import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool )
import Outputable ( Outputable(..){-instance * []-} )
--import PprStyle--ToDo:rm
import PprType ( GenType, GenTyVar )
import Pretty
-import SrcLoc ( mkUnknownSrcLoc )
+import SrcLoc ( noSrcLoc )
import Type ( GenType, SYN_IE(Type), SYN_IE(TauType), mkTyVarTy, getTyVar, eqSimpleTy,
getTyVar_maybe )
-import TysWiredIn ( intTy )
+import TysWiredIn ( intTy, unitTy )
import TyVar ( GenTyVar, SYN_IE(GenTyVarSet),
elementOfTyVarSet, emptyTyVarSet, unionTyVarSets,
isEmptyTyVarSet, tyVarSetToList )
disambigOne :: [SimpleDictInfo s] -> TcM s ()
disambigOne dict_infos
- | not (isStandardNumericDefaultable classes)
- = failTc (ambigErr dicts) -- no default
-
- | otherwise -- isStandardNumericDefaultable dict_infos
+ | any isNumericClass classes && all isStandardClass classes
= -- THE DICTS OBEY THE DEFAULTABLE CONSTRAINT
-- SO, TRY DEFAULT TYPES IN ORDER
tcGetDefaultTys `thenNF_Tc` \ default_tys ->
let
try_default [] -- No defaults work, so fail
- = failTc (defaultErr dicts default_tys)
+ = failTc (ambigErr dicts)
try_default (default_ty : default_tys)
= tryTc (try_default default_tys) $ -- If default_ty fails, we try
tcInstType [] chosen_default_ty `thenNF_Tc` \ chosen_default_tc_ty -> -- Tiresome!
unifyTauTy chosen_default_tc_ty (mkTyVarTy tyvar)
+ | all isCcallishClass classes
+ = -- Default CCall stuff to (); we don't even both to check that () is an
+ -- instance of CCallable/CReturnable, because we know it is.
+ unifyTauTy (mkTyVarTy tyvar) unitTy
+
+ | otherwise -- No defaults
+ = failTc (ambigErr dicts)
+
where
(_,_,tyvar) = head dict_infos -- Should be non-empty
dicts = [dict | (dict,_,_) <- dict_infos]
\end{code}
-@isStandardNumericDefaultable@ sees whether the dicts have the
-property required for defaulting; namely at least one is numeric, and
-all are standard; or all are CcallIsh.
-
-\begin{code}
-isStandardNumericDefaultable :: [Class] -> Bool
-
-isStandardNumericDefaultable classes
- = --pprTrace "isStdNumeric:\n" (ppAboves [ppCat (map (ppr PprDebug) classes), ppCat (map (ppr PprDebug . isNumericClass) classes), ppCat (map (ppr PprDebug . isStandardClass) classes), ppCat (map (ppr PprDebug . isCcallishClass) classes)]) $
- (any isNumericClass classes && all isStandardClass classes)
- || (all isCcallishClass classes)
-\end{code}
-
Errors and contexts
(bagToList insts))
\end{code}
-\begin{code}
-defaultErr dicts defaulting_tys sty
- = ppHang (ppStr "Ambiguously-overloaded types could not be resolved:")
- 4 (ppAboves [
- ppHang (ppStr "Conflicting:")
- 4 (ppInterleave ppSemi (map (pprInst sty ""{-???-}) dicts)),
- ppHang (ppStr "Defaulting types :")
- 4 (ppr sty defaulting_tys),
- ppStr "([Int, Double] is the default list of defaulting types.)" ])
-\end{code}
IMP_Ubiq(){-uitous-}
-import HsSyn ( TyDecl(..), ConDecl(..), BangType(..),
- ClassDecl(..), MonoType(..), PolyType(..),
- Sig(..), MonoBinds, Fake, InPat, HsBinds(..), Bind, HsExpr )
-import RnHsSyn ( isRnTyCon, RenamedTyDecl(..), RenamedClassDecl(..),
- RnName(..){-instance Uniquable-}
+import HsSyn ( HsDecl(..), TyDecl(..), ConDecl(..), BangType(..),
+ ClassDecl(..), HsType(..), HsTyVar, DefaultDecl, InstDecl,
+ IfaceSig, Sig(..), MonoBinds, Fake, InPat, HsBinds(..), Bind, HsExpr,
+ hsDeclName
+ )
+import RnHsSyn ( RenamedTyDecl(..), RenamedClassDecl(..), SYN_IE(RenamedHsDecl)
)
import TcHsSyn ( SYN_IE(TcHsBinds), TcIdOcc(..) )
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import Inst ( SYN_IE(InstanceMapper) )
import TcClassDcl ( tcClassDecl1 )
-import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv,
- tcTyVarScope )
+import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv )
import SpecEnv ( SpecEnv )
import TcKind ( TcKind, newKindVars )
import TcTyDecls ( tcTyDecl, mkDataBinds )
+import TcMonoType ( tcTyVarScope )
import Bag
import Class ( SYN_IE(Class), classSelIds )
import Digraph ( findSCCs, SCC(..) )
-import Name ( getSrcLoc )
+import Name ( Name, getSrcLoc, isTvOcc, nameOccName )
import PprStyle
import Pretty
import UniqSet ( SYN_IE(UniqSet), emptyUniqSet,
The main function
~~~~~~~~~~~~~~~~~
\begin{code}
-data Decl = TyD RenamedTyDecl | ClD RenamedClassDecl
-
tcTyAndClassDecls1 :: InstanceMapper
- -> Bag RenamedTyDecl -> Bag RenamedClassDecl
+ -> [RenamedHsDecl]
-> TcM s (TcEnv s)
-tcTyAndClassDecls1 inst_mapper rnty_decls rncls_decls
- = sortByDependency syn_decls cls_decls decls `thenTc` \ groups ->
+tcTyAndClassDecls1 inst_mapper decls
+ = sortByDependency decls `thenTc` \ groups ->
tcGroups inst_mapper groups
- where
- cls_decls = mapBag ClD rncls_decls
- ty_decls = mapBag TyD rnty_decls
- syn_decls = filterBag is_syn_decl ty_decls
- decls = ty_decls `unionBags` cls_decls
-
- is_syn_decl (TyD (TySynonym _ _ _ _)) = True
- is_syn_decl _ = False
tcGroups inst_mapper []
= tcGetEnv `thenNF_Tc` \ env ->
Dealing with a group
~~~~~~~~~~~~~~~~~~~~
\begin{code}
-tcGroup :: InstanceMapper -> Bag Decl -> TcM s (TcEnv s)
+tcGroup :: InstanceMapper -> Bag RenamedHsDecl -> TcM s (TcEnv s)
tcGroup inst_mapper decls
= -- pprTrace "tcGroup: " (ppCat (map (fst.fmt_decl) (bagToList decls))) $
returnTc final_env
where
- (tyvar_rn_names, tycon_names_w_arities, class_names) = get_binders decls
-
- tyvar_names = map de_rn tyvar_rn_names
- de_rn (RnName n) = n
+ (tyvar_names, tycon_names_w_arities, class_names) = get_binders decls
combine do_a do_b
= do_a `thenTc` \ (a1,a2) ->
~~~~~~~~~~~~~~~~~~~~~
\begin{code}
tcDecl :: InstanceMapper
- -> Decl
+ -> RenamedHsDecl
-> TcM s (Bag TyCon, Bag Class)
tcDecl inst_mapper (TyD decl)
Dependency analysis
~~~~~~~~~~~~~~~~~~~
\begin{code}
-sortByDependency :: Bag Decl -> Bag Decl -> Bag Decl -> TcM s [Bag Decl]
-sortByDependency syn_decls cls_decls decls
+sortByDependency :: [RenamedHsDecl] -> TcM s [Bag RenamedHsDecl]
+sortByDependency decls
= let -- CHECK FOR SYNONYM CYCLES
syn_sccs = findSCCs mk_edges syn_decls
- syn_cycles = [map fmt_decl (bagToList decls)
- | CyclicSCC decls <- syn_sccs]
+ syn_cycles = [ map fmt_decl (bagToList decls)
+ | CyclicSCC decls <- syn_sccs]
in
checkTc (null syn_cycles) (typeCycleErr syn_cycles) `thenTc_`
let -- CHECK FOR CLASS CYCLES
cls_sccs = findSCCs mk_edges cls_decls
- cls_cycles = [map fmt_decl (bagToList decls)
- | CyclicSCC decls <- cls_sccs]
+ cls_cycles = [ map fmt_decl (bagToList decls)
+ | CyclicSCC decls <- cls_sccs]
in
checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_`
-- DO THE MAIN DEPENDENCY ANALYSIS
let
- decl_sccs = findSCCs mk_edges decls
+ decl_sccs = findSCCs mk_edges ty_cls_decls
scc_bags = map bag_acyclic decl_sccs
in
returnTc (scc_bags)
-
+
where
- bag_acyclic (AcyclicSCC scc) = unitBag scc
- bag_acyclic (CyclicSCC sccs) = sccs
+ syn_decls = listToBag (filter is_syn_decl decls)
+ ty_cls_decls = listToBag (filter is_ty_cls_decl decls)
+ cls_decls = listToBag (filter is_cls_decl decls)
+
+
+
+bag_acyclic (AcyclicSCC scc) = unitBag scc
+bag_acyclic (CyclicSCC sccs) = sccs
+
+is_syn_decl (TyD (TySynonym _ _ _ _)) = True
+is_syn_decl _ = False
+
+is_ty_cls_decl (TyD _) = True
+is_ty_cls_decl (ClD _) = True
+is_ty_cls_decl other = False
+
+is_cls_decl (ClD _) = True
+is_cls_decl other = False
fmt_decl decl
= (ppr PprForUser name, getSrcLoc name)
where
- name = get_name decl
- get_name (TyD (TyData _ name _ _ _ _ _)) = name
- get_name (TyD (TyNew _ name _ _ _ _ _)) = name
- get_name (TyD (TySynonym name _ _ _)) = name
- get_name (ClD (ClassDecl _ name _ _ _ _ _)) = name
+ name = hsDeclName decl
\end{code}
Edges in Type/Class decls
~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
mk_edges (TyD (TyData ctxt name _ condecls derivs _ _))
- = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecls `unionUniqSets` get_deriv derivs))
+ = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets`
+ get_cons condecls `unionUniqSets`
+ get_deriv derivs))
+
mk_edges (TyD (TyNew ctxt name _ condecl derivs _ _))
- = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_cons condecl `unionUniqSets` get_deriv derivs))
+ = (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets`
+ get_con condecl `unionUniqSets`
+ get_deriv derivs))
+
mk_edges (TyD (TySynonym name _ rhs _))
= (uniqueOf name, set_to_bag (get_ty rhs))
+
mk_edges (ClD (ClassDecl ctxt name _ sigs _ _ _))
= (uniqueOf name, set_to_bag (get_ctxt ctxt `unionUniqSets` get_sigs sigs))
get_cons cons
= unionManyUniqSets (map get_con cons)
- where
- get_con (ConDecl _ btys _)
- = unionManyUniqSets (map get_bty btys)
- get_con (ConOpDecl bty1 _ bty2 _)
- = unionUniqSets (get_bty bty1) (get_bty bty2)
- get_con (NewConDecl _ ty _)
- = get_ty ty
- get_con (RecConDecl _ nbtys _)
- = unionManyUniqSets (map (get_bty.snd) nbtys)
-
- get_bty (Banged ty) = get_pty ty
- get_bty (Unbanged ty) = get_pty ty
+
+get_con (ConDecl _ btys _)
+ = unionManyUniqSets (map get_bty btys)
+get_con (ConOpDecl bty1 _ bty2 _)
+ = unionUniqSets (get_bty bty1) (get_bty bty2)
+get_con (NewConDecl _ ty _)
+ = get_ty ty
+get_con (RecConDecl _ nbtys _)
+ = unionManyUniqSets (map (get_bty.snd) nbtys)
+
+get_bty (Banged ty) = get_ty ty
+get_bty (Unbanged ty) = get_ty ty
get_ty (MonoTyVar tv)
= emptyUniqSet
get_ty (MonoTyApp name tys)
- = (if isRnTyCon name then set_name name else emptyUniqSet)
+ = (if isTvOcc (nameOccName name) then emptyUniqSet else set_name name)
`unionUniqSets` get_tys tys
get_ty (MonoFunTy ty1 ty2)
= unionUniqSets (get_ty ty1) (get_ty ty2)
-get_ty (MonoListTy ty)
- = get_ty ty -- careful when defining [] (,,) etc as
-get_ty (MonoTupleTy tys) -- [ty] (ty,ty,ty) will not give edges!
- = get_tys tys
-get_ty other = panic "TcTyClsDecls:get_ty"
-
-get_pty (HsForAllTy _ ctxt mty)
+get_ty (MonoListTy tc ty)
+ = set_name tc `unionUniqSets` get_ty ty
+get_ty (MonoTupleTy tc tys)
+ = set_name tc `unionUniqSets` get_tys tys
+get_ty (HsForAllTy _ ctxt mty)
= get_ctxt ctxt `unionUniqSets` get_ty mty
-get_pty other = panic "TcTyClsDecls:get_pty"
+get_ty other = panic "TcTyClsDecls:get_ty"
get_tys tys
= unionManyUniqSets (map get_ty tys)
get_sigs sigs
= unionManyUniqSets (map get_sig sigs)
where
- get_sig (ClassOpSig _ ty _ _) = get_pty ty
+ get_sig (ClassOpSig _ ty _ _) = get_ty ty
get_sig other = panic "TcTyClsDecls:get_sig"
set_name name = unitUniqSet (uniqueOf name)
\begin{code}
-get_binders :: Bag Decl
- -> ([RnName], -- TyVars; no dups
- [(RnName, Maybe Arity)],-- Tycons; no dups; arities for synonyms
- [RnName]) -- Classes; no dups
+get_binders :: Bag RenamedHsDecl
+ -> ([HsTyVar Name], -- TyVars; no dups
+ [(Name, Maybe Arity)], -- Tycons; no dups; arities for synonyms
+ [Name]) -- Classes; no dups
get_binders decls = (bagToList tyvars, bagToList tycons, bagToList classes)
where
where
sig_tvs (ClassOpSig _ ty _ _) = pty_tvs ty
pty_tvs (HsForAllTy tvs _ _) = listToBag tvs -- tvs doesn't include the class tyvar
+ pty_tvs other = emptyBag
\end{code}
import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..),
Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..),
HsBinds(..), HsLit, Stmt, Qualifier, ArithSeqInfo,
- PolyType, Fake, InPat,
- Bind(..), MonoBinds(..), Sig,
- MonoType )
-import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..),
- RnName{-instance Outputable-}
+ HsType, Fake, InPat, HsTyVar,
+ Bind(..), MonoBinds(..), Sig
)
+import HsTypes ( getTyVarName )
+import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..) )
import TcHsSyn ( mkHsTyLam, mkHsDictLam, tcIdType,
SYN_IE(TcHsBinds), TcIdOcc(..)
)
import Inst ( newDicts, InstOrigin(..), Inst )
-import TcMonoType ( tcMonoTypeKind, tcMonoType, tcPolyType, tcContext )
+import TcMonoType ( tcHsTypeKind, tcHsType, tcContext )
import TcSimplify ( tcSimplifyThetas )
import TcType ( tcInstTyVars, tcInstType, tcInstId )
import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass,
newLocalId, newLocalIds, tcLookupClassByKey
)
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind )
import PprType ( GenClass, GenType{-instance Outputable-},
GenTyVar{-instance Outputable-}{-ToDo:possibly rm-}
)
+import CoreUnfold ( getUnfoldingTemplate )
import Class ( GenClass{-instance Eq-}, classInstEnv )
import Id ( mkDataCon, dataConSig, mkRecordSelId, idType,
dataConFieldLabels, dataConStrictMarks,
- StrictnessMark(..),
+ StrictnessMark(..), getIdUnfolding,
GenId{-instance NamedThing-}
)
import FieldLabel
import Kind ( Kind, mkArrowKind, mkBoxedTypeKind )
import SpecEnv ( SpecEnv, nullSpecEnv )
-import Name ( nameSrcLoc, isLocallyDefinedName, getSrcLoc,
- Name{-instance Ord3-}
+import Name ( nameSrcLoc, isLocallyDefined, getSrcLoc,
+ OccName(..), Name{-instance Ord3-}
)
import Outputable ( Outputable(..), interpp'SP )
import Pretty
tcAddErrCtxt (tySynCtxt tycon_name) $
-- Look up the pieces
- tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, _, rec_tycon) ->
- mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
+ tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) ->
+ mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName) tyvar_names
+ `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
-- Look at the rhs
- tcMonoTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) ->
+ tcHsTypeKind rhs `thenTc` \ (rhs_kind, rhs_ty) ->
-- Unify tycon kind with (k1->...->kn->rhs)
unifyKind tycon_kind
= tcTyDataOrNew DataType context tycon_name tyvar_names con_decls derivings pragmas src_loc
tcTyDecl (TyNew context tycon_name tyvar_names con_decl derivings pragmas src_loc)
- = tcTyDataOrNew NewType context tycon_name tyvar_names con_decl derivings pragmas src_loc
+ = tcTyDataOrNew NewType context tycon_name tyvar_names [con_decl] derivings pragmas src_loc
tcTyDataOrNew data_or_new context tycon_name tyvar_names con_decls derivings pragmas src_loc
tcAddErrCtxt (tyDataCtxt tycon_name) $
-- Lookup the pieces
- tcLookupTyCon tycon_name `thenNF_Tc` \ (tycon_kind, _, rec_tycon) ->
- mapAndUnzipNF_Tc tcLookupTyVar tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
- tc_derivs derivings `thenNF_Tc` \ derived_classes ->
+ tcLookupTyCon tycon_name `thenTc` \ (tycon_kind, _, rec_tycon) ->
+ mapAndUnzipNF_Tc (tcLookupTyVar.getTyVarName)
+ tyvar_names `thenNF_Tc` \ (tyvar_kinds, rec_tyvars) ->
+ tc_derivs derivings `thenTc` \ derived_classes ->
-- Typecheck the context
tcContext context `thenTc` \ ctxt ->
in
returnTc tycon
-tc_derivs Nothing = returnNF_Tc []
-tc_derivs (Just ds) = mapNF_Tc tc_deriv ds
+tc_derivs Nothing = returnTc []
+tc_derivs (Just ds) = mapTc tc_deriv ds
tc_deriv name
- = tcLookupClass name `thenNF_Tc` \ (_, clas) ->
- returnNF_Tc clas
+ = tcLookupClass name `thenTc` \ (_, clas) ->
+ returnTc clas
\end{code}
Generating constructor/selector bindings for data declarations
mkDataBinds_one tycon
= ASSERT( isDataTyCon tycon || isNewTyCon tycon )
- mapAndUnzipTc mkConstructor data_cons `thenTc` \ (con_ids, con_binds) ->
- mapAndUnzipTc (mkRecordSelector tycon) groups `thenTc` \ (sel_ids, sel_binds) ->
- returnTc (con_ids ++ sel_ids,
- SingleBind $ NonRecBind $
- foldr AndMonoBinds
- (foldr AndMonoBinds EmptyMonoBinds sel_binds)
- con_binds
- )
+ mapTc checkConstructorContext data_cons `thenTc_`
+ mapTc (mkRecordSelector tycon) groups `thenTc` \ sel_ids ->
+ let
+ data_ids = data_cons ++ sel_ids
+
+ -- For the locally-defined things
+ -- we need to turn the unfoldings inside the Ids into bindings,
+ binds = [ CoreMonoBind (RealId data_id) (getUnfoldingTemplate (getIdUnfolding data_id))
+ | data_id <- data_ids, isLocallyDefined data_id
+ ]
+ in
+ returnTc (data_ids,
+ SingleBind (NonRecBind (foldr AndMonoBinds EmptyMonoBinds binds))
+ )
where
data_cons = tyConDataCons tycon
fields = [ (con, field) | con <- data_cons,
= fieldLabelName field1 `cmp` fieldLabelName field2
\end{code}
-We're going to build a constructor that looks like:
-
- data (Data a, C b) => T a b = T1 !a !Int b
-
- T1 = /\ a b ->
- \d1::Data a, d2::C b ->
- \p q r -> case p of { p ->
- case q of { q ->
- HsCon T1 [a,b] [p,q,r]}}
-
-Notice that
-
-* d2 is thrown away --- a context in a data decl is used to make sure
- one *could* construct dictionaries at the site the constructor
- is used, but the dictionary isn't actually used.
-
-* We have to check that we can construct Data dictionaries for
- the types a and Int. Once we've done that we can throw d1 away too.
-
-* We use (case p of ...) to evaluate p, rather than "seq" because
- all that matters is that the arguments are evaluated. "seq" is
- very careful to preserve evaluation order, which we don't need
- to be here.
+-- Check that all the types of all the strict arguments are in Eval
\begin{code}
-mkConstructor con_id
- | not (isLocallyDefinedName (getName con_id))
- = returnTc (con_id, EmptyMonoBinds)
+checkConstructorContext con_id
+ | not (isLocallyDefined con_id)
+ = returnTc ()
| otherwise -- It is locally defined
- = tcInstId con_id `thenNF_Tc` \ (tc_tyvars, tc_theta, tc_tau) ->
- newDicts DataDeclOrigin tc_theta `thenNF_Tc` \ (_, dicts) ->
+ = tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
let
- (tc_arg_tys, tc_result_ty) = splitFunTy tc_tau
- n_args = length tc_arg_tys
- in
- newLocalIds (nOfThem n_args SLIT("con")) tc_arg_tys `thenNF_Tc` \ args ->
+ strict_marks = dataConStrictMarks con_id
+ (tyvars,theta,tau) = splitSigmaTy (idType con_id)
+ (arg_tys, result_ty) = splitFunTy tau
- -- Check that all the types of all the strict arguments are in Eval
- tcLookupClassByKey evalClassKey `thenNF_Tc` \ eval_clas ->
- let
- (_,theta,tau) = splitSigmaTy (idType con_id)
- (arg_tys, _) = splitFunTy tau
- strict_marks = dataConStrictMarks con_id
- eval_theta = [ (eval_clas,arg_ty)
- | (arg_ty, MarkedStrict) <- zipEqual "strict_args"
+ eval_theta = [ (eval_clas,arg_ty)
+ | (arg_ty, MarkedStrict) <- zipEqual "strict_args"
arg_tys strict_marks
- ]
+ ]
in
tcSimplifyThetas classInstEnv theta eval_theta `thenTc` \ eval_theta' ->
checkTc (null eval_theta')
- (missingEvalErr con_id eval_theta') `thenTc_`
-
- -- Build the data constructor
- let
- con_rhs = mkHsTyLam tc_tyvars $
- mkHsDictLam dicts $
- mk_pat_match args $
- mk_case (zipEqual "strict_args" args strict_marks) $
- HsCon con_id (mkTyVarTys tc_tyvars) (map HsVar args)
-
- mk_pat_match [] body = body
- mk_pat_match (arg:args) body = HsLam $
- PatMatch (VarPat arg) $
- SimpleMatch (mk_pat_match args body)
-
- mk_case [] body = body
- mk_case ((arg,MarkedStrict):args) body = HsCase (HsVar arg)
- [PatMatch (VarPat arg) $
- SimpleMatch (mk_case args body)]
- src_loc
- mk_case (_:args) body = mk_case args body
-
- src_loc = nameSrcLoc (getName con_id)
- in
-
- returnTc (con_id, VarMonoBind (RealId con_id) con_rhs)
+ (missingEvalErr con_id eval_theta')
\end{code}
-We're going to build a record selector that looks like this:
-
- data T a b c = T1 { op :: a, ...}
- | T2 { op :: a, ...}
- | T3
-
- sel :: forall a b c. T a b c -> a
- sel = /\ a b c -> \ T1 { sel = x } -> x
- T2 { sel = 2 } -> x
-
-Note that the selector Id itself is used as the field
-label; it has to be an Id, you see!
-
\begin{code}
mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields)
-- These fields all have the same name, but are from
-- different constructors in the data type
- = let
- field_ty = fieldLabelType first_field_label
- field_name = fieldLabelName first_field_label
- other_tys = [fieldLabelType fl | (_, fl) <- other_fields]
- (tyvars, _, _, _) = dataConSig first_con
- data_ty = applyTyCon tycon (mkTyVarTys tyvars)
- -- tyvars of first_con may be free in field_ty
- in
-
-- Check that all the fields in the group have the same type
-- This check assumes that all the constructors of a given
-- data type use the same type variables
- checkTc (all (eqTy field_ty) other_tys)
+ = checkTc (all (eqTy field_ty) other_tys)
(fieldTypeMisMatch field_name) `thenTc_`
-
- -- Create an Id for the field itself
- tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) ->
- tcInstType tenv field_ty `thenNF_Tc` \ field_ty' ->
- let
- data_ty' = applyTyCon tycon tyvar_tys
- in
- newLocalId SLIT("x") field_ty' `thenNF_Tc` \ field_id ->
- newLocalId SLIT("r") data_ty' `thenNF_Tc` \ record_id ->
-
- -- Now build the selector
- let
- selector_ty :: Type
- selector_ty = mkForAllTys tyvars $
- mkFunTy data_ty $
- field_ty
+ returnTc selector_id
+ where
+ field_ty = fieldLabelType first_field_label
+ field_name = fieldLabelName first_field_label
+ other_tys = [fieldLabelType fl | (_, fl) <- other_fields]
+ (tyvars, _, _, _) = dataConSig first_con
+ data_ty = applyTyCon tycon (mkTyVarTys tyvars)
+ -- tyvars of first_con may be free in field_ty
+ -- Now build the selector
+
+ selector_ty :: Type
+ selector_ty = mkForAllTys tyvars $
+ mkFunTy data_ty $
+ field_ty
- selector_id :: Id
- selector_id = mkRecordSelId first_field_label selector_ty
-
- -- HsSyn is dreadfully verbose for defining the selector!
- selector_rhs = mkHsTyLam tyvars' $
- HsLam $
- PatMatch (VarPat record_id) $
- SimpleMatch $
- selector_body
-
- selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon)
-
- mk_match (con_id, field_label)
- = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $
- SimpleMatch $
- HsVar field_id
- in
- returnTc (selector_id, if isLocallyDefinedName (getName tycon)
- then VarMonoBind (RealId selector_id) selector_rhs
- else EmptyMonoBinds)
+ selector_id :: Id
+ selector_id = mkRecordSelId first_field_label selector_ty
\end{code}
Constructors
tcConDecl tycon tyvars ctxt (NewConDecl name ty src_loc)
= tcAddSrcLoc src_loc $
- tcMonoType ty `thenTc` \ arg_ty ->
+ tcHsType ty `thenTc` \ arg_ty ->
let
data_con = mkDataCon (getName name)
[NotMarkedStrict]
returnTc data_con
tcField (field_label_names, bty)
- = tcPolyType (get_pty bty) `thenTc` \ field_ty ->
+ = tcHsType (get_pty bty) `thenTc` \ field_ty ->
returnTc [(name, field_ty, get_strictness bty) | name <- field_label_names]
tcDataCon tycon tyvars ctxt name btys src_loc
stricts = map get_strictness btys
tys = map get_pty btys
in
- mapTc tcPolyType tys `thenTc` \ arg_tys ->
+ mapTc tcHsType tys `thenTc` \ arg_tys ->
let
data_con = mkDataCon (getName name)
stricts
import Id ( idType )
import Kind ( Kind )
import TcKind ( TcKind )
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import Usage ( SYN_IE(Usage), GenUsage, SYN_IE(UVar), duffUsage )
import TysPrim ( voidTy )
IMP_Ubiq()
-- friends:
-import TcMonad hiding ( rnMtoTcM )
+import TcMonad
import Type ( GenType(..), typeKind, mkFunTy, getFunTy_maybe )
import TyCon ( TyCon, mkFunTyCon )
import TyVar ( GenTyVar(..), SYN_IE(TyVar), tyVarKind )
classSuperDictSelId, classOpId, classDefaultMethodId,
classSig, classBigSig, classInstEnv,
isSuperClassOf,
- classOpTagByString, classOpTagByString_maybe,
-
- derivableClassKeys, needsDataDeclCtxtClassKeys,
- cCallishClassKeys, isNoDictClass,
- isNumericClass, isStandardClass, isCcallishClass,
+ classOpTagByOccName, classOpTagByOccName_maybe,
GenClassOp(..), SYN_IE(ClassOp),
mkClassOp,
import MatchEnv ( MatchEnv )
import Maybes ( assocMaybe )
-import Name ( changeUnique, Name )
+import Name ( changeUnique, Name, OccName, occNameString )
import Unique -- Keys for built-in classes
import Pretty ( SYN_IE(Pretty), ppCat, ppPStr )
---import PprStyle ( PprStyle )
+import PprStyle ( PprStyle(..) )
import SrcLoc ( SrcLoc )
import Util
\end{code}
\begin{code}
data GenClassOp ty
- = ClassOp FAST_STRING -- The operation name
+ = ClassOp OccName -- The operation name
Int -- Unique within a class; starts at 1
%************************************************************************
%* *
-\subsection[Class-std-groups]{Standard groups of Prelude classes}
-%* *
-%************************************************************************
-
-@derivableClassKeys@ is also used in checking \tr{deriving} constructs
-(@TcDeriv@).
-
-NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@
-even though every numeric class has these two as a superclass,
-because the list of ambiguous dictionaries hasn't been simplified.
-
-\begin{code}
-isNumericClass, isStandardClass :: Class -> Bool
-
-isNumericClass (Class key _ _ _ _ _ _ _ _ _) = --pprTrace "isNum:" (ppCat (map pprUnique (key : numericClassKeys ))) $
- key `is_elem` numericClassKeys
-isStandardClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` standardClassKeys
-isCcallishClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` cCallishClassKeys
-isNoDictClass (Class key _ _ _ _ _ _ _ _ _) = key `is_elem` noDictClassKeys
-is_elem = isIn "is_X_Class"
-
-numericClassKeys
- = [ numClassKey
- , realClassKey
- , integralClassKey
- , fractionalClassKey
- , floatingClassKey
- , realFracClassKey
- , realFloatClassKey
- ]
-
-derivableClassKeys
- = [ eqClassKey
- , ordClassKey
- , enumClassKey
- , evalClassKey
- , boundedClassKey
- , showClassKey
- , readClassKey
- , ixClassKey
- ]
-
-needsDataDeclCtxtClassKeys -- see comments in TcDeriv
- = [ readClassKey
- ]
-
-cCallishClassKeys = [ cCallableClassKey, cReturnableClassKey ]
-
-standardClassKeys
- = derivableClassKeys ++ numericClassKeys ++ cCallishClassKeys
- --
- -- We have to have "CCallable" and "CReturnable" in the standard
- -- classes, so that if you go...
- --
- -- _ccall_ foo ... 93{-numeric literal-} ...
- --
- -- ... it can do The Right Thing on the 93.
-
-noDictClassKeys -- These classes are used only for type annotations;
- -- they are not implemented by dictionaries, ever.
- = cCallishClassKeys
- -- I used to think that class Eval belonged in here, but
- -- we really want functions with type (Eval a => ...) and that
- -- means that we really want to pass a placeholder for an Eval
- -- dictionary. The unit tuple is what we'll get if we leave things
- -- alone, and that'll do for now. Could arrange to drop that parameter
- -- in the end.
-\end{code}
-
-%************************************************************************
-%* *
\subsection[Class-instances]{Instance declarations for @Class@}
%* *
%************************************************************************
instance NamedThing (GenClass tyvar uvar) where
getName (Class _ n _ _ _ _ _ _ _ _) = n
+
+instance NamedThing (GenClassOp ty) where
+ getOccName (ClassOp occ _ _) = occ
\end{code}
******************************************************************
\begin{code}
-mkClassOp :: FAST_STRING -> Int -> ty -> GenClassOp ty
+mkClassOp :: OccName -> Int -> ty -> GenClassOp ty
mkClassOp name tag ty = ClassOp name tag ty
classOpTag :: GenClassOp ty -> Int
classOpTag (ClassOp _ tag _) = tag
classOpString :: GenClassOp ty -> FAST_STRING
-classOpString (ClassOp str _ _) = str
+classOpString (ClassOp occ _ _) = occNameString occ
classOpLocalType :: GenClassOp ty -> ty {-SigmaType-}
classOpLocalType (ClassOp _ _ ty) = ty
Rather unsavoury ways of getting ClassOp tags:
\begin{code}
-classOpTagByString_maybe :: Class -> FAST_STRING -> Maybe Int
-classOpTagByString :: Class -> FAST_STRING -> Int
+classOpTagByOccName_maybe :: Class -> OccName -> Maybe Int
+classOpTagByOccName :: Class -> OccName -> Int
-classOpTagByString clas op
- = case (classOpTagByString_maybe clas op) of
+classOpTagByOccName clas op
+ = case (classOpTagByOccName_maybe clas op) of
Just tag -> tag
#ifdef DEBUG
- Nothing -> pprPanic "classOpTagByString:" (ppCat (ppPStr op : map (ppPStr . classOpString) (classOps clas)))
+ Nothing -> pprPanic "classOpTagByOccName:" (ppCat (ppr PprDebug op : map (ppPStr . classOpString) (classOps clas)))
#endif
-classOpTagByString_maybe clas op
- = go (map classOpString (classOps clas)) 1
+classOpTagByOccName_maybe clas op
+ = go (classOps clas) 1
where
- go [] _ = Nothing
- go (n:ns) tag = if n == op
- then Just tag
- else go ns (tag+1)
+ go [] _ = Nothing
+ go (ClassOp occ _ _ : ns) tag = if occ == op
+ then Just tag
+ else go ns (tag+1)
\end{code}
%************************************************************************
hasMoreBoxityInfo,
resultKind, argKind,
- isUnboxedKind, isTypeKind,
+ pprKind, pprParendKind,
+
+ isUnboxedTypeKind, isTypeKind, isBoxedTypeKind,
notArrowKind
) where
isTypeKind TypeKind = True
isTypeKind other = False
-isUnboxedKind :: Kind -> Bool
-isUnboxedKind UnboxedTypeKind = True
-isUnboxedKind other = False
+isBoxedTypeKind :: Kind -> Bool
+isBoxedTypeKind BoxedTypeKind = True
+isBoxedTypeKind other = False
+
+isUnboxedTypeKind :: Kind -> Bool
+isUnboxedTypeKind UnboxedTypeKind = True
+isUnboxedTypeKind other = False
hasMoreBoxityInfo :: Kind -> Kind -> Bool
instance Outputable Kind where
ppr sty kind = pprKind kind
-pprKind TypeKind = ppStr "*"
-pprKind BoxedTypeKind = ppStr "*b"
-pprKind UnboxedTypeKind = ppStr "*u"
-pprKind (ArrowKind k1 k2) = ppSep [pprKind_parend k1, ppStr "->", pprKind k2]
+pprKind TypeKind = ppStr "**" -- Can be boxed or unboxed
+pprKind BoxedTypeKind = ppStr "*"
+pprKind UnboxedTypeKind = ppStr "*#" -- Unboxed
+pprKind (ArrowKind k1 k2) = ppSep [pprParendKind k1, ppStr "->", pprKind k2]
-pprKind_parend k@(ArrowKind _ _) = ppBesides [ppLparen, pprKind k, ppRparen]
-pprKind_parend k = pprKind k
+pprParendKind k@(ArrowKind _ _) = ppBesides [ppLparen, pprKind k, ppRparen]
+pprParendKind k = pprKind k
\end{code}
#include "HsVersions.h"
module PprType(
- GenTyVar, pprGenTyVar,
+ GenTyVar, pprGenTyVar, pprTyVarBndr,
TyCon, pprTyCon, showTyCon,
GenType,
pprGenType, pprParendGenType,
pprType, pprParendType,
pprMaybeTy,
getTypeString,
- typeMaybeString,
specMaybeTysSuffix,
getTyDescription,
GenClass,
import TyCon ( TyCon(..), NewOrData )
import Class ( SYN_IE(Class), GenClass(..),
SYN_IE(ClassOp), GenClassOp(..) )
-import Kind ( Kind(..) )
+import Kind ( Kind(..), isBoxedTypeKind, pprParendKind )
import Usage ( pprUVar, GenUsage(..), SYN_IE(Usage), SYN_IE(UVar) )
-- others:
import CStrings ( identToC )
import CmdLineOpts ( opt_OmitInterfacePragmas )
import Maybes ( maybeToBool )
-import Name ( isLexVarSym, isLexSpecialSym, origName, moduleOf,
- getLocalName, Name{-instance Outputable-}
+import Name ( nameString, Name{-instance Outputable-},
+ OccName, pprOccName, getOccString, pprNonSymOcc
)
import Outputable ( ifPprShowAll, interpp'SP )
import PprEnv
pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
=> PprStyle -> GenType tyvar uvar -> Pretty
-pprGenType sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC ty
-pprParendGenType sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC ty
+pprGenType sty ty = ppr_ty (init_ppr_env sty) tOP_PREC ty
+pprParendGenType sty ty = ppr_ty (init_ppr_env sty) tYCON_PREC ty
-pprType sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC (ty :: Type)
-pprParendType sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC (ty :: Type)
+pprType, pprParendType :: PprStyle -> Type -> Pretty
+pprType sty ty = ppr_ty (init_ppr_env_type sty) tOP_PREC ty
+pprParendType sty ty = ppr_ty (init_ppr_env_type sty) tYCON_PREC ty
pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
=> PprStyle -> Maybe (GenType tyvar uvar) -> Pretty
\end{code}
\begin{code}
-ppr_ty :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
- => PprStyle -> PprEnv tyvar uvar bndr occ -> Int
+ppr_ty :: PprEnv tyvar uvar bndr occ -> Int
-> GenType tyvar uvar
-> Pretty
-ppr_ty sty env ctxt_prec (TyVarTy tyvar)
- = ppr_tyvar env tyvar
+ppr_ty env ctxt_prec (TyVarTy tyvar)
+ = pTyVarO env tyvar
-ppr_ty sty env ctxt_prec (TyConTy tycon usage)
- = ppr sty tycon
+ppr_ty env ctxt_prec (TyConTy tycon usage)
+ = ppr_tycon env tycon
-ppr_ty sty env ctxt_prec ty@(ForAllTy _ _)
- | showUserishTypes sty = ppr_ty sty env' ctxt_prec body_ty
-
- | otherwise = ppSep [ ppPStr SLIT("_forall_"),
- ppIntersperse pp'SP pp_tyvars,
- ppPStr SLIT("=>"),
- ppr_ty sty env' ctxt_prec body_ty
- ]
+ppr_ty env ctxt_prec ty@(ForAllTy _ _)
+ | show_forall = ppSep [ ppPStr SLIT("_forall_"), pp_tyvars,
+ pp_theta, ppPStr SLIT("=>"), pp_body
+ ]
+ | null theta = pp_body
+ | otherwise = ppSep [pp_theta, ppPStr SLIT("=>"), pp_body]
where
- (tyvars, body_ty) = splitForAllTy ty
- env' = foldl add_tyvar env tyvars
- pp_tyvars = map (ppr_tyvar env') tyvars
-
-ppr_ty sty env ctxt_prec (ForAllUsageTy uv uvs ty)
+ (tyvars, rho_ty) = splitForAllTy ty
+ (theta, body_ty) | show_context = splitRhoTy rho_ty
+ | otherwise = ([], rho_ty)
+
+ pp_tyvars = ppBracket (ppIntersperse ppSP (map (pTyVarB env) tyvars))
+ pp_theta | null theta = ppNil
+ | otherwise = ppCurlies (ppInterleave ppComma (map (ppr_dict env tOP_PREC) theta))
+ pp_body = ppr_ty env ctxt_prec body_ty
+
+ sty = pStyle env
+ show_forall = case sty of
+ PprForUser -> False
+ other -> True
+
+ show_context = case sty of
+ PprInterface -> True
+ PprForUser -> True
+ other -> False
+
+ppr_ty env ctxt_prec (ForAllUsageTy uv uvs ty)
= panic "ppr_ty:ForAllUsageTy"
-ppr_ty sty env ctxt_prec ty@(FunTy (DictTy _ _ _) _ _)
- | showUserishTypes sty
- -- Print a nice looking context (Eq a, Text b) => ...
- = ppSep [ppBeside (ppr_theta theta) (ppPStr SLIT(" =>")),
- ppr_ty sty env ctxt_prec body_ty
- ]
- where
- (theta, body_ty) = splitRhoTy ty
-
- ppr_theta = case sty of { PprInterface -> ppr_theta_2 ; _ -> ppr_theta_1 }
-
- ppr_theta_1 [ct] = ppr_dict sty env tOP_PREC ct
- ppr_theta_1 cts = ppParens (ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts))
-
- ppr_theta_2 cts = ppBesides [ppStr "{{", ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts), ppStr "}}"]
-
-ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
+ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
-- We fiddle the precedences passed to left/right branches,
-- so that right associativity comes out nicely...
= maybeParen ctxt_prec fUN_PREC
- (ppCat [ppr_ty sty env fUN_PREC ty1,
+ (ppCat [ppr_ty env fUN_PREC ty1,
ppPStr SLIT("->"),
- ppr_ty sty env tOP_PREC ty2])
+ ppr_ty env tOP_PREC ty2])
-ppr_ty sty env ctxt_prec ty@(AppTy _ _)
- = ppr_corner sty env ctxt_prec fun_ty arg_tys
+ppr_ty env ctxt_prec ty@(AppTy _ _)
+ = ppr_corner env ctxt_prec fun_ty arg_tys
where
(fun_ty, arg_tys) = splitAppTy ty
-ppr_ty sty env ctxt_prec (SynTy tycon tys expansion)
- | codeStyle sty
+ppr_ty env ctxt_prec (SynTy tycon tys expansion)
+ | codeStyle (pStyle env)
-- always expand types that squeak into C-variable names
- = ppr_ty sty env ctxt_prec expansion
+ = ppr_ty 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 tOP_PREC expansion,
- ppStr "-}"]))
+ (ppr_app env ctxt_prec (ppr_tycon env tycon) tys)
+ (ifPprShowAll (pStyle env) (ppCat [ppStr " {- expansion:",
+ ppr_ty env tOP_PREC expansion,
+ ppStr "-}"]))
+
+ppr_ty env ctxt_prec (DictTy clas ty usage)
+ = ppCurlies (ppr_dict env tOP_PREC (clas, ty))
+ -- Curlies are temporary
-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
+ppr_corner env ctxt_prec (TyConTy FunTyCon usage) arg_tys
| length arg_tys == 2
- = ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
+ = ppr_ty env ctxt_prec (FunTy ty1 ty2 usage)
where
(ty1:ty2:_) = arg_tys
-ppr_corner sty env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys
- | not (codeStyle sty) -- no magic in that case
+ppr_corner env ctxt_prec (TyConTy (TupleTyCon _ _ a) usage) arg_tys
+ | not (codeStyle (pStyle env)) -- 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]
where
- arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty sty env tOP_PREC) arg_tys)
+ arg_tys_w_commas = ppIntersperse pp'SP (map (ppr_ty env tOP_PREC) arg_tys)
-ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
- | not (codeStyle sty) && uniqueOf tycon == listTyConKey
+ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
+ | not (codeStyle (pStyle env)) && uniqueOf tycon == listTyConKey
= ASSERT(length arg_tys == 1)
- ppBesides [ppLbrack, ppr_ty sty env tOP_PREC ty1, ppRbrack]
+ ppBesides [ppLbrack, ppr_ty env tOP_PREC ty1, ppRbrack]
where
(ty1:_) = arg_tys
-ppr_corner sty env ctxt_prec (TyConTy tycon usage) arg_tys
- = ppr_app sty env ctxt_prec (ppr sty tycon) arg_tys
+ppr_corner env ctxt_prec (TyConTy tycon usage) arg_tys
+ = ppr_app env ctxt_prec (ppr_tycon env tycon) arg_tys
-ppr_corner sty env ctxt_prec (TyVarTy tyvar) arg_tys
- = ppr_app sty env ctxt_prec (ppr_tyvar env tyvar) arg_tys
+ppr_corner env ctxt_prec (TyVarTy tyvar) arg_tys
+ = ppr_app env ctxt_prec (pTyVarO env tyvar) arg_tys
-ppr_app sty env ctxt_prec pp_fun []
+ppr_app env ctxt_prec pp_fun []
= pp_fun
-ppr_app sty env ctxt_prec pp_fun arg_tys
+ppr_app env ctxt_prec pp_fun arg_tys
= maybeParen ctxt_prec tYCON_PREC (ppCat [pp_fun, arg_tys_w_spaces])
where
- arg_tys_w_spaces = ppIntersperse ppSP (map (ppr_ty sty env tYCON_PREC) arg_tys)
+ arg_tys_w_spaces = ppIntersperse ppSP (map (ppr_ty env tYCON_PREC) arg_tys)
-ppr_dict sty env ctxt_prec (clas, ty)
+ppr_dict env ctxt_prec (clas, ty)
= maybeParen ctxt_prec tYCON_PREC
- (ppCat [ppr sty clas, ppr_ty sty env tYCON_PREC ty])
+ (ppCat [ppr_class env clas, ppr_ty env tYCON_PREC ty])
\end{code}
-This stuff is effectively stubbed out for the time being
-(WDP 960425):
\begin{code}
+ -- This one uses only "ppr"
init_ppr_env sty
- = initPprEnv sty b b b b b b b b b b b
+ = initPprEnv sty b b b b (Just (ppr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b
where
b = panic "PprType:init_ppr_env"
-ppr_tyvar env tyvar = ppr (pStyle env) tyvar
-ppr_uvar env uvar = ppr (pStyle env) uvar
+ -- This one uses pprTyVarBndr, and thus is specific to GenTyVar's types
+init_ppr_env_type sty
+ = initPprEnv sty b b b b (Just (pprTyVarBndr sty)) (Just (ppr sty)) (Just (ppr sty)) b b b b b
+ where
+ b = panic "PprType:init_ppr_env"
-add_tyvar env tyvar = env
-add_uvar env uvar = env
+ppr_tycon env tycon = ppr (pStyle env) tycon
+ppr_class env clas = ppr (pStyle env) clas
\end{code}
@ppr_ty@ takes an @Int@ that is the precedence of the context.
where
pp_u = pprUnique uniq
pp_name = case name of
- Just n -> ppPStr (getLocalName n)
+ Just n -> pprOccName sty (getOccName n)
Nothing -> case kind of
TypeKind -> ppChar 'o'
BoxedTypeKind -> ppChar 't'
ArrowKind _ _ -> ppChar 'a'
\end{code}
+We print type-variable binders with their kinds in interface files.
+
+\begin{code}
+pprTyVarBndr sty@PprInterface tyvar@(TyVar uniq kind name usage)
+ | not (isBoxedTypeKind kind)
+ = ppBesides [pprGenTyVar sty tyvar, ppStr "::", pprParendKind kind]
+
+pprTyVarBndr sty tyvar = pprGenTyVar sty tyvar
+\end{code}
+
%************************************************************************
%* *
\subsection[TyCon]{@TyCon@}
mangle '>' = ppPStr SLIT("Zg")
pprTyCon :: PprStyle -> TyCon -> Pretty
+pprTyCon sty tycon = ppr sty (getName tycon)
+
+{- This old code looks suspicious to me.
+ Just printing the name should do the job; apart from the extra junk
+ on SynTyCons etc.
+
+ Let's try and live without all this...
+ Delete in due course. SLPJ Nov 96
pprTyCon sty (PrimTyCon _ name _ _) = ppr sty name
n -> maybe_code sty ( "(" ++ nOfThem (n-1) ',' ++ ")" )
pprTyCon sty tycon@(DataTyCon uniq name kind tyvars ctxt cons derivings nd)
- | uniq == listTyConKey
- = maybe_code sty "[]"
- | otherwise
= ppr sty name
pprTyCon sty (SpecTyCon tc ty_maybes)
interpp'SP sty tyvars,
pprParendGenType sty expansion,
ppStr "-}"]))
+-}
\end{code}
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_C = ppr sty op_name
+ pp_user = pprNonSymOcc sty op_name
pp_sigd = ppCat [pp_user, ppPStr SLIT("::"), ppr sty ty]
\end{code}
-- Produces things like what we have in mkCompoundName,
-- which can be "dot"ted together...
-getTypeString :: Type -> [Either OrigName FAST_STRING]
+getTypeString :: Type -> FAST_STRING
getTypeString ty
= case (splitAppTy ty) of { (tc, args) ->
- do_tc tc : map do_arg_ty args }
+ _CONCAT_ (do_tc tc : map do_arg_ty args) }
where
- do_tc (TyConTy tc _) = Left (origName "do_tc" tc)
+ do_tc (TyConTy tc _) = nameString (getName 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)))
+ (_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 (TyConTy tc _) = nameString (getName tc)
+ do_arg_ty (TyVarTy tv) = _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)))
+ _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
- tidy [] = [] -- done
-
- tidy (' ' : more)
- = case more of
- ' ' : _ -> tidy more
- '-' : '>' : xs -> '-' : '>' : tidy (no_leading_sps xs)
- other -> ' ' : tidy more
-
- tidy (',' : more) = ',' : tidy (no_leading_sps more)
-
- tidy (x : xs) = x : tidy xs -- catch all
-
- no_leading_sps [] = []
- no_leading_sps (' ':xs) = no_leading_sps xs
- no_leading_sps other = other
-
-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"
TyVarTy _ -> "*"
AppTy fun _ -> getTyDescription fun
FunTy _ res _ -> '-' : '>' : fun_result res
- TyConTy tycon _ -> _UNPK_ (getLocalName tycon)
- SynTy tycon _ _ -> _UNPK_ (getLocalName tycon)
+ TyConTy tycon _ -> getOccString tycon
+ SynTy tycon _ _ -> getOccString tycon
DictTy _ _ _ -> "dict"
ForAllTy _ ty -> getTyDescription ty
_ -> pprPanic "getTyDescription: other" (pprType PprDebug tau_ty)
SYN_IE(Class), GenClass,
SYN_IE(Id), GenId,
splitSigmaTy, splitFunTy,
- mkTupleCon, isNullaryDataCon, idType
+ tupleCon, isNullaryDataCon, idType
--LATER: specMaybeTysSuffix
)
import Kind ( Kind, mkBoxedTypeKind, mkArrowKind, resultKind, argKind )
import Maybes
-import Name ( Name, RdrName(..), appendRdr, nameUnique,
- mkTupleTyConName, mkFunTyConName
- )
-import Unique ( Unique, funTyConKey, mkTupleTyConUnique )
+import Name ( Name, nameUnique, mkWiredInTyConName )
+import Unique ( Unique, funTyConKey )
import Pretty ( SYN_IE(Pretty), PrettyRep )
import PrimRep ( PrimRep(..) )
+import PrelMods ( gHC__, pREL_TUP, pREL_BASE )
+import Lex ( mkTupNameStr )
import SrcLoc ( SrcLoc, mkBuiltinSrcLoc )
import Util ( nOfThem, isIn, Ord3(..), panic, panic#, assertPanic )
--import {-hide me-}
\end{code}
\begin{code}
-mkFunTyCon = FunTyCon
-mkSpecTyCon = SpecTyCon
+mkFunTyCon = FunTyCon
+mkFunTyConName = mkWiredInTyConName funTyConKey gHC__ SLIT("->") FunTyCon
-mkTupleTyCon arity
- = TupleTyCon u n arity
- where
- n = mkTupleTyConName arity
- u = uniqueOf n
+mkSpecTyCon = SpecTyCon
+mkTupleTyCon = TupleTyCon
mkDataTyCon name = DataTyCon (nameUnique name) name
mkPrimTyCon name = PrimTyCon (nameUnique name) name
tyConFamilySize :: TyCon -> Int
tyConDataCons (DataTyCon _ _ _ _ _ data_cons _ _) = data_cons
-tyConDataCons (TupleTyCon _ _ a) = [mkTupleCon a]
+tyConDataCons (TupleTyCon _ _ a) = [tupleCon a]
tyConDataCons other = []
-- You may think this last equation should fail,
-- but it's quite convenient to return no constructors for
\begin{code}
maybeTyConSingleCon :: TyCon -> Maybe Id
-maybeTyConSingleCon (TupleTyCon _ _ arity) = Just (mkTupleCon arity)
+maybeTyConSingleCon (TupleTyCon _ _ arity) = Just (tupleCon arity)
maybeTyConSingleCon (DataTyCon _ _ _ _ _ [c] _ _) = Just c
maybeTyConSingleCon (DataTyCon _ _ _ _ _ _ _ _) = Nothing
maybeTyConSingleCon (PrimTyCon _ _ _ _) = Nothing
getName other_tc = moduleNamePair (expectJust "tycon1" (getName other_tc))
getName other = Nothing
-}
+
\end{code}
import Unique ( Unique )
import FieldLabel ( FieldLabel )
-import Id ( Id, GenId, StrictnessMark, mkTupleCon, mkDataCon,
+import Id ( Id, GenId, StrictnessMark, mkDataCon, mkTupleCon,
isNullaryDataCon, dataConArgTys, idType )
+import TysWiredIn ( tupleCon, tupleTyCon )
import PprType ( specMaybeTysSuffix )
import Name ( Name )
import TyCon ( TyCon )
type Id = GenId (GenType (GenTyVar (GenUsage Unique)) Unique)
-- Needed in TyCon
-mkTupleCon :: Int -> Id
+tupleCon :: Int -> Id
isNullaryDataCon :: Id -> Bool
specMaybeTysSuffix :: [Maybe Type] -> _PackedString
idType :: Id -> Type
instance Eq (GenClass a b)
-- Needed in Type
+tupleTyCon :: Int -> TyCon
dataConArgTys :: Id -> [Type] -> [Type]
voidTy :: Type
mkDataCon :: Name -> [StrictnessMark] -> [FieldLabel]
-> [TyVar] -> [(Class,Type)] -> [Type] -> TyCon
-> Id
+mkTupleCon :: Int -> Name -> Type -> Id
\end{code}
import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM,
plusUFM, sizeUFM, delFromUFM, UniqFM
)
-import Name ( mkLocalName, changeUnique, Name, RdrName(..) )
+import Name ( mkSysLocalName, changeUnique, Name )
import Pretty ( SYN_IE(Pretty), PrettyRep, ppBeside, ppPStr )
import PprStyle ( PprStyle )
--import Outputable ( Outputable(..), NamedThing(..), ExportFlag(..) )
-import SrcLoc ( mkUnknownSrcLoc, SrcLoc )
+import SrcLoc ( noSrcLoc, SrcLoc )
import Unique ( showUnique, mkAlphaTyVarUnique, Unique )
import Util ( panic, Ord3(..) )
\end{code}
instance NamedThing (GenTyVar a) where
getName (TyVar _ _ (Just n) _) = n
- getName (TyVar u _ _ _) = mkLocalName u (showUnique u) True{-emph uniq-} mkUnknownSrcLoc
+ getName (TyVar u _ _ _) = mkSysLocalName u SLIT("t") noSrcLoc
\end{code}
isTauTy,
- tyVarsOfType, tyVarsOfTypes, typeKind
+ tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind
) where
IMP_Ubiq()
-- friends:
import Class ( classSig, classOpLocalType, GenClass{-instances-} )
import Kind ( mkBoxedTypeKind, resultKind, notArrowKind, Kind )
-import TyCon ( mkFunTyCon, mkTupleTyCon, isFunTyCon,
+import TyCon ( mkFunTyCon, isFunTyCon,
isPrimTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon,
tyConKind, tyConDataCons, getSynTyConDefn, TyCon )
import TyVar ( tyVarKind, GenTyVar{-instances-}, SYN_IE(GenTyVarSet),
nullUVarEnv, addOneToUVarEnv, lookupUVarEnv, eqUVar,
eqUsage )
+import Name ( NamedThing(..),
+ NameSet(..), unionNameSets, emptyNameSet, unitNameSet, minusNameSet
+ )
+
-- others
import Maybes ( maybeToBool, assocMaybe )
import PrimRep ( PrimRep(..) )
-- no methods!
other -> ASSERT(not (null all_arg_tys))
- foldl AppTy (TyConTy (mkTupleTyCon (length all_arg_tys)) u) all_arg_tys
+ foldl AppTy (TyConTy (tupleTyCon (length all_arg_tys)) u) all_arg_tys
-- A tuple of 'em
-- Note: length of all_arg_tys can be 0 if the class is
(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 True (ForAllTy _ ty) = getFunTyExpandingDicts_maybe True ty
+ -- Ignore for-alls when peeking. See note with defn of getFunTyExpandingDictsAndPeeking
+
getFunTyExpandingDicts_maybe peek other
| not peek = Nothing -- that was easy
| otherwise
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
+ -- This "peeking" stuff is used only by the code generator.
+ -- It's interested in the representation type of things, ignoring:
+ -- newtype
+ -- foralls
+ -- expanding dictionary reps
+ -- synonyms, of course
split_fun_ty get t = go t []
where
tyVarsOfTypes :: [GenType (GenTyVar flexi) uvar] -> GenTyVarSet flexi
tyVarsOfTypes tys = foldr (unionTyVarSets.tyVarsOfType) emptyTyVarSet tys
+
+-- Find the free names of a type, including the type constructors and classes it mentions
+namesOfType :: GenType (GenTyVar flexi) uvar -> NameSet
+namesOfType (TyVarTy tv) = unitNameSet (getName tv)
+namesOfType (TyConTy tycon usage) = unitNameSet (getName tycon)
+namesOfType (SynTy tycon tys ty) = unitNameSet (getName tycon) `unionNameSets`
+ namesOfType ty
+namesOfType (FunTy arg res _) = namesOfType arg `unionNameSets` namesOfType res
+namesOfType (AppTy fun arg) = namesOfType fun `unionNameSets` namesOfType arg
+namesOfType (DictTy clas ty _) = unitNameSet (getName clas) `unionNameSets`
+ namesOfType ty
+namesOfType (ForAllTy tyvar ty) = namesOfType ty `minusNameSet` unitNameSet (getName tyvar)
+namesOfType (ForAllUsageTy _ _ ty) = panic "forall usage"
\end{code}
minusFM,
foldFM,
- IF_NOT_GHC(intersectFM COMMA)
- IF_NOT_GHC(intersectFM_C COMMA)
- IF_NOT_GHC(mapFM COMMA filterFM COMMA)
+ intersectFM,
+ intersectFM_C,
+ mapFM, filterFM,
sizeFM, isEmptyFM, elemFM, lookupFM, lookupWithDefaultFM,
#endif
) where
+IMPORT_DELOOPER(SpecLoop)
import Maybes
+import Bag ( Bag, foldBag )
+import Outputable ( Outputable(..) )
-#ifdef COMPILING_GHC
-IMP_Ubiq(){-uitous-}
# ifdef DEBUG
-import Pretty
+import PprStyle ( PprStyle )
+import Pretty ( SYN_IE(Pretty), PrettyRep )
# endif
-import Bag ( foldBag )
+
+#ifdef COMPILING_GHC
# if ! OMIT_NATIVE_CODEGEN
# define IF_NCG(a) a
-- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2
intersectFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-intersectFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt)
- -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
+intersectFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt2)
+ -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt2
-- MAPPING, FOLDING, FILTERING
foldFM :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
#if defined(COMPILING_GHC)
-CHK_Ubiq() -- debugging consistency check
+CHK_Ubiq() -- debugging consistency check
-import Unique (Unique) -- only for specialising
+IMPORT_DELOOPER( SpecLoop ) -- Specialisation
+import Unique (Unique) -- only for specialising
#else
import Maybe -- renamer will tell us if there are any conflicts
:: [(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}
module PprStyle (
PprStyle(..),
- codeStyle,
+ codeStyle, ifaceStyle,
showUserishTypes
) where
shown.
The following test decides whether or not we are actually generating
-code (either C or assembly).
+code (either C or assembly), or generating interface files.
\begin{code}
codeStyle :: PprStyle -> Bool
codeStyle PprForC = True
codeStyle (PprForAsm _ _) = True
codeStyle _ = False
+
+ifaceStyle :: PprStyle -> Bool
+ifaceStyle PprInterface = True
+ifaceStyle other = False
\end{code}
\begin{code}
-- True means types like (Eq a, Text b) => a -> b
-- False means types like _forall_ a b => Eq a -> Text b -> a -> b
showUserishTypes PprForUser = True
-showUserishTypes PprInterface = True
showUserishTypes other = False
\end{code}
#endif
ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen,
ppSemi, ppComma, ppEquals,
- ppBracket, ppParens, ppQuote,
+ ppBracket, ppParens, ppQuote, ppCurlies,
ppCat, ppBeside, ppBesides, ppAbove, ppAboves,
ppNest, ppSep, ppHang, ppInterleave, ppIntersperse,
ppBracket p = ppBeside ppLbrack (ppBeside p ppRbrack)
ppParens p = ppBeside ppLparen (ppBeside p ppRparen)
+ppCurlies p = ppBeside (ppChar '{') (ppBeside p (ppChar '}'))
ppQuote p = ppBeside (ppChar '`') (ppBeside p (ppChar '\''))
ppInterleave sep ps = ppSep (pi ps)
thenSST, thenSST_, returnSST, fixSST,
thenFSST, thenFSST_, returnFSST, failFSST,
recoverFSST, recoverSST, fixFSST,
+ unsafeInterleaveSST,
newMutVarSST, readMutVarSST, writeMutVarSST
#if __GLASGOW_HASKELL__ >= 200
runSST :: SST REAL_WORLD r -> r
runSST m = case m realWorld# of SST_R r s -> r
+unsafeInterleaveSST :: SST s r -> SST s r
+unsafeInterleaveSST m s = SST_R r s -- Duplicates the state!
+ where
+ SST_R r _ = m s
+
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
import FieldLabel ( FieldLabel )
import FiniteMap ( FiniteMap )
import HeapOffs ( HeapOffset )
-import HsCore ( UnfoldingCoreExpr )
import HsPat ( OutPat )
import HsPragmas ( ClassOpPragmas, ClassPragmas, DataPragmas, GenPragmas, InstancePragmas )
import Id ( StrictnessMark, GenId, Id(..) )
-import IdInfo ( IdInfo, OptIdInfo(..), ArityInfo, DeforestInfo, Demand, StrictnessInfo, UpdateInfo )
+import IdInfo ( IdInfo, ArityInfo, DeforestInfo, StrictnessInfo, UpdateInfo )
+import Demand ( Demand )
import Kind ( Kind )
import Literal ( Literal )
import MachRegs ( Reg )
import Maybes ( MaybeErr )
import MatchEnv ( MatchEnv )
-import Name ( Module(..), OrigName, RdrName, Name, ExportFlag, NamedThing(..) )
+import Name ( Module(..), OccName, Name, ExportFlag, NamedThing(..) )
import Outputable ( Outputable(..) )
import PprStyle ( PprStyle )
import PragmaInfo ( PragmaInfo )
import Pretty ( PrettyRep )
import PrimOp ( PrimOp )
import PrimRep ( PrimRep )
-import RnHsSyn ( RnName )
import SMRep ( SMRep )
import SrcLoc ( SrcLoc )
import TcType ( TcMaybe )
-- to try to contain their visibility.
class NamedThing a where
- getName :: a -> Name
-class OptIdInfo a where
- noInfo :: a
- getInfo :: IdInfo -> a
- addInfo :: IdInfo -> a -> IdInfo
- ppInfo :: PprStyle -> (Id -> Id) -> a -> Int -> Bool -> PrettyRep
+ getOccName :: a -> OccName
+ getName :: a -> Name
+
class Ord3 a where
cmp :: a -> a -> Int#
class Outputable a where
data MaybeErr a b
data MatchEnv a b
data Name
-data OrigName = OrigName _PackedString _PackedString
-data RdrName = Unqual _PackedString | Qual _PackedString _PackedString
+data OccName
data Reg
data OutPat a b c
data PprStyle
data PrettyRep
data PrimOp
data PrimRep -- NB: an enumeration
-data RnName
data SimplifierSwitch
data SMRep
data SrcLoc
-data StrictnessInfo
+data StrictnessInfo bdee
data StrictnessMark
data SwitchResult
data TcMaybe s
data TyCon
-data UnfoldingCoreExpr a
data UniqFM a
data UpdateInfo
data UniqSupply
-- These are here only for SPECIALIZing in FiniteMap (ToDo:move?)
instance Ord Reg
-instance Ord OrigName
-instance Ord RdrName
instance Ord CLabel
instance Ord TyCon
instance Eq Reg
-instance Eq OrigName
-instance Eq RdrName
instance Eq CLabel
instance Eq TyCon
-- specializing in UniqFM, UniqSet
instance Uniquable Unique
-instance Uniquable RnName
instance Uniquable Name
-- specializing in Name
-instance NamedThing RnName
\end{code}
) where
#if defined(COMPILING_GHC)
-IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER( SpecLoop )
#endif
import Unique ( Unique, u2i, mkUniqueGrimily )
import Util
import Pretty ( SYN_IE(Pretty), PrettyRep )
+import Outputable ( Outputable(..) )
import PprStyle ( PprStyle )
import SrcLoc ( SrcLoc )
{-# SPECIALIZE
addListToUFM :: UniqFM elt -> [(Name, elt)] -> UniqFM elt
- , UniqFM elt -> [(RnName, elt)] -> UniqFM elt
#-}
{-# SPECIALIZE
addListToUFM_C :: (elt -> elt -> elt) -> UniqFM elt -> [(Name, elt)] -> UniqFM elt
- , (elt -> elt -> elt) -> UniqFM elt -> [(RnName,elt)] -> UniqFM elt
#-}
{-# SPECIALIZE
addToUFM :: UniqFM elt -> Unique -> elt -> UniqFM elt
#-}
{-# SPECIALIZE
listToUFM :: [(Unique, elt)] -> UniqFM elt
- , [(RnName, elt)] -> UniqFM elt
#-}
{-# SPECIALIZE
lookupUFM :: UniqFM elt -> Name -> Maybe elt
- , UniqFM elt -> RnName -> Maybe elt
, UniqFM elt -> Unique -> Maybe elt
#-}
-{-# SPECIALIZE
- lookupWithDefaultUFM :: UniqFM elt -> elt -> RnName -> elt
- #-}
#endif {- __GLASGOW_HASKELL__ -}
\end{code}
SYN_IE(UniqSet), -- abstract type: NOT
mkUniqSet, uniqSetToList, emptyUniqSet, unitUniqSet,
- addOneToUniqSet,
+ addOneToUniqSet, addListToUniqSet,
unionUniqSets, unionManyUniqSets, minusUniqSet,
elementOfUniqSet, mapUniqSet, intersectUniqSets,
- isEmptyUniqSet
+ isEmptyUniqSet, filterUniqSet, sizeUniqSet
) where
-IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER( SpecLoop )
import Maybes ( maybeToBool )
import UniqFM
import Unique ( Unique )
import SrcLoc ( SrcLoc )
+import Outputable ( Outputable(..) )
import Pretty ( SYN_IE(Pretty), PrettyRep )
import PprStyle ( PprStyle )
import Util ( Ord3(..) )
mkUniqSet xs = MkUniqSet (listToUFM [ (x, x) | x <- xs])
addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a
-addOneToUniqSet set x = set `unionUniqSets` unitUniqSet x
+addOneToUniqSet (MkUniqSet set) x = MkUniqSet (addToUFM set x x)
+
+addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a
+addListToUniqSet (MkUniqSet set) xs = MkUniqSet (addListToUFM set [(x,x) | x<-xs])
unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a
unionUniqSets (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (plusUFM set1 set2)
minusUniqSet :: UniqSet a -> UniqSet a -> UniqSet a
minusUniqSet (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (minusUFM set1 set2)
+filterUniqSet :: (a -> Bool) -> UniqSet a -> UniqSet a
+filterUniqSet pred (MkUniqSet set) = MkUniqSet (filterUFM pred set)
+
intersectUniqSets :: UniqSet a -> UniqSet a -> UniqSet a
intersectUniqSets (MkUniqSet set1) (MkUniqSet set2) = MkUniqSet (intersectUFM set1 set2)
elementOfUniqSet :: Uniquable a => a -> UniqSet a -> Bool
elementOfUniqSet x (MkUniqSet set) = maybeToBool (lookupUFM set x)
+sizeUniqSet :: UniqSet a -> Int
+sizeUniqSet (MkUniqSet set) = sizeUFM set
+
isEmptyUniqSet :: UniqSet a -> Bool
isEmptyUniqSet (MkUniqSet set) = isNullUFM set {-SLOW: sizeUFM set == 0-}
addOneToUniqSet :: UniqSet Unique -> Unique -> UniqSet Unique
#-}
{-# SPECIALIZE
- elementOfUniqSet :: RnName -> UniqSet RnName -> Bool
+ elementOfUniqSet :: Name -> UniqSet Name -> Bool
, Unique -> UniqSet Unique -> Bool
#-}
{-# SPECIALIZE
- mkUniqSet :: [RnName] -> UniqSet RnName
+ mkUniqSet :: [Name] -> UniqSet Name
#-}
{-# SPECIALIZE
- unitUniqSet :: RnName -> UniqSet RnName
+ unitUniqSet :: Name -> UniqSet Name
, Unique -> UniqSet Unique
#-}
#endif
\begin{document}
-\title{GHC prelude: types and operations}
-\author{Simon L Peyton Jones \and John Launchbury \and Will Partain}
+\title{The GHC Prelude and Libraries}
+\author{Simon L Peyton Jones \and Will Partain}
\maketitle
\tableofcontents
-This ``state interface document'' corresponds to Glasgow Haskell
-version~2.01.
+\section{Introduction}
-\section{Really primitive stuff}
+This document describes GHC's prelude and libraries. The basic story is that of
+the Haskell 1.3 Report and Libraries document (which we do not reproduce here),
+but this document describes in addition:
+\begin{itemize}
+\item GHC's additional non-standard libraries and types, such as state transformers,
+ packed strings, foreign objects, stable pointers, and so on.
+
+\item GHC's primitive types and operations. The standard Haskell functions are implemented
+ on top of these, and it is sometimes useful to use them directly.
+
+\item The organsiation of these libraries into directories.
+\end{itemize}
+
+\section{Overview}
+
+The libraries are organised into the following three groups, each of which
+is kept in a separate sub-directory of GHC's installed @lib/@ directory:
+\begin{description}
+\item[@lib/required/@] These are the libraries {\em required} by the Haskell
+definition. All are defined by the Haskell Report, or by the Haskell Libraries Report.
+They currently comprise:
+\begin{itemize}
+\item @Prelude@.
+\item @List@: more functions on lists.
+\item @Char@: more functions on characters.
+\item @Maybe@: more functions on @Maybe@ types.
+\item @Complex@: functions on complex numbers.
+\item @Ratio@: functions on rational numbers.
+\item @Monad@: functions on characters.
+\item @Ix@: the @Ix@ class of indexing operations.
+\item @Array@: monolithic arrays.
+\item @IO@: basic input/output functions.
+\item @Directory@: basic functions for accessing the file system.
+\item @System@: basic operating-system interface functions.
+\end{itemize}
+
+\item[@lib/glaExts@] GHC extension libraries, currently comprising:
+\begin{itemize}
+\item @PackedString@: functions that manipulate strings packed efficiently, one character per byte.
+\item @ST@: the state transformer monad.
+\item @Foreign@: types and operations for GHC's foreign-language interface.
+\end{itemize}
+
+\item[@lib/concurrent@] GHC extension libraries to support Concurrent Haskell, currently comprising:
+\begin{itemize}
+\item @Concurrent.hs@: main library.
+\item @Parallel.hs@: stuff for multi-processor parallelism.
+\item @Channel.hs@
+\item @ChannelVar.hs@
+\item @Merge.hs@
+\item @SampleVar.hs@
+\item @Semaphore.hs@
+\end{itemize}
+
+\item[@lib/ghc@] These libraries are the pieces on which all the others are built.
+They aren't typically imported by Joe Programmer, but there's nothing to stop you
+doing so if you want. In general, the modules prefixed by @Prel@ are pieces that go
+towards building @Prelude@.
+
+\begin{itemize}
+\item @GHC@: this ``library'' brings into scope all the primitive types and operations, such as
+@Int#@, @+#@, @encodeFloat#@, etc etc. It is unique in that there is no Haskell
+source code for it. Details in Section \ref{sect:ghc}.
+
+\item @PrelBase@: defines the basic types and classes without which very few Haskell programs can work.
+The classes are: @Eq@, @Ord@, @Enum@, @Bounded@, @Num@, @Show@, @Eval@, @Monad@, @MonadZero@, @MonadPlus@.
+The types are: list, @Bool@, @Char@, @Ordering@, @String@, @Int@, @Integer@, @Maybe@, @Either@.
+
+\item @PrelTup@: defines tuples and their instances.
+\item @PrelList@: defines most of the list operations required by @Prelude@. (A few are in @PrelBase@.
+
+\item @PrelNum@ defines: the numeric classes beyond @Num@ (namely @Real@, @Integral@,
+@Fractional@, @Floating@, @RealFrac@, @RealFloat@; instances for appropriate classes
+for @Int@ and @Integer@; the types @Float@, @Double@, and @Ratio@ and their instances.
+
+\item @PrelRead@: the @Read@ class and all its instances. It's kept separate because many programs
+don't use @Read@ at all, so we don't even want to link in its code.
+
+\item @ConcBase@: substrate stuff for Concurrent Haskell.
+
+\item @IOBase@: substrate stuff for the main I/O libraries.
+\item @IOHandle@: large blob of code for doing I/O on handles.
+\item @PrelIO@: the remaining small pieces to produce the I/O stuff needed by @Prelude@.
+\item @GHCerr@: error reporting code, called from code that the compiler plants in compiled programs.
+\item @GHCmain@: the definition of @mainPrimIO@, which is what {\em really} gets
+ called by the runtime system. @mainPrimIO@ in turn calls @main@.
+\end{itemize}
+\end{description}
+
+\section{The module @GHC@: really primitive stuff}
+\label{sect:ghc}
This section defines all the types which are primitive in Glasgow Haskell, and the
operations provided for them.
-A primitive type is one which cannot be defined in Haskell, and which is
-therefore built into the language and compiler.
-Primitive types are always unboxed; that is, a value of primitive type cannot be
+A primitive type is one which cannot be defined in Haskell, and which
+is therefore built into the language and compiler. Primitive types
+are always unboxed; that is, a value of primitive type cannot be
bottom.
Primitive values are often represented by a simple bit-pattern, such as @Int#@,
%************************************************************************
\begin{code}
+%OldVersion = ();
+%Decl = (); # details about individual definitions
+%Stuff = (); # where we glom things together
+%HiExists = ('old',-1, 'new',-1); # 1 <=> definitely exists; 0 <=> doesn't
+%HiHasBeenRead = ('old', 0, 'new', 0);
+%ModuleVersion = ('old', 0, 'new', 0);
+
+
+
sub postprocessHiFile {
local($hsc_hi, # The iface info produced by hsc.
$hifile_target, # The name both of the .hi file we
local($new_hi) = "$Tmp_prefix.hi-new";
-# print STDERR `$Cat $hsc_hi`;
+# print STDERR `$Cat $hsc_hi`;
&constructNewHiFile($hsc_hi, $hifile_target, $new_hi);
open(OLDHIF, "< $ifile") || &tidy_up_and_die(1,"Can't open $ifile (read)\n");
open(NEWHIF, "> $ofile") || &tidy_up_and_die(1,"Can't open $ofile (write)\n");
- # read up to __usages__ line
+ # read up to _usages_ line
$_ = <OLDHIF>;
- while ($_ ne '' && ! /^__usages__/) {
- print NEWHIF $_ unless /^(interface |\{-# GHC_PRAGMA)/;
+ while ($_ ne '' && ! /^_usages_/) {
+ print NEWHIF $_ unless /^(_interface_ |\{-# GHC_PRAGMA)/;
$_ = <OLDHIF>;
}
if ( $_ ne '' ) {
- # skip to next __<anything> line
+ # skip to next _<anything> line
$_ = <OLDHIF>;
- while ($_ ne '' && ! /^__/) { $_ = <OLDHIF>; }
+ while ($_ ne '' && ! /^_/) { $_ = <OLDHIF>; }
# print the rest
while ($_ ne '') {
open(NEWHI, "> $new_hi") || &tidy_up_and_die(1,"Can't open $new_hi (write)\n");
- local($new_module_version) = &calcNewModuleVersion();
- print NEWHI "interface ", $ModuleName{'new'}, " $new_module_version\n";
-
- print NEWHI "__usages__\n", $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq '';
-
- local(@version_keys) = sort (keys %Version);
- local($num_ver_things) = 0;
- foreach $v (@version_keys) {
- next unless $v =~ /^new:(.*$)/;
- last if $num_ver_things >= 1;
- $num_ver_things++;
- }
-
- print NEWHI "__versions__\n" unless $num_ver_things < 1;
- foreach $v (@version_keys) {
+ local(@decl_names) = (); # Entities in _declarations_ section of new module
+ foreach $v (sort (keys %Decl)) {
next unless $v =~ /^new:(.*$)/;
- $v = $1;
-
- &printNewItemVersion($v, $new_module_version), "\n";
+ push(@decl_names,$1);
}
- print NEWHI "__exports__\n";
- print NEWHI $Stuff{'new:exports'};
+ local($new_module_version) = &calcNewModuleVersion(@decl_names);
+ print NEWHI "_interface_ ", $ModuleName{'new'}, " $new_module_version\n";
if ( $Stuff{'new:instance_modules'} ) {
- print NEWHI "__instance_modules__\n";
+ print NEWHI "_instance_modules_\n";
print NEWHI $Stuff{'new:instance_modules'};
}
+ print NEWHI "_usages_\n", $Stuff{'new:usages'} unless $Stuff{'new:usages'} eq '';
+
+ print NEWHI "_exports_\n";
+ print NEWHI $Stuff{'new:exports'};
+
if ( $Stuff{'new:fixities'} ) {
- print NEWHI "__fixities__\n";
+ print NEWHI "_fixities_\n";
print NEWHI $Stuff{'new:fixities'};
}
- if ( $Stuff{'new:declarations'} ) {
- print NEWHI "__declarations__\n";
- print NEWHI $Stuff{'new:declarations'};
- }
-
if ( $Stuff{'new:instances'} ) {
- print NEWHI "__instances__\n";
+ print NEWHI "_instances_\n";
print NEWHI $Stuff{'new:instances'};
}
- if ( $Stuff{'new:pragmas'} ) {
- print NEWHI "__pragmas__\n";
- print NEWHI $Stuff{'new:pragmas'};
+ print NEWHI "_declarations_\n";
+ foreach $v (@decl_names) {
+ &printNewItemVersion(NEWHI, $v, $new_module_version); # Print new version number
+ print NEWHI $Decl{"new:$v"}; # Print the new decl itself
}
+
+
close(NEWHI) || &tidy_up_and_die(1,"Failed writing to $new_hi\n");
}
\end{code}
\begin{code}
-%Version = ();
-%Decl = (); # details about individual definitions
-%Stuff = (); # where we glom things together
-%HiExists = ('old',-1, 'new',-1); # 1 <=> definitely exists; 0 <=> doesn't
-%HiHasBeenRead = ('old', 0, 'new', 0);
-%ModuleVersion = ('old', 0, 'new', 0);
-
sub readHiFile {
local($mod, # module to read; can be special tag 'old'
# (old .hi file for module being compiled) or
$HiExists{$mod} = -1; # 1 <=> definitely exists; 0 <=> doesn't
$HiHasBeenRead{$mod} = 0;
$ModuleVersion{$mod} = 0;
+ $Stuff{"$mod:instance_modules"} = '';
$Stuff{"$mod:usages"} = ''; # stuff glommed together
$Stuff{"$mod:exports"} = '';
- $Stuff{"$mod:instance_modules"} = '';
- $Stuff{"$mod:instances"} = '';
$Stuff{"$mod:fixities"} = '';
+ $Stuff{"$mod:instances"} = '';
$Stuff{"$mod:declarations"} = '';
- $Stuff{"$mod:pragmas"} = '';
if (! -f $hifile) { # no pre-existing .hi file
$HiExists{$mod} = 0;
last hi_line;
}
- if ( /^interface ([A-Z]\S*) (\d+)/ ) {
+ if ( /^_interface_ ([A-Z]\S*) (\d+)/ ) {
$ModuleName{$mod} = $1; # not sure this is used much...
$ModuleVersion{$mod} = $2;
- } elsif ( /^interface ([A-Z]\S*)/ && $mod eq 'new' ) { # special case: no version
+ } elsif ( /^_interface_ ([A-Z]\S*)/ && $mod eq 'new' ) { # special case: no version
$ModuleName{'new'} = $1;
- } elsif ( /^__([a-z]+)__$/ ) {
+ } elsif ( /^_([a-z_]+)_$/ ) {
$now_in = $1;
} elsif ( $now_in eq 'usages' && /^(\S+)\s+(\d+)\s+:: (.*)/ ) {
$Stuff{"$mod:usages"} .= $_; # save the whole thing
- } elsif ( $now_in eq 'versions' && /^(\S+) (\d+)/ ) {
- local($item) = $1;
- local($n) = $2;
-#print STDERR "version read:item=$item, n=$n, line=$_";
- $Version{"$mod:$item"} = $n;
- } elsif ( $now_in eq 'versions' && /^(\S+)/ && $mod eq 'new') { # doesn't have versions
- local($item) = $1;
-#print STDERR "new version read:item=$item, line=$_";
- $Version{"$mod:$item"} = 'y'; # stub value...
-
- } elsif ( $now_in =~ /^(exports|instance_modules|instances|fixities|pragmas)$/ ) {
+ } elsif ( $now_in =~ /^(exports|instance_modules|instances|fixities)$/ ) {
$Stuff{"$mod:$1"} .= $_; # just save it up
} elsif ( $now_in eq 'declarations' ) { # relatively special treatment needed...
- $Stuff{"$mod:declarations"} .= $_; # just save it up
-
- if ( /^[A-Z][A-Za-z0-9_']*\.(\S+)\s+::\s+/ ) {
- $Decl{"$mod:$1"} = $_;
-
- } elsif ( /^type\s+[A-Z][A-Za-z0-9_']*\.(\S+)/ ) {
- $Decl{"$mod:$1"} = $_;
-
- } elsif ( /^(newtype|data)\s+(.*\s+=>\s+)?[A-Z][A-Za-z0-9_']*\.(\S+)\s+/ ) {
- $Decl{"$mod:$3"} = $_;
-
- } elsif ( /class\s+(.*\s+=>\s+)?[A-Z][A-Za-z0-9_']*\.(\S+)\s+.*where\s+\{.*\};/ ) {
- $Decl{"$mod:$2"} = $_; # must be wary of => bit matching after "where"...
- } elsif ( /class\s+(.*\s+=>\s+)?[A-Z][A-Za-z0-9_']*\.(\S+)\s+/ ) {
- $Decl{"$mod:$2"} = $_;
-
- } else { # oh, well...
- print STDERR "$Pgm: decl line didn't match?\n$_";
+ # We're in a declaration
+
+ # Strip off the initial version number, if any
+ if ( /^([0-9]+) (.*\n)/ ) {
+ # The "\n" is because we need to keep the newline at the end, so that
+ # it looks the same as if there's no version number and this if statement
+ # doesn't fire.
+
+ # So there's an initial version number
+ $version = $1;
+ $_ = $2;
+ }
+
+ if ( /^(\S+)\s+::\s+/ ) {
+ $current_name = $1;
+ $Decl{"$mod:$current_name"} = $_;
+ if ($mod eq "old") { $OldVersion{$current_name} = $version; }
+
+ } elsif ( /^type\s+(\S+)/ ) {
+ $current_name = $1;
+ $Decl{"$mod:$current_name"} = $_;
+ if ($mod eq "old") { $OldVersion{$current_name} = $version; }
+
+ } elsif ( /^(newtype|data)\s+(.*\s+=>\s+)?(\S+)\s+/ ) {
+ $current_name = $3;
+ $Decl{"$mod:$current_name"} = $_;
+ if ($mod eq "old") { $OldVersion{$current_name} = $version; }
+
+ } elsif ( /class\s+(.*\s+=>\s+)?(\S+)\s+.*where\s+\{.*\};/ ) {
+ # must be wary of => bit matching after "where"...
+ $current_name = $2;
+ $Decl{"$mod:$current_name"} = $_;
+ if ($mod eq "old") { $OldVersion{$current_name} = $version; }
+
+ } elsif ( /class\s+(.*\s+=>\s+)?(\S+)\s+/ ) {
+ $current_name = $2;
+ $Decl{"$mod:$current_name"} = $_;
+ if ($mod eq "old") { $OldVersion{$current_name} = $version; }
+
+ } else { # Continuation line
+ $Decl{"$mod:$current_name"} .= $_
}
} else {
\begin{code}
sub calcNewModuleVersion {
+ local (@decl_names) = @_;
return(&mv_change(1,'no old .hi file')) if $HiExists{'old'} == 0;
# could use "time()" as initial version; if a module existed, then was deleted,
local($unchanged_version) = $ModuleVersion{'old'}; # will return one of these two
local($changed_version) = $unchanged_version + 1;
- return(&mv_change($changed_version,'usages changed')) if $Stuff{'old:usages'} ne $Stuff{'new:usages'};
+# This statement is curious; it is subsumed by the foreach!
+# return(&mv_change($changed_version,'usages changed')) if $Stuff{'old:usages'} ne $Stuff{'new:usages'};
- foreach $t ( 'exports', 'instance_modules', 'instances', 'fixities', 'declarations', 'pragmas' ) {
+ foreach $t ( 'usages' , 'exports', 'instance_modules', 'instances', 'fixities' ) {
return(&mv_change($changed_version,"$t changed")) if $Stuff{"old:$t"} ne $Stuff{"new:$t"};
}
+# Decl need separate treatment; they aren't in $Stuff
+ foreach $v (@decl_names) {
+ return(&mv_change($changed_version,"$v changed")) if $Decl{"old:$v"} ne $Decl{"new:$v"};
+ }
+
+ print STDERR "Module version unchanged at $unchanged_version\n";
return($unchanged_version);
}
sub mv_change {
local($mv, $str) = @_;
-#print STDERR "$Pgm: module version changed to $mv; reason: $str\n";
+ print STDERR "$Pgm: module version changed to $mv; reason: $str\n";
return($mv);
}
sub printNewItemVersion {
- local($item, $mod_version) = @_;
+ local($hifile, $item, $mod_version) = @_;
+ local($idecl) = $Decl{"new:$item"};
- if (! defined($Decl{"new:$item"}) ) {
-# it's OK, because the thing is almost-certainly wired-in
-# print STDERR "$item: no decl?! (nothing into __versions__)\n";
- return;
- }
+ if (! defined($Decl{"old:$item"})) { # Old decl doesn't exist
+ print STDERR "new: $item\n";
+ print $hifile "$mod_version "; # Use module version
- local($idecl) = $Decl{"new:$item"};
+ } elsif ($idecl ne $Decl{"old:$item"}) { # Old decl differs from new decl
+ local($odecl) = $Decl{"old:$item"};
+# print STDERR "changed: $item\nOld: $odecl\nNew: $idecl\n";
+ print $hifile "$mod_version "; # Use module version
- if (! defined($Decl{"old:$item"})) {
-#print STDERR "new: $item\n";
- print NEWHI "$item $mod_version\n";
- } elsif ($idecl ne $Decl{"old:$item"}) {
-#print STDERR "changed: $item\n";
- print NEWHI "$item $mod_version\n";
- } elsif (! defined($Version{"old:$item"}) ) {
-#print STDERR "$item: no old version?!\n"
- } else {
- print NEWHI "$item ", $Version{"old:$item"}, "\n";
+ } elsif (! defined($OldVersion{"$item"}) ) {
+ print STDERR "$item: no old version?!\n";
+ print $hifile "$mod_version "; # Use module version
+
+ } else { # Identical decls, so use old version number
+ print STDERR "$item: unchanged\n";
+ print $hifile $OldVersion{"$item"}, " ";
}
return;
}
@SysImport_dir = ( $(INSTALLING) )
? ( "$InstDataDirGhc/imports" )
- : ( "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/prelude"
+ : ( "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/ghc"
+ , "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/glaExts"
, "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/required"
, "$TopPwd/$(CURRENT_DIR)/$(GHC_LIBSRC)/concurrent" );
+# We need to look in ghc/ and glaExts/ when searching for implicitly needed .hi files, but
+# we should really *not* look there for explicitly imported modules.
+
$GhcVersionInfo = int ($(PROJECTVERSION) * 100);
$Haskell1Version = 3; # i.e., Haskell 1.3
@Cpp_define = ();
/^-user-prelude-force/ && do { # ignore if not -user-prelude
next arg; };
- /^-split-objs(.*)/ && do {
- local($sname) = &grab_arg_arg('-split-objs', $1);
- $sname =~ s/ //g; # no spaces
-
+ /^-split-objs/ && do {
if ( $TargetPlatform !~ /^(alpha|hppa1\.1|i386|m68k|mips|powerpc|sparc)-/ ) {
$SplitObjFiles = 0;
print STDERR "WARNING: don't know how to split objects on this platform: $TargetPlatform\n`-split-objs' option ignored\n";
$SplitObjFiles = 1;
$HscOut = '-C=';
- push(@HsC_flags, "-fglobalise-toplev-names=$sname");
+ push(@HsC_flags, "-fglobalise-toplev-names");
push(@CcBoth_flags, '-DUSE_SPLIT_MARKERS');
require('ghc-split.prl')
/^-d(dump|ppr)-/ && do { push(@HsC_flags, $_); next arg; };
/^-dverbose-(simpl|stg)/ && do { push(@HsC_flags, $_); next arg; };
/^-dshow-passes/ && do { push(@HsC_flags, $_); next arg; };
+ /^-dshow-rn-trace/ && do { push(@HsC_flags, $_); next arg; };
/^-dsource-stats/ && do { push(@HsC_flags, $_); next arg; };
/^-dsimplifier-stats/ && do { push(@HsC_flags, $_); next arg; };
/^-dstg-stats/ && do { $Oopt_StgStats = $_; next arg; };
'-fdo-case-elim',
'-fcase-merge',
'-fdo-eta-reduction',
- '-fdo-lambda-eta-expansion',
+ '-fdo-lambda-eta-expansion', # After full laziness
'-freuse-con',
$Oopt_PedanticBottoms,
$Oopt_MonadEtaExpansion,
#LATER: '-fcalc-inlinings2', -- pointless for 2.01
# stg2stg passes
-#LATER: '-fupdate-analysis',
+ '-fupdate-analysis',
'-flambda-lift',
$Oopt_FinalStgProfilingMassage,
$Oopt_StgStats,
unshift(@Ld_flags,
(($Ld_main) ? (
'-u', "${Under}Main_" . $Ld_main . '_closure',
- ) : (),
- '-u', "${Under}GHCbase_unsafePerformPrimIO_fast1",
- '-u', "${Under}Prelude_Z91Z93_closure", # i.e., []
- '-u', "${Under}Prelude_IZh_static_info",
- '-u', "${Under}Prelude_False_inregs_info",
- '-u', "${Under}Prelude_True_inregs_info",
- '-u', "${Under}Prelude_CZh_static_info",
- '-u', "${Under}DEBUG_REGS"))
+ ) : ()
+# , '-u', "${Under}STbase_unsafePerformPrimIO_fast1"
+# , '-u', "${Under}Prelude_Z91Z93_closure" # i.e., []
+# , '-u', "${Under}Prelude_IZh_static_info"
+# , '-u', "${Under}Prelude_False_inregs_info"
+# , '-u', "${Under}Prelude_True_inregs_info"
+# , '-u', "${Under}Prelude_CZh_static_info"
+# , '-u', "${Under}DEBUG_REGS"
+ ))
; # just for fun, now...
\end{code}
\end{code}
-Check if hsc needs to be run at all.
-
-\begin{code}
- local($more_processing_required) = 1;
-
- if ( $Do_recomp_chkr && $do_hsc && ! $going_interactive ) {
- # recompilation-checking is important enough to live off by itself
- require('ghc-recomp.prl')
- || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-recomp.prl!\n");
-
- $more_processing_required
- = &runRecompChkr($ifile, $hscpp_hsc, $ifile_root, $ofile_target, $hifile_target);
- if ( ! $more_processing_required ) {
- print STDERR "$Pgm:recompile: NOT NEEDED!\n"; # Yay!
- # propagate dependency:
- &run_something("touch $ofile_target", "Touch $ofile_target, to propagate dependencies");
- }
- }
-
- $do_hsc = 0, $do_cc = 0, $do_as = 0 if ! $more_processing_required;
-\end{code}
+Now the Haskell compiler, C compiler, and assembler
\begin{code}
- if ( $do_hsc ) {
-
- &runHsc($ifile_root, $hsc_out, $hsc_hi, $going_interactive);
-
- # interface-handling is important enough to live off by itself
- require('ghc-iface.prl')
- || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-iface.prl!\n");
-
- &postprocessHiFile($hsc_hi, $hifile_target, $going_interactive);
-
- # save a copy of the .hc file, even if we are carrying on...
- if ($HscOut eq '-C=' && $do_cc && $Keep_hc_file_too) {
- local($to_do) = "$Rm $ifile_root.hc; $Cp $hsc_out $ifile_root.hc";
- &run_something($to_do, 'Saving copy of .hc file');
- }
-
- # save a copy of the .s file, even if we are carrying on...
- if ($HscOut eq '-S=' && $do_as && $Keep_s_file_too) {
- local($to_do) = "$Rm $ifile_root.s; $Cp $hsc_out $ifile_root.s";
- &run_something($to_do, 'Saving copy of .s file');
- }
-
- # if we're going to split up object files,
- # we inject split markers into the .hc file now
- if ( $HscOut eq '-C=' && $SplitObjFiles ) {
- &inject_split_markers ( $hsc_out );
- }
+ if ($do_hsc) {
+ &runHscAndProcessInterfaces( $ifile, $hscpp_hsc, $ifile_root,
+ $ofile_target, $hifile_target);
}
if ($do_cc) {
\end{code}
\begin{code}
+sub runHscAndProcessInterfaces {
+ local($ifile, $hscpp_hsc, $ifiel_root, $ofile_target, $hifile_target) = @_;
+
+ # $ifile is the original input file
+ # $hscpp_hsc post-unlit, post-cpp, etc., input file
+ # $ifile_root input filename minus suffix
+ # $ofile_target the output file that we ultimately hope to produce
+ # $hifile_target the .hi file ... (ditto)
+
+ local($source_unchanged) = 1;
+
+# Check if the source file is up to date relative to the target; in
+# that case we say "source is unchanged" and let the compiler bale out
+# early if the import usage information allows it.
+
+ ($i_dev,$i_ino,$i_mode,$i_nlink,$i_uid,$i_gid,$i_rdev,$i_size,
+ $i_atime,$i_mtime,$i_ctime,$i_blksize,$i_blocks) = stat($ifile);
+
+ if ( ! -f $ofile_target ) {
+ print STDERR "$Pgm:compile:Output file $ofile_target doesn't exist\n";
+ $source_unchanged = 0;
+ }
+
+ ($o_dev,$o_ino,$o_mode,$o_nlink,$o_uid,$o_gid,$o_rdev,$o_size,
+ $o_atime,$o_mtime,$o_ctime,$o_blksize,$o_blocks) = stat(_); # stat info from -f test
+
+ if ( ! -f $hifile_target ) {
+ print STDERR "$Pgm:compile:Interface file $hifile_target doesn't exist\n";
+ $source_unchanged = 0;
+ }
+
+ ($hi_dev,$hi_ino,$hi_mode,$hi_nlink,$hi_uid,$hi_gid,$hi_rdev,$hi_size,
+ $hi_atime,$hi_mtime,$hi_ctime,$hi_blksize,$hi_blocks) = stat(_); # stat info from -f test
+
+ if ($i_mtime > $o_mtime) {
+ print STDERR "$Pgm:recompile:Input file $ifile newer than $ofile_target\n";
+ $source_unchanged = 0;
+ }
+
+ # So if source_unchanged is still "1", we pass on the good news to the compiler
+ # The -recomp flag can disable this, forcing recompilation
+ if ($Do_recomp_chkr && $source_unchanged) {
+ push(@HsC_flags, '-fsource-unchanged');
+ }
+
+# Run the compiler
+
+ &runHsc($ifile_root, $hsc_out, $hsc_hi, $going_interactive);
+
+# See if it baled out early, saying nothing needed doing.
+# We work this out by seeing if it created an output .hi file
+
+ if ( ! -f $hsc_hi ) {
+ # Doesn't exist, so we baled out early.
+ # Tell the C compiler and assembler not to run
+ $do_cc = 0; $do_as = 0;
+
+ # Update dependency info
+ &run_something("touch $ofile_target", "Touch $ofile_target, to propagate dependencies");
+
+ } else {
+
+# Didn't bale out early (new .hi file) so we thunder on
+
+ # If non-interactive, heave in the consistency info at the end
+ # NB: pretty hackish (depends on how $output is set)
+ if ( ! $going_interactive ) {
+ if ( $HscOut eq '-C=' ) {
+ $to_do = "echo 'static char ghc_hsc_ID[] = \"\@(#)hsc $ifile\t$HsC_major_version.$HsC_minor_version,$HsC_consist_options\";' >> $hsc_out";
+
+ } elsif ( $HscOut eq '-S=' ) {
+ local($consist) = "hsc.$ifile.$HsC_major_version.$HsC_minor_version.$HsC_consist_options";
+ $consist =~ s/,/./g;
+ $consist =~ s/\//./g;
+ $consist =~ s/-/_/g;
+ $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly?
+ $to_do = "echo '\n\t.text\n$consist:' >> $hsc_out";
+ }
+ &run_something($to_do, 'Pin on Haskell consistency info');
+ }
+
+
+ # Interface-handling is important enough to live off by itself
+ require('ghc-iface.prl')
+ || &tidy_up_and_die(1,"$Pgm: panic: can't load ghc-iface.prl!\n");
+
+ &postprocessHiFile($hsc_hi, $hifile_target, $going_interactive);
+
+ # save a copy of the .hc file, even if we are carrying on...
+ if ($HscOut eq '-C=' && $do_cc && $Keep_hc_file_too) {
+ local($to_do) = "$Rm $ifile_root.hc; $Cp $hsc_out $ifile_root.hc";
+ &run_something($to_do, 'Saving copy of .hc file');
+ }
+
+ # save a copy of the .s file, even if we are carrying on...
+ if ($HscOut eq '-S=' && $do_as && $Keep_s_file_too) {
+ local($to_do) = "$Rm $ifile_root.s; $Cp $hsc_out $ifile_root.s";
+ &run_something($to_do, 'Saving copy of .s file');
+ }
+
+ # if we're going to split up object files,
+ # we inject split markers into the .hc file now
+ if ( $HscOut eq '-C=' && $SplitObjFiles ) {
+ &inject_split_markers ( $hsc_out );
+ }
+ }
+}
+\end{code}
+
+
+\begin{code}
sub runHsc {
local($ifile_root, $hsc_out, $hsc_hi, $going_interactive) = @_;
foreach $a ( @HsP_flags ) { $a = ",$a" unless $a =~ /^,/; }
&makeHiMap() unless $HiMapDone;
- push(@HsC_flags, "-himap=$HiMapFile");
+# print STDERR "HiIncludes: $HiIncludeString\n";
+ push(@HsC_flags, "-himap=$HiIncludeString");
+# push(@HsC_flags, "-himap=$HiMapFile");
# here, we may produce .hc/.s and/or .hi files
local($output) = '';
# finish business w/ nofibbish time/bytes-alloc stats
&process_ghc_timings() if $CollectGhcTimings;
-
- # if non-interactive, heave in the consistency info at the end
- # NB: pretty hackish (depends on how $output is set)
- if ( ! $going_interactive ) {
- if ( $HscOut eq '-C=' ) {
- $to_do = "echo 'static char ghc_hsc_ID[] = \"\@(#)hsc $ifile\t$HsC_major_version.$HsC_minor_version,$HsC_consist_options\";' >> $hsc_out";
-
- } elsif ( $HscOut eq '-S=' ) {
- local($consist) = "hsc.$ifile.$HsC_major_version.$HsC_minor_version.$HsC_consist_options";
- $consist =~ s/,/./g;
- $consist =~ s/\//./g;
- $consist =~ s/-/_/g;
- $consist =~ s/[^A-Za-z0-9_.]/ZZ/g; # ToDo: properly?
- $to_do = "echo '\n\t.text\n$consist:' >> $hsc_out";
- }
- &run_something($to_do, 'Pin on Haskell consistency info');
- }
}
\end{code}
%HiMap = ();
$HiMapDone = 0;
$HiMapFile = '';
+$HiIncludeString = (); # dir1:dir2:dir3, to pass to GHC
sub makeHiMap {
local($mod, $path, $d, $e);
foreach $d ( @Import_dir ) {
+ if ($HiIncludeString) { $HiIncludeString = "$HiIncludeString:$d";
+ } else { $HiIncludeString = $d; }
+
opendir(DIR, $d) || &tidy_up_and_die(1,"$Pgm: error when reading directory: $d\n");
local(@entry) = readdir(DIR);
foreach $e ( @entry ) {
}
foreach $d ( @SysImport_dir ) {
+ if ($HiIncludeString) { $HiIncludeString = "$HiIncludeString:$d";
+ } else { $HiIncludeString = $d; }
+
opendir(DIR, $d) || &tidy_up_and_die(1,"$Pgm: error when reading directory: $d\n");
local(@entry) = readdir(DIR);
foreach $e ( @entry ) {
} while(0); \
FUNEND; }
+#else /* PROFILING */
+
+/* When things are working these shouldn't be emitted when not profiling,
+ but it was convenient at one point to have them expand to nothing
+ when not profiling. SLPJ Dec 96 */
+
+#define START_REGISTER_CCS(reg_mod_name)
+#define END_REGISTER_CCS()
+
#endif /* PROFILING */
\end{code}
#define INFO_BF_TYPE (MAKE_BASE_INFO_TYPE(21L) | _NS | _MU | _BH)
#define INFO_INTERNAL_TYPE (MAKE_BASE_INFO_TYPE(22L))
+/* S = single-entry thunk
+ U = updatable thunk
+ N = head normal form */
+
#define INFO_SPEC_N_TYPE (INFO_SPEC_TYPE | _NF | _NS)
#define INFO_SPEC_S_TYPE (INFO_SPEC_TYPE | _TH)
#define INFO_SPEC_U_TYPE (INFO_SPEC_TYPE | _UP | _TH)
/* Declare the phantom info table vectors (just Bool at the moment) */
#ifndef COMPILING_GHC
-EXTDATA_RO(Prelude_Bool_itblvtbl);
+EXTDATA_RO(PrelBase_Bool_itblvtbl);
#endif
\end{code}
#define ltCharZh(r,a,b) r=(I_)((a)< (b))
#define leCharZh(r,a,b) r=(I_)((a)<=(b))
-#define gtIntZh(r,a,b) r=(I_)((a) >(b))
-#define geIntZh(r,a,b) r=(I_)((a)>=(b))
-#define eqIntZh(r,a,b) r=(I_)((a)==(b))
-#define neIntZh(r,a,b) r=(I_)((a)!=(b))
-#define ltIntZh(r,a,b) r=(I_)((a) <(b))
-#define leIntZh(r,a,b) r=(I_)((a)<=(b))
+/* Int comparisons: >#, >=# etc */
+#define ZgZh(r,a,b) r=(I_)((a) >(b))
+#define ZgZeZh(r,a,b) r=(I_)((a)>=(b))
+#define ZeZeZh(r,a,b) r=(I_)((a)==(b))
+#define ZdZeZh(r,a,b) r=(I_)((a)!=(b))
+#define ZlZh(r,a,b) r=(I_)((a) <(b))
+#define ZlZeZh(r,a,b) r=(I_)((a)<=(b))
#define gtWordZh(r,a,b) r=(I_)((a) >(b))
#define geWordZh(r,a,b) r=(I_)((a)>=(b))
#define ltFloatZh(r,a,b) r=(I_)((a)< (b))
#define leFloatZh(r,a,b) r=(I_)((a)<=(b))
-#define gtDoubleZh(r,a,b) r=(I_)((a)> (b))
-#define geDoubleZh(r,a,b) r=(I_)((a)>=(b))
-#define eqDoubleZh(r,a,b) r=(I_)((a)==(b))
-#define neDoubleZh(r,a,b) r=(I_)((a)!=(b))
-#define ltDoubleZh(r,a,b) r=(I_)((a)< (b))
-#define leDoubleZh(r,a,b) r=(I_)((a)<=(b))
+/* Double comparisons: >##, >=#@ etc */
+#define ZgZhZh(r,a,b) r=(I_)((a) >(b))
+#define ZgZeZhZh(r,a,b) r=(I_)((a)>=(b))
+#define ZeZeZhZh(r,a,b) r=(I_)((a)==(b))
+#define ZdZeZhZh(r,a,b) r=(I_)((a)!=(b))
+#define ZlZhZh(r,a,b) r=(I_)((a) <(b))
+#define ZlZeZhZh(r,a,b) r=(I_)((a)<=(b))
\end{code}
%************************************************************************
\begin{code}
I_ stg_div PROTO((I_ a, I_ b));
-#define plusIntZh(r,a,b) r=(a)+(b)
-#define minusIntZh(r,a,b) r=(a)-(b)
-#define timesIntZh(r,a,b) r=(a)*(b)
+#define ZpZh(r,a,b) r=(a)+(b)
+#define ZmZh(r,a,b) r=(a)-(b)
+#define ZtZh(r,a,b) r=(a)*(b)
#define quotIntZh(r,a,b) r=(a)/(b)
-#define divIntZh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
+#define ZdZh(r,a,b) r=ULTRASAFESTGCALL2(I_,(void *, I_, I_),stg_div,(a),(b))
#define remIntZh(r,a,b) r=(a)%(b)
#define negateIntZh(r,a) r=-(a)
\end{code}
%************************************************************************
\begin{code}
-#define plusDoubleZh(r,a,b) r=(a)+(b)
-#define minusDoubleZh(r,a,b) r=(a)-(b)
-#define timesDoubleZh(r,a,b) r=(a)*(b)
-#define divideDoubleZh(r,a,b) r=(a)/(b)
+#define ZpZhZh(r,a,b) r=(a)+(b)
+#define ZmZhZh(r,a,b) r=(a)-(b)
+#define ZtZhZh(r,a,b) r=(a)*(b)
+#define ZdZhZh(r,a,b) r=(a)/(b)
#define negateDoubleZh(r,a) r=-(a)
#define int2DoubleZh(r,a) r=(StgDouble)(a)
#define sinhDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),sinh,a)
#define coshDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),cosh,a)
#define tanhDoubleZh(r,a) r=(StgDouble) SAFESTGCALL1(StgDouble,(void *, StgDouble),tanh,a)
-#define powerDoubleZh(r,a,b) r=(StgDouble) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
+/* Power: **## */
+#define ZtZtZhZh(r,a,b) r=(StgDouble) SAFESTGCALL2(StgDouble,(void *, StgDouble,StgDouble),pow,a,b)
\end{code}
%************************************************************************
# DO NOT DELETE: Beginning of Haskell dependencies
-prelude/GHCbase.o : prelude/GHCbase.hs
-prelude/GHCbase.o : required/Array.hi
-prelude/GHCbase.o : required/Char.hi
-prelude/GHCbase.o : required/Ix.hi
-prelude/GHCbase.o : required/Ratio.hi
-prelude/GHCbase.o : prelude/GHCerr.hi
-prelude/GHCerr.o : prelude/GHCerr.hs
-prelude/GHCerr.o : prelude/GHCbase.hi
-prelude/GHCio.o : prelude/GHCio.hs
-prelude/GHCio.o : ../../ghc/includes/error.h
-prelude/GHCio.o : prelude/GHCbase.hi
-prelude/GHCio.o : required/Ix.hi
-prelude/GHCmain.o : prelude/GHCmain.hs
-prelude/GHCmain.o : prelude/GHCbase.hi
-prelude/GHCps.o : prelude/GHCps.hs
-prelude/GHCps.o : required/Ix.hi
-prelude/GHCps.o : required/Char.hi
-prelude/GHCps.o : prelude/GHCbase.hi
-prelude/Prelude.o : prelude/Prelude.hs
-prelude/Prelude.o : ./../includes/ieee-flpt.h
-prelude/Prelude.o : prelude/GHCbase.hi
-prelude/Prelude.o : prelude/GHCio.hi
-prelude/Prelude.o : required/Ratio.hi
-prelude/Prelude.o : required/Char.hi
-prelude/Prelude.o : required/IO.hi
-prelude/PreludeGlaST.o : prelude/PreludeGlaST.hs
-prelude/PreludeGlaST.o : prelude/GHCbase.hi
-required/Array.o : required/Array.hs
+ghc/ArrBase.o : ghc/ArrBase.lhs
+ghc/ArrBase.mc.o : ghc/ArrBase.lhs
+ghc/ArrBase.norm.o : ghc/ArrBase.lhs
+ghc/ArrBase.p.o : ghc/ArrBase.lhs
+ghc/ArrBase.mc.o : ghc/IOBase.mc.hi
+ghc/ArrBase.norm.o : ghc/IOBase.norm.hi
+ghc/ArrBase.p.o : ghc/IOBase.p.hi
+ghc/ArrBase.o : required/Ix.hi
+ghc/ArrBase.mc.o : required/Ix.mc.hi
+ghc/ArrBase.norm.o : required/Ix.norm.hi
+ghc/ArrBase.p.o : required/Ix.p.hi
+ghc/ArrBase.o : ghc/PrelList.hi
+ghc/ArrBase.mc.o : ghc/PrelList.mc.hi
+ghc/ArrBase.norm.o : ghc/PrelList.norm.hi
+ghc/ArrBase.p.o : ghc/PrelList.p.hi
+ghc/ArrBase.o : ghc/PrelNum.hi
+ghc/ArrBase.mc.o : ghc/PrelNum.mc.hi
+ghc/ArrBase.norm.o : ghc/PrelNum.norm.hi
+ghc/ArrBase.p.o : ghc/PrelNum.p.hi
+ghc/ArrBase.o : ghc/STBase.hi
+ghc/ArrBase.mc.o : ghc/STBase.mc.hi
+ghc/ArrBase.norm.o : ghc/STBase.norm.hi
+ghc/ArrBase.p.o : ghc/STBase.p.hi
+ghc/ArrBase.o : ghc/PrelBase.hi
+ghc/ArrBase.mc.o : ghc/PrelBase.mc.hi
+ghc/ArrBase.norm.o : ghc/PrelBase.norm.hi
+ghc/ArrBase.p.o : ghc/PrelBase.p.hi
+ghc/ArrBase.o : ghc/PrelTup.hi
+ghc/ArrBase.mc.o : ghc/PrelTup.mc.hi
+ghc/ArrBase.norm.o : ghc/PrelTup.norm.hi
+ghc/ArrBase.p.o : ghc/PrelTup.p.hi
+ghc/ArrBase.o : ghc/GHC.hi
+ghc/ArrBase.mc.o : ghc/GHC.mc.hi
+ghc/ArrBase.norm.o : ghc/GHC.norm.hi
+ghc/ArrBase.p.o : ghc/GHC.p.hi
+ghc/ConcBase.o : ghc/ConcBase.lhs
+ghc/ConcBase.mc.o : ghc/ConcBase.lhs
+ghc/ConcBase.norm.o : ghc/ConcBase.lhs
+ghc/ConcBase.p.o : ghc/ConcBase.lhs
+ghc/ConcBase.o : required/Prelude.hi
+ghc/ConcBase.o : ghc/STBase.hi
+ghc/ConcBase.o : ghc/GHCerr.hi
+ghc/ConcBase.mc.o : ghc/STBase.mc.hi
+ghc/ConcBase.norm.o : ghc/STBase.norm.hi
+ghc/ConcBase.p.o : ghc/STBase.p.hi
+ghc/GHCerr.o : ghc/GHCerr.lhs
+ghc/GHCerr.mc.o : ghc/GHCerr.lhs
+ghc/GHCerr.norm.o : ghc/GHCerr.lhs
+ghc/GHCerr.p.o : ghc/GHCerr.lhs
+ghc/GHCerr.o : ghc/IOBase.hi
+ghc/GHCerr.mc.o : ghc/IOBase.mc.hi
+ghc/GHCerr.norm.o : ghc/IOBase.norm.hi
+ghc/GHCerr.p.o : ghc/IOBase.p.hi
+ghc/GHCmain.o : ghc/GHCmain.lhs
+ghc/GHCmain.mc.o : ghc/GHCmain.lhs
+ghc/GHCmain.norm.o : ghc/GHCmain.lhs
+ghc/GHCmain.p.o : ghc/GHCmain.lhs
+ghc/GHCmain.mc.o : required/Prelude.mc.hi
+ghc/GHCmain.norm.o : required/Prelude.norm.hi
+ghc/GHCmain.p.o : required/Prelude.p.hi
+ghc/GHCmain.o : ghc/IOBase.hi
+ghc/GHCmain.mc.o : ghc/IOBase.mc.hi
+ghc/GHCmain.norm.o : ghc/IOBase.norm.hi
+ghc/GHCmain.p.o : ghc/IOBase.p.hi
+ghc/GHCmain.o : ghc/STBase.hi
+ghc/GHCmain.mc.o : ghc/STBase.mc.hi
+ghc/GHCmain.norm.o : ghc/STBase.norm.hi
+ghc/GHCmain.p.o : ghc/STBase.p.hi
+ghc/IOBase.o : ghc/IOBase.lhs
+ghc/IOBase.mc.o : ghc/IOBase.lhs
+ghc/IOBase.norm.o : ghc/IOBase.lhs
+ghc/IOBase.p.o : ghc/IOBase.lhs
+ghc/IOBase.o : ../../ghc/includes/error.h
+ghc/IOBase.mc.o : ../../ghc/includes/error.h
+ghc/IOBase.norm.o : ../../ghc/includes/error.h
+ghc/IOBase.p.o : ../../ghc/includes/error.h
+ghc/IOBase.mc.o : required/Prelude.mc.hi
+ghc/IOBase.norm.o : required/Prelude.norm.hi
+ghc/IOBase.p.o : required/Prelude.p.hi
+ghc/IOBase.o : ghc/STBase.hi
+ghc/IOBase.mc.o : ghc/STBase.mc.hi
+ghc/IOBase.norm.o : ghc/STBase.norm.hi
+ghc/IOBase.p.o : ghc/STBase.p.hi
+ghc/IOBase.o : ghc/PrelTup.hi
+ghc/IOBase.mc.o : ghc/PrelTup.mc.hi
+ghc/IOBase.norm.o : ghc/PrelTup.norm.hi
+ghc/IOBase.p.o : ghc/PrelTup.p.hi
+ghc/IOBase.o : glaExts/Foreign.hi
+ghc/IOBase.mc.o : glaExts/Foreign.mc.hi
+ghc/IOBase.norm.o : glaExts/Foreign.norm.hi
+ghc/IOBase.p.o : glaExts/Foreign.p.hi
+ghc/IOBase.o : glaExts/PackedString.hi
+ghc/IOBase.mc.o : glaExts/PackedString.mc.hi
+ghc/IOBase.norm.o : glaExts/PackedString.norm.hi
+ghc/IOBase.p.o : glaExts/PackedString.p.hi
+ghc/IOBase.o : ghc/PrelBase.hi
+ghc/IOBase.mc.o : ghc/PrelBase.mc.hi
+ghc/IOBase.norm.o : ghc/PrelBase.norm.hi
+ghc/IOBase.p.o : ghc/PrelBase.p.hi
+ghc/IOBase.o : ghc/GHC.hi
+ghc/IOBase.mc.o : ghc/GHC.mc.hi
+ghc/IOBase.norm.o : ghc/GHC.norm.hi
+ghc/IOBase.p.o : ghc/GHC.p.hi
+ghc/IOHandle.o : ghc/IOHandle.lhs
+ghc/IOHandle.mc.o : ghc/IOHandle.lhs
+ghc/IOHandle.norm.o : ghc/IOHandle.lhs
+ghc/IOHandle.p.o : ghc/IOHandle.lhs
+ghc/IOHandle.o : ../../ghc/includes/error.h
+ghc/IOHandle.mc.o : ../../ghc/includes/error.h
+ghc/IOHandle.norm.o : ../../ghc/includes/error.h
+ghc/IOHandle.p.o : ../../ghc/includes/error.h
+ghc/IOHandle.mc.o : required/Prelude.mc.hi
+ghc/IOHandle.norm.o : required/Prelude.norm.hi
+ghc/IOHandle.p.o : required/Prelude.p.hi
+ghc/IOHandle.o : glaExts/ST.hi
+ghc/IOHandle.mc.o : glaExts/ST.mc.hi
+ghc/IOHandle.norm.o : glaExts/ST.norm.hi
+ghc/IOHandle.p.o : glaExts/ST.p.hi
+ghc/IOHandle.o : ghc/STBase.hi
+ghc/IOHandle.mc.o : ghc/STBase.mc.hi
+ghc/IOHandle.norm.o : ghc/STBase.norm.hi
+ghc/IOHandle.p.o : ghc/STBase.p.hi
+ghc/IOHandle.o : ghc/ArrBase.hi
+ghc/IOHandle.mc.o : ghc/ArrBase.mc.hi
+ghc/IOHandle.norm.o : ghc/ArrBase.norm.hi
+ghc/IOHandle.p.o : ghc/ArrBase.p.hi
+ghc/IOHandle.o : ghc/PrelRead.hi
+ghc/IOHandle.mc.o : ghc/PrelRead.mc.hi
+ghc/IOHandle.norm.o : ghc/PrelRead.norm.hi
+ghc/IOHandle.p.o : ghc/PrelRead.p.hi
+ghc/IOHandle.o : required/Ix.hi
+ghc/IOHandle.mc.o : required/Ix.mc.hi
+ghc/IOHandle.norm.o : required/Ix.norm.hi
+ghc/IOHandle.p.o : required/Ix.p.hi
+ghc/IOHandle.o : ghc/IOBase.hi
+ghc/IOHandle.mc.o : ghc/IOBase.mc.hi
+ghc/IOHandle.norm.o : ghc/IOBase.norm.hi
+ghc/IOHandle.p.o : ghc/IOBase.p.hi
+ghc/IOHandle.o : ghc/PrelTup.hi
+ghc/IOHandle.mc.o : ghc/PrelTup.mc.hi
+ghc/IOHandle.norm.o : ghc/PrelTup.norm.hi
+ghc/IOHandle.p.o : ghc/PrelTup.p.hi
+ghc/IOHandle.o : ghc/PrelBase.hi
+ghc/IOHandle.mc.o : ghc/PrelBase.mc.hi
+ghc/IOHandle.norm.o : ghc/PrelBase.norm.hi
+ghc/IOHandle.p.o : ghc/PrelBase.p.hi
+ghc/IOHandle.o : ghc/GHC.hi
+ghc/IOHandle.mc.o : ghc/GHC.mc.hi
+ghc/IOHandle.norm.o : ghc/GHC.norm.hi
+ghc/IOHandle.p.o : ghc/GHC.p.hi
+ghc/PrelBase.o : ghc/PrelBase.lhs
+ghc/PrelBase.mc.o : ghc/PrelBase.lhs
+ghc/PrelBase.norm.o : ghc/PrelBase.lhs
+ghc/PrelBase.p.o : ghc/PrelBase.lhs
+ghc/PrelBase.mc.o : required/Prelude.mc.hi
+ghc/PrelBase.norm.o : required/Prelude.norm.hi
+ghc/PrelBase.p.o : required/Prelude.p.hi
+ghc/PrelBase.mc.o : ghc/IOBase.mc.hi
+ghc/PrelBase.norm.o : ghc/IOBase.norm.hi
+ghc/PrelBase.p.o : ghc/IOBase.p.hi
+ghc/PrelBase.o : ghc/GHC.hi
+ghc/PrelBase.mc.o : ghc/GHC.mc.hi
+ghc/PrelBase.norm.o : ghc/GHC.norm.hi
+ghc/PrelBase.p.o : ghc/GHC.p.hi
+ghc/PrelIO.o : ghc/PrelIO.lhs
+ghc/PrelIO.mc.o : ghc/PrelIO.lhs
+ghc/PrelIO.norm.o : ghc/PrelIO.lhs
+ghc/PrelIO.p.o : ghc/PrelIO.lhs
+ghc/PrelIO.mc.o : required/Prelude.mc.hi
+ghc/PrelIO.norm.o : required/Prelude.norm.hi
+ghc/PrelIO.p.o : required/Prelude.p.hi
+ghc/PrelIO.o : required/IO.hi
+ghc/PrelIO.mc.o : required/IO.mc.hi
+ghc/PrelIO.norm.o : required/IO.norm.hi
+ghc/PrelIO.p.o : required/IO.p.hi
+ghc/PrelIO.o : ghc/IOHandle.hi
+ghc/PrelIO.mc.o : ghc/IOHandle.mc.hi
+ghc/PrelIO.norm.o : ghc/IOHandle.norm.hi
+ghc/PrelIO.p.o : ghc/IOHandle.p.hi
+ghc/PrelIO.o : ghc/IOBase.hi
+ghc/PrelIO.mc.o : ghc/IOBase.mc.hi
+ghc/PrelIO.norm.o : ghc/IOBase.norm.hi
+ghc/PrelIO.p.o : ghc/IOBase.p.hi
+ghc/PrelIO.o : ghc/PrelBase.hi
+ghc/PrelIO.mc.o : ghc/PrelBase.mc.hi
+ghc/PrelIO.norm.o : ghc/PrelBase.norm.hi
+ghc/PrelIO.p.o : ghc/PrelBase.p.hi
+ghc/PrelIO.o : ghc/PrelRead.hi
+ghc/PrelIO.mc.o : ghc/PrelRead.mc.hi
+ghc/PrelIO.norm.o : ghc/PrelRead.norm.hi
+ghc/PrelIO.p.o : ghc/PrelRead.p.hi
+ghc/PrelList.o : ghc/PrelList.lhs
+ghc/PrelList.mc.o : ghc/PrelList.lhs
+ghc/PrelList.norm.o : ghc/PrelList.lhs
+ghc/PrelList.p.o : ghc/PrelList.lhs
+ghc/PrelList.mc.o : required/Prelude.mc.hi
+ghc/PrelList.norm.o : required/Prelude.norm.hi
+ghc/PrelList.p.o : required/Prelude.p.hi
+ghc/PrelList.mc.o : ghc/IOBase.mc.hi
+ghc/PrelList.norm.o : ghc/IOBase.norm.hi
+ghc/PrelList.p.o : ghc/IOBase.p.hi
+ghc/PrelList.o : ghc/PrelTup.hi
+ghc/PrelList.mc.o : ghc/PrelTup.mc.hi
+ghc/PrelList.norm.o : ghc/PrelTup.norm.hi
+ghc/PrelList.p.o : ghc/PrelTup.p.hi
+ghc/PrelList.o : ghc/PrelBase.hi
+ghc/PrelList.mc.o : ghc/PrelBase.mc.hi
+ghc/PrelList.norm.o : ghc/PrelBase.norm.hi
+ghc/PrelList.p.o : ghc/PrelBase.p.hi
+ghc/PrelNum.o : ghc/PrelNum.lhs
+ghc/PrelNum.mc.o : ghc/PrelNum.lhs
+ghc/PrelNum.norm.o : ghc/PrelNum.lhs
+ghc/PrelNum.p.o : ghc/PrelNum.lhs
+ghc/PrelNum.o : ./../includes/ieee-flpt.h
+ghc/PrelNum.mc.o : ./../includes/ieee-flpt.h
+ghc/PrelNum.norm.o : ./../includes/ieee-flpt.h
+ghc/PrelNum.p.o : ./../includes/ieee-flpt.h
+ghc/PrelNum.mc.o : required/Prelude.mc.hi
+ghc/PrelNum.norm.o : required/Prelude.norm.hi
+ghc/PrelNum.p.o : required/Prelude.p.hi
+ghc/PrelNum.mc.o : ghc/IOBase.mc.hi
+ghc/PrelNum.norm.o : ghc/IOBase.norm.hi
+ghc/PrelNum.p.o : ghc/IOBase.p.hi
+ghc/PrelNum.o : ghc/PrelList.hi
+ghc/PrelNum.mc.o : ghc/PrelList.mc.hi
+ghc/PrelNum.norm.o : ghc/PrelList.norm.hi
+ghc/PrelNum.p.o : ghc/PrelList.p.hi
+ghc/PrelNum.o : ghc/PrelBase.hi
+ghc/PrelNum.mc.o : ghc/PrelBase.mc.hi
+ghc/PrelNum.norm.o : ghc/PrelBase.norm.hi
+ghc/PrelNum.p.o : ghc/PrelBase.p.hi
+ghc/PrelNum.o : ghc/GHC.hi
+ghc/PrelNum.mc.o : ghc/GHC.mc.hi
+ghc/PrelNum.norm.o : ghc/GHC.norm.hi
+ghc/PrelNum.p.o : ghc/GHC.p.hi
+ghc/PrelRead.o : ghc/PrelRead.lhs
+ghc/PrelRead.mc.o : ghc/PrelRead.lhs
+ghc/PrelRead.norm.o : ghc/PrelRead.lhs
+ghc/PrelRead.p.o : ghc/PrelRead.lhs
+ghc/PrelRead.mc.o : required/Prelude.mc.hi
+ghc/PrelRead.norm.o : required/Prelude.norm.hi
+ghc/PrelRead.p.o : required/Prelude.p.hi
+ghc/PrelRead.mc.o : ghc/IOBase.mc.hi
+ghc/PrelRead.norm.o : ghc/IOBase.norm.hi
+ghc/PrelRead.p.o : ghc/IOBase.p.hi
+ghc/PrelRead.o : ghc/PrelNum.hi
+ghc/PrelRead.mc.o : ghc/PrelNum.mc.hi
+ghc/PrelRead.norm.o : ghc/PrelNum.norm.hi
+ghc/PrelRead.p.o : ghc/PrelNum.p.hi
+ghc/PrelRead.o : ghc/PrelList.hi
+ghc/PrelRead.mc.o : ghc/PrelList.mc.hi
+ghc/PrelRead.norm.o : ghc/PrelList.norm.hi
+ghc/PrelRead.p.o : ghc/PrelList.p.hi
+ghc/PrelRead.o : ghc/PrelTup.hi
+ghc/PrelRead.mc.o : ghc/PrelTup.mc.hi
+ghc/PrelRead.norm.o : ghc/PrelTup.norm.hi
+ghc/PrelRead.p.o : ghc/PrelTup.p.hi
+ghc/PrelRead.o : ghc/PrelBase.hi
+ghc/PrelRead.mc.o : ghc/PrelBase.mc.hi
+ghc/PrelRead.norm.o : ghc/PrelBase.norm.hi
+ghc/PrelRead.p.o : ghc/PrelBase.p.hi
+ghc/PrelTup.o : ghc/PrelTup.lhs
+ghc/PrelTup.mc.o : ghc/PrelTup.lhs
+ghc/PrelTup.norm.o : ghc/PrelTup.lhs
+ghc/PrelTup.p.o : ghc/PrelTup.lhs
+ghc/PrelTup.mc.o : required/Prelude.mc.hi
+ghc/PrelTup.norm.o : required/Prelude.norm.hi
+ghc/PrelTup.p.o : required/Prelude.p.hi
+ghc/PrelTup.mc.o : ghc/IOBase.mc.hi
+ghc/PrelTup.norm.o : ghc/IOBase.norm.hi
+ghc/PrelTup.p.o : ghc/IOBase.p.hi
+ghc/PrelTup.o : ghc/PrelBase.hi
+ghc/PrelTup.mc.o : ghc/PrelBase.mc.hi
+ghc/PrelTup.norm.o : ghc/PrelBase.norm.hi
+ghc/PrelTup.p.o : ghc/PrelBase.p.hi
+ghc/STBase.o : ghc/STBase.lhs
+ghc/STBase.mc.o : ghc/STBase.lhs
+ghc/STBase.norm.o : ghc/STBase.lhs
+ghc/STBase.p.o : ghc/STBase.lhs
+ghc/STBase.mc.o : required/Prelude.mc.hi
+ghc/STBase.norm.o : required/Prelude.norm.hi
+ghc/STBase.p.o : required/Prelude.p.hi
+ghc/STBase.o : required/Ix.hi
+ghc/STBase.mc.o : required/Ix.mc.hi
+ghc/STBase.norm.o : required/Ix.norm.hi
+ghc/STBase.p.o : required/Ix.p.hi
+ghc/STBase.o : required/Monad.hi
+ghc/STBase.mc.o : required/Monad.mc.hi
+ghc/STBase.norm.o : required/Monad.norm.hi
+ghc/STBase.p.o : required/Monad.p.hi
+ghc/STBase.o : ghc/PrelTup.hi
+ghc/STBase.mc.o : ghc/PrelTup.mc.hi
+ghc/STBase.norm.o : ghc/PrelTup.norm.hi
+ghc/STBase.p.o : ghc/PrelTup.p.hi
+ghc/STBase.o : ghc/PrelBase.hi
+ghc/STBase.mc.o : ghc/PrelBase.mc.hi
+ghc/STBase.norm.o : ghc/PrelBase.norm.hi
+ghc/STBase.p.o : ghc/PrelBase.p.hi
+ghc/STBase.o : ghc/GHC.hi
+ghc/STBase.mc.o : ghc/GHC.mc.hi
+ghc/STBase.norm.o : ghc/GHC.norm.hi
+ghc/STBase.p.o : ghc/GHC.p.hi
+required/Array.o : required/Array.lhs
+required/Array.mc.o : required/Array.lhs
+required/Array.norm.o : required/Array.lhs
+required/Array.p.o : required/Array.lhs
+required/Array.mc.o : required/Prelude.mc.hi
+required/Array.norm.o : required/Prelude.norm.hi
+required/Array.p.o : required/Prelude.p.hi
required/Array.o : required/Ix.hi
-required/Array.o : required/List.hi
-required/Array.o : prelude/GHCbase.hi
-required/Char.o : required/Char.hs
-required/Complex.o : required/Complex.hs
-required/Directory.o : required/Directory.hs
-required/Directory.o : prelude/GHCio.hi
-required/Directory.o : prelude/PreludeGlaST.hi
-required/Directory.o : prelude/GHCps.hi
-required/IO.o : required/IO.hs
+required/Array.mc.o : required/Ix.mc.hi
+required/Array.norm.o : required/Ix.norm.hi
+required/Array.p.o : required/Ix.p.hi
+required/Array.o : ghc/PrelList.hi
+required/Array.mc.o : ghc/PrelList.mc.hi
+required/Array.norm.o : ghc/PrelList.norm.hi
+required/Array.p.o : ghc/PrelList.p.hi
+required/Array.o : ghc/PrelRead.hi
+required/Array.mc.o : ghc/PrelRead.mc.hi
+required/Array.norm.o : ghc/PrelRead.norm.hi
+required/Array.p.o : ghc/PrelRead.p.hi
+required/Array.o : ghc/ArrBase.hi
+required/Array.mc.o : ghc/ArrBase.mc.hi
+required/Array.norm.o : ghc/ArrBase.norm.hi
+required/Array.p.o : ghc/ArrBase.p.hi
+required/Array.o : ghc/PrelBase.hi
+required/Array.mc.o : ghc/PrelBase.mc.hi
+required/Array.norm.o : ghc/PrelBase.norm.hi
+required/Array.p.o : ghc/PrelBase.p.hi
+required/Char.o : required/Char.lhs
+required/Char.mc.o : required/Char.lhs
+required/Char.norm.o : required/Char.lhs
+required/Char.p.o : required/Char.lhs
+required/Char.mc.o : required/Prelude.mc.hi
+required/Char.norm.o : required/Prelude.norm.hi
+required/Char.p.o : required/Prelude.p.hi
+required/Char.o : ghc/PrelBase.hi
+required/Char.mc.o : ghc/PrelBase.mc.hi
+required/Char.norm.o : ghc/PrelBase.norm.hi
+required/Char.p.o : ghc/PrelBase.p.hi
+required/Complex.o : required/Complex.lhs
+required/Complex.mc.o : required/Complex.lhs
+required/Complex.norm.o : required/Complex.lhs
+required/Complex.p.o : required/Complex.lhs
+required/Directory.o : required/Directory.lhs
+required/Directory.mc.o : required/Directory.lhs
+required/Directory.norm.o : required/Directory.lhs
+required/Directory.p.o : required/Directory.lhs
+required/Directory.o : glaExts/Foreign.hi
+required/Directory.mc.o : glaExts/Foreign.mc.hi
+required/Directory.norm.o : glaExts/Foreign.norm.hi
+required/Directory.p.o : glaExts/Foreign.p.hi
+required/Directory.o : ghc/IOBase.hi
+required/Directory.mc.o : ghc/IOBase.mc.hi
+required/Directory.norm.o : ghc/IOBase.norm.hi
+required/Directory.p.o : ghc/IOBase.p.hi
+required/Directory.o : ghc/STBase.hi
+required/Directory.mc.o : ghc/STBase.mc.hi
+required/Directory.norm.o : ghc/STBase.norm.hi
+required/Directory.p.o : ghc/STBase.p.hi
+required/Directory.o : glaExts/PackedString.hi
+required/Directory.mc.o : glaExts/PackedString.mc.hi
+required/Directory.norm.o : glaExts/PackedString.norm.hi
+required/Directory.p.o : glaExts/PackedString.p.hi
+required/IO.o : required/IO.lhs
+required/IO.mc.o : required/IO.lhs
+required/IO.norm.o : required/IO.lhs
+required/IO.p.o : required/IO.lhs
+required/IO.mc.o : required/Prelude.mc.hi
+required/IO.norm.o : required/Prelude.norm.hi
+required/IO.p.o : required/Prelude.p.hi
required/IO.o : required/Ix.hi
-required/IO.o : prelude/GHCio.hi
-required/IO.o : prelude/GHCbase.hi
-required/IO.o : prelude/GHCps.hi
-required/Ix.o : required/Ix.hs
-required/List.o : required/List.hs
-required/Maybe.o : required/Maybe.hs
-required/Monad.o : required/Monad.hs
-required/Ratio.o : required/Ratio.hs
-required/System.o : required/System.hs
-required/System.o : prelude/GHCio.hi
-required/System.o : prelude/GHCps.hi
-required/System.o : prelude/GHCbase.hi
-concurrent/Channel.o : concurrent/Channel.hs
-concurrent/Channel.o : prelude/GHCbase.hi
-concurrent/ChannelVar.o : concurrent/ChannelVar.hs
-concurrent/ChannelVar.o : prelude/GHCbase.hi
-concurrent/Concurrent.o : concurrent/Concurrent.hs
+required/IO.mc.o : required/Ix.mc.hi
+required/IO.norm.o : required/Ix.norm.hi
+required/IO.p.o : required/Ix.p.hi
+required/IO.o : ghc/STBase.hi
+required/IO.mc.o : ghc/STBase.mc.hi
+required/IO.norm.o : ghc/STBase.norm.hi
+required/IO.p.o : ghc/STBase.p.hi
+required/IO.o : ghc/IOBase.hi
+required/IO.mc.o : ghc/IOBase.mc.hi
+required/IO.norm.o : ghc/IOBase.norm.hi
+required/IO.p.o : ghc/IOBase.p.hi
+required/IO.o : ghc/ArrBase.hi
+required/IO.mc.o : ghc/ArrBase.mc.hi
+required/IO.norm.o : ghc/ArrBase.norm.hi
+required/IO.p.o : ghc/ArrBase.p.hi
+required/IO.o : ghc/IOHandle.hi
+required/IO.mc.o : ghc/IOHandle.mc.hi
+required/IO.norm.o : ghc/IOHandle.norm.hi
+required/IO.p.o : ghc/IOHandle.p.hi
+required/IO.o : glaExts/PackedString.hi
+required/IO.mc.o : glaExts/PackedString.mc.hi
+required/IO.norm.o : glaExts/PackedString.norm.hi
+required/IO.p.o : glaExts/PackedString.p.hi
+required/IO.o : ghc/PrelBase.hi
+required/IO.mc.o : ghc/PrelBase.mc.hi
+required/IO.norm.o : ghc/PrelBase.norm.hi
+required/IO.p.o : ghc/PrelBase.p.hi
+required/IO.o : ghc/GHC.hi
+required/IO.mc.o : ghc/GHC.mc.hi
+required/IO.norm.o : ghc/GHC.norm.hi
+required/IO.p.o : ghc/GHC.p.hi
+required/Ix.o : required/Ix.lhs
+required/Ix.mc.o : required/Ix.lhs
+required/Ix.norm.o : required/Ix.lhs
+required/Ix.p.o : required/Ix.lhs
+required/Ix.mc.o : required/Prelude.mc.hi
+required/Ix.norm.o : required/Prelude.norm.hi
+required/Ix.p.o : required/Prelude.p.hi
+required/Ix.mc.o : ghc/IOBase.mc.hi
+required/Ix.norm.o : ghc/IOBase.norm.hi
+required/Ix.p.o : ghc/IOBase.p.hi
+required/Ix.o : ghc/PrelNum.hi
+required/Ix.mc.o : ghc/PrelNum.mc.hi
+required/Ix.norm.o : ghc/PrelNum.norm.hi
+required/Ix.p.o : ghc/PrelNum.p.hi
+required/Ix.o : ghc/PrelTup.hi
+required/Ix.mc.o : ghc/PrelTup.mc.hi
+required/Ix.norm.o : ghc/PrelTup.norm.hi
+required/Ix.p.o : ghc/PrelTup.p.hi
+required/Ix.o : ghc/PrelBase.hi
+required/Ix.mc.o : ghc/PrelBase.mc.hi
+required/Ix.norm.o : ghc/PrelBase.norm.hi
+required/Ix.p.o : ghc/PrelBase.p.hi
+required/List.o : required/List.lhs
+required/List.mc.o : required/List.lhs
+required/List.norm.o : required/List.lhs
+required/List.p.o : required/List.lhs
+required/List.mc.o : required/Prelude.mc.hi
+required/List.norm.o : required/Prelude.norm.hi
+required/List.p.o : required/Prelude.p.hi
+required/Maybe.o : required/Maybe.lhs
+required/Maybe.mc.o : required/Maybe.lhs
+required/Maybe.norm.o : required/Maybe.lhs
+required/Maybe.p.o : required/Maybe.lhs
+required/Maybe.mc.o : required/Prelude.mc.hi
+required/Maybe.norm.o : required/Prelude.norm.hi
+required/Maybe.p.o : required/Prelude.p.hi
+required/Maybe.mc.o : ghc/IOBase.mc.hi
+required/Maybe.norm.o : ghc/IOBase.norm.hi
+required/Maybe.p.o : ghc/IOBase.p.hi
+required/Maybe.o : required/Monad.hi
+required/Maybe.mc.o : required/Monad.mc.hi
+required/Maybe.norm.o : required/Monad.norm.hi
+required/Maybe.p.o : required/Monad.p.hi
+required/Maybe.o : ghc/PrelList.hi
+required/Maybe.mc.o : ghc/PrelList.mc.hi
+required/Maybe.norm.o : ghc/PrelList.norm.hi
+required/Maybe.p.o : ghc/PrelList.p.hi
+required/Maybe.o : ghc/PrelBase.hi
+required/Maybe.mc.o : ghc/PrelBase.mc.hi
+required/Maybe.norm.o : ghc/PrelBase.norm.hi
+required/Maybe.p.o : ghc/PrelBase.p.hi
+required/Monad.o : required/Monad.lhs
+required/Monad.mc.o : required/Monad.lhs
+required/Monad.norm.o : required/Monad.lhs
+required/Monad.p.o : required/Monad.lhs
+required/Monad.mc.o : required/Prelude.mc.hi
+required/Monad.norm.o : required/Prelude.norm.hi
+required/Monad.p.o : required/Prelude.p.hi
+required/Monad.o : ghc/PrelList.hi
+required/Monad.mc.o : ghc/PrelList.mc.hi
+required/Monad.norm.o : ghc/PrelList.norm.hi
+required/Monad.p.o : ghc/PrelList.p.hi
+required/Monad.o : ghc/PrelTup.hi
+required/Monad.mc.o : ghc/PrelTup.mc.hi
+required/Monad.norm.o : ghc/PrelTup.norm.hi
+required/Monad.p.o : ghc/PrelTup.p.hi
+required/Monad.o : ghc/PrelBase.hi
+required/Monad.mc.o : ghc/PrelBase.mc.hi
+required/Monad.norm.o : ghc/PrelBase.norm.hi
+required/Monad.p.o : ghc/PrelBase.p.hi
+required/Prelude.o : required/Prelude.lhs
+required/Prelude.mc.o : required/Prelude.lhs
+required/Prelude.norm.o : required/Prelude.lhs
+required/Prelude.p.o : required/Prelude.lhs
+required/Prelude.o : ghc/PrelBase.hi
+required/Prelude.mc.o : ghc/PrelBase.mc.hi
+required/Prelude.norm.o : ghc/PrelBase.norm.hi
+required/Prelude.p.o : ghc/PrelBase.p.hi
+required/Prelude.o : ghc/PrelList.hi
+required/Prelude.mc.o : ghc/PrelList.mc.hi
+required/Prelude.norm.o : ghc/PrelList.norm.hi
+required/Prelude.p.o : ghc/PrelList.p.hi
+required/Prelude.o : ghc/PrelIO.hi
+required/Prelude.mc.o : ghc/PrelIO.mc.hi
+required/Prelude.norm.o : ghc/PrelIO.norm.hi
+required/Prelude.p.o : ghc/PrelIO.p.hi
+required/Prelude.o : ghc/PrelRead.hi
+required/Prelude.mc.o : ghc/PrelRead.mc.hi
+required/Prelude.norm.o : ghc/PrelRead.norm.hi
+required/Prelude.p.o : ghc/PrelRead.p.hi
+required/Prelude.o : ghc/PrelNum.hi
+required/Prelude.mc.o : ghc/PrelNum.mc.hi
+required/Prelude.norm.o : ghc/PrelNum.norm.hi
+required/Prelude.p.o : ghc/PrelNum.p.hi
+required/Prelude.o : ghc/PrelTup.hi
+required/Prelude.mc.o : ghc/PrelTup.mc.hi
+required/Prelude.norm.o : ghc/PrelTup.norm.hi
+required/Prelude.p.o : ghc/PrelTup.p.hi
+required/Prelude.o : required/Monad.hi
+required/Prelude.mc.o : required/Monad.mc.hi
+required/Prelude.norm.o : required/Monad.norm.hi
+required/Prelude.p.o : required/Monad.p.hi
+required/Prelude.o : required/Maybe.hi
+required/Prelude.mc.o : required/Maybe.mc.hi
+required/Prelude.norm.o : required/Maybe.norm.hi
+required/Prelude.p.o : required/Maybe.p.hi
+required/Prelude.o : ghc/IOBase.hi
+required/Prelude.mc.o : ghc/IOBase.mc.hi
+required/Prelude.norm.o : ghc/IOBase.norm.hi
+required/Prelude.p.o : ghc/IOBase.p.hi
+required/Ratio.o : required/Ratio.lhs
+required/Ratio.mc.o : required/Ratio.lhs
+required/Ratio.norm.o : required/Ratio.lhs
+required/Ratio.p.o : required/Ratio.lhs
+required/Ratio.mc.o : required/Prelude.mc.hi
+required/Ratio.norm.o : required/Prelude.norm.hi
+required/Ratio.p.o : required/Prelude.p.hi
+required/Ratio.o : ghc/PrelNum.hi
+required/Ratio.mc.o : ghc/PrelNum.mc.hi
+required/Ratio.norm.o : ghc/PrelNum.norm.hi
+required/Ratio.p.o : ghc/PrelNum.p.hi
+required/System.o : required/System.lhs
+required/System.mc.o : required/System.lhs
+required/System.norm.o : required/System.lhs
+required/System.p.o : required/System.lhs
+required/System.o : glaExts/Foreign.hi
+required/System.mc.o : glaExts/Foreign.mc.hi
+required/System.norm.o : glaExts/Foreign.norm.hi
+required/System.p.o : glaExts/Foreign.p.hi
+required/System.o : ghc/IOBase.hi
+required/System.mc.o : ghc/IOBase.mc.hi
+required/System.norm.o : ghc/IOBase.norm.hi
+required/System.p.o : ghc/IOBase.p.hi
+required/System.o : ghc/ArrBase.hi
+required/System.mc.o : ghc/ArrBase.mc.hi
+required/System.norm.o : ghc/ArrBase.norm.hi
+required/System.p.o : ghc/ArrBase.p.hi
+required/System.o : glaExts/PackedString.hi
+required/System.mc.o : glaExts/PackedString.mc.hi
+required/System.norm.o : glaExts/PackedString.norm.hi
+required/System.p.o : glaExts/PackedString.p.hi
+glaExts/Foreign.o : glaExts/Foreign.lhs
+glaExts/Foreign.mc.o : glaExts/Foreign.lhs
+glaExts/Foreign.norm.o : glaExts/Foreign.lhs
+glaExts/Foreign.p.o : glaExts/Foreign.lhs
+glaExts/Foreign.mc.o : required/Prelude.mc.hi
+glaExts/Foreign.norm.o : required/Prelude.norm.hi
+glaExts/Foreign.p.o : required/Prelude.p.hi
+glaExts/Foreign.o : ghc/STBase.hi
+glaExts/Foreign.mc.o : ghc/STBase.mc.hi
+glaExts/Foreign.norm.o : ghc/STBase.norm.hi
+glaExts/Foreign.p.o : ghc/STBase.p.hi
+glaExts/Foreign.o : ghc/ArrBase.hi
+glaExts/Foreign.mc.o : ghc/ArrBase.mc.hi
+glaExts/Foreign.norm.o : ghc/ArrBase.norm.hi
+glaExts/Foreign.p.o : ghc/ArrBase.p.hi
+glaExts/Foreign.o : ghc/PrelNum.hi
+glaExts/Foreign.mc.o : ghc/PrelNum.mc.hi
+glaExts/Foreign.norm.o : ghc/PrelNum.norm.hi
+glaExts/Foreign.p.o : ghc/PrelNum.p.hi
+glaExts/Foreign.o : ghc/PrelBase.hi
+glaExts/Foreign.mc.o : ghc/PrelBase.mc.hi
+glaExts/Foreign.norm.o : ghc/PrelBase.norm.hi
+glaExts/Foreign.p.o : ghc/PrelBase.p.hi
+glaExts/Foreign.o : ghc/GHC.hi
+glaExts/Foreign.mc.o : ghc/GHC.mc.hi
+glaExts/Foreign.norm.o : ghc/GHC.norm.hi
+glaExts/Foreign.p.o : ghc/GHC.p.hi
+glaExts/PackedString.o : glaExts/PackedString.lhs
+glaExts/PackedString.mc.o : glaExts/PackedString.lhs
+glaExts/PackedString.norm.o : glaExts/PackedString.lhs
+glaExts/PackedString.p.o : glaExts/PackedString.lhs
+glaExts/PackedString.mc.o : required/Prelude.mc.hi
+glaExts/PackedString.norm.o : required/Prelude.norm.hi
+glaExts/PackedString.p.o : required/Prelude.p.hi
+glaExts/PackedString.mc.o : ghc/IOBase.mc.hi
+glaExts/PackedString.norm.o : ghc/IOBase.norm.hi
+glaExts/PackedString.p.o : ghc/IOBase.p.hi
+glaExts/PackedString.o : required/Ix.hi
+glaExts/PackedString.mc.o : required/Ix.mc.hi
+glaExts/PackedString.norm.o : required/Ix.norm.hi
+glaExts/PackedString.p.o : required/Ix.p.hi
+glaExts/PackedString.o : ghc/PrelList.hi
+glaExts/PackedString.mc.o : ghc/PrelList.mc.hi
+glaExts/PackedString.norm.o : ghc/PrelList.norm.hi
+glaExts/PackedString.p.o : ghc/PrelList.p.hi
+glaExts/PackedString.o : ghc/STBase.hi
+glaExts/PackedString.mc.o : ghc/STBase.mc.hi
+glaExts/PackedString.norm.o : ghc/STBase.norm.hi
+glaExts/PackedString.p.o : ghc/STBase.p.hi
+glaExts/PackedString.o : ghc/ArrBase.hi
+glaExts/PackedString.mc.o : ghc/ArrBase.mc.hi
+glaExts/PackedString.norm.o : ghc/ArrBase.norm.hi
+glaExts/PackedString.p.o : ghc/ArrBase.p.hi
+glaExts/PackedString.o : ghc/PrelBase.hi
+glaExts/PackedString.mc.o : ghc/PrelBase.mc.hi
+glaExts/PackedString.norm.o : ghc/PrelBase.norm.hi
+glaExts/PackedString.p.o : ghc/PrelBase.p.hi
+glaExts/PackedString.o : ghc/GHC.hi
+glaExts/PackedString.mc.o : ghc/GHC.mc.hi
+glaExts/PackedString.norm.o : ghc/GHC.norm.hi
+glaExts/PackedString.p.o : ghc/GHC.p.hi
+glaExts/ST.o : glaExts/ST.lhs
+glaExts/ST.mc.o : glaExts/ST.lhs
+glaExts/ST.norm.o : glaExts/ST.lhs
+glaExts/ST.p.o : glaExts/ST.lhs
+glaExts/ST.mc.o : required/Prelude.mc.hi
+glaExts/ST.norm.o : required/Prelude.norm.hi
+glaExts/ST.p.o : required/Prelude.p.hi
+glaExts/ST.mc.o : ghc/IOBase.mc.hi
+glaExts/ST.norm.o : ghc/IOBase.norm.hi
+glaExts/ST.p.o : ghc/IOBase.p.hi
+glaExts/ST.o : ghc/ArrBase.hi
+glaExts/ST.mc.o : ghc/ArrBase.mc.hi
+glaExts/ST.norm.o : ghc/ArrBase.norm.hi
+glaExts/ST.p.o : ghc/ArrBase.p.hi
+glaExts/ST.o : ghc/STBase.hi
+glaExts/ST.mc.o : ghc/STBase.mc.hi
+glaExts/ST.norm.o : ghc/STBase.norm.hi
+glaExts/ST.p.o : ghc/STBase.p.hi
+glaExts/ST.o : ghc/PrelBase.hi
+glaExts/ST.mc.o : ghc/PrelBase.mc.hi
+glaExts/ST.norm.o : ghc/PrelBase.norm.hi
+glaExts/ST.p.o : ghc/PrelBase.p.hi
+glaExts/ST.o : ghc/GHC.hi
+glaExts/ST.mc.o : ghc/GHC.mc.hi
+glaExts/ST.norm.o : ghc/GHC.norm.hi
+glaExts/ST.p.o : ghc/GHC.p.hi
+concurrent/Channel.o : concurrent/Channel.lhs
+concurrent/Channel.mc.o : concurrent/Channel.lhs
+concurrent/Channel.norm.o : concurrent/Channel.lhs
+concurrent/Channel.p.o : concurrent/Channel.lhs
+concurrent/ChannelVar.o : concurrent/ChannelVar.lhs
+concurrent/ChannelVar.mc.o : concurrent/ChannelVar.lhs
+concurrent/ChannelVar.norm.o : concurrent/ChannelVar.lhs
+concurrent/ChannelVar.p.o : concurrent/ChannelVar.lhs
+concurrent/Concurrent.o : concurrent/Concurrent.lhs
+concurrent/Concurrent.mc.o : concurrent/Concurrent.lhs
+concurrent/Concurrent.norm.o : concurrent/Concurrent.lhs
+concurrent/Concurrent.p.o : concurrent/Concurrent.lhs
+concurrent/Concurrent.o : required/IO.hi
+concurrent/Concurrent.mc.o : required/IO.mc.hi
+concurrent/Concurrent.norm.o : required/IO.norm.hi
+concurrent/Concurrent.p.o : required/IO.p.hi
concurrent/Concurrent.o : concurrent/Parallel.hi
+concurrent/Concurrent.mc.o : concurrent/Parallel.mc.hi
+concurrent/Concurrent.norm.o : concurrent/Parallel.norm.hi
+concurrent/Concurrent.p.o : concurrent/Parallel.p.hi
concurrent/Concurrent.o : concurrent/ChannelVar.hi
+concurrent/Concurrent.mc.o : concurrent/ChannelVar.mc.hi
+concurrent/Concurrent.norm.o : concurrent/ChannelVar.norm.hi
+concurrent/Concurrent.p.o : concurrent/ChannelVar.p.hi
concurrent/Concurrent.o : concurrent/Channel.hi
+concurrent/Concurrent.mc.o : concurrent/Channel.mc.hi
+concurrent/Concurrent.norm.o : concurrent/Channel.norm.hi
+concurrent/Concurrent.p.o : concurrent/Channel.p.hi
concurrent/Concurrent.o : concurrent/Semaphore.hi
+concurrent/Concurrent.mc.o : concurrent/Semaphore.mc.hi
+concurrent/Concurrent.norm.o : concurrent/Semaphore.norm.hi
+concurrent/Concurrent.p.o : concurrent/Semaphore.p.hi
concurrent/Concurrent.o : concurrent/Merge.hi
+concurrent/Concurrent.mc.o : concurrent/Merge.mc.hi
+concurrent/Concurrent.norm.o : concurrent/Merge.norm.hi
+concurrent/Concurrent.p.o : concurrent/Merge.p.hi
concurrent/Concurrent.o : concurrent/SampleVar.hi
-concurrent/Concurrent.o : prelude/GHCbase.hi
-concurrent/Merge.o : concurrent/Merge.hs
+concurrent/Concurrent.mc.o : concurrent/SampleVar.mc.hi
+concurrent/Concurrent.norm.o : concurrent/SampleVar.norm.hi
+concurrent/Concurrent.p.o : concurrent/SampleVar.p.hi
+concurrent/Concurrent.o : ghc/ConcBase.hi
+concurrent/Concurrent.mc.o : ghc/ConcBase.mc.hi
+concurrent/Concurrent.norm.o : ghc/ConcBase.norm.hi
+concurrent/Concurrent.p.o : ghc/ConcBase.p.hi
+concurrent/Merge.o : concurrent/Merge.lhs
+concurrent/Merge.mc.o : concurrent/Merge.lhs
+concurrent/Merge.norm.o : concurrent/Merge.lhs
+concurrent/Merge.p.o : concurrent/Merge.lhs
concurrent/Merge.o : concurrent/Semaphore.hi
-concurrent/Merge.o : prelude/GHCbase.hi
-concurrent/Merge.o : prelude/GHCio.hi
-concurrent/Merge.o : concurrent/Concurrent.hi
-concurrent/Parallel.o : concurrent/Parallel.hs
-concurrent/Parallel.o : prelude/GHCbase.hi
-concurrent/Parallel.o : prelude/GHCerr.hi
-concurrent/SampleVar.o : concurrent/SampleVar.hs
-concurrent/SampleVar.o : prelude/GHCbase.hi
-concurrent/Semaphore.o : concurrent/Semaphore.hs
-concurrent/Semaphore.o : prelude/GHCbase.hi
+concurrent/Merge.mc.o : concurrent/Semaphore.mc.hi
+concurrent/Merge.norm.o : concurrent/Semaphore.norm.hi
+concurrent/Merge.p.o : concurrent/Semaphore.p.hi
+concurrent/Parallel.o : concurrent/Parallel.lhs
+concurrent/Parallel.mc.o : concurrent/Parallel.lhs
+concurrent/Parallel.norm.o : concurrent/Parallel.lhs
+concurrent/Parallel.p.o : concurrent/Parallel.lhs
+concurrent/SampelVar.o : concurrent/SampelVar.lhs
+concurrent/SampelVar.mc.o : concurrent/SampelVar.lhs
+concurrent/SampelVar.norm.o : concurrent/SampelVar.lhs
+concurrent/SampelVar.p.o : concurrent/SampelVar.lhs
+concurrent/SampleVar.o : concurrent/SampleVar.lhs
+concurrent/SampleVar.mc.o : concurrent/SampleVar.lhs
+concurrent/SampleVar.norm.o : concurrent/SampleVar.lhs
+concurrent/SampleVar.p.o : concurrent/SampleVar.lhs
+concurrent/Semaphore.o : concurrent/Semaphore.lhs
+concurrent/Semaphore.mc.o : concurrent/Semaphore.lhs
+concurrent/Semaphore.norm.o : concurrent/Semaphore.lhs
+concurrent/Semaphore.p.o : concurrent/Semaphore.lhs
# DO NOT DELETE: End of Haskell dependencies
--- /dev/null
+/* This is the Jmakefile for the library stuff.
+ This stuff is all written in (Glasgow-extended) Haskell.
+
+Everything here *must* be compiled w/ the Glasgow Haskell compiler.
+(Hence the use of $(GHC), rather than $(HC) [the latter is your "standard"
+Haskell compiler -- whatever you've configured]).
+
+If you use EXTRA_HC_OPTS on the command line (which you shouldn't,
+strictly speaking), it will probably work -- it is pinned onto
+GHC_OPTS, just for fun.
+*/
+
+/****************************************************************
+* *
+* Jmakefile preamble-y things *
+* *
+****************************************************************/
+
+#define IHaveSubdirs
+
+#if IncludeTestDirsInBuild == YES
+#define __ghc_lib_tests_dir tests
+#else
+#define __ghc_lib_tests_dir /* nothing */
+#endif
+
+SUBDIRS = cbits __ghc_lib_tests_dir
+
+#define NoDocsTargetForSubdirs
+#define NoInstallDocsTargetForSubdirs
+#define NoDependTargetForSubdirs
+
+GhcDriverNeededHere(depend all)
+EtagsNeededHere(tags)
+
+/****************************************************************
+* *
+* options used for compiling/etc. things *
+* *
+****************************************************************/
+
+/* The driver will give warnings if -split-objs, but that's cool... */
+GHC_OPTS=-recomp -cpp \
+ -dcore-lint \
+ -irequired:glaExts:ghc \
+ HcMaxHeapFlag $(EXTRA_HC_OPTS)
+
+EXTRA_MKDEPENDHS_OPTS = -irequired:prelude:ghc:hbc:glaExts:concurrent
+
+PREL_OPTS=
+
+/* per-build options: shared with RTS */
+#define rts_or_lib(r,l) l
+#include "../mkworld/GHC_OPTS"
+
+/* this is just friendliness to "hstags" */
+HSTAGS_OPTS=-fglasgow-exts
+
+/***************************************************************/
+
+/****************************************************************
+* *
+* what it is we are compiling; *
+* these are long and tedious lists, but c'est la guerre *
+* *
+****************************************************************/
+
+BASIC_HS = \
+required/Prelude.lhs \
+required/Array.lhs \
+required/Char.lhs \
+required/Complex.lhs \
+required/Directory.lhs \
+required/IO.lhs \
+required/Ix.lhs \
+required/List.lhs \
+required/Maybe.lhs \
+required/Monad.lhs \
+required/Ratio.lhs \
+required/System.lhs \
+\
+ghc/PrelBase.lhs \
+ghc/GHCerr.lhs \
+ghc/PrelIO.lhs \
+ghc/IOHandle.lhs \
+ghc/IOBase.lhs \
+ghc/STBase.lhs \
+ghc/ArrBase.lhs \
+ghc/PrelRead.lhs \
+ghc/GHCmain.lhs \
+ghc/PrelList.lhs \
+ghc/PrelNum.lhs \
+ghc/PrelTup.lhs \
+\
+glaExts/ST.lhs \
+glaExts/Foreign.lhs \
+glaExts/PackedString.lhs \
+
+# Leave out concurrency for now
+# \
+ghc/ConcBase.lhs \
+# concurrent/Channel.lhs \
+# concurrent/ChannelVar.lhs \
+# concurrent/Merge.lhs \
+# concurrent/Parallel.lhs \
+# concurrent/SampleVar.lhs \
+# concurrent/Semaphore.lhs \
+# concurrent/Concurrent.lhs
+
+BASIC_HIs = $(BASIC_HS:.lhs=.hi)
+
+BASIC_OBJS_DIRS = $(BASIC_HS:.lhs=)
+
+/* easy way to make many many Make variables: */
+WayThingVars(BASIC)
+
+/************************************************************************
+* *
+* Macros for creating and installing libHS<x>.a (in its many flavors). *
+* *
+*************************************************************************/
+
+/****************************************************************
+* *
+* Creating and installing... *
+* libHS_<tag>.a standard Prelude library *
+* *
+****************************************************************/
+
+/* make sure install's target dir is there */
+#if DoInstallGHCSystem == YES
+MakeDirectories(install, $(INSTLIBDIR_GHC) $(INSTDATADIR_GHC)/imports)
+
+InstallDataTarget(MODULES,$(INSTDATADIR_GHC)/imports)
+#endif /* installing */
+
+BasicEverything(libHS, $(INSTLIBDIR_GHC), $(INSTDATADIR_GHC))
+
+/****************************************************************
+* *
+* Creating the individual .hc files: *
+* *
+* For the just-vary-the-GC-thanks flavors, we only need to *
+* compile .hs->.hc once; then re-use the .hc file each time. *
+* *
+* For the profiling one (_p) and all the user-specified *
+* ones, we recompile the Haskell each time. *
+* *
+* NB: old (WDP 95/06) *
+****************************************************************/
+
+/* some "helpful" internal macros first... */
+
+#if GhcWithHscBuiltViaC == YES && HaskellCompilerType == HC_USE_HC_FILES
+#define CompileWayishly__(hc,file,isuf,way,flags) @@\
+clean :: @@\
+ $(RM) CAT3(file,way,.hc)
+#endif
+
+/* now use the macro: */
+
+/* NB: the -Onots are only because -O would not go through on
+ a reasonably-sized machine (i.e., one I have)
+*/
+
+
+CompileWayishly(GHC,required/Prelude,lhs, /*-split-objs Prelude*/ -fglasgow-exts)
+CompileWayishly(GHC,required/Array,lhs, /*-split-objs Array*/ -fglasgow-exts)
+CompileWayishly(GHC,required/Char,lhs, /*-split-objs Char*/)
+CompileWayishly(GHC,required/Complex,lhs, /*-split-objs Complex*/)
+CompileWayishly(GHC,required/Ix,lhs, /*-split-objs Ix*/ -fglasgow-exts)
+CompileWayishly(GHC,required/List,lhs, /*-split-objs List*/)
+CompileWayishly(GHC,required/Maybe,lhs, /*-split-objs Maybe*/)
+CompileWayishly(GHC,required/Monad,lhs, /*-split-objs Monad*/)
+CompileWayishly(GHC,required/Ratio,lhs, /*-split-objs Ratio*/)
+
+CompileWayishly(GHC,required/Directory,lhs, /*-split-objs Directory*/ -fglasgow-exts \
+ '-#include"cbits/stgio.h"' -monly-3-regs)
+CompileWayishly(GHC,required/IO,lhs, /*-split-objs IO*/ -fglasgow-exts \
+ '-#include"cbits/stgio.h"')
+CompileWayishly(GHC,required/System,lhs, /*-split-objs System*/ -fglasgow-exts \
+ '-#include"cbits/stgio.h"')
+
+
+CompileWayishly(GHC,ghc/ConcBase,lhs, /*-split-objs ConcBase*/ -fglasgow-exts)
+CompileWayishly(GHC,ghc/PrelBase,lhs, /*-split-objs PrelBase*/ -fglasgow-exts)
+CompileWayishly(GHC,ghc/STBase,lhs, /*-split-objs STBase*/ -fglasgow-exts)
+CompileWayishly(GHC,ghc/IOBase,lhs, /*-split-objs IOBase*/ -fglasgow-exts)
+CompileWayishly(GHC,ghc/ArrBase,lhs, /*-split-objs ArrBase*/ -fglasgow-exts)
+CompileWayishly(GHC,ghc/PrelRead,lhs, /*-split-objs PrelRead*/ -fglasgow-exts)
+CompileWayishly(GHC,ghc/PrelList,lhs, /*-split-objs PrelList*/)
+CompileWayishly(GHC,ghc/PrelNum,lhs, /*-split-objs PrelNum*/ -fglasgow-exts)
+CompileWayishly(GHC,ghc/PrelTup,lhs, /*-split-objs PrelTup*/)
+CompileWayishly(GHC,ghc/PrelIO,lhs, /*-split-objs PrelIO*/ -fglasgow-exts)
+CompileWayishly(GHC,ghc/IOHandle,lhs, /*-split-objs IOHandle*/ -fglasgow-exts)
+CompileWayishly(GHC,ghc/GHCerr,lhs, /*-split-objs GHCerr*/ -fglasgow-exts)
+CompileWayishly(GHC,ghc/GHCmain,lhs, /*-split-objs GHCmain*/ -fglasgow-exts)
+
+CompileWayishly(GHC,glaExts/Foreign,lhs, /*-split-objs Foreign*/ -fglasgow-exts)
+CompileWayishly(GHC,glaExts/ST,lhs, /*-split-objs ST*/ -fglasgow-exts)
+CompileWayishly(GHC,glaExts/PackedString,lhs, /*-split-objs PackedString*/ -fglasgow-exts)
+
+
+CompileWayishly(GHC,concurrent/Channel,lhs,)
+CompileWayishly(GHC,concurrent/ChannelVar,lhs,)
+CompileWayishly(GHC,concurrent/Merge,lhs,-iconcurrent)
+CompileWayishly(GHC,concurrent/Parallel,lhs,-fglasgow-exts)
+CompileWayishly(GHC,concurrent/SampleVar,lhs,)
+CompileWayishly(GHC,concurrent/Semaphore,lhs,)
+CompileWayishly(GHC,concurrent/Concurrent,lhs,-iconcurrent)
+
+/****************************************************************
+* *
+* misc "make" targets -- depend, clean, tags *
+* *
+****************************************************************/
+
+hc-files : $(BASIC_HS:.lhs=.hc)
+
+/* this is a BAD idea!
+ExtraStuffToClean( $(SRCS_C) )
+ without the .hc files, the distrib cannot boot itself
+*/
+ExtraStuffToBeVeryClean( $(SRCS_C) )
+ExtraStuffToBeVeryClean( $(STD_VERY_CLEAN) )
+
+ClearTagsFile()
+/* Ugly but OK? [WDP 94/09] */
+HsTagsTarget( */[A-Z]*.*hs )
+HSTAGS_OPTS=-cpp -fglasgow-exts
+
+/* should be *LAST* */
+#if HaskellCompilerType != HC_USE_HC_FILES
+ /* otherwise, the dependencies jeopardize our .hc files --
+ which are all we have! */
+MAIN_INCLUDE_DIR = $(TOP_PWD)/$(CURRENT_DIR)/$(GHC_INCLUDES)
+
+MKDEPENDHS_OPTS= \
+IfBuild_mc(-s mc) \
+IfBuild_mr(-s mr) \
+IfBuild_mt(-s mt) \
+IfBuild_mp(-s mp) \
+IfBuild_mg(-s mg) \
+IfBuild_2s(-s 2s) \
+IfBuild_1s(-s 1s) \
+IfBuild_du(-s du) \
+IfBuild_p(-s p) \
+IfBuild_t(-s t) \
+IfBuild_a(-s a) \
+IfBuild_b(-s b) \
+IfBuild_c(-s c) \
+IfBuild_d(-s d) \
+IfBuild_e(-s e) \
+IfBuild_f(-s f) \
+IfBuild_g(-s g) \
+IfBuild_h(-s h) \
+IfBuild_i(-s i) \
+IfBuild_j(-s j) \
+IfBuild_k(-s k) \
+IfBuild_l(-s l) \
+IfBuild_m(-s m) \
+IfBuild_n(-s n) \
+IfBuild_o(-s o) \
+IfBuild_A(-s A) \
+IfBuild_B(-s B) \
+-o hc -I$(MAIN_INCLUDE_DIR)
+
+HaskellDependTarget( $(BASIC_HS) )
+#endif
#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.2 1996/11/21 16:47:41 simonm Exp $
+# $Id: Makefile,v 1.3 1996/12/19 09:13:55 simonpj Exp $
TOP = ../..
include $(TOP)/ghc/mk/ghc.mk
$(MAKE) -f Makefile.libHS suffix=$$i; \
done
+# Shortcut for typical case when testing: just make the "normal" version
+libHS.a ::
+ $(MAKE) -f Makefile.libHS suffix=norm
+
install ::
@for i in $(WAY_SUFFIXES); do \
$(MAKE) -f Makefile.libHS suffix=$$i install; \
#-----------------------------------------------------------------------------
-# $Id: Makefile.libHS,v 1.2 1996/11/21 16:47:42 simonm Exp $
+# $Id: Makefile.libHS,v 1.3 1996/12/19 09:13:56 simonpj Exp $
TOP = ../..
include $(TOP)/ghc/mk/ghc.mk
# per-build options: shared with runtime system
include ../mk/buildflags.mk
+# ============= ADDED BY SIMON =============
+ifeq ($(GhcWithHscBuiltViaC),YES)
+ HC = $(GHC)
+ SuffixRule_hc_o = YES
+else
+ HaskellSuffixRules = YES
+endif
+include $(TOP)/mk/rules.mk
+# ===========================================
+
# Everything here *must* be compiled with the Glasgow Haskell compiler.
# (Hence the use of $(GHC), rather than $(HC).)
# The driver will give warnings if -split-objs, but that's cool...
GHC_OPTS = \
- -recomp -cpp -dcore-lint -irequired -fusing-ghc-internals -fvia-C \
+ -recomp -cpp -dcore-lint -fglasgow-exts -fvia-C \
$(HcMaxHeapFlag) $(EXTRA_HC_OPTS)
-SRCS = $(wildcard prelude/*.hs required/*.hs concurrent/*.hs)
-OBJS = $(SRCS:.hs=.$(suffix)_o)
+SRCS = $(wildcard ghc/*.lhs required/*.lhs glaExts/*.lhs concurrent/*.lhs)
+ifeq ($(suffix), norm)
+OBJS = $(SRCS:.lhs=.o)
+else
+OBJS = $(SRCS:.lhs=.$(suffix)_o)
+endif
#-----------------------------------------------------------------------------
# Rules for building various types of objects from HS files
endif
ifneq ($(GhcWithHscBuiltViaC),YES)
-%.o : %.hs
- $(LIB_GHC) $($*_flags) $*.hs
+%.o : %.lhs
+ $(LIB_GHC) $($*_flags) $*.lhs
-%.$(suffix)_o : %.hs
+%.$(suffix)_o : %.lhs
$(LIB_GHC) $(GHC_OPTS_$(suffix)) $($*_flags) $*.hs
else # $(GhcWithHscBuiltViaC) == YES
# The -Onots are only because -O would not go through on
# a reasonably-sized machine (i.e., one I have)
-prelude/Prelude_flags = \
- -iprelude -fglasgow-exts -fcompiling-ghc-internals Prelude \
- -fno-implicit-prelude '-\#include"cbits/stgio.h"' -H18m -Onot
-prelude/GHCbase_flags = \
- -iprelude -fglasgow-exts -fcompiling-ghc-internals GHCbase \
- '-\#include"cbits/stgio.h"' -H20m -monly-2-regs -Onot
-prelude/GHCerr_flags = \
- -iprelude -fglasgow-exts -fcompiling-ghc-internals GHCerr -H12m -Onot
-prelude/GHCps_flags = \
- -iprelude -fglasgow-exts '-\#include"cbits/stgio.h"' -monly-3-regs -Onot
-prelude/GHCio_flags = \
- -iprelude -fglasgow-exts '-\#include"cbits/stgio.h"' -Onot
-prelude/GHCmain_flags = -iprelude -fglasgow-exts
-prelude/PreludeGlaST_flags = -iprelude -fglasgow-exts
-
-required/Array_flags = -fglasgow-exts -iprelude -Onot
-required/Directory_flags = \
- -fglasgow-exts '-\#include"cbits/stgio.h"' -monly-3-regs
-required/IO_flags = -fglasgow-exts '-\#include"cbits/stgio.h"'
-required/Ix_flags = -fglasgow-exts
-required/System_flags = -fglasgow-exts '-\#include"cbits/stgio.h"'
+ghc/PackedString_flags = '-\#include"cbits/stgio.h"' -monly-3-regs
+required/Directory_flags = '-\#include"cbits/stgio.h"' -monly-3-regs
+required/System_flags = '-\#include"cbits/stgio.h"'
concurrent/Merge_flags = -iconcurrent
concurrent/Parallel_flags = -fglasgow-exts
# Depend and install stuff
MKDEPENDHS_OPTS += -I$(GHC_INCLUDES)
-MKDEPENDHS_OPTS += -irequired:prelude:ghc:hbc:glaExts:concurrent
+MKDEPENDHS_OPTS += -irequired:ghc:hbc:glaExts:concurrent
MKDEPENDHS_OPTS += $(foreach way,$(WAY_SUFFIXES),-s .$(way))
# Todo: make this a generic include of hsdepend.mk or something.
/* Question: this is just an amusing hex code isn't it
-- or does it mean something? ADR */
P_ realWorldZh_closure = (P_) 0xbadbadbaL;
-P_ GHCbuiltins_void_closure = (P_) 0xbadbadbaL;
+P_ GHC_void_closure = (P_) 0xbadbadbaL;
-SET_STATIC_HDR(WorldStateToken_closure,GHCbase_SZh_static_info,CC_SUBSUMED/*harmless*/,,ED_RO_)
+SET_STATIC_HDR(WorldStateToken_closure,STBase_SZh_static_info,CC_SUBSUMED/*harmless*/,,ED_RO_)
, (W_) 0xbadbadbaL
};
might have to perform a DynamicReturn (just Bool at the moment).
\begin{code}
-ED_RO_(Prelude_False_inregs_info);
-ED_RO_(Prelude_True_inregs_info);
+ED_RO_(PrelBase_False_inregs_info);
+ED_RO_(PrelBase_True_inregs_info);
-const W_ Prelude_Bool_itblvtbl[] = {
- (W_) Prelude_False_inregs_info,
- (W_) Prelude_True_inregs_info
+const W_ PrelBase_Bool_itblvtbl[] = {
+ (W_) PrelBase_False_inregs_info,
+ (W_) PrelBase_True_inregs_info
};
\end{code}
#define NULL_REG_MAP
#include "SMinternal.h"
-EXTDATA_RO(Prelude_CZh_static_info);
-EXTDATA_RO(Prelude_IZh_static_info);
+EXTDATA_RO(PrelBase_CZh_static_info);
+EXTDATA_RO(PrelBase_IZh_static_info);
#define __CHARLIKE_CLOSURE(n) (CHARLIKE_closures+((n)*(CHARLIKE_HS+1)))
#define __INTLIKE_CLOSURE(n) (INTLIKE_closures_def+(((n)-MIN_INTLIKE)*(INTLIKE_HS+1)))
-#define CHARLIKE_HDR(n) SET_STATIC_FIXED_HDR(__CHARLIKE_CLOSURE(n),Prelude_CZh_static_info,CC_DONTZuCARE), (W_) n
+#define CHARLIKE_HDR(n) SET_STATIC_FIXED_HDR(__CHARLIKE_CLOSURE(n),PrelBase_CZh_static_info,CC_DONTZuCARE), (W_) n
-#define INTLIKE_HDR(n) SET_STATIC_FIXED_HDR(__INTLIKE_CLOSURE(n),Prelude_IZh_static_info,CC_DONTZuCARE), (W_) n
+#define INTLIKE_HDR(n) SET_STATIC_FIXED_HDR(__INTLIKE_CLOSURE(n),PrelBase_IZh_static_info,CC_DONTZuCARE), (W_) n
const W_ CHARLIKE_closures[] = {
CHARLIKE_HDR(0),
projects / ghc-hetmet.git / commitdiff