From e1fc52f6868619bbeafaced910c50a304db5e0f9 Mon Sep 17 00:00:00 2001 From: simonpj Date: Sun, 8 Mar 1998 22:45:56 +0000 Subject: [PATCH] [project @ 1998-03-08 22:44:44 by simonpj] New specialiser; warning: simplifier *may* be broken --- ghc/compiler/Makefile | 8 +- ghc/compiler/absCSyn/CLabel.lhs | 4 +- ghc/compiler/basicTypes/Id.lhs | 215 +++------------------------- ghc/compiler/basicTypes/IdInfo.lhs | 28 +--- ghc/compiler/coreSyn/CoreUnfold.lhs | 8 +- ghc/compiler/coreSyn/CoreUtils.lhs | 244 ++------------------------------ ghc/compiler/deSugar/DsExpr.lhs | 18 --- ghc/compiler/main/CmdLineOpts.lhs | 9 +- ghc/compiler/parser/hsparser.y | 2 +- ghc/compiler/prelude/PrelVals.lhs | 8 +- ghc/compiler/simplCore/ConFold.lhs | 2 +- ghc/compiler/simplCore/OccurAnal.lhs | 105 ++++++-------- ghc/compiler/simplCore/SimplCase.lhs | 27 ++-- ghc/compiler/simplCore/SimplCore.lhs | 18 ++- ghc/compiler/simplCore/SimplEnv.lhs | 159 +++++++++++---------- ghc/compiler/simplCore/SimplMonad.lhs | 65 +++------ ghc/compiler/simplCore/SimplPgm.lhs | 1 - ghc/compiler/simplCore/SimplUtils.lhs | 42 +++++- ghc/compiler/simplCore/SimplVar.lhs | 135 ++++++++++++++++-- ghc/compiler/simplCore/Simplify.lhs | 74 ++++------ ghc/compiler/specialise/SpecEnv.lhs | 158 ++++++++++++--------- ghc/compiler/specialise/Specialise.lhs | 134 ++++++++++++------ ghc/compiler/typecheck/Inst.lhs | 23 +-- ghc/compiler/typecheck/TcBinds.lhs | 8 +- ghc/compiler/typecheck/TcClassDcl.lhs | 2 +- ghc/compiler/typecheck/TcEnv.lhs | 2 +- ghc/compiler/typecheck/TcIfaceSig.lhs | 12 +- ghc/compiler/typecheck/TcInstUtil.lhs | 4 +- ghc/compiler/typecheck/Unify.lhs | 33 +++-- ghc/compiler/types/TyVar.lhs | 24 +++- ghc/compiler/types/Type.lhs | 78 ++++++---- ghc/compiler/utils/UniqFM.lhs | 6 + 32 files changed, 694 insertions(+), 962 deletions(-) diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 5578d24..5674098 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.36 1998/03/05 13:12:20 sof Exp $ +# $Id: Makefile,v 1.37 1998/03/08 22:44:44 simonpj Exp $ TOP = .. include $(TOP)/mk/boilerplate.mk @@ -132,16 +132,13 @@ SRC_HC_OPTS += -recomp $(GhcHcOpts) # The standard suffix rule for compiling a Haskell file # adds these flags to the command line -absCSyn/AbsCSyn_HC_OPTS = -fno-omit-reexported-instances absCSyn/CStrings_HC_OPTS = -monly-3-regs # Was 6m with 2.10 absCSyn/PprAbsC_HC_OPTS = -H10m basicTypes/IdInfo_HC_OPTS = -K2m -coreSyn/AnnCoreSyn_HC_OPTS = -fno-omit-reexported-instances hsSyn/HsExpr_HC_OPTS = -K2m -hsSyn/HsSyn_HC_OPTS = -fno-omit-reexported-instances main/Main_HC_OPTS = -fvia-C -DPROJECTVERSION=$(GhcProjectVersion) main/MkIface_HC_OPTS = -DPROJECTVERSION=$(GhcProjectVersionInt) main/CmdLineOpts_HC_OPTS = -fvia-C @@ -179,10 +176,7 @@ rename/RnIfaces_HC_OPTS = -H8m -fvia-C rename/RnExpr_HC_OPTS = -H10m rename/RnNames_HC_OPTS = -H12m rename/RnMonad_HC_OPTS = -fvia-C -# Urk! Really big heap for ParseUnfolding -#rename/ParseUnfolding_HC_OPTS = -H45m specialise/Specialise_HC_OPTS = -Onot -H12m -stgSyn/StgSyn_HC_OPTS = -fno-omit-reexported-instances typecheck/TcGenDeriv_HC_OPTS = -H10m # Was 10m for 2.10 diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 6111c6a..296bde8 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -54,7 +54,7 @@ import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl ) import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg ) import CStrings ( pp_cSEP ) -import Id ( externallyVisibleId, cmpId_withSpecDataCon, +import Id ( externallyVisibleId, isDataCon, isDictFunId, isDefaultMethodId_maybe, fIRST_TAG, @@ -117,7 +117,7 @@ instance Ord CLabelId where CLabelId a < CLabelId b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } CLabelId a >= CLabelId b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } CLabelId a > CLabelId b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } - compare (CLabelId a) (CLabelId b) = a `cmpId_withSpecDataCon` b + compare (CLabelId a) (CLabelId b) = a `compare` b \end{code} \begin{code} diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 927d333..5f12c46 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -50,9 +50,7 @@ module Id ( -- PREDICATES omitIfaceSigForId, - cmpEqDataCon, cmpId, - cmpId_withSpecDataCon, externallyVisibleId, idHasNoFreeTyVars, idWantsToBeINLINEd, getInlinePragma, @@ -66,7 +64,6 @@ module Id ( isRecordSelector, isDictSelId_maybe, isNullaryDataCon, - isSpecPragmaId, isPrimitiveId_maybe, isSysLocalId, isTupleCon, @@ -74,18 +71,13 @@ module Id ( toplevelishId, unfoldingUnfriendlyId, - -- SUBSTITUTION - applyTypeEnvToId, - apply_to_Id, - -- PRINTING and RENUMBERING pprId, --- pprIdInUnfolding, showId, -- Specialialisation getIdSpecialisation, - addIdSpecialisation, + setIdSpecialisation, -- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc) addIdUnfolding, @@ -118,11 +110,11 @@ module Id ( intersectIdSets, isEmptyIdSet, isNullIdEnv, - lookupIdEnv, + lookupIdEnv, lookupIdSubst, lookupNoFailIdEnv, mapIdEnv, minusIdSet, - mkIdEnv, + mkIdEnv, elemIdEnv, mkIdSet, modifyIdEnv, modifyIdEnv_Directly, @@ -213,10 +205,7 @@ data IdDetails -- 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 + ---------------- Global values @@ -260,14 +249,6 @@ data IdDetails -- actually do comparisons that way, we kindly supply -- a Unique for that purpose. - | SpecId -- A specialisation of another Id - Id -- Id of which this is a specialisation - [Maybe Type] -- Types at which it is specialised; - -- A "Nothing" says this type ain't relevant. - Bool -- True <=> no free type vars; it's not enough - -- to know about the unspec version, because - -- we may specialise to a type w/ free tyvars - -- (i.e., in one of the "Maybe Type" dudes). type ConTag = Int type DictVar = Id @@ -301,38 +282,6 @@ generates The type variables in the name are irrelevant; we print them as stars. -Constant method ids are generated from instance decls where -there is no context; that is, no dictionaries are needed to -construct the method. Example -\begin{verbatim} - instance Foo Int where - op = ... -\end{verbatim} -Then we get a constant method -\begin{verbatim} - Foo.op.Int = ... -\end{verbatim} - -It is possible, albeit unusual, to have a constant method -for an instance decl which has type vars: -\begin{verbatim} - instance Foo [a] where - op [] ys = True - op (x:xs) ys = False -\end{verbatim} -We get the constant method -\begin{verbatim} - Foo.op.[*] = ... -\end{verbatim} -So a constant method is identified by a class/op/type triple. -The type variables in the type are irrelevant. - - -For Ids whose names must be known/deducible in other modules, we have -to conjure up their worker's names (and their worker's worker's -names... etc) in a known systematic way. - - %************************************************************************ %* * \subsection[Id-documentation]{Documentation} @@ -384,9 +333,6 @@ include dictionaries for the immediate superclasses of C at the type (T a b ..). %---------------------------------------------------------------------- -\item[@SpecId@:] - -%---------------------------------------------------------------------- \item[@LocalId@:] A purely-local value, e.g., a function argument, something defined in a @where@ clauses, ... --- but which appears in the original program text. @@ -395,11 +341,6 @@ the original program text. \item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in the original program text; these are introduced by the compiler in doing its thing. - -%---------------------------------------------------------------------- -\item[@SpecPragmaId@:] Introduced by the compiler to record -Specialisation pragmas. It is dead code which MUST NOT be removed -before specialisation. \end{description} Further remarks: @@ -433,7 +374,6 @@ properties, but they may not. -- isDataCon returns False for @newtype@ constructors isDataCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ tc) _ _) = isDataTyCon tc isDataCon (Id _ _ _ (TupleConId _) _ _) = True -isDataCon (Id _ _ _ (SpecId unspec _ _) _ _) = isDataCon unspec isDataCon other = False isNewCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ tc) _ _) = isNewTyCon tc @@ -442,11 +382,9 @@ isNewCon other = False -- isAlgCon returns True for @data@ or @newtype@ constructors isAlgCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ _) _ _) = True isAlgCon (Id _ _ _ (TupleConId _) _ _) = True -isAlgCon (Id _ _ _ (SpecId unspec _ _) _ _) = isAlgCon unspec isAlgCon other = False isTupleCon (Id _ _ _ (TupleConId _) _ _) = True -isTupleCon (Id _ _ _ (SpecId unspec _ _) _ _) = isTupleCon unspec isTupleCon other = False \end{code} @@ -470,11 +408,8 @@ toplevelishId (Id _ _ _ details _ _) chk (DictSelId _) = True chk (DefaultMethodId _) = True chk (DictFunId _ _) = 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) @@ -487,10 +422,8 @@ idHasNoFreeTyVars (Id _ _ _ details _ info) chk (DictSelId _) = True chk (DefaultMethodId _) = True chk (DictFunId _ _) = True - 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 -- omitIfaceSigForId tells whether an Id's info is implied by other declarations, @@ -515,11 +448,11 @@ omitIfaceSigForId (Id _ name _ details _ _) -- The dfun id must *not* be omitted, because it carries version info for -- the instance decl (AlgConId _ _ _ _ _ _ _ _ _) -> True - (TupleConId _) -> True - (RecordSelId _) -> True - (DictSelId _) -> True + (TupleConId _) -> True + (RecordSelId _) -> True + (DictSelId _) -> True - other -> False -- Don't omit! + other -> False -- Don't omit! -- NB DefaultMethodIds are not omitted \end{code} @@ -532,15 +465,6 @@ isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (strictnessInfo info) isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True isSysLocalId other = False -isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _) _ _) = True -isSpecPragmaId other = False - -isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _) _ _) - = ASSERT(not (maybeToBool (isSpecId_maybe unspec))) - Just (unspec, ty_maybes) -isSpecId_maybe other_id - = Nothing - isDictSelId_maybe (Id _ _ _ (DictSelId cls) _ _) = Just cls isDictSelId_maybe _ = Nothing @@ -582,43 +506,6 @@ externallyVisibleId id@(Id _ name _ _ _ _) = not (isLocalName name) -- not local => global => externally visible \end{code} -CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@: -`Top-levelish Ids'' cannot have any free type variables, so applying -the type-env cannot have any effect. (NB: checked in CoreLint?) - -\begin{code} -type TypeEnv = TyVarEnv Type - -applyTypeEnvToId :: TypeEnv -> Id -> Id -applyTypeEnvToId type_env id@(Id _ _ ty _ _ _) - = apply_to_Id ( \ ty -> - instantiateTy type_env ty - ) id -\end{code} - -\begin{code} -apply_to_Id :: (Type -> Type) -> Id -> Id - -apply_to_Id ty_fn id@(Id u n ty details prag info) - | idHasNoFreeTyVars id - = id - | otherwise - = Id u n (ty_fn ty) (apply_to_details details) prag (apply_to_IdInfo ty_fn info) - where - apply_to_details (SpecId unspec ty_maybes no_ftvs) - = let - new_unspec = apply_to_Id ty_fn unspec - new_maybes = map apply_to_maybe ty_maybes - in - SpecId new_unspec new_maybes (no_free_tvs ty) - -- ToDo: gratuitous recalc no_ftvs???? - where - apply_to_maybe Nothing = Nothing - apply_to_maybe (Just ty) = Just (ty_fn ty) - - apply_to_details other = other -\end{code} - %************************************************************************ %* * @@ -711,9 +598,9 @@ mkSysLocal str uniq ty loc mkUserLocal occ uniq ty loc = Id uniq (mkLocalName uniq occ loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo -mkUserId :: Name -> GenType flexi -> PragmaInfo -> GenId (GenType flexi) -mkUserId name ty pragma_info - = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo +mkUserId :: Name -> GenType flexi -> GenId (GenType flexi) +mkUserId name ty + = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo \end{code} \begin{code} @@ -733,21 +620,6 @@ mkIdWithNewName (Id _ _ ty details prag info) new_name mkIdWithNewType :: Id -> Type -> Id mkIdWithNewType (Id u name _ details pragma info) ty = Id u name ty details pragma info - -{- --- Specialised version of constructor: only used in STG and code generation --- Note: The specialsied Id has the same unique as the unspeced Id - -mkSameSpecCon ty_maybes unspec@(Id u name ty details pragma info) - = ASSERT(isDataCon unspec) - ASSERT(not (maybeToBool (isSpecId_maybe unspec))) - Id u name new_ty (SpecId unspec ty_maybes (no_free_tvs new_ty)) pragma info - where - new_ty = specialiseTy ty ty_maybes 0 - - -- pprTrace "SameSpecCon:Unique:" - -- (ppSep (ppr unspec: [pprMaybeTy ty | ty <- ty_maybes])) --} \end{code} Make some local @Ids@ for a template @CoreExpr@. These have bogus @@ -866,7 +738,6 @@ isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience dataConTag :: DataCon -> ConTag -- will panic if not a DataCon dataConTag (Id _ _ _ (AlgConId tag _ _ _ _ _ _ _ _) _ _) = tag dataConTag (Id _ _ _ (TupleConId _) _ _) = fIRST_TAG -dataConTag (Id _ _ _ (SpecId unspec _ _) _ _) = dataConTag unspec dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon dataConTyCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ tycon) _ _) = tycon @@ -884,25 +755,6 @@ dataConSig (Id _ _ _ (TupleConId arity) _ _) tyvars = take arity alphaTyVars tyvar_tys = mkTyVarTys tyvars -dataConSig (Id _ _ _ (SpecId unspec ty_maybes _) _ _) - = (spec_tyvars, spec_theta_ty, spec_con_tyvars, spec_con_theta, spec_arg_tys, spec_tycon) - where - (tyvars, theta_ty, con_tyvars, con_theta, arg_tys, tycon) = dataConSig unspec - - ty_env = tyvars `zip` ty_maybes - - spec_tyvars = [tyvar | (tyvar, Nothing) <- ty_env] - spec_con_tyvars = [tyvar | (tyvar, Nothing) <- con_tyvars `zip` ty_maybes] -- Hmm.. - - spec_env = mkTyVarEnv [(tyvar, ty) | (tyvar, Just ty) <- ty_env] - spec_arg_tys = map (instantiateTauTy spec_env) arg_tys - - spec_theta_ty = if null theta_ty then [] - else panic "dataConSig:ThetaTy:SpecDataCon1" - spec_con_theta = if null con_theta then [] - else panic "dataConSig:ThetaTy:SpecDataCon2" - spec_tycon = mkSpecTyCon tycon ty_maybes - -- dataConRepType returns the type of the representation of a contructor -- This may differ from the type of the contructor Id itself for two reasons: @@ -937,13 +789,11 @@ dataConFieldLabels x@(Id _ _ _ idt _ _) = LocalId _ -> "l" SysLocalId _ -> "sl" PrimitiveId _ -> "p" - SpecPragmaId _ _ -> "sp" ImportedId -> "i" RecordSelId _ -> "r" DictSelId _ -> "m" DefaultMethodId _ -> "d" - DictFunId _ _ -> "di" - SpecId _ _ _ -> "spec")) + DictFunId _ _ -> "di")) #endif dataConStrictMarks :: DataCon -> [StrictnessMark] @@ -1097,9 +947,9 @@ addIdFBTypeInfo (Id u n ty info details) upd_info getIdSpecialisation :: Id -> IdSpecEnv getIdSpecialisation (Id _ _ _ _ _ info) = specInfo info -addIdSpecialisation :: Id -> IdSpecEnv -> Id -addIdSpecialisation (Id u n ty details prags info) spec_info - = Id u n ty details prags (info `addSpecInfo` spec_info) +setIdSpecialisation :: Id -> IdSpecEnv -> Id +setIdSpecialisation (Id u n ty details prags info) spec_info + = Id u n ty details prags (info `setSpecInfo` spec_info) \end{code} Strictness: we snaffle the info out of the IdInfo. @@ -1140,32 +990,6 @@ instance Ord (GenId ty) where compare a b = cmpId a b \end{code} -@cmpId_withSpecDataCon@ ensures that any spectys are taken into -account when comparing two data constructors. We need to do this -because a specialised data constructor has the same Unique as its -unspecialised counterpart. - -\begin{code} -cmpId_withSpecDataCon :: Id -> Id -> Ordering - -cmpId_withSpecDataCon id1 id2 - | eq_ids && isDataCon id1 && isDataCon id2 - = cmpEqDataCon id1 id2 - - | otherwise - = cmp_ids - where - cmp_ids = cmpId id1 id2 - eq_ids = case cmp_ids of { EQ -> True; other -> False } - -cmpEqDataCon (Id _ _ _ (SpecId _ mtys1 _) _ _) (Id _ _ _ (SpecId _ mtys2 _) _ _) - = panic "Id.cmpEqDataCon:cmpUniTypeMaybeList mtys1 mtys2" - -cmpEqDataCon _ (Id _ _ _ (SpecId _ _ _) _ _) = LT -cmpEqDataCon (Id _ _ _ (SpecId _ _ _) _ _) _ = GT -cmpEqDataCon _ _ = EQ -\end{code} - %************************************************************************ %* * \subsection[Id-other-instances]{Other instance declarations for @Id@s} @@ -1237,9 +1061,11 @@ rngIdEnv :: IdEnv a -> [a] isNullIdEnv :: IdEnv a -> Bool lookupIdEnv :: IdEnv a -> GenId ty -> Maybe a lookupNoFailIdEnv :: IdEnv a -> GenId ty -> a +elemIdEnv :: Id -> IdEnv a -> Bool \end{code} \begin{code} +elemIdEnv = elemUFM addOneToIdEnv = addToUFM combineIdEnvs = plusUFM_C delManyFromIdEnv = delListFromUFM @@ -1251,11 +1077,16 @@ mkIdEnv = listToUFM nullIdEnv = emptyUFM rngIdEnv = eltsUFM unitIdEnv = unitUFM +isNullIdEnv = isNullUFM growIdEnvList env pairs = plusUFM env (listToUFM pairs) -isNullIdEnv env = sizeUFM env == 0 lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx } +lookupIdSubst :: IdEnv Id -> Id -> Id +lookupIdSubst env id = case lookupIdEnv env id of + Just id' -> id' -- Return original if + Nothing -> id -- it isn't in subst + -- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the -- modify function, and put it back. diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index d50a60e..31ca5b6 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -12,7 +12,6 @@ module IdInfo ( noIdInfo, ppIdInfo, - applySubstToIdInfo, apply_to_IdInfo, -- not for general use, please ArityInfo(..), exactArity, atLeastArity, unknownArity, @@ -30,7 +29,7 @@ module IdInfo ( unfoldInfo, addUnfoldInfo, - IdSpecEnv, specInfo, addSpecInfo, + IdSpecEnv, specInfo, setSpecInfo, UpdateInfo, UpdateSpec, mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, addUpdateInfo, @@ -47,10 +46,11 @@ module IdInfo ( import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding ) import {-# SOURCE #-} CoreSyn ( SimplifiableCoreExpr ) + -- for mkdependHS, CoreSyn.hi-boot refers to it: import BinderInfo ( BinderInfo ) -import SpecEnv ( SpecEnv, emptySpecEnv, isEmptySpecEnv ) +import SpecEnv ( SpecEnv, emptySpecEnv ) import BasicTypes ( NewOrData ) import Demand @@ -98,25 +98,6 @@ noIdInfo = IdInfo UnknownArity UnknownDemand emptySpecEnv NoStrictnessInfo noUnf NoUpdateInfo NoArgUsageInfo NoFBTypeInfo \end{code} -Simply turgid. But BE CAREFUL: don't @apply_to_Id@ if that @Id@ -will in turn @apply_to_IdInfo@ of the self-same @IdInfo@. (A very -nasty loop, friends...) -\begin{code} -apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold - update arg_usage fb_ww) - | isEmptySpecEnv spec - = idinfo - | otherwise - = panic "IdInfo:apply_to_IdInfo" -\end{code} - -Variant of the same thing for the typechecker. -\begin{code} -applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold - update arg_usage fb_ww) - = panic "IdInfo:applySubstToIdInfo" -\end{code} - \begin{code} ppIdInfo :: Bool -- True <=> print specialisations, please -> IdInfo @@ -250,8 +231,7 @@ where pi' :: Lift Int# is the specialised version of pi. specInfo :: IdInfo -> IdSpecEnv specInfo (IdInfo _ _ spec _ _ _ _ _) = spec -addSpecInfo id_info spec | isEmptySpecEnv spec = id_info -addSpecInfo (IdInfo a b _ d e f g h) spec = IdInfo a b spec d e f g h +setSpecInfo (IdInfo a b _ d e f g h) spec = IdInfo a b spec d e f g h \end{code} diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 31276b6..eea46d1 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -460,8 +460,12 @@ smallEnoughToInline _ _ UnfoldAlways = True smallEnoughToInline _ _ UnfoldNever = False smallEnoughToInline arg_is_evald_s result_is_scruted (UnfoldIfGoodArgs m_tys_wanted n_vals_wanted discount_vec size scrut_discount) - = enough_args n_vals_wanted arg_is_evald_s && - size - discount <= opt_UnfoldingUseThreshold + = if enough_args n_vals_wanted arg_is_evald_s && + size - discount <= opt_UnfoldingUseThreshold + then + pprTrace "small enough" (int size <+> int discount) True + else + False where enough_args n [] | n > 0 = False -- A function with no value args => don't unfold diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index d9b9207..3a1af2f 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -7,15 +7,13 @@ module CoreUtils ( coreExprType, coreAltsType, coreExprCc, - substCoreExpr, substCoreBindings - - , mkCoreIfThenElse - , argToExpr - , unTagBinders, unTagBindersAlts - - , maybeErrorApp - , nonErrorRHSs - , squashableDictishCcExpr + mkCoreIfThenElse, + argToExpr, + unTagBinders, unTagBindersAlts, + + maybeErrorApp, + nonErrorRHSs, + squashableDictishCcExpr ) where #include "HsVersions.h" @@ -24,7 +22,7 @@ import CoreSyn import CostCentre ( isDictCC, CostCentre, noCostCentre ) import Id ( idType, mkSysLocal, isBottomingId, - toplevelishId, mkIdWithNewUniq, applyTypeEnvToId, + toplevelishId, mkIdWithNewUniq, dataConRepType, addOneToIdEnv, growIdEnvList, lookupIdEnv, isNullIdEnv, IdEnv, Id @@ -412,229 +410,3 @@ squashableDictishCcExpr cc expr | notValArg a = squashable f squashable other = False \end{code} - -%************************************************************************ -%* * -\subsection{Core-renaming utils} -%* * -%************************************************************************ - -\begin{code} -substCoreBindings :: ValEnv - -> TypeEnv -- TyVar=>Type - -> [CoreBinding] - -> UniqSM [CoreBinding] - -substCoreExpr :: ValEnv - -> TypeEnv -- TyVar=>Type - -> CoreExpr - -> UniqSM CoreExpr - -substCoreBindings venv tenv binds - -- if the envs are empty, then avoid doing anything - = if (isNullIdEnv venv && isEmptyTyVarEnv tenv) then - returnUs binds - else - do_CoreBindings venv tenv binds - -substCoreExpr venv tenv expr - = if (isNullIdEnv venv && isEmptyTyVarEnv tenv) then - returnUs expr - else - do_CoreExpr venv tenv expr -\end{code} - -The equiv code for @Types@ is in @TyUtils@. - -Because binders aren't necessarily unique: we don't do @plusEnvs@ -(which check for duplicates); rather, we use the shadowing version, -@growIdEnv@ (and shorthand @addOneToIdEnv@). - -@do_CoreBindings@ takes into account the semantics of a list of -@CoreBindings@---things defined early in the list are visible later in -the list, but not vice versa. - -\begin{code} -type ValEnv = IdEnv CoreExpr - -do_CoreBindings :: ValEnv - -> TypeEnv - -> [CoreBinding] - -> UniqSM [CoreBinding] - -do_CoreBinding :: ValEnv - -> TypeEnv - -> CoreBinding - -> UniqSM (CoreBinding, ValEnv) - -do_CoreBindings venv tenv [] = returnUs [] -do_CoreBindings venv tenv (b:bs) - = do_CoreBinding venv tenv b `thenUs` \ (new_b, new_venv) -> - do_CoreBindings new_venv tenv bs `thenUs` \ new_bs -> - returnUs (new_b : new_bs) - -do_CoreBinding venv tenv (NonRec binder rhs) - = do_CoreExpr venv tenv rhs `thenUs` \ new_rhs -> - - dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) -> - -- now plug new bindings into envs - let new_venv = addOneToIdEnv venv old new in - - returnUs (NonRec new_binder new_rhs, new_venv) - -do_CoreBinding venv tenv (Rec binds) - = -- for letrec, we plug in new bindings BEFORE cloning rhss - mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_maps) -> - let new_venv = growIdEnvList venv new_maps in - - mapUs (do_CoreExpr new_venv tenv) rhss `thenUs` \ new_rhss -> - returnUs (Rec (zipEqual "do_CoreBinding" new_binders new_rhss), new_venv) - where - (binders, rhss) = unzip binds -\end{code} - -\begin{code} -do_CoreArg :: ValEnv - -> TypeEnv - -> CoreArg - -> UniqSM CoreArgOrExpr - -do_CoreArg venv tenv a@(VarArg v) - = returnUs ( - case (lookupIdEnv venv v) of - Nothing -> AnArg a - Just expr -> AnExpr expr - ) - -do_CoreArg venv tenv (TyArg ty) - = returnUs (AnArg (TyArg (instantiateTy tenv ty))) - -do_CoreArg venv tenv other_arg = returnUs (AnArg other_arg) -\end{code} - -\begin{code} -do_CoreExpr :: ValEnv - -> TypeEnv - -> CoreExpr - -> UniqSM CoreExpr - -do_CoreExpr venv tenv orig_expr@(Var var) - = returnUs ( - case (lookupIdEnv venv var) of - Nothing -> --false:ASSERT(toplevelishId var) (SIGH) - orig_expr - Just expr -> expr - ) - -do_CoreExpr venv tenv e@(Lit _) = returnUs e - -do_CoreExpr venv tenv (Con con as) - = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as -> - mkCoCon con new_as - -do_CoreExpr venv tenv (Prim op as) - = mapUs (do_CoreArg venv tenv) as `thenUs` \ new_as -> - do_PrimOp op `thenUs` \ new_op -> - mkCoPrim new_op new_as - where - do_PrimOp (CCallOp label is_asm may_gc arg_tys result_ty) - = let - new_arg_tys = map (instantiateTy tenv) arg_tys - new_result_ty = instantiateTy tenv result_ty - in - returnUs (CCallOp label is_asm may_gc new_arg_tys new_result_ty) - - do_PrimOp other_op = returnUs other_op - -do_CoreExpr venv tenv (Lam (ValBinder binder) expr) - = dup_binder tenv binder `thenUs` \(new_binder, (old,new)) -> - let new_venv = addOneToIdEnv venv old new in - do_CoreExpr new_venv tenv expr `thenUs` \ new_expr -> - returnUs (Lam (ValBinder new_binder) new_expr) - -do_CoreExpr venv tenv (Lam (TyBinder tyvar) expr) - = dup_tyvar tyvar `thenUs` \ (new_tyvar, (old, new)) -> - let - new_tenv = addToTyVarEnv tenv old new - in - do_CoreExpr venv new_tenv expr `thenUs` \ new_expr -> - returnUs (Lam (TyBinder new_tyvar) new_expr) - -do_CoreExpr venv tenv (App expr arg) - = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> - do_CoreArg venv tenv arg `thenUs` \ new_arg -> - mkCoApps new_expr [new_arg] -- ToDo: more efficiently? - -do_CoreExpr venv tenv (Case expr alts) - = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> - do_alts venv tenv alts `thenUs` \ new_alts -> - returnUs (Case new_expr new_alts) - where - do_alts venv tenv (AlgAlts alts deflt) - = mapUs (do_boxed_alt venv tenv) alts `thenUs` \ new_alts -> - do_default venv tenv deflt `thenUs` \ new_deflt -> - returnUs (AlgAlts new_alts new_deflt) - where - do_boxed_alt venv tenv (con, binders, expr) - = mapAndUnzipUs (dup_binder tenv) binders `thenUs` \ (new_binders, new_vmaps) -> - let new_venv = growIdEnvList venv new_vmaps in - do_CoreExpr new_venv tenv expr `thenUs` \ new_expr -> - returnUs (con, new_binders, new_expr) - - - do_alts venv tenv (PrimAlts alts deflt) - = mapUs (do_unboxed_alt venv tenv) alts `thenUs` \ new_alts -> - do_default venv tenv deflt `thenUs` \ new_deflt -> - returnUs (PrimAlts new_alts new_deflt) - where - do_unboxed_alt venv tenv (lit, expr) - = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> - returnUs (lit, new_expr) - - do_default venv tenv NoDefault = returnUs NoDefault - - do_default venv tenv (BindDefault binder expr) - = dup_binder tenv binder `thenUs` \ (new_binder, (old, new)) -> - let new_venv = addOneToIdEnv venv old new in - do_CoreExpr new_venv tenv expr `thenUs` \ new_expr -> - returnUs (BindDefault new_binder new_expr) - -do_CoreExpr venv tenv (Let core_bind expr) - = do_CoreBinding venv tenv core_bind `thenUs` \ (new_bind, new_venv) -> - -- and do the body of the let - do_CoreExpr new_venv tenv expr `thenUs` \ new_expr -> - returnUs (Let new_bind new_expr) - -do_CoreExpr venv tenv (SCC label expr) - = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> - returnUs (SCC label new_expr) - -do_CoreExpr venv tenv (Coerce c ty expr) - = do_CoreExpr venv tenv expr `thenUs` \ new_expr -> - returnUs (Coerce c (instantiateTy tenv ty) new_expr) -\end{code} - -\begin{code} -dup_tyvar :: TyVar -> UniqSM (TyVar, (TyVar, Type)) -dup_tyvar tyvar - = getUnique `thenUs` \ uniq -> - let new_tyvar = cloneTyVar tyvar uniq in - returnUs (new_tyvar, (tyvar, mkTyVarTy new_tyvar)) - --- same thing all over again -------------------- - -dup_binder :: TypeEnv -> Id -> UniqSM (Id, (Id, CoreExpr)) -dup_binder tenv b - = if (toplevelishId b) then - -- binder is "top-level-ish"; -- it should *NOT* be renamed - -- ToDo: it's unsavoury that we return something to heave in env - returnUs (b, (b, Var b)) - - else -- otherwise, the full business - getUnique `thenUs` \ uniq -> - let - new_b1 = mkIdWithNewUniq b uniq - new_b2 = applyTypeEnvToId tenv new_b1 - in - returnUs (new_b2, (b, Var new_b2)) -\end{code} diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index d57b125..9548bd5 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -540,24 +540,6 @@ dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with continue_with ((sel_id, rhs_atom) : rbinds') \end{code} -\begin{code} --- do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args) --- = do_unfold (addToTyVarEnv ty_env tyvar ty) val_env body args --- --- do_unfold ty_env val_env (Lam (ValBinder binder) body) (arg@(VarArg expr) : args) --- = dsExprToAtom arg $ \ arg_atom -> --- do_unfold ty_env --- (addOneToIdEnv val_env binder (argToExpr arg_atom)) --- body args --- --- do_unfold ty_env val_env body args --- = -- Clone the remaining part of the template --- uniqSMtoDsM (substCoreExpr val_env ty_env body) `thenDs` \ body' -> --- --- -- Apply result to remaining arguments --- mkAppDs body' args -\end{code} - Basically does the translation given in the Haskell~1.3 report: \begin{code} dsDo :: DoOrListComp diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 0f12e51..995a719 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -16,6 +16,7 @@ module CmdLineOpts ( maybe_CompilingGhcInternals, opt_AllStrict, + opt_AllowOverlappingInstances, opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs, opt_AutoSccsOnIndividualCafs, @@ -209,9 +210,6 @@ data SimplifierSwitch | MaxSimplifierIterations Int - | KeepSpecPragmaIds -- We normally *toss* Ids we can do without - | KeepUnusedBindings - | SimplNoLetFromCase -- used when turning off floating entirely | SimplNoLetFromApp -- (for experimentation only) WDP 95/10 | SimplNoLetFromStrictLet @@ -269,6 +267,7 @@ unpacked_opts = map _UNPK_ argv \begin{code} opt_AllStrict = lookUp SLIT("-fall-strict") +opt_AllowOverlappingInstances = lookUp SLIT("-fallow-overlapping-instances") 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") @@ -450,8 +449,6 @@ classifyOpts = sep argv [] [] -- accumulators... "-fcase-merge" -> SIMPL_SW(SimplCaseMerge) "-flet-to-case" -> SIMPL_SW(SimplLetToCase) "-fpedantic-bottoms" -> SIMPL_SW(SimplPedanticBottoms) - "-fkeep-spec-pragma-ids" -> SIMPL_SW(KeepSpecPragmaIds) - "-fkeep-unused-bindings" -> SIMPL_SW(KeepUnusedBindings) "-fmay-delete-conjurable-ids" -> SIMPL_SW(SimplMayDeleteConjurableIds) "-fessential-unfoldings-only" -> SIMPL_SW(EssentialUnfoldingsOnly) "-fignore-inline-pragma" -> SIMPL_SW(IgnoreINLINEPragma) @@ -504,8 +501,6 @@ tagOf_SimplSwitch SimplDoLambdaEtaExpansion = ILIT(16) tagOf_SimplSwitch EssentialUnfoldingsOnly = ILIT(19) tagOf_SimplSwitch ShowSimplifierProgress = ILIT(20) tagOf_SimplSwitch (MaxSimplifierIterations _) = ILIT(21) -tagOf_SimplSwitch KeepSpecPragmaIds = ILIT(25) -tagOf_SimplSwitch KeepUnusedBindings = ILIT(26) tagOf_SimplSwitch SimplNoLetFromCase = ILIT(27) tagOf_SimplSwitch SimplNoLetFromApp = ILIT(28) tagOf_SimplSwitch SimplNoLetFromStrictLet = ILIT(29) diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y index d74d494..0ea933f 100644 --- a/ghc/compiler/parser/hsparser.y +++ b/ghc/compiler/parser/hsparser.y @@ -898,7 +898,7 @@ valdef : vallhs } ; -get_line_no : { $$ = startlineno } +get_line_no : { $$ = startlineno; } ; vallhs : patk { $$ = $1; } diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 4d36604..be0072f 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -119,7 +119,7 @@ and make a jolly old mess. \begin{code} tRACE_ID = pcMiscPrelId traceIdKey pREL_IO_BASE SLIT("trace") traceTy - (noIdInfo `addSpecInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy) + (noIdInfo `setSpecInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy) where traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy) \end{code} @@ -500,7 +500,7 @@ buildId {-LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey-}) `addStrictnessInfo` mkStrictnessInfo [WwStrict] False) `addArgUsageInfo` mkArgUsageInfo [ArgUsage 2]) - `addSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy) + `setSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy) -- cheating, but since _build never actually exists ... where -- The type of this strange object is: @@ -569,7 +569,7 @@ foldrId = pcMiscPrelId foldrIdKey pREL_BASE SLIT("foldr") `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False) `addArityInfo` exactArity 3) `addUpdateInfo` mkUpdateInfo [2,2,1]) - `addSpecInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy) + `setSpecInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy) foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl") foldlTy idInfo @@ -583,7 +583,7 @@ foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl") `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False) `addArityInfo` exactArity 3) `addUpdateInfo` mkUpdateInfo [2,2,1]) - `addSpecInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy) + `setSpecInfo` 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: diff --git a/ghc/compiler/simplCore/ConFold.lhs b/ghc/compiler/simplCore/ConFold.lhs index 2f06ecb..fdc3eca 100644 --- a/ghc/compiler/simplCore/ConFold.lhs +++ b/ghc/compiler/simplCore/ConFold.lhs @@ -16,10 +16,10 @@ import CoreSyn import CoreUnfold ( Unfolding, SimpleUnfolding ) import Id ( idType ) import Literal ( mkMachInt, mkMachWord, Literal(..) ) --- import MagicUFs ( MagicUnfoldingFun ) import PrimOp ( PrimOp(..) ) import SimplEnv import SimplMonad +import SimplUtils ( newId ) import TysWiredIn ( trueDataCon, falseDataCon ) import Char ( ord, chr ) diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 7a4ca18..f5e2206 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -28,21 +28,17 @@ import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma, addOneToIdSet, IdSet, nullIdEnv, unitIdEnv, combineIdEnvs, delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv, - mapIdEnv, lookupIdEnv, IdEnv, - GenId{-instance Eq-} + mapIdEnv, lookupIdEnv, IdEnv ) +import Specialise ( idSpecVars ) import Name ( isExported, isLocallyDefined ) import Type ( splitFunTy_maybe, splitForAllTys ) import Maybes ( maybeToBool ) import PprCore -import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} ) -import TyVar ( GenTyVar{-instance Eq-} ) -import Unique ( Unique{-instance Eq-}, u2i ) +import Unique ( u2i ) import UniqFM ( keysUFM ) import Util ( zipWithEqual ) import Outputable - -isSpecPragmaId_maybe x = Nothing -- ToDo:!trace "OccurAnal.isSpecPragmaId_maybe" \end{code} @@ -55,19 +51,6 @@ isSpecPragmaId_maybe x = Nothing -- ToDo:!trace "OccurAnal.isSpecPragmaId_maybe" \begin{code} data OccEnv = OccEnv - Bool -- Keep-unused-bindings flag - -- False <=> OK to chuck away binding - -- and ignore occurrences within it - Bool -- Keep-spec-pragma-ids flag - -- False <=> OK to chuck away spec pragma bindings - -- and ignore occurrences within it - Bool -- Keep-conjurable flag - -- False <=> OK to throw away *dead* - -- "conjurable" Ids; at the moment, that - -- *only* means constant methods, which - -- are top-level. A use of a "conjurable" - -- Id may appear out of thin air -- e.g., - -- specialiser conjuring up refs to const methods. Bool -- IgnoreINLINEPragma flag -- False <=> OK to use INLINEPragma information -- True <=> ignore INLINEPragma information @@ -79,15 +62,15 @@ data OccEnv = addNewCands :: OccEnv -> [Id] -> OccEnv -addNewCands (OccEnv kd ks kc ip ifun cands) ids - = OccEnv kd ks kc ip ifun (cands `unionIdSets` mkIdSet ids) +addNewCands (OccEnv ip ifun cands) ids + = OccEnv ip ifun (cands `unionIdSets` mkIdSet ids) addNewCand :: OccEnv -> Id -> OccEnv -addNewCand (OccEnv ks kd kc ip ifun cands) id - = OccEnv kd ks kc ip ifun (addOneToIdSet cands id) +addNewCand (OccEnv ip ifun cands) id + = OccEnv ip ifun (addOneToIdSet cands id) isCandidate :: OccEnv -> Id -> Bool -isCandidate (OccEnv _ _ _ _ ifun cands) id = ifun id cands +isCandidate (OccEnv _ ifun cands) id = ifun id cands inlineMe :: OccEnv -> Id -> Bool inlineMe env id @@ -96,16 +79,6 @@ inlineMe env id -} idWantsToBeINLINEd id -keepUnusedBinding :: OccEnv -> Id -> Bool -keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _ _) binder - = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder)) - -{- UNUSED: -keepBecauseConjurable :: OccEnv -> Id -> Bool -keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _ _) binder - = False - {- keep_conjurable && isConstMethodId binder -} --} type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage @@ -168,17 +141,14 @@ tagBinder usage binder = usage_of usage binder - | isExported binder = noBinderInfo -- Visible-elsewhere things count as many + | isExported binder + = noBinderInfo -- Visible-elsewhere things count as many | otherwise = case (lookupIdEnv usage binder) of Nothing -> deadOccurrence Just info -> info -isNeeded env usage binder - = if isDeadOcc (usage_of usage binder) then - keepUnusedBinding env binder -- Maybe keep it anyway - else - True +isNeeded env usage binder = not (isDeadOcc (usage_of usage binder)) \end{code} @@ -204,10 +174,7 @@ occurAnalyseBinds binds simplifier_sw_chkr where (_, binds') = doo initial_env binds - initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings) - (simplifier_sw_chkr KeepSpecPragmaIds) - (not (simplifier_sw_chkr SimplMayDeleteConjurableIds)) - (simplifier_sw_chkr IgnoreINLINEPragma) + initial_env = OccEnv (simplifier_sw_chkr IgnoreINLINEPragma) (\id in_scope -> isLocallyDefined id) -- Anything local is interesting emptyIdSet -- Not actually used @@ -242,10 +209,7 @@ occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting occurAnalyseExpr interesting expr = occAnal initial_env expr where - initial_env = OccEnv False {- Drop unused bindings -} - False {- Drop SpecPragmaId bindings -} - True {- Keep conjurable Ids -} - False {- Do not ignore INLINE Pragma -} + initial_env = OccEnv False {- Do not ignore INLINE Pragma -} (\id locals -> interesting id || elementOfIdSet id locals) emptyIdSet @@ -268,7 +232,7 @@ Bindings \begin{code} type Node details = (details, Int, [Int]) -- The Ints are gotten from the Unique, -- which is gotten from the Id. -type Details1 = (Id, (UsageDetails, SimplifiableCoreExpr)) +type Details1 = (Id, UsageDetails, SimplifiableCoreExpr) type Details2 = ((Id, BinderInfo), SimplifiableCoreExpr) @@ -337,7 +301,10 @@ occAnalBind env (Rec pairs) body_usage new_env = env `addNewCands` binders analysed_pairs :: [Details1] - analysed_pairs = [(nukeNoInlinePragma bndr, occAnalRhs new_env bndr rhs) | (bndr,rhs) <- pairs] + analysed_pairs = [ (nukeNoInlinePragma bndr, rhs_usage, rhs') + | (bndr, rhs) <- pairs, + let (rhs_usage, rhs') = occAnalRhs new_env bndr rhs + ] sccs :: [SCC (Node Details1)] sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges @@ -346,8 +313,8 @@ occAnalBind env (Rec pairs) body_usage ---- stuff for dependency analysis of binds ------------------------------- edges :: [Node Details1] edges = _scc_ "occAnalBind.assoc" - [ (pair, IBOX(u2i (idUnique id)), edges_from rhs_usage) - | pair@(id, (rhs_usage, rhs)) <- analysed_pairs + [ (details, IBOX(u2i (idUnique id)), edges_from rhs_usage) + | details@(id, rhs_usage, rhs) <- analysed_pairs ] -- (a -> b) means a mentions b @@ -366,7 +333,7 @@ occAnalBind env (Rec pairs) body_usage ---- stuff to "re-constitute" bindings from dependency-analysis info ------ -- Non-recursive SCC - do_final_bind (AcyclicSCC ((bndr, (rhs_usage, rhs')), _, _)) (body_usage, binds_so_far) + do_final_bind (AcyclicSCC ((bndr, rhs_usage, rhs'), _, _)) (body_usage, binds_so_far) | isNeeded env body_usage bndr = (combined_usage, new_bind : binds_so_far) | otherwise @@ -383,15 +350,15 @@ occAnalBind env (Rec pairs) body_usage | otherwise = (body_usage, binds_so_far) -- Dead code where - pairs = [pair | (pair, _, _) <- cycle] - bndrs = [bndr | (bndr, _) <- pairs] - rhs_usages = [rhs_usage | (_, (rhs_usage, _)) <- pairs] + details = [details | (details, _, _) <- cycle] + bndrs = [bndr | (bndr, _, _) <- details] + rhs_usages = [rhs_usage | (_, rhs_usage, _) <- details] total_usage = foldr combineUsageDetails body_usage rhs_usages (combined_usage, tagged_binders) = tagBinders total_usage bndrs final_bind = Rec (reOrderRec env new_cycle) new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_binders cycle) - mk_new_bind tagged_bndr ((_, (_, rhs')), key, keys) = ((tagged_bndr, rhs'), key, keys) + mk_new_bind (bndr, occ_info) ((_, _, rhs'), key, keys) = (((bndr, occ_info), rhs'), key, keys) \end{code} @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic @@ -453,13 +420,13 @@ reOrderRec -- dontINLINE pragmas that there are no loops left. -- Non-recursive case -reOrderRec env (AcyclicSCC (pair, _, _)) = [pair] +reOrderRec env (AcyclicSCC (bind, _, _)) = [bind] -- Common case of simple self-recursion reOrderRec env (CyclicSCC [bind]) = [((addNoInlinePragma bndr, occ_info), rhs)] where - (((bndr,occ_info), rhs), _, _) = bind + (((bndr, occ_info), rhs), _, _) = bind reOrderRec env (CyclicSCC binds) = -- Choose a loop breaker, mark it no-inline, @@ -473,12 +440,12 @@ reOrderRec env (CyclicSCC binds) ((bndr,occ_info), rhs) = chosen_pair -- Choosing the loop breaker; heursitic - choose_loop_breaker (bind@(pair, _, _) : rest) + choose_loop_breaker (bind@(details, _, _) : rest) | not (null rest) && - bad_choice pair + bad_choice details = (chosen, bind : unchosen) -- Don't pick it | otherwise -- Pick it - = (pair,rest) + = (details,rest) where (chosen, unchosen) = choose_loop_breaker rest @@ -519,6 +486,12 @@ ToDo: try using the occurrence info for the inline'd binder. [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec. +[March 98] A new wrinkle is that if the binder has specialisations inside +it then we count the specialised Ids as "extra rhs's". That way +the "parent" keeps the specialised "children" alive. If the parent +dies (because it isn't referenced any more), then the children will +die too unless they are already referenced directly. + \begin{code} occAnalRhs :: OccEnv -> Id -> CoreExpr -- Binder and rhs @@ -533,13 +506,15 @@ occAnalRhs env id (Var v) occAnalRhs env id rhs | inlineMe env id - = (mapIdEnv markMany rhs_usage, rhs') + = (mapIdEnv markMany total_usage, rhs') | otherwise - = (rhs_usage, rhs') + = (total_usage, rhs') where (rhs_usage, rhs') = occAnal env rhs + total_usage = foldr add rhs_usage (idSpecVars id) + add v u = addOneOcc u v (argOccurrence 0) \end{code} Expressions diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs index ea06d8d..007221c 100644 --- a/ghc/compiler/simplCore/SimplCase.lhs +++ b/ghc/compiler/simplCore/SimplCase.lhs @@ -28,12 +28,13 @@ import Literal ( isNoRepLit, Literal{-instance Eq-} ) import Maybes ( maybeToBool ) import PrelVals ( voidId ) import PrimOp ( primOpOkForSpeculation, PrimOp{-instance Eq-} ) +import SimplVar ( simplBinder, simplBinders ) +import SimplUtils ( newId, newIds ) import SimplEnv import SimplMonad import Type ( isUnpointedType, splitAlgTyConApp_maybe, splitAlgTyConApp, mkFunTy, mkFunTys ) import TyCon ( isDataTyCon ) import TysPrim ( voidTy ) -import Unique ( Unique{-instance Eq-} ) import Util ( Eager, runEager, appEager, isIn, isSingleton, zipEqual, panic, assertPanic ) \end{code} @@ -359,7 +360,7 @@ completeCase env scrut alts rhs_c elim_deflt_binder (BindDefault used_binder rhs) -- Binder used = case scrut of Var v -> -- Binder used, but can be eliminated in favour of scrut - (True, [rhs], extendIdEnvWithAtom env used_binder (VarArg v)) + (True, [rhs], bindIdToAtom env used_binder (VarArg v)) non_var -> -- Binder used, and can't be elimd (False, [rhs], env) @@ -453,9 +454,8 @@ bindLargeRhs env args rhs_ty rhs_c | otherwise = -- Generate the rhs - cloneIds env used_args `thenSmpl` \ used_args' -> + simplBinders env used_args `thenSmpl` \ (new_env, used_args') -> let - new_env = extendIdEnvWithClones env used_args used_args' rhs_fun_ty :: OutType rhs_fun_ty = mkFunTys (map idType used_args') rhs_ty in @@ -532,9 +532,8 @@ simplAlts env scrut (AlgAlts alts deflt) rhs_c where deflt_form = OtherCon [con | (con,_,_) <- alts] do_alt (con, con_args, rhs) - = cloneIds env con_args `thenSmpl` \ con_args' -> + = simplBinders env con_args `thenSmpl` \ (env1, con_args') -> let - env1 = extendIdEnvWithClones env con_args con_args' new_env = case scrut of Var v -> extendEnvGivenNewRhs env1 v (Con con args) where @@ -603,9 +602,8 @@ simplDefault env scrut NoDefault form rhs_c -- Special case for variable scrutinee; see notes above. simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs) info_from_this_case rhs_c - = cloneId env binder `thenSmpl` \ binder' -> + = simplBinder env binder `thenSmpl` \ (env1, binder') -> let - env1 = extendIdEnvWithClone env binder binder' env2 = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case -- Add form details for the default binder @@ -618,9 +616,8 @@ simplDefault env (Var scrut_var) (BindDefault binder@(_,occ_info) rhs) simplDefault env scrut (BindDefault binder@(_,occ_info) rhs) info_from_this_case rhs_c - = cloneId env binder `thenSmpl` \ binder' -> + = simplBinder env binder `thenSmpl` \ (env1, binder') -> let - env1 = extendIdEnvWithClone env binder binder' new_env = extendEnvGivenRhsInfo env1 binder' occ_info info_from_this_case in rhs_c new_env rhs `thenSmpl` \ rhs' -> @@ -660,7 +657,7 @@ completePrimCaseWithKnownLit env lit (PrimAlts alts deflt) rhs_c BindDefault binder rhs -> -- OK, there's a default case -- Just bind the Id to the atom and continue let - new_env = extendIdEnvWithAtom env binder (LitArg lit) + new_env = bindIdToAtom env binder (LitArg lit) in rhs_c new_env rhs \end{code} @@ -691,8 +688,9 @@ completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c | alt_con == con = -- Matching alternative! let - new_env = extendIdEnvWithAtoms env - (zipEqual "SimplCase" alt_args (filter isValArg con_args)) + val_args = filter isValArg con_args + new_env = foldr bind env (zipEqual "SimplCase" alt_args val_args) + bind (bndr, atom) env = bindIdToAtom env bndr atom in rhs_c new_env rhs @@ -708,9 +706,8 @@ completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c BindDefault binder@(_,occ_info) rhs -> -- OK, there's a default case -- let-bind the binder to the constructor - cloneId env binder `thenSmpl` \ id' -> + simplBinder env binder `thenSmpl` \ (env1, id') -> let - env1 = extendIdEnvWithClone env binder id' new_env = extendEnvGivenBinding env1 occ_info id' (Con con con_args) in rhs_c new_env rhs `thenSmpl` \ rhs' -> diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index fde905d..42a2405 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -33,17 +33,17 @@ import FiniteMap ( FiniteMap, emptyFM ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) import FoldrBuildWW ( mkFoldrBuildWW ) -import Id ( mkSysLocal, setIdVisibility, replaceIdInfo, +import Id ( mkSysLocal, mkUserId, setIdVisibility, replaceIdInfo, replacePragmaInfo, getIdDemandInfo, idType, getIdInfo, getPragmaInfo, mkIdWithNewUniq, nullIdEnv, addOneToIdEnv, delOneFromIdEnv, lookupIdEnv, IdEnv, omitIfaceSigForId, - apply_to_Id, - GenId{-instance Outputable-}, Id + Id ) import IdInfo ( willBeDemanded, DemandInfo ) import Name ( isExported, isLocallyDefined, isLocalName, uniqToOccName, + setNameVisibility, Module, NamedThing(..), OccName(..) ) import TyCon ( TyCon ) @@ -754,8 +754,16 @@ newId id thing_inside mod env (gus, local_uniq, floats) = let -- Give the Id a fresh print-name, *and* rename its type local_uniq' = incrUnique local_uniq - rn_id = setIdVisibility Nothing local_uniq id - id' = apply_to_Id (nmbr_ty env local_uniq') rn_id + name' = setNameVisibility Nothing local_uniq (getName id) + ty' = nmbr_ty env local_uniq' (idType id) + id' = mkUserId name' ty' + -- NB: This throws away the IdInfo of the Id, which we + -- no longer need. That means we don't need to + -- run over it with env, nor renumber it + -- + -- NB: the Id's unique remains unchanged; it's only + -- its print name that is affected by local_uniq + env' = addToUFM env id (ValBinder id') in thing_inside id' mod env' (gus, local_uniq', floats) diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 2487299..5e86269 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -8,13 +8,11 @@ module SimplEnv ( nullSimplEnv, combineSimplEnv, pprSimplEnv, -- debugging only - extendTyEnv, extendTyEnvList, extendTyEnvEnv, - simplTy, simplTyInId, + bindTyVar, bindTyVars, simplTy, - extendIdEnvWithAtom, extendIdEnvWithAtoms, - extendIdEnvWithClone, extendIdEnvWithClones, - lookupId, + lookupId, bindIdToAtom, + getSubstEnvs, setTyEnv, setIdEnv, notInScope, markDangerousOccs, lookupRhsInfo, lookupOutIdEnv, isEvaluated, @@ -58,18 +56,17 @@ import CoreUnfold ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom, import CoreUtils ( coreExprCc ) import CostCentre ( CostCentre, subsumedCosts, noCostCentreAttached ) import FiniteMap -- lots of things -import Id ( applyTypeEnvToId, getInlinePragma, - nullIdEnv, growIdEnvList, lookupIdEnv, +import Id ( getInlinePragma, + nullIdEnv, growIdEnvList, lookupIdEnv, delOneFromIdEnv, addOneToIdEnv, modifyIdEnv, modifyIdEnv_Directly, - IdEnv, IdSet, GenId, Id ) + IdEnv, IdSet, Id ) import Literal ( Literal{-instances-} ) import Maybes ( expectJust ) import OccurAnal ( occurAnalyseExpr ) import PprCore -- various instances -import PprType ( GenType, GenTyVar ) import Type ( instantiateTy, Type ) -import TyVar ( emptyTyVarEnv, plusTyVarEnv, addToTyVarEnv, growTyVarEnvList, - TyVarEnv, GenTyVar{-instance Eq-} , +import TyVar ( TyVarEnv, emptyTyVarEnv, plusTyVarEnv, addToTyVarEnv, growTyVarEnvList, + TyVarSet, emptyTyVarSet, TyVar ) import Unique ( Unique{-instance Outputable-}, Uniquable(..) ) @@ -128,6 +125,22 @@ Id. Unfoldings in the Id itself are used only for imported things inside the Ids, etc.). \begin{code} +type InTypeEnv = (TyVarSet, -- In-scope tyvars (in result) + TyVarEnv Type) -- Type substitution + -- If t is in the in-scope set, it certainly won't be + -- in the domain of the substitution, and vice versa + +type InIdEnv = (IdEnv Id, -- In-scope Ids (in result) + IdEnv OutArg) -- Id substitution + -- The in-scope set is represented by an IdEnv, because + -- we use it to propagate pragma info etc from binding + -- site to occurrences. + + -- The substitution usually maps an Id to its clone, + -- but if the orig defn is a let-binding, and + -- the RHS of the let simplifies to an atom, + -- we just add the binding to the substitution and elide the let. + data SimplEnv = SimplEnv SwitchChecker @@ -141,7 +154,7 @@ data SimplEnv nullSimplEnv :: SwitchChecker -> SimplEnv nullSimplEnv sw_chkr - = SimplEnv sw_chkr subsumedCosts emptyTyVarEnv nullIdEnv nullIdEnv nullConApps + = SimplEnv sw_chkr subsumedCosts (emptyTyVarSet, emptyTyVarEnv) (nullIdEnv, nullIdEnv) nullIdEnv nullConApps combineSimplEnv :: SimplEnv -> SimplEnv -> SimplEnv combineSimplEnv env@(SimplEnv chkr _ _ _ out_id_env con_apps) @@ -149,6 +162,17 @@ combineSimplEnv env@(SimplEnv chkr _ _ _ out_id_env con_apps) = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps pprSimplEnv (SimplEnv _ _ ty_env in_id_env out_id_env con_apps) = panic "pprSimplEnv" + +getSubstEnvs :: SimplEnv -> (InTypeEnv, InIdEnv) +getSubstEnvs (SimplEnv _ _ ty_env in_id_env _ _) = (ty_env, in_id_env) + +setTyEnv :: SimplEnv -> InTypeEnv -> SimplEnv +setTyEnv (SimplEnv chkr encl_cc _ in_id_env out_id_env con_apps) ty_env + = SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps + +setIdEnv :: SimplEnv -> InIdEnv -> SimplEnv +setIdEnv (SimplEnv chkr encl_cc ty_env _ out_id_env con_apps) id_env + = SimplEnv chkr encl_cc ty_env id_env out_id_env con_apps \end{code} @@ -239,30 +263,25 @@ getEnclosingCC (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) = en %* * %************************************************************************ -\begin{code} -type TypeEnv = TyVarEnv Type -type InTypeEnv = TypeEnv -- Maps InTyVars to OutTypes - -extendTyEnv :: SimplEnv -> TyVar -> Type -> SimplEnv -extendTyEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) tyvar ty - = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps - where - new_ty_env = addToTyVarEnv ty_env tyvar ty +These two "bind" functions extend the tyvar substitution. +They don't affect what tyvars are in scope. -extendTyEnvList :: SimplEnv -> [(TyVar,Type)] -> SimplEnv -extendTyEnvList (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) pairs - = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps +\begin{code} +bindTyVar :: SimplEnv -> TyVar -> Type -> SimplEnv +bindTyVar (SimplEnv chkr encl_cc (tyvars, ty_subst) in_id_env out_id_env con_apps) tyvar ty + = SimplEnv chkr encl_cc (tyvars, new_ty_subst) in_id_env out_id_env con_apps where - new_ty_env = growTyVarEnvList ty_env pairs + new_ty_subst = addToTyVarEnv ty_subst tyvar ty -extendTyEnvEnv :: SimplEnv -> TypeEnv -> SimplEnv -extendTyEnvEnv (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) new_ty_env - = SimplEnv chkr encl_cc new_ty_env in_id_env out_id_env con_apps +bindTyVars :: SimplEnv -> TyVarEnv Type -> SimplEnv +bindTyVars (SimplEnv chkr encl_cc (tyvars, ty_subst) in_id_env out_id_env con_apps) extra_subst + = SimplEnv chkr encl_cc (tyvars, new_ty_subst) in_id_env out_id_env con_apps where - new_ty_env = ty_env `plusTyVarEnv` new_ty_env + new_ty_subst = ty_subst `plusTyVarEnv` extra_subst +\end{code} -simplTy (SimplEnv _ _ ty_env _ _ _) ty = returnEager (instantiateTy ty_env ty) -simplTyInId (SimplEnv _ _ ty_env _ _ _) id = returnEager (applyTypeEnvToId ty_env id) +\begin{code} +simplTy (SimplEnv _ _ (_, ty_subst) _ _ _) ty = returnEager (instantiateTy ty_subst ty) \end{code} %************************************************************************ @@ -272,68 +291,48 @@ simplTyInId (SimplEnv _ _ ty_env _ _ _) id = returnEager (applyTypeEnvToId ty_en %************************************************************************ \begin{code} -type InIdEnv = IdEnv OutArg -- Maps InIds to their value - -- Usually this is just the cloned Id, but if - -- if the orig defn is a let-binding, and - -- the RHS of the let simplifies to an atom, - -- we just bind the variable to that atom, and - -- elide the let. -\end{code} - -\begin{code} lookupId :: SimplEnv -> Id -> Eager ans OutArg -lookupId (SimplEnv _ _ _ in_id_env _ _) id - = case (lookupIdEnv in_id_env id) of +lookupId (SimplEnv _ _ _ (in_scope_ids, id_subst) _ _) id + = case lookupIdEnv id_subst id of Just atom -> returnEager atom - Nothing -> returnEager (VarArg id) + Nothing -> case lookupIdEnv in_scope_ids id of + Just id' -> returnEager (VarArg id') + Nothing -> returnEager (VarArg id) +\end{code} + +notInScope forgets that the specified binder is in scope. +It is used when we decide to bind a let(rec) bound thing to +an atom, *after* the Id has been added to the in-scope mapping by simplBinder. + +\begin{code} +notInScope :: SimplEnv -> OutBinder -> SimplEnv +notInScope (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) out_id_env con_apps) id + = SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) out_id_env con_apps + where + new_in_scope_ids = delOneFromIdEnv in_scope_ids id \end{code} +These "bind" functions extend the Id substitution. + \begin{code} -extendIdEnvWithAtom - :: SimplEnv - -> InBinder - -> OutArg{-Val args only, please-} - -> SimplEnv +bindIdToAtom :: SimplEnv + -> InBinder + -> OutArg -- Val args only, please + -> SimplEnv -extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) +bindIdToAtom (SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) out_id_env con_apps) (in_id,occ_info) atom = case atom of LitArg _ -> SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps VarArg out_id -> SimplEnv chkr encl_cc ty_env new_in_id_env - (modifyOccInfo out_id_env (uniqueOf out_id, occ_info)) con_apps ---SimplEnv chkr encl_cc ty_env new_in_id_env new_out_id_env con_apps + (modifyOccInfo out_id_env (uniqueOf out_id, occ_info)) + con_apps where - new_in_id_env = addOneToIdEnv in_id_env in_id atom -{- - new_out_id_env = case atom of - LitArg _ -> out_id_env - VarArg out_id -> modifyOccInfo out_id_env (uniqueOf out_id, occ_info) --} - -extendIdEnvWithAtoms :: SimplEnv -> [(InBinder, OutArg)] -> SimplEnv -extendIdEnvWithAtoms = foldr (\ (bndr,val) env -> extendIdEnvWithAtom env bndr val) - - -extendIdEnvWithClone :: SimplEnv -> InBinder -> OutId -> SimplEnv - -extendIdEnvWithClone (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) - (in_id,_) out_id - = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps - where - new_in_id_env = addOneToIdEnv in_id_env in_id (VarArg out_id) - -extendIdEnvWithClones :: SimplEnv -> [InBinder] -> [OutId] -> SimplEnv -extendIdEnvWithClones (SimplEnv chkr encl_cc ty_env in_id_env out_id_env con_apps) - in_binders out_ids - = SimplEnv chkr encl_cc ty_env new_in_id_env out_id_env con_apps - where - new_in_id_env = growIdEnvList in_id_env bindings - bindings = zipEqual "extendIdEnvWithClones" - [id | (id,_) <- in_binders] - (map VarArg out_ids) + new_in_id_env = (in_scope_ids, addOneToIdEnv id_subst in_id atom) \end{code} + %************************************************************************ %* * \subsubsection{The @OutIdEnv@} @@ -346,7 +345,6 @@ both locally-bound ones, and perhaps some imported ones too. \begin{code} type OutIdEnv = IdEnv (OutId, BinderInfo, RhsInfo) - \end{code} The "Id" part is just so that we can recover the domain of the mapping, which @@ -440,6 +438,7 @@ extendEnvGivenInlining env@(SimplEnv chkr encl_cc ty_env in_id_env out_id_env co new_out_id_env = addToUFM out_id_env id (id, occ_info, InUnfolding env rhs) \end{code} + %************************************************************************ %* * \subsubsection{The @ConAppMap@ type} diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index f0645c9..80b0248 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -7,31 +7,29 @@ module SimplMonad ( SmplM, initSmpl, returnSmpl, thenSmpl, thenSmpl_, - mapSmpl, mapAndUnzipSmpl, + mapSmpl, mapAndUnzipSmpl, mapAccumLSmpl, + + -- Unique supply + getUniqueSmpl, getUniquesSmpl, -- Counting SimplCount{-abstract-}, TickType(..), tick, tickN, tickUnfold, simplCount, detailedSimplCount, - zeroSimplCount, showSimplCount, combineSimplCounts, - - -- Cloning - cloneId, cloneIds, cloneTyVarSmpl, newIds, newId + zeroSimplCount, showSimplCount, combineSimplCounts ) where #include "HsVersions.h" --- import {-# SOURCE #-} Simplify --- import {-# SOURCE #-} MagicUFs - import Id ( GenId, mkSysLocal, mkIdWithNewUniq, Id ) import CoreUnfold ( SimpleUnfolding ) import SimplEnv import SrcLoc ( noSrcLoc ) -import TyVar ( cloneTyVar, TyVar ) +import TyVar ( TyVar ) import Type ( Type ) import UniqSupply ( getUnique, getUniques, splitUniqSupply, UniqSupply ) +import Unique ( Unique ) import Util ( zipWithEqual, Eager, appEager ) import Outputable import Ix @@ -96,6 +94,17 @@ mapAndUnzipSmpl f (x:xs) = f x `thenSmpl` \ (r1, r2) -> mapAndUnzipSmpl f xs `thenSmpl` \ (rs1, rs2) -> returnSmpl (r1:rs1, r2:rs2) + +mapAccumLSmpl f acc [] = returnSmpl (acc, []) +mapAccumLSmpl f acc (x:xs) = f acc x `thenSmpl` \ (acc', x') -> + mapAccumLSmpl f acc' xs `thenSmpl` \ (acc'', xs') -> + returnSmpl (acc'', x':xs') + +getUniqueSmpl :: SmplM Unique +getUniqueSmpl us sc = (getUnique us, sc) + +getUniquesSmpl :: Int -> SmplM [Unique] +getUniquesSmpl n us sc = (getUniques n us, sc) \end{code} @@ -332,41 +341,3 @@ combineSimplCounts (SimplCount n1 stuff1 unf1) (SimplCount n2 stuff2 unf2) #endif \end{code} -%************************************************************************ -%* * -\subsection{Monad primitives} -%* * -%************************************************************************ - -\begin{code} -newId :: Type -> SmplM Id -newId ty us sc - = (mkSysLocal SLIT("s") uniq ty noSrcLoc, sc) - where - uniq = getUnique us - -newIds :: [Type] -> SmplM [Id] -newIds tys us sc - = (zipWithEqual "newIds" mk_id tys uniqs, sc) - where - uniqs = getUniques (length tys) us - mk_id ty uniq = mkSysLocal SLIT("s") uniq ty noSrcLoc - -cloneTyVarSmpl :: TyVar -> SmplM TyVar - -cloneTyVarSmpl tyvar us sc - = (new_tyvar, sc) - where - uniq = getUnique us - new_tyvar = cloneTyVar tyvar uniq - -cloneId :: SimplEnv -> InBinder -> SmplM OutId -cloneId env (id,_) us sc - = simplTyInId env id `appEager` \ id_with_new_ty -> - (mkIdWithNewUniq id_with_new_ty uniq, sc) - where - uniq = getUnique us - -cloneIds :: SimplEnv -> [InBinder] -> SmplM [OutId] -cloneIds env binders = mapSmpl (cloneId env) binders -\end{code} diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs index 197ed80..f3f2f7e 100644 --- a/ghc/compiler/simplCore/SimplPgm.lhs +++ b/ghc/compiler/simplCore/SimplPgm.lhs @@ -13,7 +13,6 @@ import CmdLineOpts ( opt_D_verbose_core2core, opt_D_dump_simpl_iterations, ) import CoreSyn import CoreUnfold ( SimpleUnfolding ) -import CoreUtils ( substCoreExpr ) import Id ( mkIdEnv, lookupIdEnv, IdEnv ) import Maybes ( catMaybes ) diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 718dfee..03ee2bd 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -6,6 +6,8 @@ \begin{code} module SimplUtils ( + newId, newIds, + floatExposesHNF, etaCoreExpr, mkRhsTyLam, @@ -23,9 +25,10 @@ import BinderInfo import CmdLineOpts ( opt_DoEtaReduction, SimplifierSwitch(..) ) import CoreSyn import CoreUnfold ( SimpleUnfolding, mkFormSummary, exprIsTrivial, FormSummary(..) ) -import Id ( idType, isBottomingId, addInlinePragma, addIdDemandInfo, +import Id ( idType, isBottomingId, mkSysLocal, + addInlinePragma, addIdDemandInfo, idWantsToBeINLINEd, dataConArgTys, Id, - getIdArity, GenId{-instance Eq-} + getIdArity, ) import IdInfo ( ArityInfo(..), DemandInfo ) import Maybes ( maybeToBool ) @@ -37,15 +40,40 @@ import Type ( tyVarsOfType, mkForAllTys, mkTyVarTys, getTyVar_maybe, splitAlgTyConApp_maybe, Type ) import TyCon ( isDataTyCon ) -import TyVar ( elementOfTyVarSet, - GenTyVar{-instance Eq-} ) -import Util ( isIn, panic, assertPanic ) +import TyVar ( elementOfTyVarSet ) +import SrcLoc ( noSrcLoc ) +import Util ( isIn, zipWithEqual, panic, assertPanic ) + +\end{code} + +%************************************************************************ +%* * +\subsection{New ids} +%* * +%************************************************************************ + +\begin{code} +newId :: Type -> SmplM Id +newId ty + = getUniqueSmpl `thenSmpl` \ uniq -> + returnSmpl (mkSysLocal SLIT("s") uniq ty noSrcLoc) + +newIds :: [Type] -> SmplM [Id] +newIds tys + = getUniquesSmpl (length tys) `thenSmpl` \ uniqs -> + returnSmpl (zipWithEqual "newIds" mk_id tys uniqs) + where + mk_id ty uniq = mkSysLocal SLIT("s") uniq ty noSrcLoc \end{code} -Floating -~~~~~~~~ +%************************************************************************ +%* * +\subsection{Floating} +%* * +%************************************************************************ + The function @floatExposesHNF@ tells whether let/case floating will expose a head normal form. It is passed booleans indicating the desired strategy. diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index caafa54..3799d5e 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -2,10 +2,11 @@ % (c) The AQUA Project, Glasgow University, 1993-1996 % \section[SimplVar]{Simplifier stuff related to variables} - + \begin{code} module SimplVar ( - completeVar + completeVar, + simplBinder, simplBinders, simplTyBinder, simplTyBinders ) where #include "HsVersions.h" @@ -18,19 +19,27 @@ import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), SimpleUnfolding(..), FormSummary, whnfOrBottom, smallEnoughToInline ) +import Specialise ( substSpecEnvRhs ) import BinderInfo ( BinderInfo, noBinderInfo, okToInline ) import CostCentre ( CostCentre, isCurrentCostCentre ) -import Id ( idType, getIdInfo, getIdUnfolding, getIdSpecialisation, - idMustBeINLINEd, GenId{-instance Outputable-} +import Id ( idType, getIdInfo, getIdUnfolding, + getIdSpecialisation, setIdSpecialisation, + idMustBeINLINEd, idHasNoFreeTyVars, + mkIdWithNewUniq, mkIdWithNewType, + elemIdEnv, isNullIdEnv, addOneToIdEnv ) -import SpecEnv ( matchSpecEnv ) +import SpecEnv ( lookupSpecEnv, substSpecEnv, isEmptySpecEnv ) import Literal ( isNoRepLit ) import MagicUFs ( applyMagicUnfoldingFun, MagicUnfoldingFun ) -import PprType ( GenType{-instance Outputable-} ) import SimplEnv import SimplMonad +import Type ( instantiateTy, mkTyVarTy ) import TyCon ( tyConFamilySize ) +import TyVar ( TyVar, cloneTyVar, + isEmptyTyVarEnv, addToTyVarEnv, + addOneToTyVarSet, elementOfTyVarSet + ) import Maybes ( maybeToBool ) import Outputable \end{code} @@ -50,6 +59,15 @@ completeVar env var args result_ty = tick MagicUnfold `thenSmpl_` magic_result + -- Look for existing specialisations before + -- trying inlining + | maybeToBool maybe_specialisation + = tick SpecialisationDone `thenSmpl_` + simplExpr (bindTyVars env spec_bindings) + spec_template + remaining_args + result_ty + -- If there's an InUnfolding it means that there's no -- let-binding left for the thing, so we'd better inline it! | must_unfold @@ -69,16 +87,10 @@ completeVar env var args result_ty && ok_to_inline && costCentreOk (getEnclosingCC env) (getEnclosingCC unf_env) ) - = unfold var unf_env unf_template args result_ty + = pprTrace "Unfolding" (ppr var) $ + unfold var unf_env unf_template args result_ty - | maybeToBool maybe_specialisation - = tick SpecialisationDone `thenSmpl_` - simplExpr (extendTyEnvEnv env spec_bindings) - spec_template - remaining_args - result_ty - | otherwise = returnSmpl (mkGenApp (Var var) args) @@ -114,7 +126,7 @@ completeVar env var args result_ty ---------- Specialisation stuff (ty_args, remaining_args) = initialTyArgs args - maybe_specialisation = matchSpecEnv (getIdSpecialisation var) ty_args + maybe_specialisation = lookupSpecEnv (getIdSpecialisation var) ty_args Just (spec_bindings, spec_template) = maybe_specialisation @@ -161,3 +173,96 @@ costCentreOk cc_encl cc_rhs = isCurrentCostCentre cc_encl || not (isCurrentCostCentre cc_rhs) \end{code} + +%************************************************************************ +%* * +\section{Dealing with a single binder} +%* * +%************************************************************************ + +When we hit a binder we may need to + (a) apply the the type envt (if non-empty) to its type + (b) apply the type envt and id envt to its SpecEnv (if it has one) + (c) give it a new unique to avoid name clashes + +\begin{code} +simplBinder :: SimplEnv -> InBinder -> SmplM (SimplEnv, OutId) +simplBinder env (id, _) + | not_in_scope -- Not in scope, so no need to clone + && empty_ty_subst -- No type substitution to do inside the Id + && isNullIdEnv id_subst -- No id substitution to do inside the Id + = let + env' = setIdEnv env (addOneToIdEnv in_scope_ids id id, id_subst) + in + returnSmpl (env', id) + + | otherwise + = +#if DEBUG + -- I reckon the empty-env thing should catch + -- most no-free-tyvars things, so this test should be redundant + (if idHasNoFreeTyVars id then pprTrace "applyEnvsToId" (ppr id) else (\x -> x)) +#endif + (let + -- id1 has its type zapped + id1 | empty_ty_subst = id + | otherwise = mkIdWithNewType id ty' + + -- id2 has its SpecEnv zapped + id2 | isEmptySpecEnv spec_env = id1 + | otherwise = setIdSpecialisation id spec_env' + in + if not_in_scope then + -- No need to clone + let + env' = setIdEnv env (addOneToIdEnv in_scope_ids id id2, id_subst) + in + returnSmpl (env', id2) + else + -- Must clone + getUniqueSmpl `thenSmpl` \ uniq -> + let + id3 = mkIdWithNewUniq id2 uniq + env' = setIdEnv env (addOneToIdEnv in_scope_ids id3 id3, + addOneToIdEnv id_subst id (VarArg id3)) + in + returnSmpl (env', id3) + ) + where + ((in_scope_tyvars, ty_subst), (in_scope_ids, id_subst)) = getSubstEnvs env + empty_ty_subst = isEmptyTyVarEnv ty_subst + not_in_scope = not (id `elemIdEnv` in_scope_ids) + + ty = idType id + ty' = instantiateTy ty_subst ty + + spec_env = getIdSpecialisation id + spec_env' = substSpecEnv ty_subst (substSpecEnvRhs ty_subst id_subst) spec_env + +simplBinders :: SimplEnv -> [InBinder] -> SmplM (SimplEnv, [OutId]) +simplBinders env binders = mapAccumLSmpl simplBinder env binders +\end{code} + +\begin{code} +simplTyBinder :: SimplEnv -> TyVar -> SmplM (SimplEnv, TyVar) +simplTyBinder env tyvar + | not (tyvar `elementOfTyVarSet` tyvars) -- No need to clone + = let + env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar, ty_subst) + in + returnSmpl (env', tyvar) + + | otherwise -- Need to clone + = getUniqueSmpl `thenSmpl` \ uniq -> + let + tyvar' = cloneTyVar tyvar uniq + env' = setTyEnv env (tyvars `addOneToTyVarSet` tyvar', + addToTyVarEnv ty_subst tyvar (mkTyVarTy tyvar')) + in + returnSmpl (env', tyvar') + where + ((tyvars, ty_subst), (ids, id_subst)) = getSubstEnvs env + +simplTyBinders :: SimplEnv -> [TyVar] -> SmplM (SimplEnv, [TyVar]) +simplTyBinders env binders = mapAccumLSmpl simplTyBinder env binders +\end{code} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 2340b23..522a96c 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -22,21 +22,18 @@ import CoreUtils ( coreExprType, nonErrorRHSs, maybeErrorApp, ) import Id ( idType, idMustBeINLINEd, idWantsToBeINLINEd, idMustNotBeINLINEd, addIdArity, getIdArity, - getIdDemandInfo, addIdDemandInfo, - GenId{-instance NamedThing-} + getIdDemandInfo, addIdDemandInfo ) import Name ( isExported ) import IdInfo ( willBeDemanded, noDemandInfo, DemandInfo, ArityInfo(..), atLeastArity, unknownArity ) import Literal ( isNoRepLit ) import Maybes ( maybeToBool ) -import PprType ( GenType{-instance Outputable-}, GenTyVar{- instance Outputable -} ) import PrimOp ( primOpOkForSpeculation, PrimOp(..) ) import SimplCase ( simplCase, bindLargeRhs ) import SimplEnv import SimplMonad -import SimplVar ( completeVar ) -import Unique ( Unique ) +import SimplVar ( completeVar, simplBinder, simplBinders, simplTyBinder, simplTyBinders ) import SimplUtils import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, applyTys, mkFunTys, splitAlgTyConApp_maybe, @@ -197,8 +194,9 @@ simplTopBinds env binds simpl_top_binds env (NonRec binder@(in_id,occ_info) rhs : binds) = --- No cloning necessary at top level - simplRhsExpr env binder rhs in_id `thenSmpl` \ (rhs',arity) -> - completeNonRec env binder (in_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') -> + simplBinder env binder `thenSmpl` \ (env1, out_id) -> + simplRhsExpr env binder rhs out_id `thenSmpl` \ (rhs',arity) -> + completeNonRec env1 binder (out_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds1') -> simpl_top_binds new_env binds `thenSmpl` \ binds2' -> returnSmpl (binds1' ++ binds2') @@ -218,15 +216,10 @@ simplTopBinds env binds -- -- Sure we could have made the indirection-shorting a bit cleverer, but -- propagating pragma info is a Good Idea anyway. - let - env1 = extendIdEnvWithClones env binders ids - in - simplRecursiveGroup env1 ids pairs `thenSmpl` \ (bind', new_env) -> + simplBinders env (map fst pairs) `thenSmpl` \ (env1, out_ids) -> + simplRecursiveGroup env1 out_ids pairs `thenSmpl` \ (bind', new_env) -> simpl_top_binds new_env binds `thenSmpl` \ binds' -> returnSmpl (Rec bind' : binds') - where - binders = map fst pairs - ids = map fst binders \end{code} %************************************************************************ @@ -330,16 +323,14 @@ First the case when it's applied to an argument. \begin{code} simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty = tick TyBetaReduction `thenSmpl_` - simplExpr (extendTyEnv env tyvar ty) body args result_ty + simplExpr (bindTyVar env tyvar ty) body args result_ty \end{code} \begin{code} simplExpr env tylam@(Lam (TyBinder tyvar) body) [] result_ty - = cloneTyVarSmpl tyvar `thenSmpl` \ tyvar' -> + = simplTyBinder env tyvar `thenSmpl` \ (new_env, tyvar') -> let - new_ty = mkTyVarTy tyvar' - new_env = extendTyEnv env tyvar new_ty - new_result_ty = applyTy result_ty new_ty + new_result_ty = applyTy result_ty (mkTyVarTy tyvar') in simplExpr new_env body [] new_result_ty `thenSmpl` \ body' -> returnSmpl (Lam (TyBinder tyvar') body') @@ -372,7 +363,7 @@ simplExpr env expr@(Lam (ValBinder binder) body) orig_args result_ty go n env (Lam (ValBinder binder) body) (val_arg : args) | isValArg val_arg -- The lambda has an argument = tick BetaReduction `thenSmpl_` - go (n+1) (extendIdEnvWithAtom env binder val_arg) body args + go (n+1) (bindIdToAtom env binder val_arg) body args go n env expr@(Lam (ValBinder binder) body) args -- The lambda is un-saturated, so we must zap the occurrence info @@ -505,11 +496,9 @@ simplRhsExpr env binder@(id,occ_info) rhs new_id | otherwise -- OK, use the big hammer = -- Deal with the big lambda part - mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' -> + simplTyBinders env tyvars `thenSmpl` \ (lam_env, tyvars') -> let - new_tys = mkTyVarTys tyvars' - body_ty = applyTys rhs_ty new_tys - lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars new_tys) + body_ty = applyTys rhs_ty (mkTyVarTys tyvars') in -- Deal with the little lambda part -- Note that we call simplLam even if there are no binders, @@ -635,11 +624,8 @@ simplValLam env expr min_no_of_args expr_ty 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' -> - let - new_env = extendIdEnvWithClones env binders binders' - in - simplExpr new_env body [] body_ty `thenSmpl` \ body' -> + = simplBinders env binders `thenSmpl` \ (new_env, binders') -> + simplExpr new_env body [] body_ty `thenSmpl` \ body' -> returnSmpl (mkValLam binders' body', final_arity) | otherwise -- Eta expansion possible @@ -653,10 +639,7 @@ simplValLam env expr min_no_of_args expr_ty else \x -> x) $ tick EtaExpansion `thenSmpl_` - cloneIds env binders `thenSmpl` \ binders' -> - let - new_env = extendIdEnvWithClones env binders binders' - in + simplBinders env binders `thenSmpl` \ (new_env, binders') -> newIds extra_binder_tys `thenSmpl` \ extra_binders' -> simplExpr new_env body (map VarArg extra_binders') etad_body_ty `thenSmpl` \ body' -> returnSmpl ( @@ -973,9 +956,9 @@ simplNonRec env binder@(id,occ_info) rhs body_c body_ty simpl_bind env rhs = complete_bind env rhs complete_bind env rhs - = cloneId env binder `thenSmpl` \ new_id -> + = simplBinder env binder `thenSmpl` \ (env_w_clone, new_id) -> simplRhsExpr env binder rhs new_id `thenSmpl` \ (rhs',arity) -> - completeNonRec env binder + completeNonRec env_w_clone binder (new_id `withArity` arity) rhs' `thenSmpl` \ (new_env, binds) -> body_c new_env `thenSmpl` \ body' -> returnSmpl (mkCoLetsAny binds body') @@ -1050,7 +1033,11 @@ completeNonRec env binder new_id new_rhs -- its binding. && maybeToBool maybe_atomic_rhs = tick tick_type `thenSmpl_` - returnSmpl (extendIdEnvWithAtom env binder rhs_arg, []) + let + env1 = notInScope env new_id + env2 = bindIdToAtom env1 binder rhs_arg + in + returnSmpl (env2, []) where Just (rhs_arg, tick_type) = maybe_atomic_rhs maybe_atomic_rhs @@ -1074,8 +1061,7 @@ completeNonRec env binder new_id new_rhs completeNonRec env binder@(id,occ_info) new_id new_rhs = returnSmpl (new_env , [NonRec new_id new_rhs]) where - new_env = extendEnvGivenBinding (extendIdEnvWithClone env binder new_id) - occ_info new_id new_rhs + new_env = extendEnvGivenBinding env occ_info new_id new_rhs \end{code} ---------------------------------------------------------------------------- @@ -1185,13 +1171,10 @@ simplRec env pairs body_c body_ty let binders = map fst pairs' in - cloneIds env binders `thenSmpl` \ ids' -> - let - env_w_clones = extendIdEnvWithClones env binders ids' - in + simplBinders env binders `thenSmpl` \ (env_w_clones, ids') -> simplRecursiveGroup env_w_clones ids' pairs' `thenSmpl` \ (pairs', new_env) -> - body_c new_env `thenSmpl` \ body' -> + body_c new_env `thenSmpl` \ body' -> returnSmpl (Let (Rec pairs') body') \end{code} @@ -1229,7 +1212,10 @@ simplRecursiveGroup env (new_id : new_ids) ((binder@(id, occ_info), rhs) : pairs = env | is_atomic eta'd_rhs -- If rhs (after eta reduction) is atomic - = extendIdEnvWithAtom env binder the_arg + = let + env1 = notInScope env new_id + in + bindIdToAtom env1 binder the_arg | otherwise -- Non-atomic = extendEnvGivenBinding env occ_info new_id new_rhs diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs index 194acef..af66c9b 100644 --- a/ghc/compiler/specialise/SpecEnv.lhs +++ b/ghc/compiler/specialise/SpecEnv.lhs @@ -6,14 +6,14 @@ \begin{code} module SpecEnv ( SpecEnv, - emptySpecEnv, isEmptySpecEnv, - addToSpecEnv, matchSpecEnv, unifySpecEnv + emptySpecEnv, isEmptySpecEnv, specEnvValues, + addToSpecEnv, lookupSpecEnv, substSpecEnv ) where #include "HsVersions.h" -import Type ( Type, GenType, matchTys, tyVarsOfTypes ) -import TyVar ( TyVarEnv, lookupTyVarEnv, tyVarSetToList ) +import Type ( Type, GenType, mkTyVarTy, matchTys, tyVarsOfTypes, applyToTyVars ) +import TyVar ( TyVar, TyVarEnv, tyVarFlexi, setTyVarFlexi, lookupTyVarEnv, tyVarSetToList ) import Unify ( Subst, unifyTyListsX ) import Maybes import Util ( assertPanic ) @@ -28,11 +28,35 @@ import Util ( assertPanic ) %************************************************************************ \begin{code} +type TemplateType = GenType Bool + -- The Bool is True for template type variables; + -- that is, ones that can be bound + data SpecEnv value = EmptySE - | SpecEnv [([Type], value)] -- No pair of templates unify with each others + | SpecEnv [([TemplateType], value)] + +specEnvValues :: SpecEnv value -> [value] +specEnvValues EmptySE = [] +specEnvValues (SpecEnv alist) = map snd alist \end{code} +In some SpecEnvs overlap is prohibited; that is, no pair of templates unify. + +In others, overlap is permitted, but only in such a way that one can make +a unique choice when looking up. That is, overlap is only permitted if +one template matches the other, or vice versa. So this is ok: + + [a] [Int] + +but this is not + + (Int,a) (b,Int) + +If overlap is permitted, the list is kept most specific first, so that +the first lookup is the right choice. + + For now we just use association lists. \begin{code} @@ -43,79 +67,85 @@ isEmptySpecEnv EmptySE = True isEmptySpecEnv _ = False \end{code} -@lookupSpecEnv@ looks up in a @SpecEnv@. Since no pair of templates -unify, the first match must be the only one. +@lookupSpecEnv@ looks up in a @SpecEnv@, using a one-way match. Since the env is kept +ordered, the first match must be the only one. +The thing we are looking up can have an +arbitrary "flexi" part. \begin{code} -data SpecEnvResult val - = Match Subst val -- Match, instantiating only - -- type variables in the template - - | CouldMatch -- A match could happen if the - -- some of the type variables in the key - -- were further instantiated. - - | NoMatch -- No match possible, regardless of how - -- the key is further instantiated - --- If the key *unifies* with one of the templates, then the --- result is Match or CouldMatch, depending on whether any of the --- type variables in the key had to be instantiated - -unifySpecEnv :: SpecEnv value -- The envt - -> [Type] -- Key - -> SpecEnvResult value +lookupSpecEnv :: SpecEnv value -- The envt + -> [GenType flexi] -- Key + -> Maybe (TyVarEnv (GenType flexi), value) - -unifySpecEnv EmptySE key = NoMatch -unifySpecEnv (SpecEnv alist) key - = find alist - where - find [] = NoMatch - find ((tpl, val) : rest) - = case unifyTyListsX tpl key of - Nothing -> find rest - Just subst | all uninstantiated (tyVarSetToList (tyVarsOfTypes key)) - -> Match subst val - | otherwise - -> CouldMatch - where - uninstantiated tv = case lookupTyVarEnv subst tv of - Just xx -> False - Nothing -> True - --- matchSpecEnv does a one-way match only, but in return --- it is more polymorphic than unifySpecEnv - -matchSpecEnv :: SpecEnv value -- The envt - -> [GenType flexi] -- Key - -> Maybe (TyVarEnv (GenType flexi), value) - -matchSpecEnv EmptySE key = Nothing -matchSpecEnv (SpecEnv alist) key +lookupSpecEnv EmptySE key = Nothing +lookupSpecEnv (SpecEnv alist) key = find alist where find [] = Nothing find ((tpl, val) : rest) = case matchTys tpl key of - Nothing -> find rest + Nothing -> find rest Just (subst, leftovers) -> ASSERT( null leftovers ) Just (subst, val) \end{code} @addToSpecEnv@ extends a @SpecEnv@, checking for overlaps. +A boolean flag controls overlap reporting. + +True => overlap is permitted, but only if one template matches the other; + not if they unify but neither is + \begin{code} -addToSpecEnv :: SpecEnv value -- Envt - -> [Type] -> value -- New item - -> MaybeErr (SpecEnv value) -- Success... - ([Type], value) -- Failure: Offending overlap - -addToSpecEnv EmptySE key value = returnMaB (SpecEnv [(key, value)]) -addToSpecEnv (SpecEnv alist) key value - = case filter matches_key alist of - [] -> returnMaB (SpecEnv ((key,value) : alist)) -- No match - (bad : _) -> failMaB bad -- At least one match +addToSpecEnv :: Bool -- True <=> overlap permitted + -> SpecEnv value -- Envt + -> [TyVar] -> [Type] -> value -- New item + -> MaybeErr (SpecEnv value) -- Success... + ([TemplateType], value) -- Failure: Offending overlap + +addToSpecEnv overlap_ok spec_env tvs tys value + = case spec_env of + EmptySE -> returnMaB (SpecEnv [ins_item]) + SpecEnv alist -> insert alist `thenMaB` \ alist' -> + returnMaB (SpecEnv alist') where - matches_key (tpl, val) = maybeToBool (unifyTyListsX tpl key) + ins_item = (ins_tys, value) + ins_tys = map (applyToTyVars mk_tv) tys + + mk_tv tv = mkTyVarTy (setTyVarFlexi tv (tv `elem` tvs)) + -- tvs identifies the template variables + + insert [] = returnMaB [ins_item] + insert alist@(cur_item@(cur_tys, _) : rest) + | unifiable && not overlap_ok = failMaB cur_item + | unifiable && ins_item_more_specific = returnMaB (ins_item : alist) + | unifiable && not cur_item_more_specific = failMaB cur_item + | otherwise = -- Less specific, or not unifiable... carry on + insert rest `thenMaB` \ rest' -> + returnMaB (cur_item : rest') + where + unifiable = maybeToBool (unifyTyListsX cur_tys ins_tys) + ins_item_more_specific = maybeToBool (matchTys cur_tys ins_tys) + cur_item_more_specific = maybeToBool (matchTys ins_tys cur_tys) +\end{code} + +Finally, during simplification we must apply the current substitution to +the SpecEnv. + +\begin{code} +substSpecEnv :: TyVarEnv Type -> (val -> val) -> SpecEnv val -> SpecEnv val +substSpecEnv ty_env val_fn EmptySE = EmptySE +substSpecEnv ty_env val_fn (SpecEnv alist) + = SpecEnv [(map ty_fn tys, val_fn val) | (tys, val) <- alist] + where + ty_fn = applyToTyVars tyvar_fn + + -- Apply the substitution; but if we ever substitute + -- we need to convert a Type to a TemplateType + tyvar_fn tv | tyVarFlexi tv = mkTyVarTy tv + | otherwise = case lookupTyVarEnv ty_env tv of + Nothing -> mkTyVarTy tv + Just ty -> applyToTyVars set_non_tpl ty + + set_non_tpl tv = mkTyVarTy (setTyVarFlexi tv False) \end{code} diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 76e3c3e..aade3c4 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -5,19 +5,21 @@ \begin{code} module Specialise ( - specProgram + specProgram, + idSpecVars, + substSpecEnvRhs ) where #include "HsVersions.h" import Id ( Id, DictVar, idType, mkUserLocal, - getIdSpecialisation, addIdSpecialisation, isSpecPragmaId, + getIdSpecialisation, setIdSpecialisation, IdSet, mkIdSet, addOneToIdSet, intersectIdSets, isEmptyIdSet, emptyIdSet, unionIdSets, minusIdSet, unitIdSet, elementOfIdSet, - IdEnv, mkIdEnv, lookupIdEnv, addOneToIdEnv + IdEnv, mkIdEnv, lookupIdEnv, addOneToIdEnv, delOneFromIdEnv ) import Type ( Type, mkTyVarTy, splitSigmaTy, instantiateTy, isDictTy, @@ -27,19 +29,19 @@ import TyCon ( TyCon ) import TyVar ( TyVar, TyVarSet, mkTyVarSet, isEmptyTyVarSet, intersectTyVarSets, elementOfTyVarSet, unionTyVarSets, emptyTyVarSet, - TyVarEnv, mkTyVarEnv + TyVarEnv, mkTyVarEnv, delFromTyVarEnv ) -import CoreSyn +import CoreSyn import OccurAnal ( occurAnalyseGlobalExpr ) import Name ( NamedThing(..), getSrcLoc ) -import SpecEnv ( addToSpecEnv ) +import SpecEnv ( addToSpecEnv, lookupSpecEnv, specEnvValues ) import UniqSupply ( UniqSupply, UniqSM, initUs, thenUs, returnUs, getUnique, mapUs ) import FiniteMap -import Maybes ( MaybeErr(..) ) +import Maybes ( MaybeErr(..), maybeToBool ) import Bag import List ( partition ) import Util ( zipEqual ) @@ -834,24 +836,20 @@ specBind (NonRec bndr rhs) body_uds in returnSM ([], all_uds) - | isSpecPragmaId bndr - -- SpecPragmaIds are there solely to generate specialisations - -- Just drop the whole binding; keep only its usage details - = specExpr rhs `thenSM` \ (rhs', rhs_uds) -> - returnSM ([], rhs_uds `plusUDs` body_uds) - | otherwise = -- Deal with the RHS, specialising it according -- to the calls found in the body specDefn (calls body_uds) (bndr,rhs) `thenSM` \ ((bndr',rhs'), spec_defns, spec_uds) -> let (all_uds, (dict_binds, dump_calls)) - = splitUDs [ValBinder bndr'] (spec_uds `plusUDs` body_uds) + = splitUDs [ValBinder bndr] (spec_uds `plusUDs` body_uds) + + -- If we make specialisations then we Rec the whole lot together + -- If not, leave it as a NonRec + new_bind | null spec_defns = NonRec bndr' rhs' + | otherwise = Rec ((bndr',rhs'):spec_defns) in - returnSM ( [NonRec bndr' rhs'] - ++ dict_binds - ++ spec_defns, - all_uds ) + returnSM ( new_bind : dict_binds, all_uds ) specBind (Rec pairs) body_uds = mapSM (specDefn (calls body_uds)) pairs `thenSM` \ stuff -> @@ -860,18 +858,16 @@ specBind (Rec pairs) body_uds spec_defns = concat spec_defns_s spec_uds = plusUDList spec_uds_s (all_uds, (dict_binds, dump_calls)) - = splitUDs (map (ValBinder . fst) pairs') (spec_uds `plusUDs` body_uds) + = splitUDs (map (ValBinder . fst) pairs) (spec_uds `plusUDs` body_uds) + new_bind = Rec (spec_defns ++ pairs') in - returnSM ( [Rec pairs'] - ++ dict_binds - ++ spec_defns, - all_uds ) + returnSM ( new_bind : dict_binds, all_uds ) specDefn :: CallDetails -- Info on how it is used in its scope -> (Id, CoreExpr) -- The thing being bound and its un-processed RHS -> SpecM ((Id, CoreExpr), -- The thing and its processed RHS -- the Id may now have specialisations attached - [CoreBinding], -- Extra, specialised bindings + [(Id,CoreExpr)], -- Extra, specialised bindings UsageDetails -- Stuff to fling upwards from the RHS and its ) -- specialised versions @@ -903,10 +899,14 @@ specDefn calls (fn, rhs) returnSM ((fn, rhs'), [], rhs_uds) where - fn_type = idType fn - (tyvars, theta, tau) = splitSigmaTy fn_type - n_tyvars = length tyvars - n_dicts = length theta + fn_type = idType fn + (tyvars, theta, tau) = splitSigmaTy fn_type + n_tyvars = length tyvars + n_dicts = length theta + mk_spec_tys call_ts = zipWith mk_spec_ty call_ts tyvars + where + mk_spec_ty (Just ty) _ = ty + mk_spec_ty Nothing tyvar = mkTyVarTy tyvar (rhs_tyvars, rhs_ids, rhs_body) = collectBinders rhs rhs_dicts = take n_dicts rhs_ids @@ -918,13 +918,19 @@ specDefn calls (fn, rhs) Nothing -> [] Just cs -> fmToList cs + -- Filter out calls for which we already have a specialisation + calls_to_spec = filter spec_me calls_for_me + spec_me (call_ts, _) = not (maybeToBool (lookupSpecEnv id_spec_env (mk_spec_tys call_ts))) + id_spec_env = getIdSpecialisation fn + + ---------------------------------------------------------- -- Specialise to one particular call pattern spec_call :: ProtoUsageDetails -- From the original body, captured by -- the dictionary lambdas -> ([Maybe Type], [DictVar]) -- Call instance - -> SpecM (CoreBinding, -- Specialised definition + -> SpecM ((Id,CoreExpr), -- Specialised definition UsageDetails, -- Usage details from specialised body - ([Type], CoreExpr)) -- Info for the Id's SpecEnv + ([TyVar], [Type], CoreExpr)) -- Info for the Id's SpecEnv spec_call bound_uds (call_ts, call_ds) = ASSERT( length call_ts == n_tyvars && length call_ds == n_dicts ) -- Calls are only recorded for properly-saturated applications @@ -936,36 +942,35 @@ specDefn calls (fn, rhs) -- and the type of this binder let spec_tyvars = [tyvar | (tyvar, Nothing) <- tyvars `zip` call_ts] - spec_tys = zipWith mk_spec_ty call_ts tyvars + spec_tys = mk_spec_tys call_ts spec_rhs = mkTyLam spec_tyvars $ mkGenApp rhs (map TyArg spec_tys ++ map VarArg call_ds) - spec_id_ty = mkForAllTys spec_tyvars (applyTys fn_type spec_tys) - - mk_spec_ty (Just ty) _ = ty - mk_spec_ty Nothing tyvar = mkTyVarTy tyvar + spec_id_ty = mkForAllTys spec_tyvars (instantiateTy ty_env tau) + ty_env = mkTyVarEnv (zipEqual "spec_call" tyvars spec_tys) in newIdSM fn spec_id_ty `thenSM` \ spec_f -> -- Construct the stuff for f's spec env - -- [t1,b,t3,d] |-> \d1 d2 -> f1 b d + -- [b,d] [t1,b,t3,d] |-> \d1 d2 -> f1 b d let spec_env_rhs = mkValLam call_ds $ mkTyApp (Var spec_f) $ map mkTyVarTy spec_tyvars - spec_env_info = (spec_tys, spec_env_rhs) + spec_env_info = (spec_tyvars, spec_tys, spec_env_rhs) in -- Specialise the UDs from f's RHS let - tv_env = [ (rhs_tyvar,ty) + -- Only the overloaded tyvars should be free in the uds + ty_env = [ (rhs_tyvar,ty) | (rhs_tyvar, Just ty) <- zipEqual "specUDs1" rhs_tyvars call_ts ] dict_env = zipEqual "specUDs2" rhs_dicts call_ds in - specUDs tv_env dict_env bound_uds `thenSM` \ spec_uds -> + specUDs ty_env dict_env bound_uds `thenSM` \ spec_uds -> - returnSM (NonRec spec_f spec_rhs, + returnSM ((spec_f, spec_rhs), spec_uds, spec_env_info ) @@ -1181,15 +1186,58 @@ addIdSpecialisations id spec_stuff pprTrace "Duplicate specialisations" (vcat (map ppr errs)) else \x -> x ) - addIdSpecialisation id new_spec_env + setIdSpecialisation id new_spec_env where (new_spec_env, errs) = foldr add (getIdSpecialisation id, []) spec_stuff - add (tys, template) (spec_env, errs) - = case addToSpecEnv spec_env tys (occurAnalyseGlobalExpr template) of + add (tyvars, tys, template) (spec_env, errs) + = case addToSpecEnv True spec_env tyvars tys (occurAnalyseGlobalExpr template) of Succeeded spec_env' -> (spec_env', errs) Failed err -> (spec_env, err:errs) +-- Given an Id, isSpecVars returns all its specialisations. +-- We extract these from its SpecEnv. +-- This is used by the occurrence analyser and free-var finder; +-- we regard an Id's specialisations as free in the Id's definition. + +idSpecVars :: Id -> [Id] +idSpecVars id + = map get_spec (specEnvValues (getIdSpecialisation id)) + where + -- get_spec is another cheapo function like dictRhsFVs + -- It knows what these specialisation temlates look like, + -- and just goes for the jugular + get_spec (App f _) = get_spec f + get_spec (Lam _ b) = get_spec b + get_spec (Var v) = v + +-- substSpecEnvRhs applies a substitution to the RHS's of a SpecEnv +-- It's placed here because Specialise.lhs built that RHS, so +-- it knows its structure. (Fully general subst + +substSpecEnvRhs te ve rhs + = go te ve rhs + where + go te ve (App f (TyArg ty)) = App (go te ve f) (TyArg (instantiateTy te ty)) + go te ve (App f (VarArg v)) = App (go te ve f) (case lookupIdEnv ve v of + Just arg' -> arg' + Nothing -> VarArg v) + go te ve (Var v) = case lookupIdEnv ve v of + Just (VarArg v') -> Var v' + Just (LitArg l) -> Lit l + Nothing -> Var v + + -- These equations are a bit half baked, because + -- they don't deal properly wih capture. + -- But I'm sure it'll never matter... sigh. + go te ve (Lam b@(TyBinder tyvar) e) = Lam b (go te' ve e) + where + te' = delFromTyVarEnv te tyvar + + go te ve (Lam b@(ValBinder (v,_)) e) = Lam b (go te ve' e) + where + ve' = delOneFromIdEnv ve v + ---------------------------------------- type SpecM a = UniqSM a diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index d899c08..fa54823 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -29,6 +29,7 @@ module Inst ( #include "HsVersions.h" +import CmdLineOpts ( opt_AllowOverlappingInstances ) import HsSyn ( HsLit(..), HsExpr(..), MonoBinds ) import RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr ) import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr, @@ -52,9 +53,9 @@ import Id ( idType, mkUserLocal, mkSysLocal, Id, import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass ) import Name ( OccName(..), Name, occNameString, getOccName ) import PprType ( TyCon, pprConstraint ) -import SpecEnv ( SpecEnv, matchSpecEnv, addToSpecEnv ) +import SpecEnv ( SpecEnv, lookupSpecEnv ) import SrcLoc ( SrcLoc ) -import Type ( Type, ThetaType, instantiateTy, instantiateThetaTy, matchTys, +import Type ( Type, ThetaType, instantiateTy, instantiateThetaTy, isTyVarTy, mkDictTy, splitForAllTys, splitSigmaTy, splitRhoTy, tyVarsOfType, tyVarsOfTypes, mkSynTy @@ -467,7 +468,7 @@ lookupInst :: Inst s -- Dictionaries lookupInst dict@(Dict _ clas tys orig loc) - = case matchSpecEnv (classInstEnv clas) tys of + = case lookupSpecEnv (classInstEnv clas) tys of Just (tenv, dfun_id) -> let @@ -547,7 +548,7 @@ lookupSimpleInst :: ClassInstEnv -> NF_TcM s (Maybe ThetaType) -- Here are the needed (c,t)s lookupSimpleInst class_inst_env clas tys - = case matchSpecEnv class_inst_env tys of + = case lookupSpecEnv class_inst_env tys of Nothing -> returnNF_Tc Nothing Just (tenv, dfun) @@ -557,20 +558,6 @@ lookupSimpleInst class_inst_env clas tys \end{code} -\begin{code} -addClassInst - :: ClassInstEnv -- Incoming envt - -> [Type] -- The instance types: inst_tys - -> Id -- Dict fun id to apply. Free tyvars of inst_ty must - -- be the same as the forall'd tyvars of the dfun id. - -> MaybeErr - ClassInstEnv -- Success - ([Type], Id) -- Offending overlap - -addClassInst inst_env inst_tys dfun_id = addToSpecEnv inst_env inst_tys dfun_id -\end{code} - - %************************************************************************ %* * diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index f058aac..02e55fb 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -44,7 +44,7 @@ import TcType ( TcType, TcThetaType, TcTauType, import Unify ( unifyTauTy, unifyTauTyLists ) import Kind ( isUnboxedTypeKind, mkTypeKind, isTypeKind, mkBoxedTypeKind ) -import Id ( GenId, idType, mkUserId ) +import Id ( idType, mkUserId, replacePragmaInfo ) import IdInfo ( noIdInfo ) import Maybes ( maybeToBool, assocMaybe ) import Name ( getOccName, getSrcLoc, Name ) @@ -240,7 +240,7 @@ tcBindWithSigs top_lvl binder_names mbind tc_ty_sigs is_rec prag_info_fn poly_ids = map mk_dummy binder_names mk_dummy name = case maybeSig tc_ty_sigs name of Just (TySigInfo _ poly_id _ _ _ _) -> poly_id -- Signature - Nothing -> mkUserId name forall_a_a NoPragmaInfo -- No signature + Nothing -> mkUserId name forall_a_a -- No signature in returnTc (EmptyMonoBinds, emptyLIE, poly_ids) ) $ @@ -339,7 +339,7 @@ tcBindWithSigs top_lvl binder_names mbind tc_ty_sigs is_rec prag_info_fn where maybe_sig = maybeSig tc_ty_sigs binder_name Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _) = maybe_sig - poly_id = mkUserId binder_name poly_ty (prag_info_fn binder_name) + poly_id = replacePragmaInfo (mkUserId binder_name poly_ty) (prag_info_fn binder_name) poly_ty = mkForAllTys real_tyvars_to_gen_list $ mkFunTys dict_tys $ zonked_mono_id_ty -- It's important to build a fully-zonked poly_ty, because -- we'll slurp out its free type variables when extending the @@ -630,7 +630,7 @@ tcTySig prag_info_fn (Sig v ty src_loc) -- Convert from Type to TcType tcInstSigType sigma_ty `thenNF_Tc` \ sigma_tc_ty -> let - poly_id = mkUserId v sigma_tc_ty (prag_info_fn v) + poly_id = replacePragmaInfo (mkUserId v sigma_tc_ty) (prag_info_fn v) in -- Instantiate this type -- It's important to do this even though in the error-free case diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 2372f39..39ac7de 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -59,7 +59,7 @@ import Maybes ( assocMaybe, maybeToBool ) -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas ) tcGenPragmas ty id ps = returnNF_Tc noIdInfo -tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `addSpecInfo` spec, +tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `setSpecInfo` spec, noIdInfo) \end{code} diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 587176a..a2137dc 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -387,7 +387,7 @@ newMonoIds names kind m = newTyVarTys no_of_names kind `thenNF_Tc` \ tys -> let new_ids = zipWithEqual "newMonoIds" mk_id names tys - mk_id name ty = mkUserId name ty NoPragmaInfo + mk_id name ty = mkUserId name ty in tcExtendLocalValEnv names new_ids (m new_ids) where diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 2d7a666..cecc64a 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -245,7 +245,7 @@ tcCoreExpr (UfLet (UfRec pairs) body) tcCoreLamBndr (UfValBinder name ty) thing_inside = tcHsType ty `thenTc` \ ty' -> let - id = mkUserId name ty' NoPragmaInfo + id = mkUserId name ty' in tcExtendGlobalValEnv [id] $ thing_inside (ValBinder id) @@ -260,7 +260,7 @@ tcCoreLamBndr (UfTyBinder name kind) thing_inside tcCoreValBndr (UfValBinder name ty) thing_inside = tcHsType ty `thenTc` \ ty' -> let - id = mk_id name ty' + id = mkUserId name ty' in tcExtendGlobalValEnv [id] $ thing_inside id @@ -268,15 +268,13 @@ tcCoreValBndr (UfValBinder name ty) thing_inside tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders = mapTc tcHsType tys `thenTc` \ tys' -> let - ids = zipWithEqual "tcCoreValBndr" mk_id names tys' + ids = zipWithEqual "tcCoreValBndr" mkUserId names tys' in tcExtendGlobalValEnv ids $ thing_inside ids where names = map (\ (UfValBinder name _) -> name) bndrs tys = map (\ (UfValBinder _ ty) -> ty) bndrs - -mk_id name ty = mkUserId name ty NoPragmaInfo \end{code} \begin{code} @@ -294,7 +292,7 @@ tcCoreAlts scrut_ty (UfAlgAlts alts deflt) let arg_tys = dataConArgTys con' inst_tys (tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty - arg_ids = zipWithEqual "tcCoreAlts" mk_id names arg_tys + arg_ids = zipWithEqual "tcCoreAlts" mkUserId names arg_tys in tcExtendGlobalValEnv arg_ids $ tcCoreExpr rhs `thenTc` \ rhs' -> @@ -311,7 +309,7 @@ tcCoreAlts scrut_ty (UfPrimAlts alts deflt) tcCoreDefault scrut_ty UfNoDefault = returnTc NoDefault tcCoreDefault scrut_ty (UfBindDefault name rhs) = let - deflt_id = mk_id name scrut_ty + deflt_id = mkUserId name scrut_ty in tcExtendGlobalValEnv [deflt_id] $ tcCoreExpr rhs `thenTc` \ rhs' -> diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index 28abdaf..86d31bd 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -17,6 +17,7 @@ module TcInstUtil ( import RnHsSyn ( RenamedMonoBinds, RenamedSig(..) ) +import CmdLineOpts ( opt_AllowOverlappingInstances ) import TcMonad import Inst ( InstanceMapper ) @@ -161,7 +162,8 @@ addClassInstance dfun_id _ src_loc _) class_inst_env = -- Add the instance to the class's instance environment - case addToSpecEnv class_inst_env inst_tys dfun_id of + case addToSpecEnv opt_AllowOverlappingInstances + class_inst_env inst_tyvars inst_tys dfun_id of Failed (ty', dfun_id') -> addErrTc (dupInstErr clas (inst_tys, src_loc) (ty', getSrcLoc dfun_id')) `thenNF_Tc_` diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs index bb28f2b..4e20000 100644 --- a/ghc/compiler/typecheck/Unify.lhs +++ b/ghc/compiler/typecheck/Unify.lhs @@ -19,8 +19,9 @@ import TcMonad import Type ( GenType(..), Type, tyVarsOfType, typeKind, mkFunTy, splitFunTy_maybe, splitTyConApp_maybe ) import TyCon ( TyCon, mkFunTyCon, isTupleTyCon, tyConArity, Arity ) -import TyVar ( GenTyVar(..), TyVar, tyVarKind, tyVarSetToList, - TyVarEnv, lookupTyVarEnv, emptyTyVarEnv, addToTyVarEnv +import TyVar ( TyVar(..), GenTyVar(..), tyVarKind, tyVarFlexi, + TyVarEnv, lookupTyVarEnv, emptyTyVarEnv, addToTyVarEnv, + tyVarSetToList ) import TcType ( TcType, TcMaybe(..), TcTauType, TcTyVar, newTyVarTy, tcReadTyVar, tcWriteTyVar, zonkTcType @@ -366,16 +367,19 @@ unify_tuple_ty_help arity ty Unify types with an explicit substitution and no monad. \begin{code} -type Subst = TyVarEnv Type -- Not necessarily idempotent +type Subst = TyVarEnv (GenType Bool) -- Not necessarily idempotent -unifyTysX :: Type -> Type -> Maybe Subst +unifyTysX :: GenType Bool + -> GenType Bool + -> Maybe Subst unifyTysX ty1 ty2 = uTysX ty1 ty2 (\s -> Just s) emptyTyVarEnv -unifyTyListsX :: [Type] -> [Type] -> Maybe Subst +unifyTyListsX :: [GenType Bool] -> [GenType Bool] -> Maybe Subst unifyTyListsX tys1 tys2 = uTyListsX tys1 tys2 (\s -> Just s) emptyTyVarEnv -uTysX :: Type -> Type +uTysX :: GenType Bool + -> GenType Bool -> (Subst -> Maybe Subst) -> Subst -> Maybe Subst @@ -384,8 +388,15 @@ uTysX (SynTy _ ty1) ty2 k subst = uTysX ty1 ty2 k subst uTysX ty1 (SynTy _ ty2) k subst = uTysX ty1 ty2 k subst -- Variables; go for uVar -uTysX (TyVarTy tyvar1) ty2 k subst = uVarX tyvar1 ty2 k subst -uTysX ty1 (TyVarTy tyvar2) k subst = uVarX tyvar2 ty1 k subst +uTysX (TyVarTy tyvar1) (TyVarTy tyvar2) k subst + | tyvar1 == tyvar2 + = k subst +uTysX (TyVarTy tyvar1) ty2 k subst + | tyVarFlexi tyvar1 + = uVarX tyvar1 ty2 k subst +uTysX ty1 (TyVarTy tyvar2) k subst + | tyVarFlexi tyvar2 + = uVarX tyvar2 ty1 k subst -- Functions; just check the two parts uTysX (FunTy fun1 arg1) (FunTy fun2 arg2) k subst @@ -430,13 +441,11 @@ uTysX ty1 ty2 k subst = Nothing uTyListsX [] [] k subst = k subst uTyListsX (ty1:tys1) (ty2:tys2) k subst = uTysX ty1 ty2 (uTyListsX tys1 tys2 k) subst -uTyListsX tys1 tys2 k subst = Nothing -- Fail if the lists are different lengths +uTyListsX tys1 tys2 k subst = Nothing -- Fail if the lists are different lengths \end{code} \begin{code} -uVarX tv1 (TyVarTy tv2) k subst | tv1 == tv2 = k subst - -- Binding a variable to itself is a no-op - +-- Invariant: tv1 is a unifiable variable uVarX tv1 ty2 k subst = case lookupTyVarEnv subst tv1 of Just ty1 -> -- Already bound diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs index 0ca0d1a..c106981 100644 --- a/ghc/compiler/types/TyVar.lhs +++ b/ghc/compiler/types/TyVar.lhs @@ -2,8 +2,10 @@ module TyVar ( GenTyVar(..), TyVar, - mkTyVar, mkSysTyVar, - tyVarKind, -- TyVar -> Kind + mkTyVar, mkSysTyVar, + tyVarKind, -- TyVar -> Kind + tyVarFlexi, -- GenTyVar flexi -> flexi + setTyVarFlexi, cloneTyVar, nameTyVar, openAlphaTyVar, @@ -16,7 +18,7 @@ module TyVar ( growTyVarEnvList, isEmptyTyVarEnv, lookupTyVarEnv, delFromTyVarEnv, GenTyVarSet, TyVarSet, - emptyTyVarSet, unitTyVarSet, unionTyVarSets, + emptyTyVarSet, unitTyVarSet, unionTyVarSets, addOneToTyVarSet, unionManyTyVarSets, intersectTyVarSets, mkTyVarSet, tyVarSetToList, elementOfTyVarSet, minusTyVarSet, isEmptyTyVarSet @@ -30,7 +32,7 @@ import Kind ( Kind, mkBoxedTypeKind, mkTypeKind ) -- others import UniqSet -- nearly all of it import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM, - plusUFM, sizeUFM, delFromUFM, UniqFM + plusUFM, sizeUFM, delFromUFM, isNullUFM, UniqFM ) import BasicTypes ( Unused, unused ) import Name ( mkSysLocalName, mkLocalName, Name, NamedThing(..), OccName ) @@ -50,6 +52,12 @@ data GenTyVar flexi_slot -- inference, and to contain usages. type TyVar = GenTyVar Unused + +tyVarFlexi :: GenTyVar flexi -> flexi +tyVarFlexi (TyVar _ _ _ flex) = flex + +setTyVarFlexi :: GenTyVar flexi1 -> flexi2 -> GenTyVar flexi2 +setTyVarFlexi (TyVar u k n _) flex = TyVar u k n flex \end{code} @@ -105,7 +113,7 @@ type TyVarEnv elt = UniqFM elt emptyTyVarEnv :: TyVarEnv a mkTyVarEnv :: [(GenTyVar flexi, a)] -> TyVarEnv a zipTyVarEnv :: [GenTyVar flexi] -> [a] -> TyVarEnv a -addToTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> a -> TyVarEnv a +addToTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> a -> TyVarEnv a growTyVarEnvList :: TyVarEnv a -> [(GenTyVar flexi, a)] -> TyVarEnv a isEmptyTyVarEnv :: TyVarEnv a -> Bool lookupTyVarEnv :: TyVarEnv a -> GenTyVar flexi -> Maybe a @@ -118,10 +126,10 @@ addToTyVarEnv = addToUFM lookupTyVarEnv = lookupUFM delFromTyVarEnv = delFromUFM plusTyVarEnv = plusUFM +isEmptyTyVarEnv = isNullUFM zipTyVarEnv tyvars tys = listToUFM (zipEqual "zipTyVarEnv" tyvars tys) growTyVarEnvList env pairs = plusUFM env (listToUFM pairs) -isEmptyTyVarEnv env = sizeUFM env == 0 \end{code} Sets @@ -140,9 +148,11 @@ elementOfTyVarSet :: GenTyVar flexi -> GenTyVarSet flexi -> Bool minusTyVarSet :: GenTyVarSet flexi -> GenTyVarSet flexi -> GenTyVarSet flexi isEmptyTyVarSet :: GenTyVarSet flexi -> Bool mkTyVarSet :: [GenTyVar flexi] -> GenTyVarSet flexi +addOneToTyVarSet :: GenTyVarSet flexi -> GenTyVar flexi -> GenTyVarSet flexi emptyTyVarSet = emptyUniqSet -unitTyVarSet = unitUniqSet +unitTyVarSet = unitUniqSet +addOneToTyVarSet = addOneToUniqSet intersectTyVarSets= intersectUniqSets unionTyVarSets = unionUniqSets unionManyTyVarSets= unionManyUniqSets diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index b52b884..6973687 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -28,7 +28,7 @@ module Type ( tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind, - instantiateTy, instantiateTauTy, instantiateThetaTy, + instantiateTy, instantiateTauTy, instantiateThetaTy, applyToTyVars, showTypeCategory ) where @@ -45,7 +45,7 @@ import TyCon ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTy tyConKind, tyConDataCons, getSynTyConDefn, tyConPrimRep, tyConClass_maybe, TyCon ) import TyVar ( GenTyVarSet, TyVarEnv, GenTyVar, TyVar, - tyVarKind, emptyTyVarSet, unionTyVarSets, minusTyVarSet, + tyVarKind, tyVarFlexi, emptyTyVarSet, unionTyVarSets, minusTyVarSet, unitTyVarSet, lookupTyVarEnv, delFromTyVarEnv, zipTyVarEnv, mkTyVarEnv, emptyTyVarEnv, isEmptyTyVarEnv, addToTyVarEnv ) import Name ( NamedThing(..), @@ -510,20 +510,27 @@ instantiateTy tenv ty -- and when (b) all the type variables are being instantiated -- In return it is more polymorphic than instantiateTy -instantiateTauTy tenv ty = go ty +instantiateTauTy tenv ty = applyToTyVars lookup ty + where + lookup tv = case lookupTyVarEnv tenv tv of + Just ty -> ty -- Must succeed + + +instantiateThetaTy :: TyVarEnv Type -> ThetaType -> ThetaType +instantiateThetaTy tenv theta + = [(clas, map (instantiateTauTy tenv) tys) | (clas, tys) <- theta] + +applyToTyVars :: (GenTyVar flexi1 -> GenType flexi2) + -> GenType flexi1 + -> GenType flexi2 +applyToTyVars f ty = go ty where - go ty@(TyVarTy tv) = case (lookupTyVarEnv tenv tv) of - Just ty -> ty -- Must succeed + go (TyVarTy tv) = f tv go (TyConApp tc tys) = TyConApp tc (map go tys) go (SynTy ty1 ty2) = SynTy (go ty1) (go ty2) go (FunTy arg res) = FunTy (go arg) (go res) go (AppTy fun arg) = mkAppTy (go fun) (go arg) go (ForAllTy tv ty) = panic "instantiateTauTy" - - -instantiateThetaTy :: TyVarEnv Type -> ThetaType -> ThetaType -instantiateThetaTy tenv theta - = [(clas, map (instantiateTauTy tenv) tys) | (clas, tys) <- theta] \end{code} @@ -586,15 +593,15 @@ types. It also fails on nested foralls. types. \begin{code} -matchTy :: GenType flexi1 -- Template - -> GenType flexi2 -- Proposed instance of template - -> Maybe (TyVarEnv (GenType flexi2)) -- Matching substitution +matchTy :: GenType Bool -- Template + -> GenType flexi -- Proposed instance of template + -> Maybe (TyVarEnv (GenType flexi)) -- Matching substitution -matchTys :: [GenType flexi1] -- Templates - -> [GenType flexi2] -- Proposed instance of template - -> Maybe (TyVarEnv (GenType flexi2), -- Matching substitution - [GenType flexi2]) -- Left over instance types +matchTys :: [GenType Bool] -- Templates + -> [GenType flexi] -- Proposed instance of template + -> Maybe (TyVarEnv (GenType flexi), -- Matching substitution + [GenType flexi]) -- Left over instance types matchTy ty1 ty2 = match ty1 ty2 (\s -> Just s) emptyTyVarEnv matchTys tys1 tys2 = match_list tys1 tys2 (\pr -> Just pr) emptyTyVarEnv @@ -603,27 +610,36 @@ matchTys tys1 tys2 = match_list tys1 tys2 (\pr -> Just pr) emptyTyVarEnv @match@ is the main function. \begin{code} -match :: GenType flexi1 -> GenType flexi2 -- Current match pair - -> (TyVarEnv (GenType flexi2) -> Maybe result) -- Continuation - -> TyVarEnv (GenType flexi2) -- Current substitution +match :: GenType Bool -> GenType flexi -- Current match pair + -> (TyVarEnv (GenType flexi) -> Maybe result) -- Continuation + -> TyVarEnv (GenType flexi) -- Current substitution -> Maybe result -- When matching against a type variable, see if the variable -- has already been bound. If so, check that what it's bound to -- is the same as ty; if not, bind it and carry on. -match (TyVarTy v) ty k = \s -> case lookupTyVarEnv s v of - Nothing -> k (addToTyVarEnv s v ty) - Just ty' | ty' == ty -> k s -- Succeeds - | otherwise -> Nothing -- Fails - -match (FunTy arg1 res1) (FunTy arg2 res2) k = match arg1 arg2 (match res1 res2 k) -match (AppTy fun1 arg1) (AppTy fun2 arg2) k = match fun1 fun2 (match arg1 arg2 k) +match (TyVarTy v) ty k = \s -> if tyVarFlexi v then + -- v is a template variable + case lookupTyVarEnv s v of + Nothing -> k (addToTyVarEnv s v ty) + Just ty' | ty' == ty -> k s -- Succeeds + | otherwise -> Nothing -- Fails + else + -- v is not a template variable; ty had better match + -- Can't use (==) because types differ + case ty of + TyVarTy v' | uniqueOf v == uniqueOf v' + -> k s -- Success + other -> Nothing -- Failure + +match (FunTy arg1 res1) (FunTy arg2 res2) k = match arg1 arg2 (match res1 res2 k) +match (AppTy fun1 arg1) (AppTy fun2 arg2) k = match fun1 fun2 (match arg1 arg2 k) match (TyConApp tc1 tys1) (TyConApp tc2 tys2) k | tc1 == tc2 = match_list tys1 tys2 ( \(s,tys2') -> - if null tys2' then + if null tys2' then k s -- Succeed - else + else Nothing -- Fail ) @@ -631,8 +647,8 @@ match (TyConApp tc1 tys1) (TyConApp tc2 tys2) k | tc1 == tc2 -- same reasons as in the unifier. Please see the -- considerable commentary there before changing anything -- here! (WDP 95/05) -match (SynTy _ ty1) ty2 k = match ty1 ty2 k -match ty1 (SynTy _ ty2) k = match ty1 ty2 k +match (SynTy _ ty1) ty2 k = match ty1 ty2 k +match ty1 (SynTy _ ty2) k = match ty1 ty2 k -- Catch-all fails match _ _ _ = \s -> Nothing diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs index 0883011..03c5add 100644 --- a/ghc/compiler/utils/UniqFM.lhs +++ b/ghc/compiler/utils/UniqFM.lhs @@ -33,6 +33,7 @@ module UniqFM ( intersectUFM_C, foldUFM, mapUFM, + elemUFM, filterUFM, sizeUFM, isNullUFM, @@ -106,6 +107,7 @@ mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt sizeUFM :: UniqFM elt -> Int +elemUFM :: Uniquable key => key -> UniqFM elt -> Bool lookupUFM :: Uniquable key => UniqFM elt -> key -> Maybe elt lookupUFM_Directly -- when you've got the Unique already @@ -527,6 +529,10 @@ looking up in a hurry is the {\em whole point} of this binary tree lark. Lookup up a binary tree is easy (and fast). \begin{code} +elemUFM key fm = case lookUp fm (u2i (uniqueOf key)) of + Nothing -> False + Just _ -> True + lookupUFM fm key = lookUp fm (u2i (uniqueOf key)) lookupUFM_Directly fm key = lookUp fm (u2i key) -- 1.7.10.4