# -----------------------------------------------------------------------------
-# $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
# 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
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
import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg )
import CStrings ( pp_cSEP )
-import Id ( externallyVisibleId, cmpId_withSpecDataCon,
+import Id ( externallyVisibleId,
isDataCon, isDictFunId,
isDefaultMethodId_maybe,
fIRST_TAG,
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}
-- PREDICATES
omitIfaceSigForId,
- cmpEqDataCon,
cmpId,
- cmpId_withSpecDataCon,
externallyVisibleId,
idHasNoFreeTyVars,
idWantsToBeINLINEd, getInlinePragma,
isRecordSelector,
isDictSelId_maybe,
isNullaryDataCon,
- isSpecPragmaId,
isPrimitiveId_maybe,
isSysLocalId,
isTupleCon,
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,
intersectIdSets,
isEmptyIdSet,
isNullIdEnv,
- lookupIdEnv,
+ lookupIdEnv, lookupIdSubst,
lookupNoFailIdEnv,
mapIdEnv,
minusIdSet,
- mkIdEnv,
+ mkIdEnv, elemIdEnv,
mkIdSet,
modifyIdEnv,
modifyIdEnv_Directly,
-- 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
-- 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
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}
(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.
\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:
-- 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
-- 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}
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)
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,
-- 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}
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
-- 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}
-
%************************************************************************
%* *
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}
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
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
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:
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]
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.
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}
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
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.
noIdInfo,
ppIdInfo,
- applySubstToIdInfo, apply_to_IdInfo, -- not for general use, please
ArityInfo(..),
exactArity, atLeastArity, unknownArity,
unfoldInfo, addUnfoldInfo,
- IdSpecEnv, specInfo, addSpecInfo,
+ IdSpecEnv, specInfo, setSpecInfo,
UpdateInfo, UpdateSpec,
mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, addUpdateInfo,
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
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
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}
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
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"
import CostCentre ( isDictCC, CostCentre, noCostCentre )
import Id ( idType, mkSysLocal, isBottomingId,
- toplevelishId, mkIdWithNewUniq, applyTypeEnvToId,
+ toplevelishId, mkIdWithNewUniq,
dataConRepType,
addOneToIdEnv, growIdEnvList, lookupIdEnv,
isNullIdEnv, IdEnv, Id
| 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}
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
maybe_CompilingGhcInternals,
opt_AllStrict,
+ opt_AllowOverlappingInstances,
opt_AutoSccsOnAllToplevs,
opt_AutoSccsOnExportedToplevs,
opt_AutoSccsOnIndividualCafs,
| 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
\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")
"-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)
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)
}
;
-get_line_no : { $$ = startlineno }
+get_line_no : { $$ = startlineno; }
;
vallhs : patk { $$ = $1; }
\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}
{-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:
`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
`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:
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 )
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}
\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
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
-}
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
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}
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
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
\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)
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
---- 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
---- 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
| 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
-- 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,
((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
[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
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
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}
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)
| 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
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
-- 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
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' ->
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}
| 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
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' ->
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 )
= 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)
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,
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(..) )
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
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)
= 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}
%* *
%************************************************************************
-\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}
%************************************************************************
%************************************************************************
\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@}
\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
new_out_id_env = addToUFM out_id_env id (id, occ_info, InUnfolding env rhs)
\end{code}
+
%************************************************************************
%* *
\subsubsection{The @ConAppMap@ type}
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
= 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}
#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}
)
import CoreSyn
import CoreUnfold ( SimpleUnfolding )
-import CoreUtils ( substCoreExpr )
import Id ( mkIdEnv, lookupIdEnv, IdEnv
)
import Maybes ( catMaybes )
\begin{code}
module SimplUtils (
+ newId, newIds,
+
floatExposesHNF,
etaCoreExpr, mkRhsTyLam,
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 )
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.
% (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"
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}
= 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
&& 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)
---------- 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
= 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}
)
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,
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')
--
-- 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}
%************************************************************************
\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')
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
| 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,
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
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 (
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')
-- 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
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}
----------------------------------------------------------------------------
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}
= 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
\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 )
%************************************************************************
\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}
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}
\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,
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 )
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 ->
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
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
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
-- 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
)
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
#include "HsVersions.h"
+import CmdLineOpts ( opt_AllowOverlappingInstances )
import HsSyn ( HsLit(..), HsExpr(..), MonoBinds )
import RnHsSyn ( RenamedArithSeqInfo, RenamedHsExpr )
import TcHsSyn ( TcExpr, TcIdOcc(..), TcIdBndr,
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
-- 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
-> 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)
\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}
-
-
%************************************************************************
%* *
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 )
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)
) $
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
-- 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
-- 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}
= 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
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)
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
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}
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' ->
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' ->
import RnHsSyn ( RenamedMonoBinds, RenamedSig(..) )
+import CmdLineOpts ( opt_AllowOverlappingInstances )
import TcMonad
import Inst ( InstanceMapper )
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_`
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
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
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
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
module TyVar (
GenTyVar(..), TyVar,
- mkTyVar, mkSysTyVar,
- tyVarKind, -- TyVar -> Kind
+ mkTyVar, mkSysTyVar,
+ tyVarKind, -- TyVar -> Kind
+ tyVarFlexi, -- GenTyVar flexi -> flexi
+ setTyVarFlexi,
cloneTyVar, nameTyVar,
openAlphaTyVar,
growTyVarEnvList, isEmptyTyVarEnv, lookupTyVarEnv, delFromTyVarEnv,
GenTyVarSet, TyVarSet,
- emptyTyVarSet, unitTyVarSet, unionTyVarSets,
+ emptyTyVarSet, unitTyVarSet, unionTyVarSets, addOneToTyVarSet,
unionManyTyVarSets, intersectTyVarSets, mkTyVarSet,
tyVarSetToList, elementOfTyVarSet, minusTyVarSet,
isEmptyTyVarSet
-- 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 )
-- 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}
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
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
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
tyVarsOfType, tyVarsOfTypes, namesOfType, typeKind,
- instantiateTy, instantiateTauTy, instantiateThetaTy,
+ instantiateTy, instantiateTauTy, instantiateThetaTy, applyToTyVars,
showTypeCategory
) where
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(..),
-- 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}
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
@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
)
-- 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
intersectUFM_C,
foldUFM,
mapUFM,
+ elemUFM,
filterUFM,
sizeUFM,
isNullUFM,
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
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)
projects / ghc-hetmet.git / commitdiff