Things in brackets are what the module *uses*.
A 'loop' indicates a use from a module compiled later
- Name, PrimRep, FieldLabel (loop Type.Type)
+ Name, PrimRep
then
PrelNames
then
- Var (Name, loop CoreSyn.CoreExpr, loop IdInfo.IdInfo,
- loop Type.GenType, loop Type.Kind)
+ Var (Name, loop IdInfo.IdInfo,
+ loop Type.Type, loop Type.Kind)
then
VarEnv, VarSet, ThinAir
then
then
Type (loop DataCon.DataCon, loop Subst.substTy)
then
- TysPrim (Type), PprEnv (loop DataCon.DataCon, Type)
+ FieldLabel( Type), TysPrim (Type), PprEnv (loop DataCon.DataCon, Type)
then
Unify, PprType (PprEnv)
then
#include "HsVersions.h"
-import {-# SOURCE #-} TypeRep( Type ) -- FieldLabel is compiled very early
-import {-# SOURCE #-} TyCon( TyCon ) -- FieldLabel is compiled very early
-
+import Type( Type )
+import TyCon( TyCon )
import Name ( Name{-instance Eq/Outputable-}, NamedThing(..), nameUnique )
import Outputable
import Unique ( Uniquable(..) )
Id, DictId,
-- Simple construction
- mkId, mkVanillaId, mkSysLocal, mkUserLocal,
+ mkGlobalId, mkLocalId, mkSpecPragmaId, mkLocalIdWithInfo,
+ mkSysLocal, mkUserLocal, mkVanillaGlobal,
mkTemplateLocals, mkTemplateLocalsNum, mkWildId, mkTemplateLocal,
+ mkWorkerId,
-- Taking an Id apart
idName, idType, idUnique, idInfo,
- idPrimRep, isId,
+ idPrimRep, isId, globalIdDetails,
recordSelectorFieldLabel,
-- Modifying an Id
- setIdName, setIdUnique, setIdType, setIdNoDiscard,
+ setIdName, setIdUnique, setIdType, setIdNoDiscard, setGlobalIdDetails,
setIdInfo, lazySetIdInfo, modifyIdInfo, maybeModifyIdInfo,
- zapLamIdInfo, zapDemandIdInfo,
+ zapLamIdInfo, zapDemandIdInfo,
-- Predicates
isImplicitId, isDeadBinder,
- externallyVisibleId,
- isSpecPragmaId, isRecordSelector,
- isPrimOpId, isPrimOpId_maybe, isDictFunId,
+ isSpecPragmaId, isExportedId, isLocalId, isGlobalId,
+ isRecordSelector,
+ isPrimOpId, isPrimOpId_maybe,
isDataConId, isDataConId_maybe,
isDataConWrapId, isDataConWrapId_maybe,
isBottomingId,
- isExportedId, isLocalId,
hasNoBinding,
-- Inline pragma stuff
setIdOccInfo,
idArity, idArityInfo,
- idFlavour,
idDemandInfo,
idStrictness,
idTyGenInfo,
import CoreSyn ( Unfolding, CoreRules )
import BasicTypes ( Arity )
import Var ( Id, DictId,
- isId, mkIdVar,
- idName, idType, idUnique, idInfo,
- setIdName, setVarType, setIdUnique,
+ isId, isExportedId, isSpecPragmaId, isLocalId,
+ idName, idType, idUnique, idInfo, isGlobalId,
+ setIdName, setVarType, setIdUnique, setIdNoDiscard,
setIdInfo, lazySetIdInfo, modifyIdInfo,
maybeModifyIdInfo,
- externallyVisibleId
+ globalIdDetails, setGlobalIdDetails
)
+import qualified Var ( mkLocalId, mkGlobalId, mkSpecPragmaId )
import Type ( Type, typePrimRep, addFreeTyVars,
usOnce, seqType, splitTyConApp_maybe )
import Demand ( Demand )
import Name ( Name, OccName,
mkSysLocalName, mkLocalName,
- getOccName
+ getOccName, getSrcLoc
)
-import OccName ( UserFS )
+import OccName ( UserFS, mkWorkerOcc )
import PrimRep ( PrimRep )
import TysPrim ( statePrimTyCon )
import FieldLabel ( FieldLabel )
%* *
%************************************************************************
-Absolutely all Ids are made by mkId. It
- a) Pins free-tyvar-info onto the Id's type,
- where it can easily be found.
- b) Ensures that exported Ids are
+Absolutely all Ids are made by mkId. It is just like Var.mkId,
+but in addition it pins free-tyvar-info onto the Id's type,
+where it can easily be found.
\begin{code}
-mkId :: Name -> Type -> IdInfo -> Id
-mkId name ty info = mkIdVar name (addFreeTyVars ty) info
+mkLocalIdWithInfo :: Name -> Type -> IdInfo -> Id
+mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info
+
+mkSpecPragmaId :: OccName -> Unique -> Type -> SrcLoc -> Id
+mkSpecPragmaId occ uniq ty loc = Var.mkSpecPragmaId (mkLocalName uniq occ loc)
+ (addFreeTyVars ty)
+ noCafIdInfo
+
+mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id
+mkGlobalId details name ty info = Var.mkGlobalId details name (addFreeTyVars ty) info
\end{code}
\begin{code}
-mkVanillaId :: Name -> Type -> Id
-mkVanillaId name ty = mkId name ty vanillaIdInfo
+mkLocalId :: Name -> Type -> Id
+mkLocalId name ty = mkLocalIdWithInfo name ty noCafIdInfo
-- SysLocal: for an Id being created by the compiler out of thin air...
-- UserLocal: an Id with a name the user might recognize...
mkUserLocal :: OccName -> Unique -> Type -> SrcLoc -> Id
mkSysLocal :: UserFS -> Unique -> Type -> Id
+mkVanillaGlobal :: Name -> Type -> IdInfo -> Id
-mkSysLocal fs uniq ty = mkVanillaId (mkSysLocalName uniq fs) ty
-mkUserLocal occ uniq ty loc = mkVanillaId (mkLocalName uniq occ loc) ty
+mkSysLocal fs uniq ty = mkLocalId (mkSysLocalName uniq fs) ty
+mkUserLocal occ uniq ty loc = mkLocalId (mkLocalName uniq occ loc) ty
+mkVanillaGlobal = mkGlobalId VanillaGlobal
\end{code}
Make some local @Ids@ for a template @CoreExpr@. These have bogus
@Uniques@, but that's OK because the templates are supposed to be
instantiated before use.
-
+
\begin{code}
-- "Wild Id" typically used when you need a binder that you don't expect to use
mkWildId :: Type -> Id
mkWildId ty = mkSysLocal SLIT("wild") (mkBuiltinUnique 1) ty
+mkWorkerId :: Unique -> Id -> Type -> Id
+-- A worker gets a local name. CoreTidy will globalise it if necessary.
+mkWorkerId uniq unwrkr ty
+ = mkLocalId wkr_name ty
+ where
+ wkr_name = mkLocalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcLoc unwrkr)
+
-- "Template locals" typically used in unfoldings
mkTemplateLocals :: [Type] -> [Id]
mkTemplateLocals tys = zipWith (mkSysLocal SLIT("tpl"))
mkTemplateLocalsNum :: Int -> [Type] -> [Id]
-- The Int gives the starting point for unique allocation
mkTemplateLocalsNum n tys = zipWith (mkSysLocal SLIT("tpl"))
- (getNumBuiltinUniques n (length tys))
- tys
+ (getNumBuiltinUniques n (length tys))
+ tys
mkTemplateLocal :: Int -> Type -> Id
mkTemplateLocal i ty = mkSysLocal SLIT("tpl") (mkBuiltinUnique i) ty
%* *
%************************************************************************
-\begin{code}
-idFlavour :: Id -> IdFlavour
-idFlavour id = flavourInfo (idInfo id)
+The @SpecPragmaId@ exists only to make Ids that are
+on the *LHS* of bindings created by SPECIALISE pragmas;
+eg: s = f Int d
+The SpecPragmaId is never itself mentioned; it
+exists solely so that the specialiser will find
+the call to f, and make specialised version of it.
+The SpecPragmaId binding is discarded by the specialiser
+when it gathers up overloaded calls.
+Meanwhile, it is not discarded as dead code.
-setIdNoDiscard :: Id -> Id
-setIdNoDiscard id -- Make an Id into a NoDiscardId, unless it is already
- = modifyIdInfo setNoDiscardInfo id
+\begin{code}
recordSelectorFieldLabel :: Id -> FieldLabel
-recordSelectorFieldLabel id = case idFlavour id of
- RecordSelId lbl -> lbl
+recordSelectorFieldLabel id = case globalIdDetails id of
+ RecordSelId lbl -> lbl
-isRecordSelector id = case idFlavour id of
+isRecordSelector id = case globalIdDetails id of
RecordSelId lbl -> True
other -> False
-isPrimOpId id = case idFlavour id of
+isPrimOpId id = case globalIdDetails id of
PrimOpId op -> True
other -> False
-isPrimOpId_maybe id = case idFlavour id of
+isPrimOpId_maybe id = case globalIdDetails id of
PrimOpId op -> Just op
other -> Nothing
-isDataConId id = case idFlavour id of
+isDataConId id = case globalIdDetails id of
DataConId _ -> True
other -> False
-isDataConId_maybe id = case idFlavour id of
+isDataConId_maybe id = case globalIdDetails id of
DataConId con -> Just con
other -> Nothing
-isDataConWrapId_maybe id = case idFlavour id of
+isDataConWrapId_maybe id = case globalIdDetails id of
DataConWrapId con -> Just con
other -> Nothing
-isDataConWrapId id = case idFlavour id of
+isDataConWrapId id = case globalIdDetails id of
DataConWrapId con -> True
other -> False
-isSpecPragmaId id = case idFlavour id of
- SpecPragmaId -> True
- other -> False
-
-hasNoBinding id = case idFlavour id of
- DataConId _ -> True
- PrimOpId _ -> True
- other -> False
-- hasNoBinding returns True of an Id which may not have a
-- binding, even though it is defined in this module. Notably,
-- the constructors of a dictionary are in this situation.
+hasNoBinding id = case globalIdDetails id of
+ DataConId _ -> True
+ PrimOpId _ -> True
+ other -> False
-isDictFunId id = case idFlavour id of
- DictFunId -> True
- other -> False
-
--- Don't drop a binding for an exported Id,
--- if it otherwise looks dead.
--- Perhaps a better name would be isDiscardableId
-isExportedId :: Id -> Bool
-isExportedId id = case idFlavour id of
- VanillaId -> False
- other -> True
-
-isLocalId :: Id -> Bool
--- True of Ids that are locally defined, but are not constants
--- like data constructors, record selectors, and the like.
--- See comments with CoreFVs.isLocalVar
-isLocalId id
-#ifdef DEBUG
- | not (isId id) = pprTrace "isLocalid" (ppr id) False
- | otherwise
-#endif
- = case idFlavour id of
- VanillaId -> True
- ExportedId -> True
- SpecPragmaId -> True
- other -> False
-\end{code}
-
-
-isImplicitId tells whether an Id's info is implied by other
-declarations, so we don't need to put its signature in an interface
-file, even if it's mentioned in some other interface unfolding.
-
-\begin{code}
isImplicitId :: Id -> Bool
+ -- isImplicitId tells whether an Id's info is implied by other
+ -- declarations, so we don't need to put its signature in an interface
+ -- file, even if it's mentioned in some other interface unfolding.
isImplicitId id
- = case idFlavour id of
+ = case globalIdDetails id of
RecordSelId _ -> True -- Includes dictionary selectors
PrimOpId _ -> True
DataConId _ -> True
_interface_ IdInfo 1
_exports_
-IdInfo IdInfo seqIdInfo vanillaIdInfo;
+IdInfo IdInfo GlobalIdDetails notGlobalId seqIdInfo vanillaIdInfo;
_declarations_
1 data IdInfo ;
+1 data GlobalIdDetails ;
+1 notGlobalId _:_ GlobalIdDetails ;;
1 seqIdInfo _:_ IdInfo -> PrelBase.() ;;
1 vanillaIdInfo _:_ IdInfo ;;
__interface IdInfo 1 0 where
-__export IdInfo IdInfo seqIdInfo vanillaIdInfo ;
+__export IdInfo IdInfo GlobalIdDetails notGlobalId seqIdInfo vanillaIdInfo ;
1 data IdInfo ;
+1 data GlobalIdDetails ;
+1 notGlobalId :: GlobalIdDetails ;
1 seqIdInfo :: IdInfo -> PrelBase.Z0T ;
1 vanillaIdInfo :: IdInfo ;
\begin{code}
module IdInfo (
- IdInfo, -- Abstract
+ GlobalIdDetails(..), notGlobalId, -- Not abstract
- vanillaIdInfo, constantIdInfo, mkIdInfo, seqIdInfo, megaSeqIdInfo,
+ IdInfo, -- Abstract
+ vanillaIdInfo, noTyGenIdInfo, noCafOrTyGenIdInfo, noCafIdInfo,
+ seqIdInfo, megaSeqIdInfo,
-- Zapping
zapLamInfo, zapDemandInfo,
- zapSpecPragInfo, shortableIdInfo, copyIdInfo,
-
- -- Flavour
- IdFlavour(..), flavourInfo, makeConstantFlavour,
- setNoDiscardInfo, setFlavourInfo,
- ppFlavourInfo,
+ shortableIdInfo, copyIdInfo,
-- Arity
ArityInfo(..),
-- infixl so you can say (id `set` a `set` b)
\end{code}
+%************************************************************************
+%* *
+\subsection{GlobalIdDetails
+%* *
+%************************************************************************
+
+This type is here (rather than in Id.lhs) mainly because there's
+an IdInfo.hi-boot, but no Id.hi-boot, and GlobalIdDetails is imported
+(recursively) by Var.lhs.
+
+\begin{code}
+data GlobalIdDetails
+ = VanillaGlobal -- Imported from elsewhere, a default method Id.
+
+ | RecordSelId FieldLabel -- The Id for a record selector
+ | DataConId DataCon -- The Id for a data constructor *worker*
+ | DataConWrapId DataCon -- The Id for a data constructor *wrapper*
+ -- [the only reasons we need to know is so that
+ -- a) we can suppress printing a definition in the interface file
+ -- b) when typechecking a pattern we can get from the
+ -- Id back to the data con]
+
+ | PrimOpId PrimOp -- The Id for a primitive operator
+
+ | NotGlobalId -- Used as a convenient extra return value from globalIdDetails
+
+notGlobalId = NotGlobalId
+
+instance Outputable GlobalIdDetails where
+ ppr NotGlobalId = ptext SLIT("[***NotGlobalId***]")
+ ppr VanillaGlobal = ptext SLIT("[GlobalId]")
+ ppr (DataConId _) = ptext SLIT("[DataCon]")
+ ppr (DataConWrapId _) = ptext SLIT("[DataConWrapper]")
+ ppr (PrimOpId _) = ptext SLIT("[PrimOp]")
+ ppr (RecordSelId _) = ptext SLIT("[RecSel]")
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{The main IdInfo type}
+%* *
+%************************************************************************
+
An @IdInfo@ gives {\em optional} information about an @Id@. If
present it never lies, but it may not be present, in which case there
is always a conservative assumption which can be made.
- There is one exception: the 'flavour' is *not* optional.
- You must not discard it.
- It used to be in Var.lhs, but that seems unclean.
-
Two @Id@s may have different info even though they have the same
@Unique@ (and are hence the same @Id@); for example, one might lack
the properties attached to the other.
\begin{code}
data IdInfo
= IdInfo {
- flavourInfo :: IdFlavour, -- NOT OPTIONAL
arityInfo :: ArityInfo, -- Its arity
demandInfo :: Demand, -- Whether or not it is definitely demanded
specInfo :: CoreRules, -- Specialisations of this function which exist
megaSeqIdInfo :: IdInfo -> ()
megaSeqIdInfo info
- = seqFlavour (flavourInfo info) `seq`
- seqArity (arityInfo info) `seq`
+ = seqArity (arityInfo info) `seq`
seqDemand (demandInfo info) `seq`
seqRules (specInfo info) `seq`
seqTyGenInfo (tyGenInfo info) `seq`
Setters
\begin{code}
-setFlavourInfo info fl = fl `seq` info { flavourInfo = fl }
setWorkerInfo info wk = wk `seq` info { workerInfo = wk }
setSpecInfo info sp = PSEQ sp (info { specInfo = sp })
setTyGenInfo info tg = tg `seq` info { tyGenInfo = tg }
setCafInfo info cf = info { cafInfo = cf }
setCprInfo info cp = info { cprInfo = cp }
setLBVarInfo info lb = info { lbvarInfo = lb }
-
-setNoDiscardInfo info = case flavourInfo info of
- VanillaId -> info { flavourInfo = ExportedId }
- other -> info
-zapSpecPragInfo info = case flavourInfo info of
- SpecPragmaId -> info { flavourInfo = VanillaId }
- other -> info
\end{code}
\begin{code}
vanillaIdInfo :: IdInfo
- -- Used for locally-defined Ids
- -- We are going to calculate correct CAF information at the end
-vanillaIdInfo = mkIdInfo VanillaId NoCafRefs
-
-constantIdInfo :: IdInfo
- -- Used for imported Ids
- -- The default is that they *do* have CAFs; an interface-file pragma
- -- may say "oh no it doesn't", but in the absence of such a pragma
- -- we'd better assume it does
-constantIdInfo = mkIdInfo ConstantId MayHaveCafRefs
-
-mkIdInfo :: IdFlavour -> CafInfo -> IdInfo
-mkIdInfo flv caf
+vanillaIdInfo
= IdInfo {
- flavourInfo = flv,
- cafInfo = caf,
+ cafInfo = MayHaveCafRefs, -- Safe!
arityInfo = UnknownArity,
demandInfo = wwLazy,
specInfo = emptyCoreRules,
inlinePragInfo = NoInlinePragInfo,
occInfo = NoOccInfo
}
-\end{code}
-
-
-%************************************************************************
-%* *
-\subsection{Flavour}
-%* *
-%************************************************************************
-
-\begin{code}
-data IdFlavour
- = VanillaId -- Locally defined, not exported
- | ExportedId -- Locally defined, exported
- | SpecPragmaId -- Locally defined, RHS holds specialised call
- | ConstantId -- Imported from elsewhere, or a default method Id.
+noTyGenIdInfo = vanillaIdInfo `setTyGenInfo` TyGenNever
+ -- Many built-in things have fixed types, so we shouldn't
+ -- run around generalising them
- | DictFunId -- We flag dictionary functions so that we can
- -- conveniently extract the DictFuns from a set of
- -- bindings when building a module's interface
+noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs
+ -- Local things don't refer to Cafs
- | DataConId DataCon -- The Id for a data constructor *worker*
- | DataConWrapId DataCon -- The Id for a data constructor *wrapper*
- -- [the only reasons we need to know is so that
- -- a) we can suppress printing a definition in the interface file
- -- b) when typechecking a pattern we can get from the
- -- Id back to the data con]
- | PrimOpId PrimOp -- The Id for a primitive operator
- | RecordSelId FieldLabel -- The Id for a record selector
-
-
-makeConstantFlavour :: IdFlavour -> IdFlavour
-makeConstantFlavour flavour = new_flavour
- where new_flavour = case flavour of
- VanillaId -> ConstantId
- ExportedId -> ConstantId
- ConstantId -> ConstantId -- e.g. Default methods
- DictFunId -> DictFunId
- flavour -> pprTrace "makeConstantFlavour"
- (ppFlavourInfo flavour)
- flavour
-
-
-ppFlavourInfo :: IdFlavour -> SDoc
-ppFlavourInfo VanillaId = empty
-ppFlavourInfo ExportedId = ptext SLIT("[Exported]")
-ppFlavourInfo SpecPragmaId = ptext SLIT("[SpecPrag]")
-ppFlavourInfo ConstantId = ptext SLIT("[Constant]")
-ppFlavourInfo DictFunId = ptext SLIT("[DictFun]")
-ppFlavourInfo (DataConId _) = ptext SLIT("[DataCon]")
-ppFlavourInfo (DataConWrapId _) = ptext SLIT("[DataConWrapper]")
-ppFlavourInfo (PrimOpId _) = ptext SLIT("[PrimOp]")
-ppFlavourInfo (RecordSelId _) = ptext SLIT("[RecSel]")
-
-seqFlavour :: IdFlavour -> ()
-seqFlavour f = f `seq` ()
+noCafOrTyGenIdInfo = noTyGenIdInfo `setCafInfo` NoCafRefs
+ -- Most also guarantee not to refer to CAFs
\end{code}
-The @SpecPragmaId@ exists only to make Ids that are
-on the *LHS* of bindings created by SPECIALISE pragmas;
-eg: s = f Int d
-The SpecPragmaId is never itself mentioned; it
-exists solely so that the specialiser will find
-the call to f, and make specialised version of it.
-The SpecPragmaId binding is discarded by the specialiser
-when it gathers up overloaded calls.
-Meanwhile, it is not discarded as dead code.
-
%************************************************************************
%* *
ppWorkerInfo NoWorker = empty
ppWorkerInfo (HasWorker wk_id _) = ptext SLIT("__P") <+> ppr wk_id
-noWorkerInfo = NoWorker
-
workerExists :: WorkerInfo -> Bool
workerExists NoWorker = False
workerExists (HasWorker _ _) = True
\begin{code}
module MkId (
- mkSpecPragmaId, mkWorkerId,
-
mkDictFunId, mkDefaultMethodId,
mkDictSelId,
import Class ( Class, classTyCon, classTyVars, classSelIds )
import Var ( Id, TyVar )
import VarSet ( isEmptyVarSet )
-import Name ( mkWiredInName, mkLocalName,
- mkWorkerOcc, mkCCallName,
- Name, NamedThing(..), getSrcLoc
- )
+import Name ( mkWiredInName, mkCCallName, Name )
import OccName ( mkVarOcc )
import PrimOp ( PrimOp(DataToTagOp, CCallOp),
primOpSig, mkPrimOpIdName,
dataConSig, dataConStrictMarks, dataConId,
maybeMarkedUnboxed, splitProductType_maybe
)
-import Id ( idType, mkId,
- mkVanillaId, mkTemplateLocals, mkTemplateLocalsNum,
+import Id ( idType, mkGlobalId, mkVanillaGlobal,
+ mkTemplateLocals, mkTemplateLocalsNum,
mkTemplateLocal, idCprInfo
)
-import IdInfo ( IdInfo, constantIdInfo, mkIdInfo,
+import IdInfo ( IdInfo, vanillaIdInfo, noTyGenIdInfo, noCafOrTyGenIdInfo,
exactArity, setUnfoldingInfo, setCafInfo, setCprInfo,
- setArityInfo, setSpecInfo, setTyGenInfo,
+ setArityInfo, setSpecInfo,
mkStrictnessInfo, setStrictnessInfo,
- IdFlavour(..), CafInfo(..), CprInfo(..), TyGenInfo(..)
+ GlobalIdDetails(..), CafInfo(..), CprInfo(..)
)
import FieldLabel ( mkFieldLabel, fieldLabelName,
firstFieldLabelTag, allFieldLabelTags, fieldLabelType
import Char ( ord )
\end{code}
-
%************************************************************************
%* *
\subsection{Wired in Ids}
%************************************************************************
%* *
-\subsection{Easy ones}
-%* *
-%************************************************************************
-
-\begin{code}
-mkSpecPragmaId occ uniq ty loc
- = mkId (mkLocalName uniq occ loc) ty (mkIdInfo SpecPragmaId NoCafRefs)
- -- Maybe a SysLocal? But then we'd lose the location
-
-mkDefaultMethodId dm_name rec_c ty
- = mkId dm_name ty info
- where
- info = constantIdInfo `setTyGenInfo` TyGenNever
- -- type is wired-in (see comment at TcClassDcl.tcClassSig), so
- -- do not generalise it
-
-mkWorkerId :: Unique -> Id -> Type -> Id
--- A worker gets a local name. CoreTidy will globalise it if necessary.
-mkWorkerId uniq unwrkr ty
- = mkVanillaId wkr_name ty
- where
- wkr_name = mkLocalName uniq (mkWorkerOcc (getOccName unwrkr)) (getSrcLoc unwrkr)
-\end{code}
-
-%************************************************************************
-%* *
\subsection{Data constructors}
%* *
%************************************************************************
-- Makes the *worker* for the data constructor; that is, the function
-- that takes the reprsentation arguments and builds the constructor.
mkDataConId work_name data_con
- = mkId work_name (dataConRepType data_con) info
+ = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
where
- info = mkIdInfo (DataConId data_con) NoCafRefs
+ info = noCafOrTyGenIdInfo
`setArityInfo` exactArity arity
`setStrictnessInfo` strict_info
`setCprInfo` cpr_info
mkDataConWrapId data_con
= wrap_id
where
- wrap_id = mkId (dataConName data_con) wrap_ty info
+ wrap_id = mkGlobalId (DataConWrapId data_con) (dataConName data_con) wrap_ty info
work_id = dataConId data_con
- info = mkIdInfo (DataConWrapId data_con) NoCafRefs
+ info = noCafOrTyGenIdInfo
`setUnfoldingInfo` mkTopUnfolding (mkInlineMe wrap_rhs)
`setCprInfo` cpr_info
-- The Cpr info can be important inside INLINE rhss, where the
`setArityInfo` exactArity arity
-- It's important to specify the arity, so that partial
-- applications are treated as values
- `setTyGenInfo` TyGenNever
- -- No point generalising its type, since it gets eagerly inlined
- -- away anyway
wrap_ty = mkForAllTys all_tyvars $
mkFunTys all_arg_tys
-- we can't conjure it up out of thin air
= sel_id
where
- sel_id = mkId (fieldLabelName field_label) selector_ty info
-
+ sel_id = mkGlobalId (RecordSelId field_label) (fieldLabelName field_label) selector_ty info
field_ty = fieldLabelType field_label
data_cons = tyConDataCons tycon
tyvars = tyConTyVars tycon -- These scope over the types in
mkFunTy data_ty field_tau
arity = 1 + n_dict_tys + n_field_dict_tys
- info = mkIdInfo (RecordSelId field_label) caf_info
+ info = noTyGenIdInfo
+ `setCafInfo` caf_info
`setArityInfo` exactArity arity
`setUnfoldingInfo` unfolding
- `setTyGenInfo` TyGenNever
-- ToDo: consider adding further IdInfo
unfolding = mkTopUnfolding sel_rhs
= sel_id
where
ty = exprType rhs
- sel_id = mkId name ty info
+ sel_id = mkGlobalId (RecordSelId field_lbl) name ty info
field_lbl = mkFieldLabel name tycon ty tag
tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id
- info = mkIdInfo (RecordSelId field_lbl) NoCafRefs
+ info = noCafOrTyGenIdInfo
`setArityInfo` exactArity 1
`setUnfoldingInfo` unfolding
- `setTyGenInfo` TyGenNever
-- We no longer use 'must-inline' on record selectors. They'll
-- inline like crazy if they scrutinise a constructor
(tyvars,arg_tys,res_ty, arity, strict_info) = primOpSig prim_op
ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty)
name = mkPrimOpIdName prim_op
- id = mkId name ty info
+ id = mkGlobalId (PrimOpId prim_op) name ty info
- info = mkIdInfo (PrimOpId prim_op) NoCafRefs
+ info = noCafOrTyGenIdInfo
`setSpecInfo` rules
`setArityInfo` exactArity arity
`setStrictnessInfo` strict_info
= ASSERT( isEmptyVarSet (tyVarsOfType ty) )
-- A CCallOpId should have no free type variables;
-- when doing substitutions won't substitute over it
- mkId name ty info
+ mkGlobalId (PrimOpId prim_op) name ty info
where
occ_str = showSDocIface (braces (pprCCallOp ccall <+> ppr ty))
-- The "occurrence name" of a ccall is the full info about the
name = mkCCallName uniq occ_str
prim_op = CCallOp ccall
- info = mkIdInfo (PrimOpId prim_op) NoCafRefs
+ info = noCafOrTyGenIdInfo
`setArityInfo` exactArity arity
`setStrictnessInfo` strict_info
%************************************************************************
%* *
-\subsection{DictFuns}
+\subsection{DictFuns and default methods}
%* *
%************************************************************************
\begin{code}
+mkDefaultMethodId dm_name ty
+ = mkVanillaGlobal dm_name ty noTyGenIdInfo
+
mkDictFunId :: Name -- Name to use for the dict fun;
-> Class
-> [TyVar]
-> Id
mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta
- = mkId dfun_name dfun_ty info
+ = mkVanillaGlobal dfun_name dfun_ty noTyGenIdInfo
where
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
- info = mkIdInfo DictFunId MayHaveCafRefs
- `setTyGenInfo` TyGenNever
- -- type is wired-in (see comment at TcClassDcl.tcClassSig), so
- -- do not generalise it
- -- An imported dfun may refer to CAFs, so we assume the worst
+ info = noTyGenIdInfo
+ -- Type is wired-in (see comment at TcClassDcl.tcClassSig),
+ -- so do not generalise it
{- 1 dec 99: disable the Mark Jones optimisation for the sake
of compatibility with Hugs.
unsafeCoerceId
= pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
where
- info = constantIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkForAllTys [openAlphaTyVar,openBetaTyVar]
getTagId
= pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info
where
- info = constantIdInfo
- `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
-- We don't provide a defn for this; you must inline it
ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy)
realWorldPrimId -- :: State# RealWorld
= pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
realWorldStatePrimTy
- (noCafIdInfo `setUnfoldingInfo` mkOtherCon [])
+ (noCafOrTyGenIdInfo `setUnfoldingInfo` mkOtherCon [])
-- The mkOtherCon makes it look that realWorld# is evaluated
-- which in turn makes Simplify.interestingArg return True,
-- which in turn makes INLINE things applied to realWorld# likely
pAR_ERROR_ID
= pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
- (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafIdInfo
-
+ (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafOrTyGenIdInfo
\end{code}
pcMiscPrelId key mod str ty info
= let
name = mkWiredInName mod (mkVarOcc str) key
- imp = mkId name ty info -- the usual case...
+ imp = mkVanillaGlobal name ty info -- the usual case...
in
imp
-- We lie and say the thing is imported; otherwise, we get into
pc_bottoming_Id key mod name ty
= pcMiscPrelId key mod name ty bottoming_info
where
- bottoming_info = noCafIdInfo
+ bottoming_info = noCafOrTyGenIdInfo
`setStrictnessInfo` mkStrictnessInfo ([wwStrict], True)
-- these "bottom" out, no matter what their arguments
generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy
--- Very useful...
-noCafIdInfo = constantIdInfo `setCafInfo` NoCafRefs
-
(openAlphaTyVar:openBetaTyVar:_) = openAlphaTyVars
openAlphaTy = mkTyVarTy openAlphaTyVar
openBetaTy = mkTyVarTy openBetaTyVar
isTyVarName, isDllName,
nameIsLocalOrFrom, isHomePackageName,
- -- Environment
- NameEnv, mkNameEnv,
- emptyNameEnv, unitNameEnv, nameEnvElts,
- extendNameEnv_C, extendNameEnv, foldNameEnv, filterNameEnv,
- plusNameEnv, plusNameEnv_C, extendNameEnv, extendNameEnvList,
- lookupNameEnv, lookupNameEnv_NF, delFromNameEnv, elemNameEnv,
-
-
-- Class NamedThing and overloaded friends
NamedThing(..),
getSrcLoc, getOccString, toRdrName
import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule )
import CmdLineOpts ( opt_Static )
import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc )
-import Unique ( Unique, Uniquable(..), u2i, pprUnique, pprUnique10 )
+import Unique ( Unique, Uniquable(..), u2i, pprUnique )
import FastTypes
-import Maybes ( expectJust )
-import UniqFM
import Outputable
\end{code}
%************************************************************************
%* *
-\subsection{Name environment}
-%* *
-%************************************************************************
-
-\begin{code}
-type NameEnv a = UniqFM a -- Domain is Name
-
-emptyNameEnv :: NameEnv a
-mkNameEnv :: [(Name,a)] -> NameEnv a
-nameEnvElts :: NameEnv a -> [a]
-extendNameEnv_C :: (a->a->a) -> NameEnv a -> Name -> a -> NameEnv a
-extendNameEnv :: NameEnv a -> Name -> a -> NameEnv a
-plusNameEnv :: NameEnv a -> NameEnv a -> NameEnv a
-plusNameEnv_C :: (a->a->a) -> NameEnv a -> NameEnv a -> NameEnv a
-extendNameEnvList:: NameEnv a -> [(Name,a)] -> NameEnv a
-delFromNameEnv :: NameEnv a -> Name -> NameEnv a
-elemNameEnv :: Name -> NameEnv a -> Bool
-unitNameEnv :: Name -> a -> NameEnv a
-lookupNameEnv :: NameEnv a -> Name -> Maybe a
-lookupNameEnv_NF :: NameEnv a -> Name -> a
-mapNameEnv :: (a->b) -> NameEnv a -> NameEnv b
-foldNameEnv :: (a -> b -> b) -> b -> NameEnv a -> b
-filterNameEnv :: (elt -> Bool) -> NameEnv elt -> NameEnv elt
-
-emptyNameEnv = emptyUFM
-foldNameEnv = foldUFM
-mkNameEnv = listToUFM
-nameEnvElts = eltsUFM
-extendNameEnv_C = addToUFM_C
-extendNameEnv = addToUFM
-plusNameEnv = plusUFM
-plusNameEnv_C = plusUFM_C
-extendNameEnvList= addListToUFM
-delFromNameEnv = delFromUFM
-elemNameEnv = elemUFM
-mapNameEnv = mapUFM
-unitNameEnv = unitUFM
-filterNameEnv = filterUFM
-
-lookupNameEnv = lookupUFM
-lookupNameEnv_NF env n = expectJust "lookupNameEnv_NF" (lookupUFM env n)
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Pretty printing}
%* *
%************************************************************************
TyVar,
tyVarName, tyVarKind,
setTyVarName, setTyVarUnique,
- mkTyVar, mkSysTyVar, isTyVar, isSigTyVar,
+ mkTyVar, mkSysTyVar,
newMutTyVar, newSigTyVar,
- readMutTyVar, writeMutTyVar, isMutTyVar, makeTyVarImmutable,
+ readMutTyVar, writeMutTyVar, makeTyVarImmutable,
-- Ids
Id, DictId,
idName, idType, idUnique, idInfo, modifyIdInfo, maybeModifyIdInfo,
- setIdName, setIdUnique, setIdInfo, lazySetIdInfo, zapIdInfo,
- mkIdVar, isId, externallyVisibleId
+ setIdName, setIdUnique, setIdInfo, lazySetIdInfo,
+ setIdNoDiscard, zapSpecPragmaId,
+
+ globalIdDetails, setGlobalIdDetails,
+
+ mkLocalId, mkGlobalId, mkSpecPragmaId,
+
+ isTyVar, isMutTyVar, isSigTyVar,
+ isId, isLocalVar, isLocalId,
+ isGlobalId, isExportedId, isSpecPragmaId,
+ mustHaveLocalBinding
) where
#include "HsVersions.h"
import {-# SOURCE #-} TypeRep( Type, Kind )
-import {-# SOURCE #-} IdInfo( IdInfo, seqIdInfo, vanillaIdInfo )
+import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId,
+ IdInfo, seqIdInfo )
-import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey )
import Name ( Name, OccName, NamedThing(..),
setNameUnique, setNameOcc, nameUnique,
mkSysLocalName, isExternallyVisibleName
)
+import Unique ( Unique, Uniquable(..), mkUniqueGrimily, getKey )
import FastTypes
import Outputable
}
data VarDetails
- = AnId
+ = LocalId -- Used for locally-defined Ids (see NOTE below)
+ LocalIdDetails -- True <=> exported; don't discard even if dead
+
+ | GlobalId -- Used for imported Ids, dict selectors etc
+ GlobalIdDetails
+
| TyVar
| MutTyVar (IORef (Maybe Type)) -- Used during unification;
Bool -- True <=> this is a type signature variable, which
-- should not be unified with a non-tyvar type
--- For a long time I tried to keep mutable Vars statically type-distinct
--- from immutable Vars, but I've finally given up. It's just too painful.
--- After type checking there are no MutTyVars left, but there's no static check
--- of that fact.
+ -- For a long time I tried to keep mutable Vars statically type-distinct
+ -- from immutable Vars, but I've finally given up. It's just too painful.
+ -- After type checking there are no MutTyVars left, but there's no static check
+ -- of that fact.
+
+data LocalIdDetails
+ = NotExported -- Not exported
+ | Exported -- Exported
+ | SpecPragma -- Not exported, but not to be discarded either
+ -- It's unclean that this is so deeply built in
\end{code}
+LocalId and GlobalId
+~~~~~~~~~~~~~~~~~~~~
+A GlobalId is
+ * always a constant (top-level)
+ * imported, or data constructor, or primop, or record selector
+
+A LocalId is
+ * bound within an expression (lambda, case, local let(rec))
+ * or defined at top level in the module being compiled
+
+After CoreTidy, top-level LocalIds are turned into GlobalIds
+
+
\begin{code}
instance Outputable Var where
ppr var = ppr (varName var)
makeTyVarImmutable :: TyVar -> TyVar
makeTyVarImmutable tyvar = tyvar { varDetails = TyVar}
-
-isTyVar :: Var -> Bool
-isTyVar (Var {varDetails = details}) = case details of
- TyVar -> True
- MutTyVar _ _ -> True
- other -> False
-
-isMutTyVar :: Var -> Bool
-isMutTyVar (Var {varDetails = MutTyVar _ _}) = True
-isMutTyVar other = False
-
-isSigTyVar :: Var -> Bool
-isSigTyVar (Var {varDetails = MutTyVar _ is_sig}) = is_sig
-isSigTyVar other = False
\end{code}
setIdName :: Id -> Name -> Id
setIdName = setVarName
+setIdNoDiscard :: Id -> Id
+setIdNoDiscard id
+ = WARN( not (isLocalId id), ppr id )
+ id { varDetails = LocalId Exported }
+
+zapSpecPragmaId :: Id -> Id
+zapSpecPragmaId id
+ = case varDetails id of
+ LocalId SpecPragma -> id { varDetails = LocalId NotExported }
+ other -> id
+
lazySetIdInfo :: Id -> IdInfo -> Id
lazySetIdInfo var info = var {varInfo = info}
setIdInfo var info = seqIdInfo info `seq` var {varInfo = info}
-- Try to avoid spack leaks by seq'ing
-zapIdInfo :: Id -> Id
-zapIdInfo var = var {varInfo = vanillaIdInfo}
-
modifyIdInfo :: (IdInfo -> IdInfo) -> Id -> Id
modifyIdInfo fn var@(Var {varInfo = info})
= seqIdInfo new_info `seq` var {varInfo = new_info}
Just new_info -> var {varInfo = new_info}
\end{code}
+%************************************************************************
+%* *
+\subsection{Predicates over variables
+%* *
+%************************************************************************
+
\begin{code}
-mkIdVar :: Name -> Type -> IdInfo -> Id
-mkIdVar name ty info
- = Var {varName = name, realUnique = getKey (nameUnique name), varType = ty,
- varDetails = AnId, varInfo = info}
+mkId :: Name -> Type -> VarDetails -> IdInfo -> Id
+mkId name ty details info
+ = Var { varName = name,
+ realUnique = getKey (nameUnique name), -- Cache the unique
+ varType = ty,
+ varDetails = details,
+ varInfo = info }
+
+mkLocalId :: Name -> Type -> IdInfo -> Id
+mkLocalId name ty info = mkId name ty (LocalId NotExported) info
+
+mkSpecPragmaId :: Name -> Type -> IdInfo -> Id
+mkSpecPragmaId name ty info = mkId name ty (LocalId SpecPragma) info
+
+mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id
+mkGlobalId details name ty info = mkId name ty (GlobalId details) info
\end{code}
\begin{code}
-isId :: Var -> Bool
-isId (Var {varDetails = AnId}) = True
-isId other = False
-\end{code}
+isTyVar, isMutTyVar, isSigTyVar :: Var -> Bool
+isId, isLocalVar, isLocalId :: Var -> Bool
+isGlobalId, isExportedId, isSpecPragmaId :: Var -> Bool
+mustHaveLocalBinding :: Var -> Bool
-@externallyVisibleId@: is it true that another module might be
-able to ``see'' this Id in a code generation sense. That
-is, another .o file might refer to this Id.
+isTyVar var = case varDetails var of
+ TyVar -> True
+ MutTyVar _ _ -> True
+ other -> False
-In tidyCorePgm (SimplCore.lhs) we carefully set each top level thing's
-local-ness precisely so that the test here would be easy
+isMutTyVar (Var {varDetails = MutTyVar _ _}) = True
+isMutTyVar other = False
-This defn appears here (rather than, say, in Id.lhs) because
-CostCentre.lhs uses it (CostCentre feeds PprType feeds Id.lhs)
+isSigTyVar (Var {varDetails = MutTyVar _ is_sig}) = is_sig
+isSigTyVar other = False
+isId var = case varDetails var of
+ LocalId _ -> True
+ GlobalId _ -> True
+ other -> False
+
+isLocalId var = case varDetails var of
+ LocalId _ -> True
+ other -> False
+
+-- isLocalVar returns True for type variables as well as local Ids
+-- These are the variables that we need to pay attention to when finding free
+-- variables, or doing dependency analysis.
+isLocalVar var = case varDetails var of
+ LocalId _ -> True
+ TyVar -> True
+ MutTyVar _ _ -> True
+ other -> False
+
+-- mustHaveLocalBinding returns True of Ids and TyVars
+-- that must have a binding in this module. The converse
+-- is not quite right: there are some GlobalIds that must have
+-- bindings, such as record selectors. But that doesn't matter,
+-- because it's only used for assertions
+mustHaveLocalBinding var = isLocalVar var
+
+isGlobalId var = case varDetails var of
+ GlobalId _ -> True
+ other -> False
+
+isExportedId var = case varDetails var of
+ LocalId Exported -> True
+ GlobalId _ -> True
+ other -> False
+
+isSpecPragmaId var = case varDetails var of
+ LocalId SpecPragma -> True
+ other -> False
\end{code}
+
\begin{code}
-externallyVisibleId :: Id -> Bool
-externallyVisibleId var = isExternallyVisibleName (varName var)
+globalIdDetails :: Var -> GlobalIdDetails
+-- Works OK on local Ids too, returning notGlobalId
+globalIdDetails var = case varDetails var of
+ GlobalId details -> details
+ other -> notGlobalId
+setGlobalIdDetails :: Id -> GlobalIdDetails -> Id
+setGlobalIdDetails id details = id { varDetails = GlobalId details }
\end{code}
+
import HscTypes
import RnEnv ( unQualInScope )
import Id ( idType, idName )
-import Name ( Name, lookupNameEnv, extendNameEnvList,
- NamedThing(..) )
+import Name ( Name, NamedThing(..) )
+import NameEnv
import RdrName ( emptyRdrEnv )
import Module ( Module, ModuleName, moduleName, isHomeModule,
mkModuleName, moduleNameUserString, moduleUserString )
\begin{code}
module CoreFVs (
- isLocalVar, mustHaveLocalBinding,
-
exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars
exprsFreeVars, -- [CoreExpr] -> VarSet
import CoreSyn
import Id ( Id, idType, isLocalId, hasNoBinding, idSpecialisation )
import VarSet
-import Var ( Var, isId )
+import Var ( Var, isId, isLocalVar )
import Type ( tyVarsOfType )
import Util ( mapAndUnzip )
import Outputable
%************************************************************************
%* *
-\subsection{isLocalVar}
-%* *
-%************************************************************************
-
-@isLocalVar@ returns True of all TyVars, and of Ids that are defined in
-this module and are not constants like data constructors and record selectors.
-These are the variables that we need to pay attention to when finding free
-variables, or doing dependency analysis.
-
-\begin{code}
-isLocalVar :: Var -> Bool
-isLocalVar v = isTyVar v || isLocalId v
-\end{code}
-
-\begin{code}
-mustHaveLocalBinding :: Var -> Bool
--- True <=> the variable must have a binding in this module
-mustHaveLocalBinding v = isTyVar v || (isLocalId v && not (hasNoBinding v))
-\end{code}
-
-
-%************************************************************************
-%* *
\section{Finding the free variables of an expression}
%* *
%************************************************************************
import CoreSyn
import Rules ( RuleBase, pprRuleBase )
-import CoreFVs ( idFreeVars, mustHaveLocalBinding )
+import CoreFVs ( idFreeVars )
import CoreUtils ( exprOkForSpeculation, coreBindsSize, mkPiType )
import Bag
import Literal ( literalType )
import DataCon ( dataConRepType )
-import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId )
+import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
import VarSet
import Subst ( mkTyVarSubst, substTy )
import Name ( getSrcLoc )
import PrimOp ( PrimOp(..) )
import Var ( Id, TyVar, setTyVarUnique )
import VarSet
-import IdInfo ( IdFlavour(..) )
-import Id ( mkSysLocal, idType, idStrictness, idFlavour, idDemandInfo, idArity,
- isDeadBinder, setIdType, isPrimOpId_maybe
+import Id ( mkSysLocal, idType, idStrictness, idDemandInfo, idArity,
+ isDeadBinder, setIdType, isPrimOpId_maybe, hasNoBinding
)
import UniqSupply
-- The type is the type of the entire application
maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
maybeSaturate fn expr n_args ty
- = case idFlavour fn of
- PrimOpId op -> saturate_it
- DataConId dc -> saturate_it
- other -> returnUs expr
+ | hasNoBinding fn = saturate_it
+ | otherwise = returnUs expr
where
fn_arity = idArity fn
excess_arity = fn_arity - n_args
ok bndr other = False
-- we can't eta reduce something which must be saturated.
- ok_to_eta_reduce (Var f)
- = case idFlavour f of
- PrimOpId op -> False
- DataConId dc -> False
- other -> True
- ok_to_eta_reduce _ = False --safe. ToDo: generalise
+ ok_to_eta_reduce (Var f) = not (hasNoBinding f)
+ ok_to_eta_reduce _ = False --safe. ToDo: generalise
tryEta bndrs (Let bind@(NonRec b r) body)
| not (any (`elemVarSet` fvs) bndrs)
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
import CoreUtils ( exprArity )
-import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars )
+import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars, ruleSomeLhsFreeVars )
import CoreLint ( showPass, endPass )
import VarEnv
import VarSet
-import Var ( Id, Var )
-import Id ( idType, idInfo, idName, isExportedId,
- idCafInfo, mkId, isLocalId, isImplicitId,
- idFlavour, modifyIdInfo, idArity
+import Var ( Id, Var, varName, globalIdDetails, setGlobalIdDetails )
+import Id ( idType, idInfo, idName, isExportedId, idSpecialisation,
+ idCafInfo, mkVanillaGlobal, isLocalId, isImplicitId,
+ modifyIdInfo, idArity, hasNoBinding, mkLocalIdWithInfo
)
import IdInfo {- loads of stuff -}
import Name ( getOccName, nameOccName, globaliseName, setNameOcc,
- localiseName, mkLocalName, isGlobalName, isDllName
+ localiseName, mkLocalName, isGlobalName, isDllName, isLocalName
)
+import NameEnv ( filterNameEnv )
import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
import Type ( tidyTopType, tidyType, tidyTyVar )
import Module ( Module, moduleName )
import PrimOp ( PrimOp(..), setCCallUnique )
import HscTypes ( PersistentCompilerState( pcs_PRS ),
PersistentRenamerState( prsOrig ),
- NameSupply( nsNames ), OrigNameCache
+ NameSupply( nsNames ), OrigNameCache,
+ TypeEnv, extendTypeEnvList,
+ DFunId, ModDetails(..), TyThing(..)
)
import UniqSupply
import DataCon ( DataCon, dataConName )
rather like the cloning step above.
- Give the Id its UTTERLY FINAL IdInfo; in ptic,
- * Its flavour becomes ConstantId, reflecting the fact that
- from now on we regard it as a constant, not local, Id
+ * Its IdDetails becomes VanillaGlobal, reflecting the fact that
+ from now on we regard it as a global, not local, Id
* its unfolding, if it should have one
\begin{code}
tidyCorePgm :: DynFlags -> Module
-> PersistentCompilerState
+ -> TypeEnv -> [DFunId]
-> [CoreBind] -> [IdCoreRule]
- -> IO (PersistentCompilerState, [CoreBind], [IdCoreRule])
-tidyCorePgm dflags mod pcs binds_in orphans_in
+ -> IO (PersistentCompilerState, [CoreBind], ModDetails)
+
+tidyCorePgm dflags mod pcs env_tc insts_tc binds_in orphans_in
= do { showPass dflags "Tidy Core"
; let ext_ids = findExternalSet binds_in orphans_in
; us <- mkSplitUniqSupply 't' -- for "tidy"
- ; let ((us1, orig_env', occ_env, subst_env), binds_out)
+ ; let ((us1, orig_env', occ_env, subst_env), tidy_binds)
= mapAccumL (tidyTopBind mod ext_ids)
(init_tidy_env us) binds_in
; let prs' = prs { prsOrig = orig { nsNames = orig_env' } }
pcs' = pcs { pcs_PRS = prs' }
- ; endPass dflags "Tidy Core" Opt_D_dump_simpl binds_out
+ ; let final_ids = [ id | bind <- tidy_binds
+ , id <- bindersOf bind
+ , isGlobalName (idName id)]
+
+ -- Dfuns are local Ids that might have
+ -- changed their unique during tidying
+ ; let lookup_dfun_id id = lookupVarEnv subst_env id `orElse`
+ pprPanic "lookup_dfun_id" (ppr id)
+
+
+ ; let final_rules = mkFinalRules orphans_out final_ids
+ final_type_env = mkFinalTypeEnv env_tc final_ids
+ final_dfun_ids = map lookup_dfun_id insts_tc
- ; return (pcs', binds_out, orphans_out)
+ ; let new_details = ModDetails { md_types = final_type_env,
+ md_rules = final_rules,
+ md_insts = final_dfun_ids }
+
+ ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
+
+ ; return (pcs', tidy_binds, new_details)
}
where
-- We also make sure to avoid any exported binders. Consider
init_tidy_env us = (us, orig_env, initTidyOccEnv avoids, emptyVarEnv)
avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
- isGlobalName (idName bndr)]
+ isGlobalName (idName bndr)]
tidyCoreExpr :: CoreExpr -> IO CoreExpr
%************************************************************************
%* *
+\subsection{Write a new interface file}
+%* *
+%************************************************************************
+
+\begin{code}
+mkFinalTypeEnv :: TypeEnv -- From typechecker
+ -> [Id] -- Final Ids
+ -> TypeEnv
+
+mkFinalTypeEnv type_env final_ids
+ = extendTypeEnvList (filterNameEnv keep_it type_env)
+ (map AnId final_ids)
+ where
+ -- The competed type environment is gotten from
+ -- a) keeping the types and classes
+ -- b) removing all Ids,
+ -- c) adding Ids with correct IdInfo, including unfoldings,
+ -- gotten from the bindings
+ -- From (c) we keep only those Ids with Global names;
+ -- the CoreTidy pass makes sure these are all and only
+ -- the externally-accessible ones
+ -- This truncates the type environment to include only the
+ -- exported Ids and things needed from them, which saves space
+ --
+ -- However, we do keep things like constructors, which should not appear
+ -- in interface files, because they are needed by importing modules when
+ -- using the compilation manager
+
+ -- We keep constructor workers, because they won't appear
+ -- in the bindings from which final_ids are derived!
+ keep_it (AnId id) = hasNoBinding id -- Remove all Ids except constructor workers
+ keep_it other = True -- Keep all TyCons and Classes
+\end{code}
+
+\begin{code}
+mkFinalRules :: [IdCoreRule] -- Orphan rules
+ -> [Id] -- Ids that are exported, so we need their rules
+ -> [IdCoreRule]
+ -- The complete rules are gotten by combining
+ -- a) the orphan rules
+ -- b) rules embedded in the top-level Ids
+mkFinalRules orphan_rules emitted
+ | opt_OmitInterfacePragmas = []
+ | otherwise
+ = orphan_rules ++ local_rules
+ where
+ local_rules = [ (fn, rule)
+ | fn <- emitted,
+ rule <- rulesRules (idSpecialisation fn),
+ not (isBuiltinRule rule),
+ -- We can't print builtin rules in interface files
+ -- Since they are built in, an importing module
+ -- will have access to them anyway
+
+ -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
+ -- from coming out, and to make it work properly we need to add ????
+ -- (put it back in for now)
+ isEmptyVarSet (ruleSomeLhsFreeVars (isLocalName . varName) rule)
+ -- Spit out a rule only if none of its LHS free vars are
+ -- LocalName things i.e. things that aren't visible to importing modules
+ -- This is a good reason not to do it when we emit the Id itself
+ ]
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Step 1: finding externals}
%* *
%************************************************************************
= foldr find init_needed binds
where
orphan_rule_ids :: IdSet
- orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isIdAndLocal rule
+ orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isLocalId rule
| (_, rule) <- orphan_rules]
init_needed :: IdEnv Bool
init_needed = mapUFM (\_ -> False) orphan_rule_ids
need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id
need_pr needed_set (id,rhs) = need_id needed_set id
-isIdAndLocal id = isId id && isLocalId id
-
addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
-- The Id is needed; extend the needed set
-- with it and its dependents (free vars etc)
rhs_is_small && -- Small enough
okToUnfoldInHiFile rhs -- No casms etc
- unfold_ids | show_unfold = exprSomeFreeVars isIdAndLocal rhs
+ unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs
| otherwise = emptyVarSet
worker_ids = case worker_info of
idinfo' = tidyIdInfo us_l tidy_env
is_external unfold_info arity_info caf_info id
- id' = mkId name' ty' idinfo'
+ id' = mkVanillaGlobal name' ty' idinfo'
subst_env' = extendVarEnv subst_env2 id id'
maybe_external = lookupVarEnv ext_ids id
tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id
| opt_OmitInterfacePragmas || not is_external
-- No IdInfo if the Id isn't external, or if we don't have -O
- = mkIdInfo new_flavour caf_info
+ = vanillaIdInfo
+ `setCafInfo` caf_info
`setStrictnessInfo` strictnessInfo core_idinfo
`setArityInfo` ArityExactly arity_info
-- Keep strictness, arity and CAF info; it's used by the code generator
| otherwise
= let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo))
in
- mkIdInfo new_flavour caf_info
+ vanillaIdInfo
+ `setCafInfo` caf_info
`setCprInfo` cprInfo core_idinfo
`setStrictnessInfo` strictnessInfo core_idinfo
`setInlinePragInfo` inlinePragInfo core_idinfo
-- after this!).
where
core_idinfo = idInfo id
- new_flavour = makeConstantFlavour (flavourInfo core_idinfo)
- -- A DFunId must stay a DFunId, so that we can gather the
- -- DFunIds up later. Other local things become ConstantIds.
-
-- This is where we set names to local/global based on whether they really are
-- externally visible (see comment at the top of this module). If the name
tidyBndr :: TidyEnv -> Var -> UniqSM (TidyEnv, Var)
tidyBndr env var
| isTyVar var = returnUs (tidyTyVar env var)
- | otherwise = tidyId env var vanillaIdInfo
+ | otherwise = tidyId env var noCafIdInfo
tidyBndrs :: TidyEnv -> [Var] -> UniqSM (TidyEnv, [Var])
tidyBndrs env vars = mapAccumLUs tidyBndr env vars
tidyBndrWithRhs env (id,rhs)
= tidyId env id idinfo
where
- idinfo = vanillaIdInfo `setArityInfo` ArityExactly (exprArity rhs)
+ idinfo = noCafIdInfo `setArityInfo` ArityExactly (exprArity rhs)
-- 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.
name' = mkLocalName uniq occ' noSrcLoc
(tidy_env', occ') = tidyOccName tidy_env (getOccName id)
ty' = tidyType (tidy_env,var_env) (idType id)
- id' = mkId name' ty' idinfo
+ id' = mkLocalIdWithInfo name' ty' idinfo
var_env' = extendVarEnv var_env id id'
in
returnUs ((tidy_env', var_env'), id')
fiddleCCall id
- = case idFlavour id of
+ = case globalIdDetails id of
PrimOpId (CCallOp ccall) ->
-- Make a guaranteed unique name for a dynamic ccall.
getUniqueUs `thenUs` \ uniq ->
- returnUs (modifyIdInfo (`setFlavourInfo`
- PrimOpId (CCallOp (setCCallUnique ccall uniq))) id)
- other_flavour ->
- returnUs id
+ returnUs (setGlobalIdDetails id
+ (PrimOpId (CCallOp (setCCallUnique ccall uniq))))
+ other -> returnUs id
\end{code}
%************************************************************************
idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
idAppIsNonUpd id n_val_args args
- = case idFlavour id of
+ = case globalIdDetails id of
DataConId con | not (isDynConApp con args) -> True
other -> n_val_args < idArity id
import PprCore ( pprCoreExpr )
import OccurAnal ( occurAnalyseGlobalExpr )
import CoreUtils ( exprIsValue, exprIsCheap, exprIsTrivial )
-import Id ( Id, idType, idFlavour, isId,
+import Id ( Id, idType, isId,
idSpecialisation, idInlinePragma, idUnfolding,
- isPrimOpId_maybe
+ isPrimOpId_maybe, globalIdDetails
)
import VarSet
import Literal ( isLitLitLit, litSize )
import PrimOp ( PrimOp(..), primOpIsDupable, primOpOutOfLine, ccallIsCasm )
-import IdInfo ( InlinePragInfo(..), OccInfo(..), IdFlavour(..),
+import IdInfo ( InlinePragInfo(..), OccInfo(..), GlobalIdDetails(..),
isNeverInlinePrag
)
import Type ( isUnLiftedType )
| fun `hasKey` buildIdKey = buildSize
| fun `hasKey` augmentIdKey = augmentSize
| otherwise
- = case idFlavour fun of
+ = case globalIdDetails fun of
DataConId dc -> conSizeN (valArgCount args)
PrimOpId op -> primOpSize op (valArgCount args)
import DataCon ( DataCon, dataConRepArity )
import PrimOp ( primOpOkForSpeculation, primOpIsCheap,
primOpIsDupable )
-import Id ( Id, idType, idFlavour, idStrictness, idLBVarInfo,
+import Id ( Id, idType, globalIdDetails, idStrictness, idLBVarInfo,
mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
isDataConId_maybe, isPrimOpId_maybe, mkSysLocal, hasNoBinding
)
import IdInfo ( LBVarInfo(..),
- IdFlavour(..),
+ GlobalIdDetails(..),
megaSeqIdInfo )
import Demand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
| n_val_args == 0 = True -- Just a type application of
-- a variable (f t1 t2 t3)
-- counts as WHNF
- | otherwise = case idFlavour id of
+ | otherwise = case globalIdDetails id of
DataConId _ -> True
RecordSelId _ -> True -- I'm experimenting with making record selection
-- look cheap, so we will substitute it inside a
= go other_expr 0 True
where
go (Var f) n_args args_ok
- = case idFlavour f of
+ = case globalIdDetails f of
DataConId _ -> True -- The strictness of the constructor has already
-- been expressed by its "wrapper", so we don't need
-- to take the arguments into account
idAppIsValue :: Id -> Int -> Bool
idAppIsValue id n_val_args
- = case idFlavour id of
+ = case globalIdDetails id of
DataConId _ -> True
PrimOpId _ -> n_val_args < idArity id
other | n_val_args == 0 -> isEvaldUnfolding (idUnfolding id)
import CoreSyn
import CostCentre ( pprCostCentreCore )
import Id ( Id, idType, isDataConId_maybe, idLBVarInfo, idArity,
- idInfo, idInlinePragma, idDemandInfo, idOccInfo
+ idInfo, idInlinePragma, idDemandInfo, idOccInfo,
+ globalIdDetails, isGlobalId, isExportedId, isSpecPragmaId
)
import Var ( isTyVar )
import IdInfo ( IdInfo, megaSeqIdInfo,
- arityInfo, ppArityInfo, ppFlavourInfo, flavourInfo,
+ arityInfo, ppArityInfo,
specInfo, cprInfo, ppCprInfo,
strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
cprInfo, ppCprInfo,
\begin{code}
-- Used for printing dump info
pprCoreBinder LetBind binder
- = vcat [sig, pragmas, ppr binder]
+ = vcat [sig, pprIdDetails binder, pragmas, ppr binder]
where
sig = pprTypedBinder binder
pragmas = ppIdInfo binder (idInfo binder)
\begin{code}
+pprIdDetails :: Id -> SDoc
+pprIdDetails id | isGlobalId id = ppr (globalIdDetails id)
+ | isExportedId id = ptext SLIT("[Exported]")
+ | isSpecPragmaId id = ptext SLIT("[SpecPrag]")
+ | otherwise = empty
+
ppIdInfo :: Id -> IdInfo -> SDoc
ppIdInfo b info
- = hsep [
- ppFlavourInfo (flavourInfo info),
- ppArityInfo a,
+ = hsep [ ppArityInfo a,
ppTyGenInfo g,
ppWorkerInfo (workerInfo info),
ppStrictnessInfo s,
CoreRules(..), CoreRule(..),
isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding
)
-import CoreFVs ( exprFreeVars, mustHaveLocalBinding )
+import CoreFVs ( exprFreeVars )
import TypeRep ( Type(..), TyNote(..) ) -- friend
import Type ( ThetaType, PredType(..), ClassContext,
tyVarsOfType, tyVarsOfTypes, mkAppTy, mkUTy, isUTy
)
import VarSet
import VarEnv
-import Var ( setVarUnique, isId )
-import Id ( idType, idInfo, setIdInfo, setIdType, idOccInfo, maybeModifyIdInfo )
-import IdInfo ( IdInfo, mkIdInfo,
+import Var ( setVarUnique, isId, mustHaveLocalBinding )
+import Id ( idType, idInfo, setIdInfo, setIdType,
+ idOccInfo, maybeModifyIdInfo )
+import IdInfo ( IdInfo, vanillaIdInfo,
occInfo, isFragileOcc, setOccInfo,
- specInfo, setSpecInfo, flavourInfo,
+ specInfo, setSpecInfo,
unfoldingInfo, setUnfoldingInfo,
- CafInfo(NoCafRefs),
WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo,
lbvarInfo, LBVarInfo(..), setLBVarInfo, hasNoLBVarInfo
)
old_info = idInfo old_id
id1 = uniqAway in_scope old_id
id2 = substIdType subst id1
- new_id = id2 `setIdInfo` mkIdInfo (flavourInfo old_info) NoCafRefs
- -- Zap the IdIno altogether, but preserve the flavour
+ new_id = setIdInfo id2 vanillaIdInfo
-- Extend the substitution if the unique has changed,
-- or there's some useful occurrence information
-- depends on DsExpr.hi-boot.
import Module ( Module )
import Id ( Id )
-import Name ( lookupNameEnv )
+import NameEnv ( lookupNameEnv )
import VarEnv
import VarSet
import Bag ( isEmptyBag )
import CallConv
import TcHsSyn ( TypecheckedForeignDecl )
import CoreUtils ( exprType, mkInlineMe )
-import Id ( Id, idType, idName, mkId, mkSysLocal,
+import Id ( Id, idType, idName, mkVanillaGlobal, mkSysLocal,
setInlinePragma )
-import IdInfo ( neverInlinePrag, vanillaIdInfo, IdFlavour(..),
- setFlavourInfo )
+import IdInfo ( neverInlinePrag, vanillaIdInfo )
import Literal ( Literal(..) )
import Module ( Module, moduleUserString )
import Name ( mkGlobalName, nameModule, nameOccName, getOccString,
helper_ty = mkForAllTys tvs $
mkFunTys wrapper_arg_tys io_res_ty
- f_helper_glob = mkId helper_name helper_ty
- (vanillaIdInfo `setFlavourInfo` ExportedId)
+ f_helper_glob = mkVanillaGlobal helper_name helper_ty vanillaIdInfo
where
name = idName fn_id
mod
-- create a totally bogus name for the top-level BCO; this
-- should be harmless, since it's never used for anything
- let invented_name = mkSysLocalName (mkPseudoUnique3 0) SLIT("Expr-Top-Level")
- let invented_id = mkVanillaId invented_name (panic "invented_id's type")
+ let invented_id = mkSysLocal SLIT("Expr-Top-Level") (mkPseudoUnique3 0)
+ (panic "invented_id's type")
+ let invented_name = idName invented_id
let (BcM_State all_proto_bcos final_ctr)
= runBc (BcM_State [] 0)
printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
ghcExit,
- doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, showPass
+ doIfSet, doIfSet_dyn,
+ dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or,
+ showPass
) where
#include "HsVersions.h"
| dopt flag dflags || verbosity dflags >= 4 = printDump (dump hdr doc)
| otherwise = return ()
+dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO ()
+dumpIfSet_dyn_or dflags flags hdr doc
+ | or [dopt flag dflags | flag <- flags]
+ || verbosity dflags >= 4
+ = printDump (dump hdr doc)
+ | otherwise = return ()
+
dump hdr doc
= vcat [text "",
line <+> text hdr <+> line,
import RdrHsSyn ( RdrNameStmt )
import Rename ( renameStmt )
import ByteCodeGen ( byteCodeGen )
-import Id ( Id, idName, idFlavour, modifyIdInfo )
-import IdInfo ( setFlavourInfo, makeConstantFlavour )
+import Id ( Id, idName )
+import IdInfo ( GlobalIdDetails(VanillaGlobal) )
import HscTypes ( InteractiveContext(..), TyThing(..) )
#endif
import Rules ( emptyRuleBase )
import PrelInfo ( wiredInThingEnv, wiredInThings )
import PrelNames ( vanillaSyntaxMap, knownKeyNames, iNTERACTIVE )
-import MkIface ( completeIface, mkModDetailsFromIface, mkModDetails,
- writeIface, pprIface )
+import MkIface ( completeIface, writeIface, pprIface )
import Type ( Type )
import TcModule
import InstEnv ( emptyInstEnv )
)
import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM )
import OccName ( OccName )
-import Name ( Name, nameModule, nameOccName, getName, isGlobalName,
- emptyNameEnv
- )
+import Name ( Name, nameModule, nameOccName, getName, isGlobalName )
+import NameEnv ( emptyNameEnv )
import Module ( Module, lookupModuleEnvByName )
import Monad ( when )
case maybe_tc_result of {
Nothing -> return (HscFail pcs_cl);
- Just (pcs_tc, env_tc, local_rules) -> do {
+ Just (pcs_tc, new_details) ->
- -- create a new details from the closed, typechecked, old iface
- let new_details = mkModDetailsFromIface env_tc local_rules
- ;
return (HscNoRecomp pcs_tc new_details old_iface)
- }}}}
+ }}}
compMsg mod location =
mod_str ++ take (12 - length mod_str) (repeat ' ')
Nothing -> return (HscFail pcs_ch{-was: pcs_rn-});
Just (pcs_tc, tc_result) -> do {
- ; let env_tc = tc_env tc_result
+ ; let env_tc = tc_env tc_result
+ insts_tc = tc_insts tc_result
-------------------
-- DESUGAR
deSugar dflags pcs_tc hst this_mod print_unqualified tc_result
-------------------
- -- SIMPLIFY, TIDY-CORE
+ -- SIMPLIFY
+ -------------------
+ ; (simplified, orphan_rules)
+ <- _scc_ "Core2Core"
+ core2core dflags pcs_tc hst dont_discard ds_binds ds_rules
+
+ -------------------
+ -- TIDY
-------------------
- -- We grab the the unfoldings at this point.
- ; (pcs_simpl, tidy_binds, orphan_rules)
- <- simplThenTidy dflags pcs_tc hst this_mod dont_discard ds_binds ds_rules
-
+ ; (pcs_simpl, tidy_binds, new_details)
+ <- tidyCorePgm dflags this_mod pcs_tc env_tc insts_tc
+ simplified orphan_rules
+
-------------------
-- BUILD THE NEW ModDetails AND ModIface
-------------------
- ; let new_details = mkModDetails env_tc tidy_binds orphan_rules
; final_iface <- _scc_ "MkFinalIface"
mkFinalIface ghci_mode dflags location
- maybe_checked_iface new_iface new_details
+ maybe_checked_iface new_iface new_details
-------------------
-- CONVERT TO STG and COMPLETE CODE GENERATION
}}
-simplThenTidy dflags pcs hst this_mod dont_discard binds rules
- = do -- Do main Core-language transformations ---------
- -- _scc_ "Core2Core"
- (simplified, orphan_rules)
- <- core2core dflags pcs hst dont_discard binds rules
-
- -- Do the final tidy-up
- (pcs', tidy_binds, tidy_orphan_rules)
- <- tidyCorePgm dflags this_mod pcs simplified orphan_rules
-
- return (pcs', tidy_binds, tidy_orphan_rules)
-
-
restOfCodeGeneration dflags toInterp this_mod imported_module_names
foreign_stuff env_tc tidy_binds
hit pit -- these last two for mapping ModNames to Modules
; bcos <- coreExprToBCOs dflags sat_expr
; let
- -- make all the bound ids "constant" ids, now that
+ -- Make all the bound ids "global" ids, now that
-- they're notionally top-level bindings. This is
-- important: otherwise when we come to compile an expression
-- using these ids later, the byte code generator will consider
-- the occurrences to be free rather than global.
- constant_bound_ids = map constantizeId bound_ids;
-
- constantizeId id
- = modifyIdInfo (`setFlavourInfo` makeConstantFlavour
- (idFlavour id)) id
+ global_bound_ids = map globaliseId bound_ids;
+ globaliseId id = setIdGlobalDetails id VanillaGlobal
- ; return (pcs2, Just (constant_bound_ids, ty, bcos))
+ ; return (pcs2, Just (global_bound_ids, ty, bcos))
}}}}}
import RdrName ( RdrNameEnv, addListToRdrEnv, emptyRdrEnv, mkRdrUnqual, rdrEnvToList )
import Name ( Name, NamedThing, getName, nameOccName, nameModule, nameSrcLoc )
-import Name -- Env
+import NameEnv
import OccName ( OccName )
import Module ( Module, ModuleName, ModuleEnv,
lookupModuleEnv, lookupModuleEnvByName, emptyModuleEnv
md_insts :: [DFunId], -- Dfun-ids for the instances in this module
md_rules :: [IdCoreRule] -- Domain may include Ids from other modules
}
+
+-- NOT YET IMPLEMENTED
+-- The ModDetails takes on several slightly different forms:
+--
+-- After typecheck + desugar
+-- md_types contains TyCons, Classes, and hasNoBinding Ids
+-- md_insts all instances from this module (incl derived ones)
+-- md_rules all rules from this module
+-- md_binds desugared bindings
+--
+-- After simplification
+-- md_types same as after typecheck
+-- md_insts ditto
+-- md_rules orphan rules only (local ones attached to binds)
+-- md_binds with rules attached
+--
+-- After tidy
+-- md_types now contains Ids as well, replete with correct IdInfo
+-- apart from
\end{code}
\begin{code}
\begin{code}
module MkIface (
- mkModDetails, mkModDetailsFromIface, completeIface,
- writeIface, pprIface, pprUsage
+ completeIface, writeIface,
+ pprModDetails, pprIface, pprUsage
) where
#include "HsVersions.h"
)
import RnMonad
import RnHsSyn ( RenamedInstDecl, RenamedTyClDecl )
-import TcHsSyn ( TypecheckedRuleDecl )
import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..),
IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts,
- TyThing(..), DFunId, TypeEnv, Avails,
+ TyThing(..), DFunId, Avails,
WhatsImported(..), GenAvailInfo(..),
ImportVersion, AvailInfo, Deprecations(..),
- extendTypeEnvList, lookupVersion,
+ lookupVersion,
)
import CmdLineOpts
-import Id ( idType, idInfo, isImplicitId, isDictFunId,
- idSpecialisation, isLocalId, idName, hasNoBinding
- )
-import Var ( isId )
-import VarSet
+import Id ( idType, idInfo, isImplicitId, isLocalId, idName )
import DataCon ( StrictnessMark(..), dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo -- Lots
-import CoreSyn ( CoreBind, CoreRule(..), IdCoreRule,
- isBuiltinRule, rulesRules,
- bindersOf, bindersOfBinds
- )
-import CoreFVs ( ruleSomeLhsFreeVars )
+import CoreSyn ( CoreBind, CoreRule(..) )
import CoreUnfold ( neverUnfold, unfoldingTemplate )
-import Name ( getName, nameModule, Name, NamedThing(..) )
-import Name -- Env
+import PprCore ( pprIdCoreRule )
+import Name ( getName, nameModule, toRdrName, isGlobalName, Name, NamedThing(..) )
+import NameEnv
import OccName ( pprOccName )
import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConGenIds,
tyConTheta, tyConTyVars, tyConDataCons, tyConFamilySize, isClassTyCon
import SrcLoc ( noSrcLoc )
import Outputable
import Module ( ModuleName )
-import Maybes ( orElse )
+import Util ( sortLt )
import IO ( IOMode(..), openFile, hClose )
\end{code}
%************************************************************************
%* *
-\subsection{Write a new interface file}
-%* *
-%************************************************************************
-
-\begin{code}
-mkModDetails :: TypeEnv -- From typechecker
- -> [CoreBind] -- Final bindings
- -- they have authoritative arity info
- -> [IdCoreRule] -- Tidy orphan rules
- -> ModDetails
-mkModDetails type_env tidy_binds orphan_rules
- = ModDetails { md_types = new_type_env,
- md_rules = rule_dcls,
- md_insts = filter isDictFunId final_ids }
- where
- -- The competed type environment is gotten from
- -- a) keeping the types and classes
- -- b) removing all Ids,
- -- c) adding Ids with correct IdInfo, including unfoldings,
- -- gotten from the bindings
- -- From (c) we keep only those Ids with Global names;
- -- the CoreTidy pass makes sure these are all and only
- -- the externally-accessible ones
- -- This truncates the type environment to include only the
- -- exported Ids and things needed from them, which saves space
- --
- -- However, we do keep things like constructors, which should not appear
- -- in interface files, because they are needed by importing modules when
- -- using the compilation manager
- new_type_env = extendTypeEnvList (filterNameEnv keep_it type_env)
- (map AnId final_ids)
-
- -- We keep constructor workers, because they won't appear
- -- in the bindings from which final_ids are derived!
- keep_it (AnId id) = hasNoBinding id
- keep_it other = True
-
- final_ids = [id | bind <- tidy_binds
- , id <- bindersOf bind
- , isGlobalName (idName id)]
-
- -- The complete rules are gotten by combining
- -- a) the orphan rules
- -- b) rules embedded in the top-level Ids
- rule_dcls | opt_OmitInterfacePragmas = []
- | otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids)
-
--- This version is used when we are re-linking a module
--- so we've only run the type checker on its previous interface
-mkModDetailsFromIface :: TypeEnv
- -> [TypecheckedRuleDecl]
- -> ModDetails
-mkModDetailsFromIface type_env rules
- = ModDetails { md_types = type_env,
- md_rules = rule_dcls,
- md_insts = dfun_ids }
- where
- dfun_ids = [dfun_id | AnId dfun_id <- nameEnvElts type_env, isDictFunId dfun_id]
- rule_dcls = [(id,rule) | IfaceRuleOut id rule <- rules]
- -- All the rules from an interface are of the IfaceRuleOut form
-\end{code}
-
-\begin{code}
-getRules :: [IdCoreRule] -- Orphan rules
- -> [CoreBind] -- Bindings, with rules in the top-level Ids
- -> IdSet -- Ids that are exported, so we need their rules
- -> [IdCoreRule]
-getRules orphan_rules binds emitted
- = orphan_rules ++ local_rules
- where
- local_rules = [ (fn, rule)
- | fn <- bindersOfBinds binds,
- fn `elemVarSet` emitted,
- rule <- rulesRules (idSpecialisation fn),
- not (isBuiltinRule rule),
- -- We can't print builtin rules in interface files
- -- Since they are built in, an importing module
- -- will have access to them anyway
-
- -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
- -- from coming out, and to make it work properly we need to add ????
- -- (put it back in for now)
- all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule))
- -- Spit out a rule only if all its lhs free vars are emitted
- -- This is a good reason not to do it when we emit the Id itself
- ]
-
-interestingId id = isId id && isLocalId id
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection{Completing an interface}
%* *
%************************************************************************
%************************************************************************
%* *
+\subsection{Writing ModDetails}
+%* *
+%************************************************************************
+
+\begin{code}
+pprModDetails :: ModDetails -> SDoc
+pprModDetails (ModDetails { md_types = type_env, md_insts = dfun_ids, md_rules = rules })
+ = vcat [ dump_types dfun_ids type_env
+ , dump_insts dfun_ids
+ , dump_rules rules]
+
+dump_types dfun_ids type_env
+ = text "TYPE SIGNATURES" $$ nest 4 (dump_sigs ids)
+ where
+ ids = [id | AnId id <- nameEnvElts type_env, want_sig id]
+ want_sig id | opt_PprStyle_Debug = True
+ | otherwise = isLocalId id &&
+ isGlobalName (idName id) &&
+ not (id `elem` dfun_ids)
+ -- isLocalId ignores data constructors, records selectors etc
+ -- The isGlobalName ignores local dictionary and method bindings
+ -- that the type checker has invented. User-defined things have
+ -- Global names.
+
+dump_insts [] = empty
+dump_insts dfun_ids = text "INSTANCES" $$ nest 4 (dump_sigs dfun_ids)
+
+dump_sigs ids
+ -- Print type signatures
+ -- Convert to HsType so that we get source-language style printing
+ -- And sort by RdrName
+ = vcat $ map ppr_sig $ sortLt lt_sig $
+ [ (toRdrName id, toHsType (idType id))
+ | id <- ids ]
+ where
+ lt_sig (n1,_) (n2,_) = n1 < n2
+ ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
+
+dump_rules [] = empty
+dump_rules rs = vcat [ptext SLIT("{-# RULES"),
+ nest 4 (vcat (map pprIdCoreRule rs)),
+ ptext SLIT("#-}")]
+\end{code}
+
+
+%************************************************************************
+%* *
\subsection{Writing an interface file}
%* *
%************************************************************************
moduleEnvElts
)
import Name ( Name, nameIsLocalOrFrom, nameModule )
-import Name ( mkNameEnv, nameEnvElts, extendNameEnv )
-import RdrName ( foldRdrEnv, isQual )
+import NameEnv
import NameSet
+import RdrName ( foldRdrEnv, isQual )
import PrelNames ( SyntaxMap, pRELUDE_Name )
import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass,
printErrorsAndWarnings, errorsFound )
getSrcLoc,
mkLocalName, mkGlobalName,
mkIPName, nameOccName, nameModule_maybe,
- setNameModuleAndLoc, mkNameEnv
+ setNameModuleAndLoc
)
-import Name ( extendNameEnv_C, plusNameEnv_C, nameEnvElts )
+import NameEnv
import NameSet
import OccName ( OccName, occNameUserString, occNameFlavour )
import Module ( ModuleName, moduleName, mkVanillaModule,
import Name ( Name {-instance NamedThing-},
nameModule, isLocalName, nameIsLocalOrFrom
)
-import Name ( mkNameEnv, extendNameEnv )
+import NameEnv
import Module ( Module,
moduleName, isHomeModule,
ModuleName, WhereFrom(..),
import Name ( Name {-instance NamedThing-}, nameOccName,
nameModule, isLocalName, NamedThing(..)
)
-import Name ( elemNameEnv, delFromNameEnv )
+import NameEnv ( elemNameEnv, delFromNameEnv, lookupNameEnv )
+import NameSet
import Module ( Module, ModuleEnv,
moduleName, isHomeModule,
ModuleName, WhereFrom(..),
extendModuleEnv_C, foldModuleEnv, lookupModuleEnv,
elemModuleSet, extendModuleSet
)
-import NameSet
import PrelInfo ( wiredInThingEnv )
import Maybes ( orElse )
import FiniteMap
nameOccName,
decode, mkLocalName, mkKnownKeyGlobal
)
-import Name ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList )
+import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList )
import Module ( Module, ModuleName, ModuleSet, emptyModuleSet )
import NameSet
import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import FiniteMap
import PrelNames ( pRELUDE_Name, mAIN_Name, main_RDR_Unqual, isUnboundName )
-import UniqFM ( lookupUFM )
import Module ( ModuleName, moduleName, WhereFrom(..) )
+import Name ( Name, nameSrcLoc, nameOccName )
import NameSet
-import Name ( Name, nameSrcLoc, nameOccName, nameEnvElts )
+import NameEnv
import HscTypes ( Provenance(..), ImportReason(..), GlobalRdrEnv,
GenAvailInfo(..), AvailInfo, Avails, AvailEnv,
Deprecations(..), ModIface(..)
import NameSet ( elemNameSet, emptyNameSet )
import Outputable
import Maybes ( maybeToBool, catMaybes, mapMaybe )
-import UniqFM ( emptyUFM, listToUFM )
import ListSetOps ( removeDups )
import Util ( sortLt )
import List ( partition )
\begin{code}
mkEmptyExportAvails :: ModuleName -> ExportAvails
-mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyUFM)
+mkEmptyExportAvails mod_name = (unitFM mod_name [], emptyNameEnv)
mkExportAvails :: ModuleName -> Bool -> GlobalRdrEnv -> [AvailInfo] -> ExportAvails
mkExportAvails mod_name unqual_imp gbl_env avails
unqual_in_scope n = unQualInScope gbl_env n
- entity_avail_env = listToUFM [ (name,avail) | avail <- avails,
+ entity_avail_env = mkNameEnv [ (name,avail) | avail <- avails,
name <- availNames avail]
plusExportAvails :: ExportAvails -> ExportAvails -> ExportAvails
= lookupSrcName global_name_env (ieName ie) `thenRn` \ name ->
-- See what's available in the current environment
- case lookupUFM entity_avail_env name of {
+ case lookupNameEnv entity_avail_env name of {
Nothing -> -- Presumably this happens because lookupSrcName didn't find
-- the name and returned an unboundName, which won't be in
-- the entity_avail_env, of course
InstTyEnv(..)
)
import MkId ( mkSysLocal )
-import Id ( idType, idName, mkVanillaId )
+import Id ( idType, idName, mkLocalId )
import UniqSupply
import Util
let
new_name = mkCompoundName SLIT("$sat") unique (idName id)
in
- (mkVanillaId new_name ty, env) }
+ (mkLocalId new_name ty, env) }
getArgLists :: CoreExpr -> ([Arg Type],[Arg Id])
getArgLists expr
extendRuleBaseList, addRuleBaseFVs, pprRuleBase )
import Module ( moduleEnvElts )
import CoreUnfold
-import PprCore ( pprCoreBindings, pprIdCoreRule, pprCoreExpr )
+import PprCore ( pprCoreBindings, pprCoreExpr )
import OccurAnal ( occurAnalyseBinds, occurAnalyseGlobalExpr )
import CoreUtils ( coreBindsSize )
import Simplify ( simplTopBinds, simplExpr )
import ErrUtils ( dumpIfSet, dumpIfSet_dyn )
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
-import Id ( idName, isDataConWrapId, setIdNoDiscard, isLocalId )
+import Id ( idName, isDataConWrapId, setIdNoDiscard, isLocalId, isImplicitId )
import VarSet
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs]
update_bndr bndr
- | is_exported (idName bndr)
- || bndr `elemVarSet` rule_rhs_fvs = setIdNoDiscard bndr'
- | otherwise = bndr'
+ | isImplicitId bndr = bndr -- Constructors, selectors; doesn't
+ -- make sense to call setIdNoDiscard
+ -- Also can't have rules
+ | dont_discard bndr = setIdNoDiscard bndr_with_rules
+ | otherwise = bndr_with_rules
where
- bndr' = lookupVarSet rule_ids bndr `orElse` bndr
+ bndr_with_rules = lookupVarSet rule_ids bndr `orElse` bndr
+
+ dont_discard bndr = is_exported (idName bndr)
+ || bndr `elemVarSet` rule_rhs_fvs
\end{code}
import qualified Subst ( simplBndrs, simplBndr, simplLetId )
import Id ( idType, idName,
idUnfolding, idStrictness,
- mkVanillaId, idInfo
+ mkLocalId, idInfo
)
import IdInfo ( StrictnessInfo(..) )
import Maybes ( maybeToBool, catMaybes )
let
poly_name = setNameUnique (idName var) uniq -- Keep same name
poly_ty = mkForAllTys tyvars_here (idType var) -- But new type of course
- poly_id = mkVanillaId poly_name poly_ty
+ poly_id = mkLocalId poly_name poly_ty
-- In the olden days, it was crucial to copy the occInfo of the original var,
-- because we were looking at occurrence-analysed but as yet unsimplified code!
import CoreFVs ( exprsFreeVars )
import DataCon ( dataConRepArity )
import Type ( tyConAppArgs )
-import PprCore ( pprCoreRules )
+import PprCore ( pprCoreRules, pprCoreRule )
import Id ( Id, idName, idType, idSpecialisation,
isDataConId_maybe,
mkUserLocal, mkSysLocal )
let (_, pats) = argsToPats con_env us call_args
]
in
- pprTrace "specialise" (ppr all_calls $$ ppr good_calls) $
mapAndUnzipUs (spec_one env fn (mkLams bndrs body))
(nubBy same_call good_calls `zip` [1..])
where
bndr_usg_ok :: IdEnv ArgOcc -> Var -> CoreArg -> Bool
bndr_usg_ok arg_occs bndr arg
- = pprTrace "bndr_ok" (ppr bndr <+> ppr (lookupVarEnv arg_occs bndr)) $
- case lookupVarEnv arg_occs bndr of
+ = case lookupVarEnv arg_occs bndr of
Just CaseScrut -> True -- Used only by case scrutiny
Just Both -> case arg of -- Used by case and elsewhere
App _ _ -> True -- so the arg should be an explicit con app
spec_id = mkUserLocal spec_occ spec_uniq (exprType spec_rhs) fn_loc
rule = Rule rule_name pat_fvs pats (mkVarApps (Var spec_id) bndrs)
in
+ pprTrace "SpecConstr" (pprCoreRule (ppr fn) rule) $
returnUs (rule, (spec_id, spec_rhs))
\end{code}
import Id ( Id, idName, idType, mkUserLocal,
idSpecialisation, modifyIdInfo
)
-import IdInfo ( zapSpecPragInfo )
-import VarSet
-import VarEnv
-
import Type ( Type, mkTyVarTy, splitSigmaTy,
tyVarsOfTypes, tyVarsOfTheta,
mkForAllTys
substAndCloneId, substAndCloneIds, substAndCloneRecIds,
lookupIdSubst, substInScope
)
+import Var ( zapSpecPragmaId )
import VarSet
import VarEnv
import CoreSyn
returnSM ((zapped_fn, rhs'), [], rhs_uds)
where
- zapped_fn = modifyIdInfo zapSpecPragInfo fn
+ zapped_fn = zapSpecPragmaId fn
-- If the fn is a SpecPragmaId, make it discardable
-- It's role as a holder for a call instance is o'er
-- But it might be alive for some other reason by now.
import Type
import TyCon ( isAlgTyCon )
import Id
-import Var ( Var )
+import Var ( Var, globalIdDetails )
import IdInfo
import DataCon
import CostCentre ( noCCS )
case scrut of
-- ToDo: Notes?
e@(App _ _) | (v, args) <- myCollectArgs e,
- PrimOpId (CCallOp ccall) <- idFlavour v,
+ PrimOpId (CCallOp ccall) <- globalIdDetails v,
ccallMayGC ccall
-> Just (filterVarSet isForeignObjArg (exprFreeVars e))
_ -> Nothing
-- continuation, but it does no harm to just union the
-- two regardless.
- app = case idFlavour f of
+ app = case globalIdDetails f of
DataConId dc -> StgConApp dc args'
PrimOpId op -> StgPrimApp op args' (exprType (mkApps (Var f) args))
_other -> StgApp f args'
import CoreUnfold ( certainlyWillInline )
import CoreLint ( showPass, endPass )
import CoreUtils ( exprType )
-import MkId ( mkWorkerId )
import Id ( Id, idType, idStrictness, idArity, isOneShotLambda,
- setIdStrictness, idInlinePragma,
+ setIdStrictness, idInlinePragma, mkWorkerId,
setIdWorkerInfo, idCprInfo, setInlinePragma )
import Type ( Type, isNewType, splitForAllTys, splitFunTys )
import IdInfo ( mkStrictnessInfo, noStrictnessInfo, StrictnessInfo(..),
)
import CoreFVs ( idFreeTyVars )
import Class ( Class )
-import Id ( Id, idType, mkUserLocal, mkSysLocal, mkVanillaId )
+import Id ( Id, idType, mkUserLocal, mkSysLocal, mkLocalId )
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Name ( mkDictOcc, mkMethodOcc, getOccName, mkLocalName )
import NameSet ( NameSet )
= tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs ->
returnNF_Tc (zipWithEqual "newDictsAtLoc" mk_dict new_uniqs theta)
where
- mk_dict uniq pred = Dict (mkVanillaId (mk_dict_name uniq pred) (mkPredTy pred)) pred inst_loc
+ mk_dict uniq pred = Dict (mkLocalId (mk_dict_name uniq pred) (mkPredTy pred)) pred inst_loc
mk_dict_name uniq (Class cls tys) = mkLocalName uniq (mkDictOcc (getOccName cls)) loc
mk_dict_name uniq (IParam name ty) = name
newIPDict orig name ty
= tcGetInstLoc orig `thenNF_Tc` \ inst_loc ->
- returnNF_Tc (Dict (mkVanillaId name ty) (IParam name ty) inst_loc)
+ returnNF_Tc (Dict (mkLocalId name ty) (IParam name ty) inst_loc)
\end{code}
import TcUnify ( unifyTauTy, unifyTauTyLists )
import CoreFVs ( idFreeTyVars )
-import Id ( mkVanillaId, setInlinePragma )
+import Id ( mkLocalId, setInlinePragma )
import Var ( idType, idName )
import IdInfo ( InlinePragInfo(..) )
import Name ( Name, getOccName, getSrcLoc )
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 -> mkVanillaId name forall_a_a -- No signature
+ Nothing -> mkLocalId name forall_a_a -- No signature
in
returnTc (EmptyMonoBinds, emptyLIE, poly_ids)
) $
(sig_tyvars, sig_poly_id)
Nothing -> (real_tyvars_to_gen, new_poly_id)
- new_poly_id = mkVanillaId binder_name poly_ty
+ new_poly_id = mkLocalId binder_name poly_ty
poly_ty = mkForAllTys real_tyvars_to_gen
$ mkFunTys dict_tys
$ idType zonked_mono_id
import Id ( Id, idType, idName )
import Module ( Module )
import Name ( Name, NamedThing(..) )
-import Name ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts )
+import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv, nameEnvElts )
import NameSet ( emptyNameSet )
import Outputable
import Type ( Type, ClassContext, mkTyVarTys, mkDictTys, mkClassPred,
let
-- Build the selector id and default method id
sel_id = mkDictSelId op_name clas
- dm_id = mkDefaultMethodId dm_name clas global_ty
+ dm_id = mkDefaultMethodId dm_name global_ty
DefMeth dm_name = sig_dm
dm_info = case maybe_dm_env of
import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet,
zonkTcTyVarsAndFV
)
-import Id ( idName, mkUserLocal, isDataConWrapId_maybe )
-import IdInfo ( constantIdInfo )
-import MkId ( mkSpecPragmaId )
+import Id ( idName, mkSpecPragmaId, mkUserLocal, isDataConWrapId_maybe )
+import IdInfo ( vanillaIdInfo )
import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo )
import VarSet
import Type ( Type,
nameOccName, getSrcLoc, mkLocalName, isLocalName,
nameIsLocalOrFrom
)
-import Name ( NameEnv, lookupNameEnv, nameEnvElts,
+import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts,
extendNameEnvList, emptyNameEnv, plusNameEnv )
import OccName ( mkDFunOcc, occNameString )
import HscTypes ( DFunId,
-- The Id must be returned without a data dependency on maybe_id
where
new_info = case tcLookupRecId_maybe env (idName id) of
- Nothing -> pprTrace "tcAddIdInfo" (ppr id) constantIdInfo
+ Nothing -> pprTrace "tcAddIdInfo" (ppr id) vanillaIdInfo
Just imported_id -> idInfo imported_id
-- ToDo: could check that types are the same
import Inst ( emptyLIE, LIE, plusLIE )
import ErrUtils ( Message )
-import Id ( Id, mkVanillaId )
+import Id ( Id, mkLocalId )
import Name ( nameOccName )
import Type ( splitFunTys
, splitTyConApp_maybe
case splitFunTys t_ty of
(arg_tys, res_ty) ->
checkForeignExport True t_ty arg_tys res_ty `thenTc_`
- let i = (mkVanillaId nm sig_ty) in
+ let i = (mkLocalId nm sig_ty) in
returnTc (i, (ForeignDecl i FoExport undefined Dynamic cconv src_loc))
tcFImport fo@(ForeignDecl nm FoLabel hs_ty ext_nm cconv src_loc) =
in
check (isFFILabelTy t_ty)
(illegalForeignTyErr False{-result-} sig_ty) `thenTc_`
- let i = (mkVanillaId nm sig_ty) in
+ let i = (mkLocalId nm sig_ty) in
returnTc (i, (ForeignDecl i FoLabel undefined ext_nm cconv src_loc))
tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_loc) =
case splitFunTys t_ty of
(arg_tys, res_ty) ->
checkForeignImport (isDynamicExtName ext_nm) (not isUnsafe) ty arg_tys res_ty `thenTc_`
- let i = (mkVanillaId nm ty) in
+ let i = (mkLocalId nm ty) in
returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc))
tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl)
import HsSyn -- oodles of it
-- others:
-import Id ( idName, idType, isLocalId, setIdType, Id )
+import Id ( idName, idType, setIdType, Id )
import DataCon ( dataConWrapId )
import TcEnv ( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
TcEnv, TcId
import CoreLint ( lintUnfolding )
import WorkWrap ( mkWrapper )
-import Id ( Id, mkId, mkVanillaId, idName, isDataConWrapId_maybe )
+import Id ( Id, mkVanillaGlobal, mkLocalId, idName, isDataConWrapId_maybe )
import Module ( Module )
import MkId ( mkCCallOpId )
import IdInfo
tcIfaceType ty `thenTc` \ sigma_ty ->
tcIdInfo unf_env in_scope_vars name
sigma_ty id_infos `thenTc` \ id_info ->
- returnTc (mkId name sigma_ty id_info)
+ returnTc (mkVanillaGlobal name sigma_ty id_info)
\end{code}
\begin{code}
tcIdInfo unf_env in_scope_vars name ty info_ins
- = foldlTc tcPrag constantIdInfo info_ins
+ = foldlTc tcPrag vanillaIdInfo info_ins
where
tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity)
tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs)
= tcCoreExpr scrut `thenTc` \ scrut' ->
let
scrut_ty = exprType scrut'
- case_bndr' = mkVanillaId case_bndr scrut_ty
+ case_bndr' = mkLocalId case_bndr scrut_ty
in
tcExtendGlobalValEnv [case_bndr'] $
mapTc (tcCoreAlt scrut_ty) alts `thenTc` \ alts' ->
tcCoreLamBndr (UfValBinder name ty) thing_inside
= tcIfaceType ty `thenTc` \ ty' ->
let
- id = mkVanillaId name ty'
+ id = mkLocalId name ty'
in
tcExtendGlobalValEnv [id] $
thing_inside id
tcCoreValBndr (UfValBinder name ty) thing_inside
= tcIfaceType ty `thenTc` \ ty' ->
let
- id = mkVanillaId name ty'
+ id = mkLocalId name ty'
in
tcExtendGlobalValEnv [id] $
thing_inside id
tcCoreValBndrs bndrs thing_inside -- Expect them all to be ValBinders
= mapTc tcIfaceType tys `thenTc` \ tys' ->
let
- ids = zipWithEqual "tcCoreValBndr" mkVanillaId names tys'
+ ids = zipWithEqual "tcCoreValBndr" mkLocalId names tys'
in
tcExtendGlobalValEnv ids $
thing_inside ids
ppr arg_tys)
| otherwise
#endif
- = zipWithEqual "tcCoreAlts" mkVanillaId id_names arg_tys
+ = zipWithEqual "tcCoreAlts" mkLocalId id_names arg_tys
in
ASSERT( con `elem` cons && length inst_tys == length main_tyvars )
tcExtendTyVarEnv ex_tyvars' $
#include "HsVersions.h"
-import CmdLineOpts ( DynFlag(..), DynFlags, opt_PprStyle_Debug )
+import CmdLineOpts ( DynFlag(..), DynFlags )
import HsSyn ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
- Stmt(..), InPat(..), HsMatchContext(..),
+ Stmt(..), InPat(..), HsMatchContext(..), RuleDecl(..),
isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch
)
-import HsTypes ( toHsType )
import PrelNames ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName,
returnIOName, bindIOName, failIOName,
itName
zonkExpr, zonkIdBndr
)
-
+import MkIface ( pprModDetails )
import TcExpr ( tcMonoExpr )
import TcMonad
import TcType ( newTyVarTy, zonkTcType, tcInstType )
import TcBinds ( tcTopBinds )
import TcClassDcl ( tcClassDecls2 )
import TcDefaults ( tcDefaults, defaultDefaultTys )
-import TcEnv ( TcEnv, RecTcEnv, InstInfo, tcExtendGlobalValEnv, tcLookup_maybe,
+import TcEnv ( TcEnv, RecTcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, tcLookup_maybe,
isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv,
tcExtendGlobalTypeEnv, tcLookupGlobalId, tcLookupTyCon,
- TcTyThing(..), tcLookupId
+ TcTyThing(..), tcLookupId
)
import TcRules ( tcIfaceRules, tcSourceRules )
import TcForeign ( tcForeignImports, tcForeignExports )
import CoreUnfold ( unfoldingTemplate, hasUnfolding )
import TysWiredIn ( mkListTy, unitTy )
import Type
-import ErrUtils ( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, showPass )
-import Id ( Id, idType, idName, isLocalId, idUnfolding )
+import ErrUtils ( printErrorsAndWarnings, errorsFound,
+ dumpIfSet_dyn, dumpIfSet_dyn_or, showPass )
+import Id ( Id, idType, idUnfolding )
import Module ( Module, moduleName )
-import Name ( Name, toRdrName, isGlobalName )
-import Name ( nameEnvElts, lookupNameEnv )
+import Name ( Name )
+import NameEnv ( nameEnvElts, lookupNameEnv )
import TyCon ( tyConGenInfo )
-import Util
import BasicTypes ( EP(..), Fixity, RecFlag(..) )
import SrcLoc ( noSrcLoc )
import Outputable
import HscTypes ( PersistentCompilerState(..), HomeSymbolTable,
PackageTypeEnv, ModIface(..),
+ ModDetails(..), DFunId,
TypeEnv, extendTypeEnvList,
TyThing(..), implicitTyThingIds,
mkTypeEnv
)
-import Rules ( ruleBaseIds )
import VarSet
\end{code}
= TcResults {
-- All these fields have info *just for this module*
tc_env :: TypeEnv, -- The top level TypeEnv
+ tc_insts :: [DFunId], -- Instances
+ tc_rules :: [TypecheckedRuleDecl], -- Transformation rules
tc_binds :: TypecheckedMonoBinds, -- Bindings
- tc_fords :: [TypecheckedForeignDecl], -- Foreign import & exports.
- tc_rules :: [TypecheckedRuleDecl] -- Transformation rules
+ tc_fords :: [TypecheckedForeignDecl] -- Foreign import & exports.
}
returnTc (final_env,
new_pcs,
TcResults { tc_env = local_type_env,
+ tc_insts = map iDFunId local_insts,
tc_binds = implicit_binds `AndMonoBinds` all_binds',
tc_fords = foi_decls ++ foe_decls',
tc_rules = all_local_rules
-> HomeSymbolTable
-> ModIface -- Iface for this module (just module & fixities)
-> (SyntaxMap, [RenamedHsDecl])
- -> IO (Maybe (PersistentCompilerState, TypeEnv, [TypecheckedRuleDecl]))
+ -> IO (Maybe (PersistentCompilerState, ModDetails))
-- The new PCS is Augmented with imported information,
-- (but not stuff from this module).
- -- The TcResults returned contains only the environment
- -- and rules.
-
typecheckIface dflags pcs hst mod_iface (syn_map, decls)
= do { maybe_tc_stuff <- typecheck dflags syn_map pcs hst alwaysQualify $
deriv_binds, local_rules) ->
ASSERT(nullBinds deriv_binds)
let
- local_things = filter (isLocalThing this_mod)
- (nameEnvElts (getTcGEnv env))
- local_type_env :: TypeEnv
- local_type_env = mkTypeEnv local_things
- in
-
- -- throw away local_inst_info
- returnTc (new_pcs, local_type_env, local_rules)
+ local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv env))
+ mod_details = ModDetails { md_types = mkTypeEnv local_things,
+ md_insts = map iDFunId local_inst_info,
+ md_rules = [(id,rule) | IfaceRuleOut id rule <- local_rules] }
+ -- All the rules from an interface are of the IfaceRuleOut form
+ in
+ returnTc (new_pcs, mod_details)
tcImports :: RecTcEnv
-> PersistentCompilerState
RenamedHsBinds, [TypecheckedRuleDecl])
-- tcImports is a slight mis-nomer.
--- It deals with everythign that could be an import:
+-- It deals with everything that could be an import:
-- type and class decls
--- interface signatures
+-- interface signatures (checked lazily)
-- instance decls
-- rule decls
-- These can occur in source code too, of course
\begin{code}
printTcDump dflags Nothing = return ()
printTcDump dflags (Just (_, results))
- = do dumpIfSet_dyn dflags Opt_D_dump_types
- "Type signatures" (dump_sigs (tc_env results))
- dumpIfSet_dyn dflags Opt_D_dump_tc
- "Typechecked" (dump_tc results)
+ = do dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc]
+ "Interface" (dump_tc_iface results)
-printIfaceDump dflags Nothing = return ()
-printIfaceDump dflags (Just (_, env, rules))
- = do dumpIfSet_dyn dflags Opt_D_dump_types
- "Type signatures" (dump_sigs env)
dumpIfSet_dyn dflags Opt_D_dump_tc
- "Typechecked" (dump_iface env rules)
+ "Typechecked" (ppr (tc_binds results))
-dump_tc results
- = vcat [ppr (tc_binds results),
- pp_rules (tc_rules results),
- ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
- ]
+
+printIfaceDump dflags Nothing = return ()
+printIfaceDump dflags (Just (_, details))
+ = dumpIfSet_dyn_or dflags [Opt_D_dump_types, Opt_D_dump_tc]
+ "Interface" (pprModDetails details)
-dump_iface env rules
- = vcat [pp_rules rules,
- ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts env]
- ]
+dump_tc_iface results
+ = vcat [pprModDetails (ModDetails {md_types = tc_env results,
+ md_insts = tc_insts results,
+ md_rules = []}) ,
+ ppr_rules (tc_rules results),
-dump_sigs env -- Print type signatures
- = -- Convert to HsType so that we get source-language style printing
- -- And sort by RdrName
- vcat $ map ppr_sig $ sortLt lt_sig $
- [ (toRdrName id, toHsType (idType id))
- | AnId id <- nameEnvElts env,
- want_sig id
+ ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
]
- where
- lt_sig (n1,_) (n2,_) = n1 < n2
- ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
- want_sig id | opt_PprStyle_Debug = True
- | otherwise = isLocalId id && isGlobalName (idName id)
- -- isLocalId ignores data constructors, records selectors etc
- -- The isGlobalName ignores local dictionary and method bindings
- -- that the type checker has invented. User-defined things have
- -- Global names.
+ppr_rules [] = empty
+ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
+ nest 4 (vcat (map ppr rs)),
+ ptext SLIT("#-}")]
ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
vcat (map ppr_gen_tycon tcs),
where
(_,from_tau) = splitForAllTys (idType from)
-pp_rules [] = empty
-pp_rules rs = vcat [ptext SLIT("{-# RULES"),
- nest 4 (vcat (map ppr rs)),
- ptext SLIT("#-}")]
\end{code}
import PprType ( pprType, pprPred )
import Subst ( mkTopTyVarSubst, substTy )
import CoreFVs ( idFreeTyVars )
-import Id ( mkVanillaId, idName, idType )
+import Id ( mkLocalId, idName, idType )
import Var ( Id, Var, TyVar, mkTyVar, tyVarKind )
import VarEnv
import VarSet
= tcAddSrcLoc src_loc $
tcAddErrCtxt (tcsigCtxt v) $
tcHsSigType ty `thenTc` \ sigma_tc_ty ->
- mkTcSig (mkVanillaId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig ->
+ mkTcSig (mkLocalId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig ->
returnTc sig
mkTcSig :: TcId -> SrcLoc -> NF_TcM TcSigInfo
emptyLIE, plusLIE, LIE, mkLIE, unitLIE, instToId,
newMethod, newOverloadedLit, newDicts, newClassDicts
)
-import Id ( mkVanillaId )
+import Id ( mkLocalId )
import Name ( Name )
import FieldLabel ( fieldLabelName )
import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupSyntaxId )
-- This is the right function to pass to tcPat when
-- we're looking at a lambda-bound pattern,
-- so there's no polymorphic guy to worry about
-tcMonoPatBndr binder_name pat_ty = returnTc (mkVanillaId binder_name pat_ty)
+tcMonoPatBndr binder_name pat_ty = returnTc (mkLocalId binder_name pat_ty)
\end{code}
import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv, isLocalThing )
import Rules ( extendRuleBase )
import Inst ( LIE, plusLIEs, instToId )
-import Id ( idName, idType, mkVanillaId )
+import Id ( idName, idType, mkLocalId )
import Module ( Module )
import VarSet
import Type ( tyVarsOfTypes, openTypeKind )
sig_tys = [t | RuleBndrSig _ t <- vars]
new_id (RuleBndr var) = newTyVarTy openTypeKind `thenNF_Tc` \ ty ->
- returnNF_Tc (mkVanillaId var ty)
+ returnNF_Tc (mkLocalId var ty)
new_id (RuleBndrSig var rn_ty) = tcHsSigType rn_ty `thenTc` \ ty ->
- returnNF_Tc (mkVanillaId var ty)
+ returnNF_Tc (mkLocalId var ty)
ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>
doubleQuotes (ptext name)
import FiniteMap
import Digraph ( stronglyConnComp, SCC(..) )
import Name ( Name, getSrcLoc, isTyVarName )
-import Name ( NameEnv, mkNameEnv, lookupNameEnv_NF )
+import NameEnv ( NameEnv, mkNameEnv, lookupNameEnv_NF )
import NameSet
import Outputable
import Maybes ( mapMaybe )
import BasicTypes ( EP(..), Boxity(..) )
import Var ( TyVar )
import VarSet ( varSetElems )
-import Id ( Id, mkTemplateLocal, idType, idName,
- mkTemplateLocalsNum, mkId
+import Id ( Id, mkVanillaGlobal, idType, idName,
+ mkTemplateLocal, mkTemplateLocalsNum
)
import TysWiredIn ( genericTyCons,
genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
inlDataCon, crossTyCon, crossDataCon
)
-import IdInfo ( constantIdInfo, setUnfoldingInfo )
+import IdInfo ( noCafOrTyGenIdInfo, setUnfoldingInfo )
import CoreUnfold ( mkTopUnfolding )
import Unique ( mkBuiltinUnique )
= Nothing
| otherwise
- = Just (EP { fromEP = mkId from_name from_ty from_id_info,
- toEP = mkId to_name to_ty to_id_info })
+ = Just (EP { fromEP = mkVanillaGlobal from_name from_ty from_id_info,
+ toEP = mkVanillaGlobal to_name to_ty to_id_info })
where
tyvars = tyConTyVars tycon -- [a, b, c]
datacons = tyConDataConsIfAvailable tycon -- [C, D]
tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c
tyvar_tys = mkTyVarTys tyvars
- from_id_info = constantIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
- to_id_info = constantIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
+ from_id_info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
+ to_id_info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
import UConSet
import CoreSyn
-import CoreFVs ( mustHaveLocalBinding )
import Rules ( RuleBase )
import TypeRep ( Type(..), TyNote(..) ) -- friend
import Type ( applyTy, applyTys,
{- ENTIRE FILE COMMENTED OUT FOR NOW -- KSW 2000-10-13
import CoreSyn
-import CoreFVs ( mustHaveLocalBinding )
import Var ( Var, varType, setVarType, mkUVar )
import Id ( isExportedId )
import Name ( isLocallyDefined )
projects / ghc-hetmet.git / commitdiff