Reorganisation of Id, IdInfo. Remove StdIdInfo, PragmaInfo; add basicTypes/MkId.lhs
import CgRetConv ( CtrlReturnConvention(..), ctrlReturnConvAlg )
import CStrings ( pp_cSEP )
import Id ( externallyVisibleId,
- isDataCon, isDictFunId,
- isDefaultMethodId_maybe,
+ isDataCon,
fIRST_TAG,
ConTag,
Id
)
import Maybes ( maybeToBool )
-import PprType ( showTyCon, GenType{-instance Outputable-} )
-import TyCon ( TyCon{-instance Eq-} )
-import Unique ( showUnique, pprUnique, Unique{-instance Eq-} )
+import PprType ( showTyCon )
+import TyCon ( TyCon )
+import Unique ( showUnique, pprUnique, Unique )
import Util ( assertPanic{-, pprTraceToDo:rm-} )
import Outputable
\end{code}
-- The type in the FieldLabel for op1 will be simply (a->a).
FieldLabelTag -- Indicates position within constructor
+ -- (starting with firstFieldLabelTag)
+ --
-- If the same field occurs in more than one constructor
-- then it'll have a separate FieldLabel on each occasion,
-- but with a single name (and presumably the same type!)
firstFieldLabelTag = 1
allFieldLabelTags :: [FieldLabelTag]
-allFieldLabelTags = [1..]
+allFieldLabelTags = [firstFieldLabelTag..]
fieldLabelName (FieldLabel n _ _) = n
fieldLabelType (FieldLabel _ ty _) = ty
_interface_ Id 1
_exports_
-Id Id GenId StrictnessMark(MarkedStrict NotMarkedStrict) dataConArgTys idType isNullaryDataCon mkDataCon mkTupleCon pprId idName;
+Id Id GenId StrictnessMark(MarkedStrict NotMarkedStrict) idType isNullaryDataCon mkDataCon mkTupleCon pprId idName;
_declarations_
1 type Id = Id.GenId Type!Type ;
1 data GenId ty ;
1 data StrictnessMark = MarkedStrict | NotMarkedStrict ;
--- Not needed any more by Type.lhs
--- 1 dataConArgTys _:_ Id -> [Type!Type] -> [Type!Type] ;;
-
1 idType _:_ Id.Id -> Type!Type ;;
1 isNullaryDataCon _:_ Id -> PrelBase.Bool ;;
1 mkDataCon _:_ Name.Name -> [Id.StrictnessMark] -> [FieldLabel!FieldLabel] -> [TyVar.TyVar] -> Type.ThetaType -> [TyVar.TyVar] -> Type!ThetaType -> [Type!TauType] -> TyCon!TyCon -> Id ;;
\begin{code}
module Id (
-- TYPES
- GenId(..), -- *naughtily* used in some places (e.g., TcHsSyn)
- Id, IdDetails,
+ GenId, -- Abstract
+ Id,
+ IdDetails(..), -- Exposed only to MkId
StrictnessMark(..),
ConTag, fIRST_TAG,
DataCon, DictFun, DictVar,
- -- CONSTRUCTION
- mkDataCon,
- mkDefaultMethodId,
- mkDictFunId,
- mkIdWithNewUniq, mkIdWithNewName, mkIdWithNewType,
- mkImported,
- mkMethodSelId,
- mkRecordSelId,
- mkSuperDictSelId,
- mkSysLocal,
- mkTemplateLocals,
- mkTupleCon,
- mkUserId,
- mkUserLocal,
- mkPrimitiveId,
- mkWorkerId,
- setIdVisibility,
+ -- Construction and modification
+ mkId, mkIdWithNewUniq, mkIdWithNewName, mkIdWithNewType,
+ mkTemplateLocals,
+ setIdVisibility, mkVanillaId,
-- DESTRUCTION (excluding pragmatic info)
idPrimRep,
idUnique,
idName,
+ -- Extracting pieces of particular sorts of Ids
dataConRepType,
dataConArgTys,
dataConNumFields,
idWantsToBeINLINEd, getInlinePragma,
idMustBeINLINEd, idMustNotBeINLINEd,
isBottomingId,
- isDataCon, isAlgCon, isNewCon,
- isDefaultMethodId,
- isDefaultMethodId_maybe,
- isDictFunId,
- isImportedId,
- isRecordSelector,
- isDictSelId_maybe,
+
+ isDataCon, isAlgCon, isNewCon, isTupleCon,
isNullaryDataCon,
+
+ isRecordSelector, isSpecPragmaId,
isPrimitiveId_maybe,
- isSysLocalId,
- isTupleCon,
- isWrapperId,
- toplevelishId,
- unfoldingUnfriendlyId,
-- PRINTING and RENUMBERING
pprId,
showId,
- -- Specialialisation
- getIdSpecialisation,
- setIdSpecialisation,
-
-- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
+ idInfo,
addIdUnfolding,
addIdArity,
addIdDemandInfo,
addIdUpdateInfo,
getIdArity,
getIdDemandInfo,
- getIdInfo,
getIdStrictness,
getIdUnfolding,
getIdUpdateInfo,
- getPragmaInfo,
- replaceIdInfo, replacePragmaInfo,
+ replaceIdInfo,
addInlinePragma, nukeNoInlinePragma, addNoInlinePragma,
+ getIdSpecialisation,
+ setIdSpecialisation,
-- IdEnvs AND IdSets
IdEnv, GenIdSet, IdSet,
#include "HsVersions.h"
import {-# SOURCE #-} CoreUnfold ( Unfolding )
-import {-# SOURCE #-} StdIdInfo ( addStandardIdInfo )
import CmdLineOpts ( opt_PprStyle_All )
-import SpecEnv ( SpecEnv )
import Bag
-import Class ( Class )
-import BasicTypes ( Arity )
import IdInfo
-import Maybes ( maybeToBool )
-import Name ( nameUnique, mkLocalName, mkSysLocalName, isLocalName,
- mkCompoundName, occNameString, modAndOcc,
- changeUnique, isWiredInName, setNameVisibility,
+import Name ( nameUnique, isLocalName, mkSysLocalName,
+ isWiredInName, setNameVisibility,
ExportFlag(..), Provenance,
OccName(..), Name, Module,
NamedThing(..)
)
import PrimOp ( PrimOp )
import PrelMods ( pREL_TUP, pREL_BASE )
-import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} )
-import PragmaInfo ( PragmaInfo(..) )
+import FieldLabel ( fieldLabelName, FieldLabel(..) )
import SrcLoc ( mkBuiltinSrcLoc )
import TysWiredIn ( tupleTyCon )
-import TyCon ( TyCon, tyConDataCons, isDataTyCon, isNewTyCon, mkSpecTyCon )
+import TyCon ( TyCon, isDataTyCon, isNewTyCon )
import Type ( mkSigmaTy, mkTyVarTys, mkFunTys,
mkTyConApp, instantiateTy, mkForAllTys,
tyVarsOfType, instantiateTy, typePrimRep,
instantiateTauTy,
- GenType, ThetaType, TauType, Type
+ ThetaType, TauType, Type, GenType
)
import TyVar ( TyVar, alphaTyVars, isEmptyTyVarSet,
TyVarEnv, zipTyVarEnv, mkTyVarEnv
)
import UniqFM
import UniqSet -- practically all of it
-import Unique ( getBuiltinUniques, Unique, Uniquable(..) )
+import Unique ( Unique, Uniquable(..), getBuiltinUniques )
import Outputable
import SrcLoc ( SrcLoc )
import Util ( nOfThem, assoc )
ToDo: possibly cache other stuff in the single-constructor @Id@ type.
\begin{code}
-data GenId ty = Id
- Unique -- Key for fast comparison
- Name
- ty -- Id's type; used all the time;
- IdDetails -- Stuff about individual kinds of Ids.
- PragmaInfo -- Properties of this Id requested by programmer
- -- eg specialise-me, inline-me
- IdInfo -- Properties of this Id deduced by compiler
+data GenId ty = Id {
+ idUnique :: Unique, -- Key for fast comparison
+ idName :: Name,
+ idType :: ty, -- Id's type; used all the time;
+ idDetails :: IdDetails, -- Stuff about individual kinds of Ids.
+ idInfo :: IdInfo -- Properties of this Id deduced by compiler
+ }
type Id = GenId Type
---------------- Local values
- = LocalId Bool -- Local name; mentioned by the user
+ = VanillaId Bool -- Ordinary Id
-- True <=> no free type vars
- | SysLocalId Bool -- Local name; made up by the compiler
- -- as for LocalId
-
| PrimitiveId PrimOp -- The Id for a primitive operation
- ---------------- Global values
-
- | ImportedId -- Global name (Imported or Implicit); Id imported from an interface
-
---------------- Data constructors
| AlgConId -- Used for both data and newtype constructors.
| RecordSelId FieldLabel
- ---------------- Things to do with overloading
+ | SpecPragmaId -- This guy 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.
- | DictSelId -- Selector that extracts a method or superclass from a dictionary
- Class -- The class
-
- | DefaultMethodId -- Default method for a particular class op
- Class -- same class, <blah-blah> info as MethodSelId
-
- -- see below
- | DictFunId Class -- A DictFun is uniquely identified
- [Type] -- by its class and type; this type has free type vars,
- -- whose identity is irrelevant. Eg Class = Eq
- -- Type = Tree a
- -- The "a" is irrelevant. As it is too painful to
- -- actually do comparisons that way, we kindly supply
- -- a Unique for that purpose.
type ConTag = Int
type DataCon = Id
\end{code}
-DictFunIds are generated from instance decls.
-\begin{verbatim}
- class Foo a where
- op :: a -> a -> Bool
-
- instance Foo a => Foo [a] where
- op = ...
-\end{verbatim}
-generates the dict fun id decl
-\begin{verbatim}
- dfun.Foo.[*] = \d -> ...
-\end{verbatim}
-The dfun id is uniquely named by the (class, type) pair. Notice, it
-isn't a (class,tycon) pair any more, because we may get manually or
-automatically generated specialisations of the instance decl:
-\begin{verbatim}
- instance Foo [Int] where
- op = ...
-\end{verbatim}
-generates
-\begin{verbatim}
- dfun.Foo.[Int] = ...
-\end{verbatim}
-The type variables in the name are irrelevant; we print them as stars.
-
%************************************************************************
%* *
-\subsection[Id-documentation]{Documentation}
+\subsection{Construction}
%* *
%************************************************************************
-[A BIT DATED [WDP]]
-
-The @Id@ datatype describes {\em values}. The basic things we want to
-know: (1)~a value's {\em type} (@idType@ is a very common
-operation in the compiler); and (2)~what ``flavour'' of value it might
-be---for example, it can be terribly useful to know that a value is a
-class method.
-
-\begin{description}
-%----------------------------------------------------------------------
-\item[@AlgConId@:] For the data constructors declared by a @data@
-declaration. Their type is kept in {\em two} forms---as a regular
-@Type@ (in the usual place), and also in its constituent pieces (in
-the ``details''). We are frequently interested in those pieces.
-
-%----------------------------------------------------------------------
-\item[@TupleConId@:] This is just a special shorthand for @DataCons@ for
-the infinite family of tuples.
-
-%----------------------------------------------------------------------
-\item[@ImportedId@:] These are values defined outside this module.
-{\em Everything} we want to know about them must be stored here (or in
-their @IdInfo@).
-
-%----------------------------------------------------------------------
-\item[@MethodSelId@:] A selector from a dictionary; it may select either
-a method or a dictionary for one of the class's superclasses.
-
-%----------------------------------------------------------------------
-\item[@DictFunId@:]
-
-@mkDictFunId [a,b..] theta C T@ is the function derived from the
-instance declaration
-
- instance theta => C (T a b ..) where
- ...
-
-It builds function @Id@ which maps dictionaries for theta,
-to a dictionary for C (T a b ..).
-
-*Note* that with the ``Mark Jones optimisation'', the theta may
-include dictionaries for the immediate superclasses of C at the type
-(T a b ..).
-
-%----------------------------------------------------------------------
-\item[@LocalId@:] A purely-local value, e.g., a function argument,
-something defined in a @where@ clauses, ... --- but which appears in
-the original program text.
-
-%----------------------------------------------------------------------
-\item[@SysLocalId@:] Same as a @LocalId@, except does {\em not} appear in
-the original program text; these are introduced by the compiler in
-doing its thing.
-\end{description}
-
-Further remarks:
-\begin{enumerate}
-%----------------------------------------------------------------------
-\item
-
-@DataCons@ @TupleCons@, @Importeds@, @SuperDictSelIds@,
-@MethodSelIds@, @DictFunIds@, and @DefaultMethodIds@ have the following
-properties:
-\begin{itemize}
-\item
-They have no free type variables, so if you are making a
-type-variable substitution you don't need to look inside them.
-\item
-They are constants, so they are not free variables. (When the STG
-machine makes a closure, it puts all the free variables in the
-closure; the above are not required.)
-\end{itemize}
-Note that @Locals@ and @SysLocals@ {\em may} have the above
-properties, but they may not.
-\end{enumerate}
+\begin{code}
+mkId :: Name -> ty -> IdDetails -> IdInfo -> GenId ty
+mkId name ty details info
+ = Id {idName = name, idUnique = nameUnique name, idType = ty,
+ idDetails = details, idInfo = info}
+
+mkVanillaId :: Name -> (GenType flexi) -> IdInfo -> GenId (GenType flexi)
+mkVanillaId name ty info
+ = Id {idName = name, idUnique = nameUnique name, idType = ty,
+ idDetails = VanillaId (isEmptyTyVarSet (tyVarsOfType ty)),
+ idInfo = info}
+
+mkIdWithNewUniq :: Id -> Unique -> Id
+mkIdWithNewUniq id uniq = id {idUnique = uniq}
+
+mkIdWithNewName :: Id -> Name -> Id
+mkIdWithNewName id new_name
+ = id {idUnique = uniqueOf new_name, idName = new_name}
+
+mkIdWithNewType :: GenId ty1 -> ty2 -> GenId ty2
+mkIdWithNewType id ty = id {idType = ty}
+\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}
+mkTemplateLocals :: [Type] -> [Id]
+mkTemplateLocals tys
+ = zipWith mk (getBuiltinUniques (length tys)) tys
+ where
+ mk uniq ty = mkVanillaId (mkSysLocalName uniq SLIT("tpl") mkBuiltinSrcLoc)
+ ty noIdInfo
+\end{code}
+
+
+\begin{code}
+-- See notes with setNameVisibility (Name.lhs)
+setIdVisibility :: Maybe Module -> Unique -> Id -> Id
+setIdVisibility maybe_mod u id
+ = id {idName = setNameVisibility maybe_mod u (idName id)}
+
+replaceIdInfo :: GenId ty -> IdInfo -> GenId ty
+replaceIdInfo id info = id {idInfo = info}
+\end{code}
%************************************************************************
%* *
%************************************************************************
\begin{code}
+fIRST_TAG :: ConTag
+fIRST_TAG = 1 -- Tags allocated from here for real constructors
+
-- isDataCon returns False for @newtype@ constructors
-isDataCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ tc) _ _) = isDataTyCon tc
-isDataCon (Id _ _ _ (TupleConId _) _ _) = True
-isDataCon other = False
+isDataCon (Id {idDetails = AlgConId _ _ _ _ _ _ _ _ tc}) = isDataTyCon tc
+isDataCon (Id {idDetails = TupleConId _}) = True
+isDataCon other = False
-isNewCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ tc) _ _) = isNewTyCon tc
-isNewCon other = False
+isNewCon (Id {idDetails = AlgConId _ _ _ _ _ _ _ _ tc}) = isNewTyCon tc
+isNewCon other = False
-- isAlgCon returns True for @data@ or @newtype@ constructors
-isAlgCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ _) _ _) = True
-isAlgCon (Id _ _ _ (TupleConId _) _ _) = True
-isAlgCon other = False
+isAlgCon (Id {idDetails = AlgConId _ _ _ _ _ _ _ _ _}) = True
+isAlgCon (Id {idDetails = TupleConId _}) = True
+isAlgCon other = False
-isTupleCon (Id _ _ _ (TupleConId _) _ _) = True
-isTupleCon other = False
+isTupleCon (Id {idDetails = TupleConId _}) = True
+isTupleCon other = False
\end{code}
-@toplevelishId@ tells whether an @Id@ {\em may} be defined in a nested
-@let(rec)@ (returns @False@), or whether it is {\em sure} to be
-defined at top level (returns @True@). This is used to decide whether
-the @Id@ is a candidate free variable. NB: you are only {\em sure}
-about something if it returns @True@!
-
\begin{code}
-toplevelishId :: Id -> Bool
idHasNoFreeTyVars :: Id -> Bool
-toplevelishId (Id _ _ _ details _ _)
- = chk details
- where
- chk (AlgConId _ __ _ _ _ _ _ _) = True
- chk (TupleConId _) = True
- chk (RecordSelId _) = True
- chk ImportedId = True
- chk (DictSelId _) = True
- chk (DefaultMethodId _) = True
- chk (DictFunId _ _) = True
- chk (LocalId _) = False
- chk (SysLocalId _) = False
- chk (PrimitiveId _) = True
-
-idHasNoFreeTyVars (Id _ _ _ details _ info)
+idHasNoFreeTyVars (Id {idDetails = details})
= chk details
where
chk (AlgConId _ _ _ _ _ _ _ _ _) = True
- chk (TupleConId _) = True
- chk (RecordSelId _) = True
- chk ImportedId = True
- chk (DictSelId _) = True
- chk (DefaultMethodId _) = True
- chk (DictFunId _ _) = True
- chk (LocalId no_free_tvs) = no_free_tvs
- chk (SysLocalId no_free_tvs) = no_free_tvs
- chk (PrimitiveId _) = True
+ chk (TupleConId _) = True
+ chk (RecordSelId _) = True
+ chk (VanillaId no_free_tvs) = no_free_tvs
+ chk (PrimitiveId _) = True
+ chk SpecPragmaId = False -- Play safe
-- omitIfaceSigForId 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
:: Id
-> Bool
-omitIfaceSigForId (Id _ name _ details _ _)
+omitIfaceSigForId (Id {idName = name, idDetails = details})
| isWiredInName name
= True
| otherwise
= case details of
- ImportedId -> True -- Never put imports in interface file
(PrimitiveId _) -> True -- Ditto, for primitives
-- This group is Ids that are implied by their type or class decl;
(AlgConId _ _ _ _ _ _ _ _ _) -> True
(TupleConId _) -> True
(RecordSelId _) -> True
- (DictSelId _) -> True
other -> False -- Don't omit!
-- NB DefaultMethodIds are not omitted
\end{code}
\begin{code}
-isImportedId (Id _ _ _ ImportedId _ _) = True
-isImportedId other = False
-
-isBottomingId (Id _ _ _ _ _ info) = bottomIsGuaranteed (strictnessInfo info)
-
-isSysLocalId (Id _ _ _ (SysLocalId _) _ _) = True
-isSysLocalId other = False
-
-isDictSelId_maybe (Id _ _ _ (DictSelId cls) _ _) = Just cls
-isDictSelId_maybe _ = Nothing
-
-isDefaultMethodId (Id _ _ _ (DefaultMethodId _) _ _) = True
-isDefaultMethodId other = False
-
-isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls) _ _)
- = Just cls
-isDefaultMethodId_maybe other = Nothing
-
-isDictFunId (Id _ _ _ (DictFunId _ _) _ _) = True
-isDictFunId other = False
-
-isWrapperId id = workerExists (getIdStrictness id)
-
-isPrimitiveId_maybe (Id _ _ _ (PrimitiveId primop) _ _) = Just primop
-isPrimitiveId_maybe other = Nothing
-\end{code}
+isBottomingId id = bottomIsGuaranteed (strictnessInfo (idInfo id))
-\begin{code}
-unfoldingUnfriendlyId -- return True iff it is definitely a bad
- :: Id -- idea to export an unfolding that
- -> Bool -- mentions this Id. Reason: it cannot
- -- possibly be seen in another module.
+isPrimitiveId_maybe (Id {idDetails = PrimitiveId primop}) = Just primop
+isPrimitiveId_maybe other = Nothing
-unfoldingUnfriendlyId id = not (externallyVisibleId id)
+isSpecPragmaId (Id {idDetails = SpecPragmaId}) = True
+isSpecPragmaId _ = False
\end{code}
@externallyVisibleId@: is it true that another module might be
\begin{code}
externallyVisibleId :: Id -> Bool
-externallyVisibleId id@(Id _ name _ _ _ _) = not (isLocalName name)
+externallyVisibleId id = not (isLocalName (idName id))
-- not local => global => externally visible
\end{code}
-%************************************************************************
-%* *
-\subsection[Id-type-funs]{Type-related @Id@ functions}
-%* *
-%************************************************************************
-
\begin{code}
-idName :: GenId ty -> Name
-idName (Id _ n _ _ _ _) = n
-
-idType :: GenId ty -> ty
-idType (Id _ _ ty _ _ _) = ty
-
-idPrimRep i = typePrimRep (idType i)
+idPrimRep id = typePrimRep (idType id)
\end{code}
-%************************************************************************
-%* *
-\subsection[Id-overloading]{Functions related to overloading}
-%* *
-%************************************************************************
-
-\begin{code}
-mkSuperDictSelId :: Unique -> Class -> Int -> Type -> Id
- -- The Int is an arbitrary tag to say which superclass is selected
- -- So, for
- -- class (C a, C b) => Foo a b where ...
- -- we get superclass selectors
- -- Foo_sc1, Foo_sc2
-
-mkSuperDictSelId u clas index ty
- = addStandardIdInfo $
- Id u name ty details NoPragmaInfo noIdInfo
- where
- name = mkCompoundName name_fn u (getName clas)
- details = DictSelId clas
- name_fn clas_str = clas_str _APPEND_ SLIT("_sc") _APPEND_ (_PK_ (show index))
-
- -- For method selectors the clean thing to do is
- -- to give the method selector the same name as the class op itself.
-mkMethodSelId op_name clas ty
- = addStandardIdInfo $
- Id (uniqueOf op_name) op_name ty (DictSelId clas) NoPragmaInfo noIdInfo
-
-mkDefaultMethodId dm_name rec_c ty
- = Id (uniqueOf dm_name) dm_name ty (DefaultMethodId rec_c) NoPragmaInfo noIdInfo
-
-mkDictFunId dfun_name full_ty clas itys
- = Id (nameUnique dfun_name) dfun_name full_ty details NoPragmaInfo noIdInfo
- where
- details = DictFunId clas itys
-
-mkWorkerId u unwrkr ty info
- = Id u name ty details NoPragmaInfo info
- where
- details = LocalId (no_free_tvs ty)
- name = mkCompoundName name_fn u (getName unwrkr)
- name_fn wkr_str = SLIT("$w") _APPEND_ wkr_str
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[local-funs]{@LocalId@-related functions}
-%* *
-%************************************************************************
-
-\begin{code}
-mkImported n ty info = Id (nameUnique n) n ty ImportedId NoPragmaInfo info
-
-mkPrimitiveId n ty primop
- = addStandardIdInfo $
- Id (nameUnique n) n ty (PrimitiveId primop) IMustBeINLINEd noIdInfo
- -- The pragma @IMustBeINLINEd@ says that this Id absolutely must be inlined.
- -- It's only true for primitives, because we don't want to make a closure for each of them.
-
-\end{code}
-
-\begin{code}
-no_free_tvs ty = isEmptyTyVarSet (tyVarsOfType ty)
-
--- SysLocal: for an Id being created by the compiler out of thin air...
--- UserLocal: an Id with a name the user might recognize...
-mkSysLocal :: FAST_STRING -> Unique -> GenType flexi -> SrcLoc -> GenId (GenType flexi)
-mkUserLocal :: OccName -> Unique -> GenType flexi -> SrcLoc -> GenId (GenType flexi)
-
-mkSysLocal str uniq ty loc
- = Id uniq (mkSysLocalName uniq str loc) ty (SysLocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
-
-mkUserLocal occ uniq ty loc
- = Id uniq (mkLocalName uniq occ loc) ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
-
-mkUserId :: Name -> GenType flexi -> GenId (GenType flexi)
-mkUserId name ty
- = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) NoPragmaInfo noIdInfo
-\end{code}
-
-\begin{code}
--- See notes with setNameVisibility (Name.lhs)
-setIdVisibility :: Maybe Module -> Unique -> Id -> Id
-setIdVisibility maybe_mod u (Id uniq name ty details prag info)
- = Id uniq (setNameVisibility maybe_mod u name) ty details prag info
-
-mkIdWithNewUniq :: Id -> Unique -> Id
-mkIdWithNewUniq (Id _ n ty details prag info) u
- = Id u (changeUnique n u) ty details prag info
-
-mkIdWithNewName :: Id -> Name -> Id
-mkIdWithNewName (Id _ _ ty details prag info) new_name
- = Id (uniqueOf new_name) new_name ty details prag info
-
-mkIdWithNewType :: Id -> Type -> Id
-mkIdWithNewType (Id u name _ details pragma info) ty
- = Id u name ty details pragma info
-\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}
-mkTemplateLocals :: [Type] -> [Id]
-mkTemplateLocals tys
- = zipWith (\ u -> \ ty -> mkSysLocal SLIT("tpl") u ty mkBuiltinSrcLoc)
- (getBuiltinUniques (length tys))
- tys
-\end{code}
-
-\begin{code}
-getIdInfo :: GenId ty -> IdInfo
-getPragmaInfo :: GenId ty -> PragmaInfo
-
-getIdInfo (Id _ _ _ _ _ info) = info
-getPragmaInfo (Id _ _ _ _ info _) = info
-
-replaceIdInfo :: Id -> IdInfo -> Id
-replaceIdInfo (Id u n ty details pinfo _) info = Id u n ty details pinfo info
-
-replacePragmaInfo :: GenId ty -> PragmaInfo -> GenId ty
-replacePragmaInfo (Id u sn ty details _ info) prag = Id u sn ty details prag info
-\end{code}
%************************************************************************
%* *
\begin{code}
getIdArity :: Id -> ArityInfo
-getIdArity id@(Id _ _ _ _ _ id_info)
- = arityInfo id_info
+getIdArity id = arityInfo (idInfo id)
addIdArity :: Id -> ArityInfo -> Id
-addIdArity (Id u n ty details pinfo info) arity
- = Id u n ty details pinfo (info `addArityInfo` arity)
+addIdArity id@(Id {idInfo = info}) arity
+ = id {idInfo = arity `setArityInfo` info}
\end{code}
%************************************************************************
%* *
%************************************************************************
-\begin{code}
-mkDataCon :: Name
- -> [StrictnessMark] -> [FieldLabel]
- -> [TyVar] -> ThetaType
- -> [TyVar] -> ThetaType
- -> [TauType] -> TyCon
- -> Id
- -- can get the tag and all the pieces of the type from the Type
-
-mkDataCon n stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon
- = ASSERT(length stricts == length args_tys)
- addStandardIdInfo data_con
- where
- -- NB: data_con self-recursion; should be OK as tags are not
- -- looked at until late in the game.
- data_con
- = Id (nameUnique n)
- n
- data_con_ty
- (AlgConId data_con_tag stricts fields tvs ctxt con_tvs con_ctxt args_tys tycon)
- IWantToBeINLINEd -- Always inline constructors if possible
- noIdInfo
-
- data_con_tag = assoc "mkDataCon" (data_con_family `zip` [fIRST_TAG..]) data_con
- data_con_family = tyConDataCons tycon
-
- data_con_ty
- = mkSigmaTy (tvs++con_tvs) (ctxt++con_ctxt)
- (mkFunTys args_tys (mkTyConApp tycon (mkTyVarTys tvs)))
-
-
-mkTupleCon :: Arity -> Name -> Type -> Id
-mkTupleCon arity name ty
- = addStandardIdInfo tuple_id
- where
- tuple_id = Id (nameUnique name) name ty
- (TupleConId arity)
- IWantToBeINLINEd -- Always inline constructors if possible
- noIdInfo
-
-fIRST_TAG :: ConTag
-fIRST_TAG = 1 -- Tags allocated from here for real constructors
-\end{code}
dataConNumFields gives the number of actual fields in the
{\em representation} of the data constructor. This may be more than appear
\begin{code}
dataConTag :: DataCon -> ConTag -- will panic if not a DataCon
-dataConTag (Id _ _ _ (AlgConId tag _ _ _ _ _ _ _ _) _ _) = tag
-dataConTag (Id _ _ _ (TupleConId _) _ _) = fIRST_TAG
+dataConTag (Id {idDetails = AlgConId tag _ _ _ _ _ _ _ _}) = tag
+dataConTag (Id {idDetails = TupleConId _}) = fIRST_TAG
dataConTyCon :: DataCon -> TyCon -- will panic if not a DataCon
-dataConTyCon (Id _ _ _ (AlgConId _ _ _ _ _ _ _ _ tycon) _ _) = tycon
-dataConTyCon (Id _ _ _ (TupleConId a) _ _) = tupleTyCon a
+dataConTyCon (Id {idDetails = AlgConId _ _ _ _ _ _ _ _ tycon}) = tycon
+dataConTyCon (Id {idDetails = TupleConId a}) = tupleTyCon a
dataConSig :: DataCon -> ([TyVar], ThetaType, [TyVar], ThetaType, [TauType], TyCon)
-- will panic if not a DataCon
-dataConSig (Id _ _ _ (AlgConId _ _ _ tyvars theta con_tyvars con_theta arg_tys tycon) _ _)
+dataConSig (Id {idDetails = AlgConId _ _ _ tyvars theta con_tyvars con_theta arg_tys tycon})
= (tyvars, theta, con_tyvars, con_theta, arg_tys, tycon)
-dataConSig (Id _ _ _ (TupleConId arity) _ _)
+dataConSig (Id {idDetails = TupleConId arity})
= (tyvars, [], [], [], tyvar_tys, tupleTyCon arity)
where
tyvars = take arity alphaTyVars
-- Actually, the unboxed part isn't implemented yet!
dataConRepType :: Id -> Type
-dataConRepType (Id _ _ _ (AlgConId _ _ _ tyvars theta con_tyvars con_theta arg_tys tycon) _ _)
+dataConRepType (Id {idDetails = AlgConId _ _ _ tyvars theta con_tyvars con_theta arg_tys tycon})
= mkForAllTys (tyvars++con_tyvars)
(mkFunTys arg_tys (mkTyConApp tycon (mkTyVarTys tyvars)))
dataConRepType other_id
idType other_id
dataConFieldLabels :: DataCon -> [FieldLabel]
-dataConFieldLabels (Id _ _ _ (AlgConId _ _ fields _ _ _ _ _ _) _ _) = fields
-dataConFieldLabels (Id _ _ _ (TupleConId _) _ _) = []
+dataConFieldLabels (Id {idDetails = AlgConId _ _ fields _ _ _ _ _ _}) = fields
+dataConFieldLabels (Id {idDetails = TupleConId _}) = []
#ifdef DEBUG
-dataConFieldLabels x@(Id _ _ _ idt _ _) =
+dataConFieldLabels x@(Id {idDetails = idt}) =
panic ("dataConFieldLabel: " ++
(case idt of
- LocalId _ -> "l"
- SysLocalId _ -> "sl"
+ VanillaId _ -> "l"
PrimitiveId _ -> "p"
- ImportedId -> "i"
- RecordSelId _ -> "r"
- DictSelId _ -> "m"
- DefaultMethodId _ -> "d"
- DictFunId _ _ -> "di"))
+ RecordSelId _ -> "r"))
#endif
dataConStrictMarks :: DataCon -> [StrictnessMark]
-dataConStrictMarks (Id _ _ _ (AlgConId _ stricts _ _ _ _ _ _ _) _ _) = stricts
-dataConStrictMarks (Id _ _ _ (TupleConId arity) _ _)
- = nOfThem arity NotMarkedStrict
+dataConStrictMarks (Id {idDetails = AlgConId _ stricts _ _ _ _ _ _ _}) = stricts
+dataConStrictMarks (Id {idDetails = TupleConId arity}) = nOfThem arity NotMarkedStrict
dataConRawArgTys :: DataCon -> [TauType] -- a function of convenience
dataConRawArgTys con = case (dataConSig con) of { (_,_, _, _, arg_tys,_) -> arg_tys }
\end{code}
\begin{code}
-mkRecordSelId field_label selector_ty
- = addStandardIdInfo $ -- Record selectors have a standard unfolding
- Id (nameUnique name)
- name
- selector_ty
- (RecordSelId field_label)
- NoPragmaInfo
- noIdInfo
- where
- name = fieldLabelName field_label
-
recordSelectorFieldLabel :: Id -> FieldLabel
-recordSelectorFieldLabel (Id _ _ _ (RecordSelId lbl) _ _) = lbl
+recordSelectorFieldLabel (Id {idDetails = RecordSelId lbl}) = lbl
-isRecordSelector (Id _ _ _ (RecordSelId lbl) _ _) = True
-isRecordSelector other = False
+isRecordSelector (Id {idDetails = RecordSelId lbl}) = True
+isRecordSelector other = False
\end{code}
-Data type declarations are of the form:
-\begin{verbatim}
-data Foo a b = C1 ... | C2 ... | ... | Cn ...
-\end{verbatim}
-For each constructor @Ci@, we want to generate a curried function; so, e.g., for
-@C1 x y z@, we want a function binding:
-\begin{verbatim}
-fun_C1 = /\ a -> /\ b -> \ [x, y, z] -> Con C1 [a, b] [x, y, z]
-\end{verbatim}
-Notice the ``big lambdas'' and type arguments to @Con@---we are producing
-2nd-order polymorphic lambda calculus with explicit types.
-
%************************************************************************
%* *
\subsection[unfolding-Ids]{Functions related to @Ids@' unfoldings}
\begin{code}
getIdUnfolding :: Id -> Unfolding
-getIdUnfolding (Id _ _ _ _ _ info) = unfoldInfo info
+getIdUnfolding id = unfoldingInfo (idInfo id)
addIdUnfolding :: Id -> Unfolding -> Id
-addIdUnfolding id@(Id u n ty details prag info) unfolding
- = Id u n ty details prag (info `addUnfoldInfo` unfolding)
+addIdUnfolding id@(Id {idInfo = info}) unfolding
+ = id {idInfo = unfolding `setUnfoldingInfo` info}
\end{code}
The inline pragma tells us to be very keen to inline this Id, but it's still
OK not to if optimisation is switched off.
\begin{code}
-getInlinePragma :: Id -> PragmaInfo
-getInlinePragma (Id _ _ _ _ prag _) = prag
+getInlinePragma :: Id -> InlinePragInfo
+getInlinePragma id = inlinePragInfo (idInfo id)
idWantsToBeINLINEd :: Id -> Bool
-idWantsToBeINLINEd (Id _ _ _ _ IWantToBeINLINEd _) = True
-idWantsToBeINLINEd (Id _ _ _ _ IMustBeINLINEd _) = True
-idWantsToBeINLINEd _ = False
+idWantsToBeINLINEd id = case getInlinePragma id of
+ IWantToBeINLINEd -> True
+ IMustBeINLINEd -> True
+ other -> False
-idMustNotBeINLINEd (Id _ _ _ _ IMustNotBeINLINEd _) = True
-idMustNotBeINLINEd _ = False
+idMustNotBeINLINEd id = case getInlinePragma id of
+ IMustNotBeINLINEd -> True
+ other -> False
-idMustBeINLINEd (Id _ _ _ _ IMustBeINLINEd _) = True
-idMustBeINLINEd _ = False
+idMustBeINLINEd id = case getInlinePragma id of
+ IMustBeINLINEd -> True
+ other -> False
addInlinePragma :: Id -> Id
-addInlinePragma (Id u sn ty details _ info)
- = Id u sn ty details IWantToBeINLINEd info
+addInlinePragma id@(Id {idInfo = info})
+ = id {idInfo = setInlinePragInfo IWantToBeINLINEd info}
nukeNoInlinePragma :: Id -> Id
-nukeNoInlinePragma id@(Id u sn ty details IMustNotBeINLINEd info)
- = Id u sn ty details NoPragmaInfo info
-nukeNoInlinePragma id@(Id u sn ty details _ info) = id -- Otherwise no-op
+nukeNoInlinePragma id@(Id {idInfo = info})
+ = case inlinePragInfo info of
+ IMustNotBeINLINEd -> id {idInfo = setInlinePragInfo NoPragmaInfo info}
+ other -> id
addNoInlinePragma :: Id -> Id
-addNoInlinePragma id@(Id u sn ty details _ info)
- = Id u sn ty details IMustNotBeINLINEd info
+addNoInlinePragma id@(Id {idInfo = info})
+ = id {idInfo = IMustNotBeINLINEd `setInlinePragInfo` info}
+
+mustInlineInfo = IMustBeINLINEd `setInlinePragInfo` noIdInfo
+wantToInlineInfo = IWantToBeINLINEd `setInlinePragInfo` noIdInfo
\end{code}
\begin{code}
getIdDemandInfo :: Id -> DemandInfo
-getIdDemandInfo (Id _ _ _ _ _ info) = demandInfo info
+getIdDemandInfo id = demandInfo (idInfo id)
addIdDemandInfo :: Id -> DemandInfo -> Id
-addIdDemandInfo (Id u n ty details prags info) demand_info
- = Id u n ty details prags (info `addDemandInfo` demand_info)
+addIdDemandInfo id@(Id {idInfo = info}) demand_info
+ = id {idInfo = demand_info `setDemandInfo` info}
\end{code}
\begin{code}
getIdUpdateInfo :: Id -> UpdateInfo
-getIdUpdateInfo (Id _ _ _ _ _ info) = updateInfo info
+getIdUpdateInfo id = updateInfo (idInfo id)
addIdUpdateInfo :: Id -> UpdateInfo -> Id
-addIdUpdateInfo (Id u n ty details prags info) upd_info
- = Id u n ty details prags (info `addUpdateInfo` upd_info)
-\end{code}
-
-\begin{code}
-{- LATER:
-getIdArgUsageInfo :: Id -> ArgUsageInfo
-getIdArgUsageInfo (Id u n ty info details) = argUsageInfo info
-
-addIdArgUsageInfo :: Id -> ArgUsageInfo -> Id
-addIdArgUsageInfo (Id u n ty info details) au_info
- = Id u n ty (info `addArgusageInfo` au_info) details
--}
-\end{code}
-
-\begin{code}
-{- LATER:
-getIdFBTypeInfo :: Id -> FBTypeInfo
-getIdFBTypeInfo (Id u n ty info details) = fbTypeInfo info
-
-addIdFBTypeInfo :: Id -> FBTypeInfo -> Id
-addIdFBTypeInfo (Id u n ty info details) upd_info
- = Id u n ty (info `addFBTypeInfo` upd_info) details
--}
+addIdUpdateInfo id@(Id {idInfo = info}) upd_info
+ = id {idInfo = upd_info `setUpdateInfo` info}
\end{code}
\begin{code}
getIdSpecialisation :: Id -> IdSpecEnv
-getIdSpecialisation (Id _ _ _ _ _ info) = specInfo info
+getIdSpecialisation id = specInfo (idInfo id)
setIdSpecialisation :: Id -> IdSpecEnv -> Id
-setIdSpecialisation (Id u n ty details prags info) spec_info
- = Id u n ty details prags (info `setSpecInfo` spec_info)
+setIdSpecialisation id@(Id {idInfo = info}) spec_info
+ = id {idInfo = spec_info `setSpecInfo` info}
\end{code}
-Strictness: we snaffle the info out of the IdInfo.
-
\begin{code}
getIdStrictness :: Id -> StrictnessInfo
-
-getIdStrictness (Id _ _ _ _ _ info) = strictnessInfo info
+getIdStrictness id = strictnessInfo (idInfo id)
addIdStrictness :: Id -> StrictnessInfo -> Id
-addIdStrictness (Id u n ty details prags info) strict_info
- = Id u n ty details prags (info `addStrictnessInfo` strict_info)
+addIdStrictness id@(Id {idInfo = info}) strict_info
+ = id {idInfo = strict_info `setStrictnessInfo` info}
\end{code}
%************************************************************************
Comparison: equality and ordering---this stuff gets {\em hammered}.
\begin{code}
-cmpId (Id u1 _ _ _ _ _) (Id u2 _ _ _ _ _) = compare u1 u2
--- short and very sweet
+cmpId (Id {idUnique = u1}) (Id {idUnique = u2}) = compare u1 u2
\end{code}
\begin{code}
\begin{code}
pprId :: Outputable ty => GenId ty -> SDoc
-pprId (Id u n _ _ prags _)
+pprId Id {idUnique = u, idName = n, idInfo = info}
= hcat [ppr n, pp_prags]
where
- pp_prags | opt_PprStyle_All = case prags of
+ pp_prags | opt_PprStyle_All = case inlinePragInfo info of
IMustNotBeINLINEd -> text "{n}"
IWantToBeINLINEd -> text "{i}"
IMustBeINLINEd -> text "{I}"
other -> empty
| otherwise = empty
-
- -- WDP 96/05/06: We can re-elaborate this as we go along...
\end{code}
\begin{code}
-idUnique (Id u _ _ _ _ _) = u
-
instance Uniquable (GenId ty) where
uniqueOf = idUnique
instance NamedThing (GenId ty) where
- getName this_id@(Id u n _ details _ _) = n
+ getName = idName
\end{code}
Note: The code generator doesn't carry a @UniqueSupply@, so it uses
noIdInfo,
ppIdInfo,
+ -- Arity
ArityInfo(..),
exactArity, atLeastArity, unknownArity,
- arityInfo, addArityInfo, ppArityInfo,
+ arityInfo, setArityInfo, ppArityInfo,
+ -- Demand
DemandInfo,
- noDemandInfo, mkDemandInfo, demandInfo, ppDemandInfo, addDemandInfo, willBeDemanded,
+ noDemandInfo, mkDemandInfo, demandInfo, ppDemandInfo, setDemandInfo, willBeDemanded,
+ Demand(..), -- Non-abstract
+ -- Strictness
StrictnessInfo(..), -- Non-abstract
- Demand(..), NewOrData, -- Non-abstract
-
workerExists,
mkStrictnessInfo, mkBottomStrictnessInfo, noStrictnessInfo, bottomIsGuaranteed,
- strictnessInfo, ppStrictnessInfo, addStrictnessInfo,
+ strictnessInfo, ppStrictnessInfo, setStrictnessInfo,
+
+ -- Unfolding
+ unfoldingInfo, setUnfoldingInfo,
- unfoldInfo, addUnfoldInfo,
+ -- Inline prags
+ InlinePragInfo(..),
+ inlinePragInfo, setInlinePragInfo,
+ -- Specialisation
IdSpecEnv, specInfo, setSpecInfo,
+ -- Update
UpdateInfo, UpdateSpec,
- mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, addUpdateInfo,
+ mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, setUpdateInfo,
+ -- Arg usage
ArgUsageInfo, ArgUsage(..), ArgUsageType,
- mkArgUsageInfo, argUsageInfo, addArgUsageInfo, getArgUsage,
+ mkArgUsageInfo, argUsageInfo, setArgUsageInfo, getArgUsage,
+ -- FB type
FBTypeInfo, FBType(..), FBConsum(..), FBProd(..),
- fbTypeInfo, ppFBTypeInfo, addFBTypeInfo, mkFBTypeInfo, getFBType
+ fbTypeInfo, ppFBTypeInfo, setFBTypeInfo, mkFBTypeInfo, getFBType
) where
#include "HsVersions.h"
\begin{code}
data IdInfo
- = IdInfo
- ArityInfo -- Its arity
+ = IdInfo {
+ arityInfo :: ArityInfo, -- Its arity
+
+ demandInfo :: DemandInfo, -- Whether or not it is definitely demanded
+
+ specInfo :: IdSpecEnv, -- Specialisations of this function which exist
+
+ strictnessInfo :: StrictnessInfo, -- Strictness properties
- DemandInfo -- Whether or not it is definitely
- -- demanded
+ unfoldingInfo :: Unfolding, -- Its unfolding; for locally-defined
+ -- things, this can *only* be NoUnfolding
- IdSpecEnv -- Specialisations of this function which exist
+ updateInfo :: UpdateInfo, -- Which args should be updated
- StrictnessInfo -- Strictness properties
+ argUsageInfo :: ArgUsageInfo, -- how this Id uses its arguments
- Unfolding -- Its unfolding; for locally-defined
- -- things, this can *only* be NoUnfolding
+ fbTypeInfo :: FBTypeInfo, -- the Foldr/Build W/W property of this function.
- UpdateInfo -- Which args should be updated
+ inlinePragInfo :: InlinePragInfo -- Inline pragmas
+ }
+\end{code}
- ArgUsageInfo -- how this Id uses its arguments
+Setters
- FBTypeInfo -- the Foldr/Build W/W property of this function.
+\begin{code}
+setFBTypeInfo fb info = info { fbTypeInfo = fb }
+setArgUsageInfo au info = info { argUsageInfo = au }
+setUpdateInfo ud info = info { updateInfo = ud }
+setDemandInfo dd info = info { demandInfo = dd }
+setStrictnessInfo st info = info { strictnessInfo = st }
+setSpecInfo sp info = info { specInfo = sp }
+setArityInfo ar info = info { arityInfo = ar }
+setInlinePragInfo pr info = info { inlinePragInfo = pr }
+setUnfoldingInfo uf info = info { unfoldingInfo = uf }
\end{code}
+
\begin{code}
-noIdInfo = IdInfo UnknownArity UnknownDemand emptySpecEnv NoStrictnessInfo noUnfolding
- NoUpdateInfo NoArgUsageInfo NoFBTypeInfo
+noIdInfo = IdInfo {
+ arityInfo = UnknownArity,
+ demandInfo = UnknownDemand,
+ specInfo = emptySpecEnv,
+ strictnessInfo = NoStrictnessInfo,
+ unfoldingInfo = noUnfolding,
+ updateInfo = NoUpdateInfo,
+ argUsageInfo = NoArgUsageInfo,
+ fbTypeInfo = NoFBTypeInfo,
+ inlinePragInfo = NoPragmaInfo
+ }
\end{code}
\begin{code}
-> IdInfo
-> SDoc
-ppIdInfo specs_please
- (IdInfo arity demand specenv strictness unfold update arg_usage fbtype)
+ppIdInfo specs_please (IdInfo {arityInfo, updateInfo, strictnessInfo, demandInfo})
= hsep [
- -- order is important!:
- ppArityInfo arity,
- ppUpdateInfo update,
-
- ppStrictnessInfo strictness,
-
- if specs_please
- then empty -- ToDo -- sty (not (isDataCon for_this_id))
- -- better_id_fn inline_env (mEnvToList specenv)
- else empty,
-
- -- DemandInfo needn't be printed since it has no effect on interfaces
- ppDemandInfo demand,
- ppFBTypeInfo fbtype
+ ppArityInfo arityInfo,
+ ppUpdateInfo updateInfo,
+ ppStrictnessInfo strictnessInfo,
+ ppDemandInfo demandInfo
]
\end{code}
= UnknownArity -- No idea
| ArityExactly Int -- Arity is exactly this
| ArityAtLeast Int -- Arity is this or greater
-\end{code}
-\begin{code}
exactArity = ArityExactly
atLeastArity = ArityAtLeast
unknownArity = UnknownArity
-arityInfo (IdInfo arity _ _ _ _ _ _ _) = arity
-
-addArityInfo (IdInfo _ a b c d e f g) arity = IdInfo arity a b c d e f g
-
-ppArityInfo UnknownArity = empty
+ppArityInfo UnknownArity = empty
ppArityInfo (ArityExactly arity) = hsep [ptext SLIT("_A_"), int arity]
ppArityInfo (ArityAtLeast arity) = hsep [ptext SLIT("_A>_"), int arity]
\end{code}
%************************************************************************
%* *
-\subsection[demand-IdInfo]{Demand info about an @Id@}
+\subsection{Inline-pragma information}
%* *
%************************************************************************
-Whether a value is certain to be demanded or not. (This is the
-information that is computed by the ``front-end'' of the strictness
-analyser.)
-
-This information is only used within a module, it is not exported
-(obviously).
-
\begin{code}
-data DemandInfo
- = UnknownDemand
- | DemandedAsPer Demand
-\end{code}
+data InlinePragInfo
+ = NoPragmaInfo
-\begin{code}
-noDemandInfo = UnknownDemand
+ | IWantToBeINLINEd
-mkDemandInfo :: Demand -> DemandInfo
-mkDemandInfo demand = DemandedAsPer demand
+ | IMustNotBeINLINEd -- Used by the simplifier to prevent looping
+ -- on recursive definitions
-willBeDemanded :: DemandInfo -> Bool
-willBeDemanded (DemandedAsPer demand) = isStrict demand
-willBeDemanded _ = False
+ | IMustBeINLINEd -- Absolutely must inline; used for PrimOps only
\end{code}
-\begin{code}
-demandInfo (IdInfo _ demand _ _ _ _ _ _) = demand
-
-addDemandInfo (IdInfo a _ c d e f g h) demand = IdInfo a demand c d e f g h
-
-ppDemandInfo UnknownDemand = text "{-# L #-}"
-ppDemandInfo (DemandedAsPer info) = hsep [text "{-#", text (showList [info] ""), text "#-}"]
-\end{code}
%************************************************************************
%* *
where pi' :: Lift Int# is the specialised version of pi.
-\begin{code}
-specInfo :: IdInfo -> IdSpecEnv
-specInfo (IdInfo _ _ spec _ _ _ _ _) = spec
-
-setSpecInfo (IdInfo a b _ d e f g h) spec = IdInfo a b spec d e f g h
-\end{code}
-
%************************************************************************
%* *
bottomIsGuaranteed BottomGuaranteed = True
bottomIsGuaranteed other = False
-strictnessInfo (IdInfo _ _ _ strict _ _ _ _) = strict
-
-addStrictnessInfo id_info NoStrictnessInfo = id_info
-addStrictnessInfo (IdInfo a b d _ e f g h) strict = IdInfo a b d strict e f g h
-
ppStrictnessInfo NoStrictnessInfo = empty
ppStrictnessInfo BottomGuaranteed = ptext SLIT("_bot_")
%************************************************************************
%* *
-\subsection[unfolding-IdInfo]{Unfolding info about an @Id@}
+\subsection[demand-IdInfo]{Demand info about an @Id@}
%* *
%************************************************************************
+Whether a value is certain to be demanded or not. (This is the
+information that is computed by the ``front-end'' of the strictness
+analyser.)
+
+This information is only used within a module, it is not exported
+(obviously).
+
+\begin{code}
+data DemandInfo
+ = UnknownDemand
+ | DemandedAsPer Demand
+\end{code}
+
\begin{code}
-unfoldInfo (IdInfo _ _ _ _ unfolding _ _ _) = unfolding
+noDemandInfo = UnknownDemand
+
+mkDemandInfo :: Demand -> DemandInfo
+mkDemandInfo demand = DemandedAsPer demand
+
+willBeDemanded :: DemandInfo -> Bool
+willBeDemanded (DemandedAsPer demand) = isStrict demand
+willBeDemanded _ = False
-addUnfoldInfo (IdInfo a b d e _ f g h) uf = IdInfo a b d e uf f g h
+ppDemandInfo UnknownDemand = text "{-# L #-}"
+ppDemandInfo (DemandedAsPer info) = hsep [text "{-#", text (showList [info] ""), text "#-}"]
\end{code}
+
%************************************************************************
%* *
\subsection[update-IdInfo]{Update-analysis info about an @Id@}
Text instance so that the update annotations can be read in.
\begin{code}
-instance Read UpdateInfo where
- readsPrec p s | null s = panic "IdInfo: empty update pragma?!"
- | otherwise = [(SomeUpdateInfo (map ok_digit s),"")]
- where
- ok_digit c | c >= '0' && c <= '2' = ord c - ord '0'
- | otherwise = panic "IdInfo: not a digit while reading update pragma"
-
-updateInfo (IdInfo _ _ _ _ _ update _ _) = update
-
-addUpdateInfo id_info NoUpdateInfo = id_info
-addUpdateInfo (IdInfo a b d e f _ g h) upd_info = IdInfo a b d e f upd_info g h
-
ppUpdateInfo NoUpdateInfo = empty
ppUpdateInfo (SomeUpdateInfo []) = empty
ppUpdateInfo (SomeUpdateInfo spec) = (<>) (ptext SLIT("_U_ ")) (hcat (map int spec))
data ArgUsageInfo
= NoArgUsageInfo
| SomeArgUsageInfo ArgUsageType
- -- ??? deriving (Eq, Ord)
data ArgUsage = ArgUsage Int -- number of arguments (is linear!)
| UnknownArgUsage
+
type ArgUsageType = [ArgUsage] -- c_1 -> ... -> BLOB
\end{code}
\end{code}
\begin{code}
-argUsageInfo (IdInfo _ _ _ _ _ _ au _) = au
-
-addArgUsageInfo id_info NoArgUsageInfo = id_info
-addArgUsageInfo (IdInfo a b d e f g _ h) au_info = IdInfo a b d e f g au_info h
-
{- UNUSED:
ppArgUsageInfo NoArgUsageInfo = empty
ppArgUsageInfo (SomeArgUsageInfo aut) = (<>) (ptext SLIT("_L_ ")) (ppArgUsageType aut)
char '"' ]
\end{code}
+
%************************************************************************
%* *
\subsection[FBType-IdInfo]{Type of an expression through Foldr/build's eyes}
\end{code}
\begin{code}
-fbTypeInfo (IdInfo _ _ _ _ _ _ _ fb) = fb
-
-addFBTypeInfo id_info NoFBTypeInfo = id_info
-addFBTypeInfo (IdInfo a b d e f g h _) fb_info = IdInfo a b d e f g h fb_info
-
ppFBTypeInfo NoFBTypeInfo = empty
ppFBTypeInfo (SomeFBTypeInfo (FBType cons prod))
= (<>) (ptext SLIT("_F_ ")) (ppFBType cons prod)
import CoreSyn
import CoreUnfold ( Unfolding )
-import Id ( mkPrimitiveId )
+import MkId ( mkPrimitiveId )
import IdInfo -- quite a few things
-import StdIdInfo
import Name ( mkWiredInIdName, Name )
import PrimOp ( primOpInfo, tagOf_PrimOp, PrimOpInfo(..), PrimOp )
import PrelMods ( pREL_GHC )
-%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
-%
-\section[Unique]{The @Unique@ data type}
+
@Uniques@ are used to distinguish entities in the compiler (@Ids@,
@Classes@, etc.) from each other. Thus, @Uniques@ are the basic
charDataConKey,
charPrimTyConKey,
charTyConKey,
+ coerceIdKey,
composeIdKey,
consDataConKey,
doubleDataConKey,
functorClassKey,
geClassOpKey,
gtDataConKey,
+ inlineIdKey,
intDataConKey,
intPrimTyConKey,
intTyConKey,
realWorldPrimIdKey,
realWorldTyConKey,
recConErrorIdKey,
+ recSelErrIdKey,
recUpdErrorIdKey,
return2GMPsDataConKey,
return2GMPsTyConKey,
foldlIdKey = mkPreludeMiscIdUnique 8
foldrIdKey = mkPreludeMiscIdUnique 9
forkIdKey = mkPreludeMiscIdUnique 10
+recSelErrIdKey = mkPreludeMiscIdUnique 11
integerMinusOneIdKey = mkPreludeMiscIdUnique 12
integerPlusOneIdKey = mkPreludeMiscIdUnique 13
integerPlusTwoIdKey = mkPreludeMiscIdUnique 14
otherwiseIdKey = mkPreludeMiscIdUnique 67
toEnumClassOpKey = mkPreludeMiscIdUnique 68
\end{code}
+
+\begin{code}
+inlineIdKey = mkPreludeMiscIdUnique 69
+coerceIdKey = mkPreludeMiscIdUnique 70
+\end{code}
import HeapOffs ( VirtualHeapOffset,
VirtualSpAOffset, VirtualSpBOffset
)
-import Id ( idPrimRep, toplevelishId,
+import Id ( idPrimRep,
mkIdEnv, rngIdEnv, IdEnv,
idSetToList,
Id
\begin{code}
getCAddrModeIfVolatile :: Id -> FCode (Maybe CAddrMode)
getCAddrModeIfVolatile name
- | toplevelishId name = returnFC Nothing
- | otherwise
+-- | toplevelishId name = returnFC Nothing
+-- | otherwise
= lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
case stable_loc of
NoStableLoc -> -- Aha! So it is volatile!
import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
import CostCentre ( useCurrentCostCentre, CostCentre )
import HeapOffs ( VirtualSpBOffset, VirtualHeapOffset )
-import Id ( idPrimRep, toplevelishId,
- dataConTag, fIRST_TAG, ConTag,
+import Id ( idPrimRep, dataConTag, fIRST_TAG, ConTag,
isDataCon, DataCon,
idSetToList, GenId{-instance Uniquable,Eq-}, Id
)
import Literal ( Literal )
import Maybes ( catMaybes )
-import PprType ( GenType{-instance Outputable-} )
import PrimOp ( primOpCanTriggerGC, PrimOp(..),
primOpStackRequired, StackRequirement(..)
)
Several special cases for primitive operations.
-******* TO DO TO DO: fix what follows
-
-Special case for
-
- case (op x1 ... xn) of
- y -> e
-
-where the type of the case scrutinee is a multi-constuctor algebraic type.
-Then we simply compile code for
-
- let y = op x1 ... xn
- in
- e
-
-In this case:
-
- case (op x1 ... xn) of
- C a b -> ...
- y -> e
-
-where the type of the case scrutinee is a multi-constuctor algebraic type.
-we just bomb out at the moment. It never happens in practice.
-
-**** END OF TO DO TO DO
-
-\begin{code}
-cgCase scrut@(StgPrim op args _) live_in_whole_case live_in_alts uniq
- (StgAlgAlts _ alts (StgBindDefault id _ deflt_rhs))
- = if not (null alts) then
- panic "cgCase: case on PrimOp with default *and* alts\n"
- -- For now, die if alts are non-empty
- else
- cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs)
- where
- scrut_rhs = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
- Updatable [] scrut
- scrut_free_vars = [ fv | StgVarArg fv <- args, not (toplevelishId fv) ]
- -- Hack, hack
-\end{code}
-
\begin{code}
cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
| AnnLet (AnnCoreBinding val_bdr val_occ flexi annot)
(AnnCoreExpr val_bdr val_occ flexi annot)
- | AnnSCC CostCentre
- (AnnCoreExpr val_bdr val_occ flexi annot)
-
- | AnnCoerce Coercion
- (GenType flexi)
+ | AnnNote (CoreNote flexi)
(AnnCoreExpr val_bdr val_occ flexi annot)
\end{code}
deAnnotate (_, AnnPrim op args) = Prim op args
deAnnotate (_, AnnLam binder body)= Lam binder (deAnnotate body)
deAnnotate (_, AnnApp fun arg) = App (deAnnotate fun) arg
-deAnnotate (_, AnnSCC lbl body) = SCC lbl (deAnnotate body)
-deAnnotate (_, AnnCoerce c ty body) = Coerce c ty (deAnnotate body)
+deAnnotate (_, AnnNote note body) = Note note (deAnnotate body)
deAnnotate (_, AnnLet bind body)
= Let (deAnnBind bind) (deAnnotate body)
import CoreSyn
import CoreUtils ( coreExprType )
-import Id ( idType, mkSysLocal,
+import MkId ( mkSysLocal )
+import Id ( idType, mkIdWithNewType,
nullIdEnv, growIdEnvList, lookupIdEnv,
- mkIdWithNewType,
- IdEnv, GenId{-instances-}, Id
+ IdEnv, Id
)
import Name ( isLocallyDefined, getSrcLoc, getOccString )
import TyCon ( isBoxedTyCon, TyCon{-instance-} )
liftCoreExpr expr@(Lit lit) = returnL expr
-liftCoreExpr (SCC label expr)
+liftCoreExpr (Note note expr)
= liftCoreExpr expr `thenL` \ expr ->
- returnL (SCC label expr)
-
-liftCoreExpr (Coerce coerce ty expr)
- = liftCoreExpr expr `thenL` \ expr ->
- returnL (Coerce coerce ty expr) -- ToDo:right?:Coerce
+ returnL (Note note expr)
liftCoreExpr (Let (NonRec binder rhs) body) -- special case: no lifting
= liftCoreExpr rhs `thenL` \ rhs ->
NamedThing(..) )
import PprCore
import ErrUtils ( doIfSet, ghcExit )
-import PprType ( GenType, GenTyVar, TyCon )
import PrimOp ( primOpType )
import PrimRep ( PrimRep(..) )
import SrcLoc ( SrcLoc )
isUnpointedType, typeKind, instantiateTy,
splitAlgTyConApp_maybe, Type
)
-import TyCon ( isPrimTyCon, isDataTyCon )
+import TyCon ( TyCon, isPrimTyCon, isDataTyCon )
import TyVar ( TyVar, tyVarKind, mkTyVarEnv )
import ErrUtils ( ErrMsg )
import Unique ( Unique )
| otherwise = checkInScope var `seqL` returnL (Just (idType var))
lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
-lintCoreExpr (SCC _ expr) = lintCoreExpr expr
-lintCoreExpr e@(Coerce coercion ty expr)
- = lintCoercion e coercion `seqL`
- lintCoreExpr expr `seqL` returnL (Just ty)
+
+lintCoreExpr (Note (Coerce to_ty from_ty) expr)
+ = lintCoreExpr expr `thenMaybeL` \ expr_ty ->
+ lintTy to_ty `seqL`
+ lintTy from_ty `seqL`
+ checkTys from_ty expr_ty (mkCoerceErr from_ty expr_ty) `seqL`
+ returnL (Just to_ty)
+
+lintCoreExpr (Note other_note expr)
+ = lintCoreExpr expr
lintCoreExpr (Let binds body)
= lintCoreBinding binds `thenL` \binders ->
var_ty = idType v
lintCoreArg e ty a@(TyArg arg_ty)
- = -- ToDo: Check that ty is well-kinded and has no unbound tyvars
+ = lintTy arg_ty `seqL`
+
case (splitForAllTy_maybe ty) of
Nothing -> addErrL (mkTyAppMsg SLIT("Illegal") ty arg_ty e) `seqL` returnL Nothing
%************************************************************************
%* *
-\subsection[lint-coercion]{Coercion}
+\subsection[lint-types]{Types}
%* *
%************************************************************************
\begin{code}
-lintCoercion e (CoerceIn con) = check_con e con
-lintCoercion e (CoerceOut con) = check_con e con
-
-check_con e con = checkL (isNewCon con)
- (mkCoerceErrMsg e)
+lintTy :: Type -> LintM ()
+lintTy ty = returnL ()
+-- ToDo: Check that ty is well-kinded and has no unbound tyvars
\end{code}
-
+
%************************************************************************
%* *
\subsection[lint-monad]{The Lint monad}
= ($$) (ptext SLIT("Application of newtype constructor:"))
(ppr e)
-mkCoerceErrMsg e
- = ($$) (ptext SLIT("Coercion using a datatype constructor:"))
- (ppr e)
-
mkCaseAltMsg :: CoreCaseAlts -> ErrMsg
mkCaseAltMsg alts
ppr binder],
hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
]
+
+mkCoerceErr from_ty expr_ty
+ = vcat [ptext SLIT("From-type of Coerce differs from type of enclosed expression"),
+ ptext SLIT("From-type:") <+> ppr from_ty,
+ ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
+ ]
\end{code}
module CoreSyn (
GenCoreBinding(..), GenCoreExpr(..),
GenCoreArg(..), GenCoreBinder(..), GenCoreCaseAlts(..),
- GenCoreCaseDefault(..),
- Coercion(..),
+ GenCoreCaseDefault(..), CoreNote(..),
bindersOf, pairsFromCoreBinds, rhssOfBind,
#include "HsVersions.h"
import CostCentre ( CostCentre )
-import Id ( idType, GenId{-instance Eq-}, Id )
+import Id ( idType, Id )
import Type ( isUnboxedType,GenType, Type )
import TyVar ( GenTyVar, TyVar )
import Util ( panic, assertPanic )
-- The "GenCoreBinding" records that information
\end{code}
-For cost centre scc expressions we introduce a new core construct
-@SCC@ so transforming passes have to deal with it explicitly. The
-alternative of using a new PrimativeOp may result in a bad
-transformations of which we are unaware.
+A @Note@ annotates a @CoreExpr@ with useful information
+of some kind.
\begin{code}
- | SCC CostCentre -- label of scc
- (GenCoreExpr val_bdr val_occ flexi) -- scc expression
+ | Note (CoreNote flexi)
+ (GenCoreExpr val_bdr val_occ flexi)
\end{code}
-Coercions arise from uses of the constructor of a @newtype@
-declaration, either in construction (resulting in a @CoreceIn@) or
-pattern matching (resulting in a @CoerceOut@).
-\begin{code}
- | Coerce Coercion
- (GenType flexi) -- Type of the whole expression
- (GenCoreExpr val_bdr val_occ flexi)
-\end{code}
+%************************************************************************
+%* *
+\subsection{Core-notes}
+%* *
+%************************************************************************
\begin{code}
-data Coercion = CoerceIn Id -- Apply this constructor
- | CoerceOut Id -- Strip this constructor
+data CoreNote flexi
+ = SCC
+ CostCentre
+
+ | Coerce
+ (GenType flexi) -- The to-type: type of whole coerce expression
+ (GenType flexi) -- The from-type: type of enclosed expression
+
+ | InlineCall -- Instructs simplifier to inline
+ -- the enclosed call
\end{code}
+
%************************************************************************
%* *
\subsection{Core-constructing functions with checking}
_declarations_
1 data Unfolding;
1 data UnfoldingGuidance;
-1 mkUnfolding _:_ PragmaInfo.PragmaInfo -> CoreSyn.CoreExpr -> CoreUnfold.Unfolding ;;
+1 mkUnfolding _:_ CoreSyn.CoreExpr -> CoreUnfold.Unfolding ;;
1 noUnfolding _:_ CoreUnfold.Unfolding ;;
noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate,
smallEnoughToInline, couldBeSmallEnoughToInline,
- certainlySmallEnoughToInline, inlineUnconditionally,
+ certainlySmallEnoughToInline, inlineUnconditionally, okToInline,
- calcUnfoldingGuidance,
-
- PragmaInfo(..) -- Re-export
+ calcUnfoldingGuidance
) where
#include "HsVersions.h"
uNFOLDING_DEAR_OP_COST,
uNFOLDING_NOREP_LIT_COST
)
-import BinderInfo ( BinderInfo, isOneFunOcc, isOneSafeFunOcc
+import BinderInfo ( BinderInfo, isOneSameSCCFunOcc,
+ isInlinableOcc, isOneSafeFunOcc
)
-import PragmaInfo ( PragmaInfo(..) )
import CoreSyn
import Literal ( Literal )
import CoreUtils ( unTagBinders )
import CoreUtils ( coreExprType )
import Id ( Id, idType, getIdArity, isBottomingId, isDataCon,
idWantsToBeINLINEd, idMustBeINLINEd, idMustNotBeINLINEd,
- IdSet, GenId{-instances-} )
+ IdSet )
import PrimOp ( fragilePrimOp, primOpCanTriggerGC )
-import IdInfo ( ArityInfo(..) )
+import IdInfo ( ArityInfo(..), InlinePragInfo(..) )
import Literal ( isNoRepLit )
import TyCon ( tyConFamilySize )
import Type ( splitAlgTyConApp_maybe )
\begin{code}
noUnfolding = NoUnfolding
-mkUnfolding inline_prag expr
+mkUnfolding expr
= let
-- strictness mangling (depends on there being no CSE)
- ufg = calcUnfoldingGuidance inline_prag opt_UnfoldingCreationThreshold expr
+ ufg = calcUnfoldingGuidance opt_UnfoldingCreationThreshold expr
occ = occurAnalyseGlobalExpr expr
cuf = CoreUnfolding (mkFormSummary expr) ufg occ
go n (Lit _) = ASSERT(n==0) ValueForm
go n (Con _ _) = ASSERT(n==0) ValueForm
go n (Prim _ _) = OtherForm
- go n (SCC _ e) = go n e
- go n (Coerce _ _ e) = go n e
+ go n (Note _ e) = go n e
go n (Let (NonRec b r) e) | exprIsTrivial r = go n e -- let f = f' alpha in (f,g)
-- should be treated as a value
exprIsTrivial (Var v) = True
exprIsTrivial (Lit lit) = not (isNoRepLit lit)
exprIsTrivial (App e (TyArg _)) = exprIsTrivial e
-exprIsTrivial (Coerce _ _ e) = exprIsTrivial e
+exprIsTrivial (Note _ e) = exprIsTrivial e
exprIsTrivial other = False
\end{code}
exprSmallEnoughToDup (Con _ _) = True -- Could check # of args
exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
-exprSmallEnoughToDup (Coerce _ _ e) = exprSmallEnoughToDup e
+exprSmallEnoughToDup (Note _ e) = exprSmallEnoughToDup e
exprSmallEnoughToDup expr
= case (collectArgs expr) of { (fun, _, vargs) ->
case fun of
\begin{code}
calcUnfoldingGuidance
- :: PragmaInfo -- INLINE pragma stuff
- -> Int -- bomb out if size gets bigger than this
+ :: Int -- bomb out if size gets bigger than this
-> CoreExpr -- expression to look at
-> UnfoldingGuidance
-calcUnfoldingGuidance IMustBeINLINEd bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so
-calcUnfoldingGuidance IWantToBeINLINEd bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so
-calcUnfoldingGuidance IMustNotBeINLINEd bOMB_OUT_SIZE expr = UnfoldNever -- ...and vice versa...
-
-calcUnfoldingGuidance NoPragmaInfo bOMB_OUT_SIZE expr
+calcUnfoldingGuidance bOMB_OUT_SIZE expr
= case collectBinders expr of { (ty_binders, val_binders, body) ->
case (sizeExpr bOMB_OUT_SIZE val_binders body) of
size_up (Lit lit) | isNoRepLit lit = sizeN uNFOLDING_NOREP_LIT_COST
| otherwise = sizeZero
- size_up (SCC lbl body) = size_up body -- SCCs cost nothing
- size_up (Coerce _ _ body) = size_up body -- Coercions cost nothing
+ size_up (Note _ body) = size_up body -- Notes cost nothing
size_up (App fun arg) = size_up fun `addSize` size_up_arg arg
-- NB Zero cost for for type applications;
is computed).
\begin{code}
-smallEnoughToInline :: Id -- The function (for trace msg only)
+smallEnoughToInline :: Id -- The function (trace msg only)
-> [Bool] -- Evaluated-ness of value arguments
-> Bool -- Result is scrutinised
-> UnfoldingGuidance
rule this out. Since ManyOcc doesn't record FunOcc/ArgOcc
\begin{code}
-inlineUnconditionally :: Bool -> (Id,BinderInfo) -> Bool
+inlineUnconditionally :: (Id,BinderInfo) -> Bool
-inlineUnconditionally ok_to_dup (id, occ_info)
+inlineUnconditionally (id, occ_info)
| idMustNotBeINLINEd id = False
- | isOneFunOcc occ_info
- && idMustBeINLINEd id = True
+ | isOneSameSCCFunOcc occ_info
+ && idWantsToBeINLINEd id = True
- | isOneSafeFunOcc (ok_to_dup || idWantsToBeINLINEd id) occ_info
+ | isOneSafeFunOcc occ_info
= True
| otherwise
= False
\end{code}
+
+okToInline is used at call sites, so it is a bit more generous
+
+\begin{code}
+okToInline :: Id -- The Id
+ -> Bool -- The thing is WHNF or bottom;
+ -> Bool -- It's small enough to duplicate the code
+ -> BinderInfo
+ -> Bool -- True <=> inline it
+
+okToInline id _ _ _ -- Check the Id first
+ | idWantsToBeINLINEd id = True
+ | idMustNotBeINLINEd id = False
+
+okToInline id whnf small binder_info = isInlinableOcc whnf small binder_info
+\end{code}
import CoreSyn
import CostCentre ( isDictCC, CostCentre, noCostCentre )
-import Id ( idType, mkSysLocal, isBottomingId,
- toplevelishId, mkIdWithNewUniq,
+import MkId ( mkSysLocal )
+import Id ( idType, isBottomingId,
+ mkIdWithNewUniq,
dataConRepType,
addOneToIdEnv, growIdEnvList, lookupIdEnv,
isNullIdEnv, IdEnv, Id
coreExprType (Lit lit) = literalType lit
coreExprType (Let _ body) = coreExprType body
-coreExprType (SCC _ expr) = coreExprType expr
coreExprType (Case _ alts) = coreAltsType alts
-coreExprType (Coerce _ ty _) = ty -- that's the whole point!
+coreExprType (Note (Coerce ty _) e) = ty
+coreExprType (Note other_note e) = coreExprType e
-- a Con is a fully-saturated application of a data constructor
-- a Prim is <ditto> of a PrimOp
\begin{code}
coreExprCc :: GenCoreExpr val_bdr val_occ flexi -> CostCentre
-coreExprCc (SCC cc e) = cc
-coreExprCc (Lam _ e) = coreExprCc e
-coreExprCc other = noCostCentre
+coreExprCc (Note (SCC cc) e) = cc
+coreExprCc (Note other_note e) = coreExprCc e
+coreExprCc (Lam _ e) = coreExprCc e
+coreExprCc other = noCostCentre
\end{code}
%************************************************************************
bop_expr f (Prim op args) = Prim op args
bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
bop_expr f (App expr arg) = App (bop_expr f expr) arg
-bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
-bop_expr f (Coerce c ty e) = Coerce c ty (bop_expr f e)
+bop_expr f (Note note expr) = Note note (bop_expr f expr)
bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
binders_ftvs = foldr (combine . munge_id_ty) noFreeTyVars binders
-- We need to collect free tyvars from the binders
-fvExpr id_cands tyvar_cands (SCC label expr)
- = (fvinfo, AnnSCC label expr2)
- where
- expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
-
-fvExpr id_cands tyvar_cands (Coerce c ty expr)
+fvExpr id_cands tyvar_cands (Note (Coerce to_ty from_ty) expr)
= (FVInfo (freeVarsOf expr2)
- (freeTyVarsOf expr2 `combine` tfvs)
+ (freeTyVarsOf expr2 `combine` tfvs1 `combine` tfvs2)
(leakinessOf expr2),
- AnnCoerce c ty expr2)
+ AnnNote (Coerce to_ty from_ty) expr2)
where
expr2 = fvExpr id_cands tyvar_cands expr
- tfvs = freeTy tyvar_cands ty
+ tfvs1 = freeTy tyvar_cands from_ty
+ tfvs2 = freeTy tyvar_cands to_ty
+
+fvExpr id_cands tyvar_cands (Note other_note expr)
+ = (fvinfo, AnnNote other_note expr2)
+ where
+ expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
\end{code}
\begin{code}
(body2, fvs_body) = addExprFVs fv_cand new_in_scope body
-addExprFVs fv_cand in_scope (SCC label expr)
- = (SCC label expr2, expr_fvs)
- where
- (expr2, expr_fvs) = addExprFVs fv_cand in_scope expr
-
-addExprFVs fv_cand in_scope (Coerce c ty expr)
- = (Coerce c ty expr2, expr_fvs)
+addExprFVs fv_cand in_scope (Note note expr)
+ = (Note note expr2, expr_fvs)
where
(expr2, expr_fvs) = addExprFVs fv_cand in_scope expr
\end{code}
import CoreSyn
import CostCentre ( showCostCentre )
-import Id ( idType, getIdInfo, isTupleCon,
+import Id ( idType, idInfo, isTupleCon,
DataCon, GenId{-instances-}, Id
)
import IdInfo ( ppIdInfo, ppStrictnessInfo )
import Literal ( Literal{-instances-} )
import Outputable -- quite a few things
import PprEnv
-import PprType ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} )
+import PprType ( pprParendType, pprTyVarBndr )
import PrimOp ( PrimOp{-instances-} )
import TyVar ( GenTyVar{-instances-} )
import Unique ( Unique{-instances-} )
(Just tvbndr) -- tyvar binders
(Just ppr) -- tyvar occs
- (Just pprParendGenType) -- types
+ (Just pprParendType) -- types
(Just pbdr) (Just pocc) -- value vars
where
Rec _ -> SLIT("_letrec_ {")
NonRec _ _ -> SLIT("let {")
-ppr_expr pe (SCC cc expr)
+ppr_expr pe (Note (SCC cc) expr)
= sep [hsep [ptext SLIT("_scc_"), pSCC pe cc],
- ppr_parend_expr pe expr ]
+ ppr_parend_expr pe expr ]
-ppr_expr pe (Coerce c ty expr)
- = sep [pp_coerce c, pTy pe ty, ppr_expr pe expr]
- where
- pp_coerce (CoerceIn v) = (<>) (ptext SLIT("_coerce_in_ ")) (ppr v)
- pp_coerce (CoerceOut v) = (<>) (ptext SLIT("_coerce_out_ ")) (ppr v)
+ppr_expr pe (Note (Coerce to_ty from_ty) expr)
+ = sep [hsep [ptext SLIT("_coerce_"), pTy pe to_ty, pTy pe from_ty],
+ ppr_parend_expr pe expr]
+
+ppr_expr pe (Note InlineCall expr)
+ = ptext SLIT("_inline_") <+> ppr_parend_expr pe expr
only_one_alt (AlgAlts [] (BindDefault _ _)) = True
only_one_alt (AlgAlts (_:[]) NoDefault) = True
= vcat [sig, pragmas, ppr binder]
where
sig = pprTypedBinder binder
- pragmas = ppIdInfo False{-no specs, thanks-} (getIdInfo binder)
+ pragmas = ppIdInfo False{-no specs, thanks-} (idInfo binder)
pprCoreBinder LambdaBind binder = pprTypedBinder binder
pprCoreBinder CaseBind binder = ppr binder
pprIfaceBinder other binder = pprTypedBinder binder
pprTypedBinder binder
- = ppr binder <+> ptext SLIT("::") <+> pprParendGenType (idType binder)
+ = ppr binder <+> ptext SLIT("::") <+> pprParendType (idType binder)
-- The space before the :: is important; it helps the lexer
-- when reading inferfaces. Otherwise it would lex "a::b" as one thing.
--
| auto_scc_candidate && worthSCC core_expr &&
(opt_AutoSccsOnAllToplevs || (isExported bndr && opt_AutoSccsOnExportedToplevs))
= getModuleAndGroupDs `thenDs` \ (mod,grp) ->
- returnDs (bndr, SCC (mkAutoCC bndr mod grp IsNotCafCC) core_expr)
+ returnDs (bndr, Note (SCC (mkAutoCC bndr mod grp IsNotCafCC)) core_expr)
| otherwise
= returnDs pair
-worthSCC (SCC _ _) = False
-worthSCC (Con _ _) = False
-worthSCC core_expr = True
+worthSCC (Note (SCC _) _) = False
+worthSCC (Con _ _) = False
+worthSCC core_expr = True
\end{code}
If profiling and dealing with a dict binding, wrap the dict in "_scc_ DICT <dict>":
|| not (isDictTy (idType var))
= returnDs rhs -- That's easy: do nothing
-{-
- | opt_CompilingGhcInternals
- = returnDs (SCC prel_dicts_cc rhs)
--}
-
| otherwise
= getModuleAndGroupDs `thenDs` \ (mod, grp) ->
-- ToDo: do -dicts-all flag (mark dict things with individual CCs)
- returnDs (SCC (mkAllDictsCC mod grp False) rhs)
-
-{- UNUSED:
-prel_dicts_cc = preludeDictsCostCentre False{-not dupd-} -- ditto
--}
+ returnDs (Note (SCC (mkAllDictsCC mod grp False)) rhs)
\end{code}
import CoreUtils ( coreExprType )
import Id ( Id(..), dataConArgTys, idType )
import Maybes ( maybeToBool )
-import PprType ( GenType{-instances-} )
import PrelVals ( packStringForCId )
import PrimOp ( PrimOp(..) )
import Type ( isUnpointedType, splitAlgTyConApp_maybe,
dsExpr (HsSCC cc expr)
= dsExpr expr `thenDs` \ core_expr ->
getModuleAndGroupDs `thenDs` \ (mod_name, group_name) ->
- returnDs ( SCC (mkUserCC cc mod_name group_name) core_expr)
+ returnDs (Note (SCC (mkUserCC cc mod_name group_name)) core_expr)
dsExpr expr@(HsCase discrim matches src_loc)
= putSrcLocDs src_loc $
dsExpr (HsCon con_id [ty] [arg])
| isNewTyCon tycon
= dsExpr arg `thenDs` \ arg' ->
- returnDs (Coerce (CoerceIn con_id) result_ty arg')
+ returnDs (Note (Coerce result_ty (coreExprType arg')) arg')
where
result_ty = mkTyConApp tycon [ty]
tycon = dataConTyCon con_id
import BasicTypes ( Module )
import ErrUtils ( WarnMsg )
import HsSyn ( OutPat )
-import Id ( mkSysLocal, mkIdWithNewUniq,
- lookupIdEnv, growIdEnvList, GenId, IdEnv,
- Id
+import MkId ( mkSysLocal )
+import Id ( mkIdWithNewUniq,
+ lookupIdEnv, growIdEnvList, IdEnv, Id
)
-import PprType ( GenType, GenTyVar )
import Outputable
import SrcLoc ( noSrcLoc, SrcLoc )
import TcHsSyn ( TypecheckedPat )
-- Stuff for newtype
(con_id, arg_ids, match_result) = head alts
arg_id = head arg_ids
- coercion_bind = NonRec arg_id (Coerce (CoerceOut con_id)
- (idType arg_id)
- (Var var))
+ coercion_bind = NonRec arg_id (Note (Coerce (idType arg_id) scrut_ty) (Var var))
newtype_sanity = null (tail alts) && null (tail arg_ids)
-- Stuff for data types
import MatchCon ( matchConFamily )
import MatchLit ( matchLiterals )
import Name ( Name {--O only-} )
-import PprType ( GenType{-instance-}, GenTyVar{-ditto-} )
import PrelVals ( pAT_ERROR_ID )
import Type ( isUnpointedType, splitAlgTyConApp,
Type
\begin{code}
module HsCore (
- UfExpr(..), UfAlts(..), UfBinder(..), UfCoercion(..),
+ UfExpr(..), UfAlts(..), UfBinder(..), UfNote(..),
UfDefault(..), UfBinding(..),
UfArg(..), UfPrimOp(..)
) where
| UfApp (UfExpr name) (UfArg name)
| UfCase (UfExpr name) (UfAlts name)
| UfLet (UfBinding name) (UfExpr name)
- | UfSCC CostCentre (UfExpr name)
- | UfCoerce (UfCoercion name) (HsType name) (UfExpr name)
+ | UfNote (UfNote name) (UfExpr name)
data UfPrimOp name
= UfCCallOp FAST_STRING -- callee
| UfOtherOp name
-data UfCoercion name = UfIn name | UfOut name
+data UfNote name = UfSCC CostCentre
+ | UfCoerce (HsType name)
+ | UfInlineCall
data UfAlts name
= UfAlgAlts [(name, [name], UfExpr name)]
where
pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs]
- ppr (UfSCC uf_cc body)
- = hsep [ptext SLIT("_scc_ <cost-centre[ToDo]>"), ppr body]
+ ppr (UfNote note body)
+ = hsep [ptext SLIT("_NOTE_ [ToDo]>"), ppr body]
instance Outputable name => Outputable (UfPrimOp name) where
ppr (UfCCallOp str is_casm can_gc arg_tys result_ty)
| HsUpdate UpdateInfo
| HsArgUsage ArgUsageInfo
| HsFBType FBTypeInfo
- -- ToDo: specialisations
+ | HsSpecialise [HsTyVar name] [HsType name] (UfExpr name)
+
data HsStrictnessInfo name
= HsStrictnessInfo [Demand]
import Name ( NamedThing )
import Id ( Id )
import Outputable
-import PprType ( pprGenType, pprParendGenType, GenType, GenTyVar )
+import PprType ( pprType, pprParendType )
+import Type ( GenType )
+import TyVar ( GenTyVar )
import SrcLoc ( SrcLoc )
\end{code}
= brackets (fsep (punctuate comma (map ppr_expr exprs)))
ppr_expr (ExplicitListOut ty exprs)
= hcat [ brackets (fsep (punctuate comma (map ppr_expr exprs))),
- ifNotPprForUser ((<>) space (parens (pprGenType ty))) ]
+ ifNotPprForUser ((<>) space (parens (pprType ty))) ]
ppr_expr (ExplicitTuple exprs)
= parens (sep (punctuate comma (map ppr_expr exprs)))
ppr_expr (HsCon con_id tys args)
- = ppr con_id <+> sep (map pprParendGenType tys ++
+ = ppr con_id <+> sep (map pprParendType tys ++
map pprParendExpr args)
ppr_expr (RecordCon con_id con rbinds)
4 (ppr_expr expr)
ppr_expr (TyApp expr [ty])
- = hang (ppr_expr expr) 4 (pprParendGenType ty)
+ = hang (ppr_expr expr) 4 (pprParendType ty)
ppr_expr (TyApp expr tys)
= hang (ppr_expr expr)
import HsBinds ( HsBinds, nullBinds )
-- Others
-import PprType ( GenType{-instance Outputable-} )
-import SrcLoc ( SrcLoc{-instances-} )
+import Type ( GenType )
+import SrcLoc ( SrcLoc )
import Util ( panic )
import Outputable
import Name ( NamedThing )
import Maybes ( maybeToBool )
import Outputable
import TyCon ( maybeTyConSingleCon )
-import PprType ( GenType )
+import Type ( GenType )
import Name ( NamedThing )
\end{code}
import CmdLineOpts
import Id ( idType, dataConRawArgTys, dataConFieldLabels,
- getIdInfo, getInlinePragma, omitIfaceSigForId,
+ idInfo, omitIfaceSigForId,
dataConStrictMarks, StrictnessMark(..),
IdSet, idSetToList, unionIdSets, unitIdSet, minusIdSet,
isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet,
- pprId,
+ pprId, getIdSpecialisation,
Id
-
)
-import IdInfo ( IdInfo, StrictnessInfo, ArityInfo,
+import IdInfo ( IdInfo, StrictnessInfo, ArityInfo, InlinePragInfo(..), inlinePragInfo,
arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo,
bottomIsGuaranteed, workerExists,
)
-import PragmaInfo ( PragmaInfo(..) )
import CoreSyn ( CoreExpr, CoreBinding, GenCoreExpr, GenCoreBinding(..) )
import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding )
import FreeVars ( addExprFVs )
tyConTheta, tyConTyVars, tyConDataCons
)
import Class ( Class, classBigSig )
+import SpecEnv ( specEnvToList )
import FieldLabel ( fieldLabelName, fieldLabelType )
import Type ( mkSigmaTy, splitSigmaTy, mkDictTy,
mkTyVarTys, Type, ThetaType
where
pp_double_semi = ptext SLIT(";;")
idinfo = get_idinfo id
- inline_pragma = getInlinePragma id
+ inline_pragma = inlinePragInfo idinfo
ty_pretty = pprType (nmbrGlobalType (idType id))
sig_pretty = hcat [ppr (getOccName id), ptext SLIT(" _:_ "), ty_pretty]
prag_pretty
| opt_OmitInterfacePragmas = empty
- | otherwise = hsep [arity_pretty, strict_pretty, unfold_pretty, pp_double_semi]
+ | otherwise = hsep [arity_pretty, strict_pretty, unfold_pretty, spec_pretty, pp_double_semi]
------------ Arity --------------
arity_pretty = ppArityInfo (arityInfo idinfo)
IWantToBeINLINEd -> SLIT("_U_")
other -> SLIT("_u_")
- show_unfold = not implicit_unfolding && -- Not unnecessary
- not dodgy_unfolding -- Not dangerous
+ show_unfold = not implicit_unfolding && -- Not unnecessary
+ unfolding_is_ok -- Not dangerous
implicit_unfolding = has_worker ||
bottomIsGuaranteed strict_info
- dodgy_unfolding = case guidance of -- True <=> too big to show, or the Inline pragma
- UnfoldNever -> True -- says it shouldn't be inlined
- other -> False
-
- guidance = calcUnfoldingGuidance inline_pragma
- opt_InterfaceUnfoldThreshold
- rhs
-
+ unfolding_is_ok
+ = case inline_pragma of
+ IMustBeINLINEd -> True
+ IWantToBeINLINEd -> True
+ IMustNotBeINLINEd -> False
+ NoPragmaInfo -> case guidance of
+ UnfoldNever -> False -- Too big
+ other -> True
+
+ guidance = calcUnfoldingGuidance opt_InterfaceUnfoldThreshold rhs
+
+ ------------ Specialisations --------------
+ spec_pretty = hsep (map pp_spec (specEnvToList (getIdSpecialisation id)))
+ pp_spec (tyvars, tys, rhs) = hsep [ptext SLIT("_P_"),
+ brackets (interpp'SP tyvars),
+ hsep (map pprParendType tys),
+ ptext SLIT("="),
+ ppr rhs
+ ]
------------ Extra free Ids --------------
new_needed_ids = (needed_ids `minusIdSet` unitIdSet id) `unionIdSets`
where
final_id_map = listToUFM [(id,id) | id <- final_ids]
get_idinfo id = case lookupUFM final_id_map id of
- Just id' -> getIdInfo id'
+ Just id' -> idInfo id'
Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $
- getIdInfo id
+ idInfo id
pretties = go needed_ids (reverse binds) -- Reverse so that later things will
-- provoke earlier ones to be emitted
import {-# SOURCE #-} CoreUnfold ( mkUnfolding )
-import Id ( Id, mkImported )
+import Id ( Id, mkVanillaId, mkTemplateLocals )
import SpecEnv ( SpecEnv, emptySpecEnv )
-- friends:
import CoreSyn -- quite a bit
import IdInfo -- quite a bit
import Name ( mkWiredInIdName, Module )
-import PragmaInfo
import Type
import TyVar ( openAlphaTyVar, alphaTyVar, betaTyVar, TyVar )
import Unique -- lots of *Keys
\begin{code}
-- only used herein:
-mk_inline_unfolding = mkUnfolding IWantToBeINLINEd
+mk_inline_unfolding expr = setUnfoldingInfo (mkUnfolding expr) $
+ setInlinePragInfo IWantToBeINLINEd noIdInfo
+
+exactArityInfo n = exactArity n `setArityInfo` noIdInfo
pcMiscPrelId :: Unique{-IdKey-} -> Module -> FAST_STRING -> Type -> IdInfo -> Id
pcMiscPrelId key mod occ ty info
= let
name = mkWiredInIdName key mod occ imp
- imp = mkImported name ty info -- the usual case...
+ imp = mkVanillaId 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 = noIdInfo `addStrictnessInfo` mkBottomStrictnessInfo
+ bottoming_info = mkBottomStrictnessInfo `setStrictnessInfo` noIdInfo
-- these "bottom" out, no matter what their arguments
eRROR_ID
generic_ERROR_ID u n
= pc_bottoming_Id u pREL_ERR n errorTy
+rEC_SEL_ERROR_ID
+ = generic_ERROR_ID recSelErrIdKey SLIT("patError")
pAT_ERROR_ID
= generic_ERROR_ID patErrorIdKey SLIT("patError")
rEC_CON_ERROR_ID
\begin{code}
tRACE_ID
= pcMiscPrelId traceIdKey pREL_IO_BASE SLIT("trace") traceTy
- (noIdInfo `setSpecInfo` pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy)
+ (pcGenerateSpecs traceIdKey tRACE_ID noIdInfo traceTy `setSpecInfo` noIdInfo)
where
traceTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [mkListTy charTy, alphaTy] alphaTy)
\end{code}
= pcMiscPrelId unpackCStringIdKey pREL_PACK SLIT("unpackCString#")
(mkFunTys [addrPrimTy{-a char *-}] stringTy) noIdInfo
-- Andy says:
--- (FunTy addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` exactArity 1)
+-- (FunTy addrPrimTy{-a char *-} stringTy) (exactArityInfo 1)
-- but I don't like wired-in IdInfos (WDP)
unpackCString2Id -- for cases when a string has a NUL in it
unpackCStringAppendId
= pcMiscPrelId unpackCStringAppendIdKey pREL_PACK SLIT("unpackAppendCString#")
(mkFunTys [addrPrimTy{-a "char *" pointer-},stringTy] stringTy)
- ((noIdInfo
- {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringAppendIdKey-})
- `addArityInfo` exactArity 2)
+ (exactArityInfo 2)
unpackCStringFoldrId
= pcMiscPrelId unpackCStringFoldrIdKey pREL_PACK SLIT("unpackFoldrCString#")
mkFunTys [charTy, alphaTy] alphaTy,
alphaTy]
alphaTy))
- ((noIdInfo
- {-LATER:`addUnfoldInfo` mkMagicUnfolding unpackCStringFoldrIdKey-})
- `addArityInfo` exactArity 3)
+ (exactArityInfo 3)
\end{code}
OK, this is Will's idea: we should have magic values for Integers 0,
seqId = pcMiscPrelId seqIdKey pRELUDE SLIT("seq")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [alphaTy, betaTy] betaTy))
- (noIdInfo `addUnfoldInfo` (mk_inline_unfolding seq_template))
+ (mk_inline_unfolding seq_template)
where
[x, y, z]
= mkTemplateLocals [
parId = pcMiscPrelId parIdKey cONC_BASE SLIT("par")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [alphaTy, betaTy] betaTy))
- (noIdInfo `addUnfoldInfo` (mk_inline_unfolding par_template))
+ (mk_inline_unfolding par_template)
where
[x, y, z]
= mkTemplateLocals [
forkId = pcMiscPrelId forkIdKey cONC_BASE SLIT("fork")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [alphaTy, betaTy] betaTy))
- (noIdInfo `addUnfoldInfo` (mk_inline_unfolding fork_template))
+ (mk_inline_unfolding fork_template)
where
[x, y, z]
= mkTemplateLocals [
parLocalId = pcMiscPrelId parLocalIdKey cONC_BASE SLIT("parLocal")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
- (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parLocal_template))
+ (mk_inline_unfolding parLocal_template)
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, x, y, z]
parGlobalId = pcMiscPrelId parGlobalIdKey cONC_BASE SLIT("parGlobal")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
- (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parGlobal_template))
+ (mk_inline_unfolding parGlobal_template)
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, x, y, z]
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
alphaTy, betaTy, gammaTy] gammaTy))
- (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAt_template))
+ (mk_inline_unfolding parAt_template)
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, v, x, y, z]
parAtAbsId = pcMiscPrelId parAtAbsIdKey cONC_BASE SLIT("parAtAbs")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
- (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtAbs_template))
+ (mk_inline_unfolding parAtAbs_template)
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, v, x, y, z]
parAtRelId = pcMiscPrelId parAtRelIdKey cONC_BASE SLIT("parAtRel")
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy, intPrimTy, alphaTy, betaTy] betaTy))
- (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtRel_template))
+ (mk_inline_unfolding parAtRel_template)
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, v, x, y, z]
(mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [intPrimTy, intPrimTy, intPrimTy, intPrimTy,
alphaTy, betaTy, gammaTy] gammaTy))
- (noIdInfo `addUnfoldInfo` (mk_inline_unfolding parAtForNow_template))
+ (mk_inline_unfolding parAtForNow_template)
where
-- Annotations: w: name, g: gran. info, s: size info, p: par info -- HWL
[w, g, s, p, v, x, y, z]
copyableId = pcMiscPrelId copyableIdKey cONC_BASE SLIT("copyable")
(mkSigmaTy [alphaTyVar] []
alphaTy)
- (noIdInfo `addUnfoldInfo` (mk_inline_unfolding copyable_template))
+ (mk_inline_unfolding copyable_template)
where
-- Annotations: x: closure that's tagged to by copyable
[x, z]
noFollowId = pcMiscPrelId noFollowIdKey cONC_BASE SLIT("noFollow")
(mkSigmaTy [alphaTyVar] []
alphaTy)
- (noIdInfo `addUnfoldInfo` (mk_inline_unfolding noFollow_template))
+ (mk_inline_unfolding noFollow_template)
where
-- Annotations: x: closure that's tagged to not follow
[x, z]
\begin{code}
buildId
= pcMiscPrelId buildIdKey pREL_ERR SLIT("build") buildTy
- ((((noIdInfo
- {-LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey-})
+ noIdInfo
+ {- LATER:`addUnfoldInfo` mkMagicUnfolding buildIdKey)
`addStrictnessInfo` mkStrictnessInfo [WwStrict] False)
`addArgUsageInfo` mkArgUsageInfo [ArgUsage 2])
`setSpecInfo` pcGenerateSpecs buildIdKey buildId noIdInfo{-ToDo-} buildTy)
+ -}
-- cheating, but since _build never actually exists ...
where
-- The type of this strange object is:
\begin{code}
augmentId
= pcMiscPrelId augmentIdKey pREL_ERR SLIT("augment") augmentTy
- (((noIdInfo
- {-LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey-})
+ noIdInfo
+ {- LATER:`addUnfoldInfo` mkMagicUnfolding augmentIdKey)
`addStrictnessInfo` mkStrictnessInfo [WwStrict,WwLazy False] False)
`addArgUsageInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
+ -}
-- cheating, but since _augment never actually exists ...
where
-- The type of this strange object is:
mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
- idInfo = (((((noIdInfo
- {-LATER:`addUnfoldInfo` mkMagicUnfolding foldrIdKey-})
- `addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
- `addArityInfo` exactArity 3)
- `addUpdateInfo` mkUpdateInfo [2,2,1])
- `setSpecInfo` pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy)
+ idInfo = noIdInfo
+ {- LATER: mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False `setStrictnessInfo`
+ exactArity 3 `setArityInfo`
+ mkUpdateInfo [2,2,1] `setUpdateInfo`
+ pcGenerateSpecs foldrIdKey foldrId noIdInfo{-ToDo-} foldrTy `setSpecInfo`
+ noIdInfo
+ -}
foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl")
foldlTy idInfo
mkSigmaTy [alphaTyVar, betaTyVar] []
(mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
- idInfo = (((((noIdInfo
- {-LATER:`addUnfoldInfo` mkMagicUnfolding foldlIdKey-})
+ idInfo = noIdInfo
+ {- LATER: `addUnfoldInfo` mkMagicUnfolding foldlIdKey)
`addStrictnessInfo` mkStrictnessInfo [WwLazy False,WwLazy False,WwStrict] False)
`addArityInfo` exactArity 3)
`addUpdateInfo` mkUpdateInfo [2,2,1])
`setSpecInfo` pcGenerateSpecs foldlIdKey foldlId noIdInfo{-ToDo-} foldlTy)
+ -}
-- A bit of magic goes no here. We translate appendId into ++,
-- you have to be carefull when you actually compile append:
import Constants ( mIN_MP_INT_SIZE, mP_STRUCT_SIZE )
import HeapOffs ( addOff, intOff, totHdrSize, HeapOffset )
import Outputable
-import PprType ( pprParendGenType, GenTyVar{-instance Outputable-} )
+import PprType ( pprParendType )
import SMRep ( SMRep(..), SMSpecRepKind(..), SMUpdateKind(..) )
import TyCon ( TyCon{-instances-} )
import Type ( mkForAllTys, mkFunTy, mkFunTys, mkTyConApp, typePrimRep,
splitAlgTyConApp, Type
)
-import TyVar --( alphaTyVar, betaTyVar, gammaTyVar, GenTyVar{-instance Eq-} )
+import TyVar --( alphaTyVar, betaTyVar, gammaTyVar )
import Unique ( Unique{-instance Eq-} )
import Util ( panic#, assoc, panic{-ToDo:rm-} )
= if is_casm then text "''" else empty
pp_tys
- = hsep (map pprParendGenType (res_ty:arg_tys))
+ = hsep (map pprParendType (res_ty:arg_tys))
in
hcat [text before, ptext fun, after, space, brackets pp_tys]
#include "HsVersions.h"
-import {-# SOURCE #-} Id ( Id, mkDataCon, mkTupleCon, StrictnessMark(..) )
+import {-# SOURCE #-} MkId ( mkDataCon, mkTupleCon )
+import {-# SOURCE #-} Id ( Id, StrictnessMark(..) )
-- friends:
import PrelMods
import CmdLineOpts ( opt_AutoSccsOnIndividualCafs )
import CostCentre -- lots of things
-import Id ( idType, mkSysLocal, emptyIdSet, Id )
+import MkId ( mkSysLocal )
+import Id ( idType, emptyIdSet, Id )
import SrcLoc ( noSrcLoc )
import Type ( splitSigmaTy, splitFunTy_maybe )
import UniqSupply ( getUnique, splitUniqSupply, UniqSupply )
| ITarity
| ITunfold Bool -- True <=> there's an INLINE pragma on this Id
| ITstrict [Demand] | ITbottom
+ | ITspecialise
| ITlam | ITbiglam | ITcase | ITprim_case | ITlet | ITletrec | ITin | ITof
- | ITcoerce_in | ITcoerce_out | ITatsign
+ | ITcoerce | ITinline | ITatsign
| ITccall (Bool,Bool) -- (is_casm, may_gc)
| ITscc CostCentre
| ITchar Char | ITstring FAST_STRING
,("u_", ITunfold False)
,("U_", ITunfold True)
,("A_", ITarity)
- ,("coerce_in_", ITcoerce_in)
- ,("coerce_out_", ITcoerce_out)
+ ,("P_", ITspecialise)
+ ,("coerce_", ITcoerce)
+ ,("inline_", ITinline)
,("bot_", ITbottom)
,("integer_", ITinteger_lit)
,("rational_", ITrational_lit)
TYPE_PART { ITtysig _ _ }
ARITY_PART { ITarity }
UNFOLD_PART { ITunfold $$ }
+ SPECIALISE { ITspecialise }
BOTTOM { ITbottom }
LAM { ITlam }
BIGLAM { ITbiglam }
LETREC { ITletrec }
IN { ITin }
OF { ITof }
- COERCE_IN { ITcoerce_in }
- COERCE_OUT { ITcoerce_out }
+ COERCE { ITcoerce }
ATSIGN { ITatsign }
CCALL { ITccall $$ }
SCC { ITscc $$ }
+ INLINE_CALL { ITinline }
CHAR { ITchar $$ }
STRING { ITstring $$ }
| strict_info { HsStrictness $1 }
| BOTTOM { HsStrictness HsBottom }
| UNFOLD_PART core_expr { HsUnfold $1 $2 }
+ | SPECIALISE OBRACK tv_bndrs CBRACK
+ atypes EQUAL core_expr { HsSpecialise $3 $5 $7 }
arity_info :: { ArityInfo }
arity_info : INTEGER { exactArity (fromInteger $1) }
| LETREC OCURLY rec_binds CCURLY
IN core_expr { UfLet (UfRec $3) $6 }
- | coerce atype core_expr { UfCoerce $1 $2 $3 }
-
| CCALL ccall_string
OBRACK atype atypes CBRACK core_args { let
(is_casm, may_gc) = $1
UfPrim (UfCCallOp $2 is_casm may_gc $5 $4)
$7
}
- | SCC core_expr { UfSCC $1 $2 }
+ | INLINE_CALL core_expr { UfNote UfInlineCall $2 }
+ | COERCE atype core_expr { UfNote (UfCoerce $2) $3 }
+ | SCC core_expr { UfNote (UfSCC $1) $2 }
rec_binds :: { [(UfBinder RdrName, UfExpr RdrName)] }
: { [] }
| core_val_bndr EQUAL core_expr SEMI rec_binds { ($1,$3) : $5 }
-coerce :: { UfCoercion RdrName }
-coerce : COERCE_IN qdata_name { UfIn $2 }
- | COERCE_OUT qdata_name { UfOut $2 }
-
prim_alts :: { [(Literal,UfExpr RdrName)] }
: { [] }
| core_lit RARROW core_expr SEMI prim_alts { ($1,$3) : $5 }
rnCoreAlts alts `thenRn` \ alts' ->
returnRn (UfCase scrut' alts')
-rnCoreExpr (UfSCC cc expr)
- = rnCoreExpr expr `thenRn` \ expr' ->
- returnRn (UfSCC cc expr')
-
-rnCoreExpr(UfCoerce coercion ty body)
- = rnCoercion coercion `thenRn` \ coercion' ->
- rnHsType ty `thenRn` \ ty' ->
- rnCoreExpr body `thenRn` \ body' ->
- returnRn (UfCoerce coercion' ty' body')
+rnCoreExpr (UfNote note expr)
+ = rnNote note `thenRn` \ note' ->
+ rnCoreExpr expr `thenRn` \ expr' ->
+ returnRn (UfNote note' expr')
rnCoreExpr (UfLam bndr body)
= rnCoreBndr bndr $ \ bndr' ->
rnCoreExpr rhs `thenRn` \ rhs' ->
returnRn (UfBindDefault bndr' rhs')
-rnCoercion (UfIn n) = lookupOccRn n `thenRn` \ n' -> returnRn (UfIn n')
-rnCoercion (UfOut n) = lookupOccRn n `thenRn` \ n' -> returnRn (UfOut n')
+rnNote (UfCoerce ty)
+ = rnHsType ty `thenRn` \ ty' ->
+ returnRn (UfCoerce ty')
+
+rnNote (UfSCC cc) = returnRn (UfSCC cc)
+rnNote UfInlineCall = returnRn UfInlineCall
rnCorePrim (UfOtherOp op)
= lookupOccRn op `thenRn` \ op' ->
= addArgs 1 (analExprFBWW e (delOneFromIdEnv env id))
analExprFBWW (CoTyLam tyvar e) env = analExprFBWW e env
-analExprFBWW (App f atom) env = rmArg (analExprFBWW f env)
-analExprFBWW (CoTyApp f ty) env = analExprFBWW f env
-analExprFBWW (SCC lab e) env = analExprFBWW e env
-analExprFBWW (Coerce _ _ _) env = panic "AnalFBWW:analExprFBWW:Coerce"
-analExprFBWW (Let binds e) env = analExprFBWW e (analBind binds env)
-analExprFBWW (Case e alts) env = foldl1 joinFBType (analAltsFBWW alts env)
+analExprFBWW (App f atom) env = rmArg (analExprFBWW f env)
+analExprFBWW (CoTyApp f ty) env = analExprFBWW f env
+analExprFBWW (Note _ e) env = analExprFBWW e env
+analExprFBWW (Let binds e) env = analExprFBWW e (analBind binds env)
+analExprFBWW (Case e alts) env = foldl1 joinFBType (analAltsFBWW alts env)
analAltsFBWW (AlgAlts alts deflt) env
= case analDefFBWW deflt env of
annotateExprFBWW (CoTyLam tyvar e) env = CoTyLam tyvar (annotateExprFBWW e env)
annotateExprFBWW (App f atom) env = App (annotateExprFBWW f env) atom
annotateExprFBWW (CoTyApp f ty) env = CoTyApp (annotateExprFBWW f env) ty
-annotateExprFBWW (SCC lab e) env = SCC lab (annotateExprFBWW e env)
-annotateExprFBWW (Coerce c ty e) env = Coerce c ty (annotateExprFBWW e env)
+annotateExprFBWW (Note note e) env = Note note (annotateExprFBWW e env)
annotateExprFBWW (Case e alts) env = Case (annotateExprFBWW e env)
(annotateAltsFBWW alts env)
annotateExprFBWW (Let bnds e) env = Let bnds' (annotateExprFBWW e env')
getBinderInfoArity,
setBinderInfoArityToZero,
- okToInline, isOneOcc, isOneFunOcc, isOneSafeFunOcc, isDeadOcc,
+ isOneOcc, isOneFunOcc, isOneSafeFunOcc, isOneSameSCCFunOcc,
+ isDeadOcc, isInlinableOcc,
isFun, isDupDanger -- for Simon Marlow deforestation
) where
isOneFunOcc (OneOcc FunOcc _ _ _ _) = True
isOneFunOcc other_bind = False
-isOneSafeFunOcc :: Bool -> BinderInfo -> Bool
-isOneSafeFunOcc ok_to_dup (OneOcc FunOcc NoDupDanger NotInsideSCC n_alts _)
- = ok_to_dup || n_alts <= 1
-isOneSafeFunOcc ok_to_dup other_bind = False
+isOneSameSCCFunOcc :: BinderInfo -> Bool
+isOneSameSCCFunOcc (OneOcc FunOcc _ NotInsideSCC _ _) = True
+isOneSameSCCFunOcc other_bind = False
+
+isOneSafeFunOcc :: BinderInfo -> Bool -- Completely safe
+isOneSafeFunOcc (OneOcc FunOcc NoDupDanger NotInsideSCC n_alts _) = n_alts <= 1
+isOneSafeFunOcc other = False
+
+-- A non-WHNF can be inlined if it doesn't occur inside a lambda,
+-- and occurs exactly once or
+-- occurs once in each branch of a case and is small
+--
+-- If the thing is in WHNF, there's no danger of duplicating work,
+-- so we can inline if it occurs once, or is small
+isInlinableOcc :: Bool -- True <=> don't worry about dup-danger
+ -> Bool -- True <=> don't worry about code size
+ -> BinderInfo
+ -> Bool -- Inlinable
+isInlinableOcc whnf small (ManyOcc _)
+ = whnf && small
+isInlinableOcc whnf small (OneOcc _ dup_danger _ n_alts _)
+ = (whnf || (case dup_danger of {NoDupDanger -> True; other -> False}))
+ && (small || n_alts <= 1)
isDeadOcc :: BinderInfo -> Bool
isDeadOcc DeadCode = True
\end{code}
-\begin{code}
-okToInline :: Bool -- The thing is WHNF or bottom;
- -> Bool -- It's small enough to duplicate the code
- -> BinderInfo
- -> Bool -- True <=> inline it
-
--- A non-WHNF can be inlined if it doesn't occur inside a lambda,
--- and occurs exactly once or
--- occurs once in each branch of a case and is small
-okToInline False small_enough (OneOcc _ NoDupDanger _ n_alts _)
- = n_alts <= 1 || small_enough
-
--- If the thing isn't a redex, there's no danger of duplicating work,
--- so we can inline if it occurs once, or is small
-okToInline True small_enough occ_info
- = one_occ || small_enough
- where
- one_occ = case occ_info of
- OneOcc _ _ _ n_alts _ -> n_alts <= 1
- other -> False
-
-okToInline whnf_or_bot small_enough any_occ = False
-\end{code}
-
Construction
~~~~~~~~~~~~~
where
whnf :: CoreExprWithFVs -> Bool
- whnf (_,AnnLit _) = True
- whnf (_,AnnCon _ _) = True
- whnf (_,AnnLam x e) = if isValBinder x then True else whnf e
- whnf (_,AnnSCC _ e) = whnf e
- whnf _ = False
+ whnf (_,AnnLit _) = True
+ whnf (_,AnnCon _ _) = True
+ whnf (_,AnnLam x e) = if isValBinder x then True else whnf e
+ whnf (_,AnnNote _ e) = whnf e
+ whnf _ = False
\end{code}
Applications: we could float inside applications, but it's probably
We don't float lets inwards past an SCC.
-ToDo: SCC: {\em should} keep info on current cc, and when passing
-one, if it is not the same, annotate all lets in binds with current
-cc, change current cc to the new one and float binds into expr.
-\begin{code}
-fiExpr to_drop (_, AnnSCC cc expr)
- = mkCoLets' to_drop (SCC cc (fiExpr [] expr))
-\end{code}
+ToDo: SCC: {\em should}
\begin{code}
-fiExpr to_drop (_, AnnCoerce c ty expr)
- = --trace "fiExpr:Coerce:wimping out" $
- mkCoLets' to_drop (Coerce c ty (fiExpr [] expr))
+fiExpr to_drop (_, AnnNote note@(SCC cc) expr)
+ = -- Wimp out for now
+ -- ToDo: keep info on current cc, and when passing
+ -- one, if it is not the same, annotate all lets in binds with current
+ -- cc, change current cc to the new one and float binds into expr.
+ mkCoLets' to_drop (Note note (fiExpr [] expr))
+
+fiExpr to_drop (_, AnnNote InlineCall expr)
+ = -- Wimp out for InlineCall; keep it close
+ -- the the call it annotates
+ mkCoLets' to_drop (Note InlineCall (fiExpr [] expr))
+
+fiExpr to_drop (_, AnnNote note@(Coerce _ _) expr)
+ = -- Just float in past coercion
+ Note note (fiExpr to_drop expr)
\end{code}
For @Lets@, the possible ``drop points'' for the \tr{to_drop}
import CmdLineOpts ( opt_D_verbose_core2core, opt_D_simplifier_stats )
import CostCentre ( dupifyCC, CostCentre )
import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList, IdEnv,
- GenId{-instance Outputable-}, Id
+ Id
)
import PprCore
-import PprType ( GenTyVar )
import SetLevels -- all of it
import BasicTypes ( Unused )
-import TyVar ( GenTyVar{-instance Eq-}, TyVar )
-import Unique ( Unique{-instance Eq-} )
+import TyVar ( TyVar )
import UniqSupply ( UniqSupply )
import List ( partition )
import Outputable
Lam (ValBinder arg) (install heres rhs'))
}}
-floatExpr env lvl (SCC cc expr)
+floatExpr env lvl (Note note@(SCC cc) expr)
= case (floatExpr env lvl expr) of { (fs, floating_defns, expr') ->
let
-- annotate bindings floated outwards past an scc expression
annotated_defns = annotate (dupifyCC cc) floating_defns
in
- (fs, annotated_defns, SCC cc expr') }
+ (fs, annotated_defns, Note note expr') }
where
annotate :: CostCentre -> FloatingBinds -> FloatingBinds
ann_bind (LetFloater (Rec pairs))
= LetFloater (Rec [(binder, ann_rhs rhs) | (binder, rhs) <- pairs])
- ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> SCC dupd_cc (fn rhs) )
+ ann_bind (CaseFloater fn) = CaseFloater ( \ rhs -> Note (SCC dupd_cc) (fn rhs) )
ann_rhs (Lam arg e) = Lam arg (ann_rhs e)
ann_rhs rhs@(Con _ _) = rhs -- no point in scc'ing WHNF data
- ann_rhs rhs = SCC dupd_cc rhs
+ ann_rhs rhs = Note (SCC dupd_cc) rhs
-- Note: Nested SCC's are preserved for the benefit of
-- cost centre stack profiling (Durham)
-floatExpr env lvl (Coerce c ty expr)
+floatExpr env lvl (Note note expr) -- Other than SCCs
= case (floatExpr env lvl expr) of { (fs, floating_defns, expr') ->
- (fs, floating_defns, Coerce c ty expr') }
+ (fs, floating_defns, Note note expr') }
floatExpr env lvl (Let bind body)
= case (floatBind env lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
wwExpr (CoTyApp f ty) =
wwExpr f `thenWw` \ f' ->
returnWw (CoTyApp f' ty)
-wwExpr (SCC lab e) =
+wwExpr (Note note e) =
wwExpr e `thenWw` \ e' ->
- returnWw (SCC lab e')
-wwExpr (Coerce c ty e) =
- wwExpr e `thenWw` \ e' ->
- returnWw (Coerce c ty e')
+ returnWw (Note note e')
wwExpr (Let bnds e) =
wwExpr e `thenWw` \ e' ->
wwBind bnds `thenWw` \ bnds' ->
liberateCase = panic "LiberateCase.liberateCase: ToDo"
{- LATER: to end of file:
-import CoreUnfold ( UnfoldingGuidance(..), PragmaInfo(..) )
+import CoreUnfold ( UnfoldingGuidance(..) )
import Id ( localiseId )
+import IdInfo { InlinePragInfo(..) }
import Maybes
import Outputable
import Util
libCase env (Con con tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Con con tys args)
libCase env (Prim op tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Prim op tys args)
libCase env (CoTyLam tv body) = CoTyLam tv (libCase env body)
-libCase env (SCC cc body) = SCC cc (libCase env body)
-libCase env (Coerce c ty body) = Coerce c ty (libCase env body)
+libCase env (Note note body) = Note note (libCase env body)
libCase env (Lam binder body)
= Lam binder (libCase (addBinders env [binder]) body)
Constructors are rather like lambdas in this way.
\begin{code}
-occAnal env (Con con args) = (mapIdEnv markDangerousToDup (occAnalArgs env args),
- Con con args)
+occAnal env (Con con args)
+ = (mapIdEnv markDangerousToDup (occAnalArgs env args),
+ Con con args)
-occAnal env (SCC cc body)
- = (mapIdEnv markInsideSCC usage, SCC cc body')
+occAnal env (Note note@(SCC cc) body)
+ = (mapIdEnv markInsideSCC usage, Note note body')
where
(usage, body') = occAnal env body
-occAnal env (Coerce c ty body)
- = (usage, Coerce c ty body')
+occAnal env (Note note body)
+ = (usage, Note note body')
where
(usage, body') = occAnal env body
mapSAT satExpr rhss `thenSAT` \ rhss' ->
returnSAT (Let (Rec (zipEqual "satExpr:Rec" binders rhss')) body')
-satExpr (SCC cc expr)
+satExpr (Note note expr)
= satExpr expr `thenSAT` \ expr2 ->
- returnSAT (SCC cc expr2)
-
-satExpr (Coerce c ty expr)
- = satExpr expr `thenSAT` \ expr2 ->
- returnSAT (Coerce c ty expr2)
+ returnSAT (Note note expr2)
\end{code}
\begin{code}
Class, ThetaType, SigmaType,
InstTyEnv(..)
)
-import Id ( mkSysLocal, idType )
+import MkId ( mkSysLocal )
+import Id ( idType )
import SrcLoc ( SrcLoc, noSrcLoc )
import UniqSupply
import Util
import CoreUtils ( coreExprType )
import CoreUnfold ( FormSummary, whnfOrBottom, mkFormSummary )
import FreeVars -- all of it
-import Id ( idType, mkSysLocal,
+import MkId ( mkSysLocal )
+import Id ( idType,
nullIdEnv, addOneToIdEnv, growIdEnvList,
unionManyIdSets, minusIdSet, mkIdSet,
idSetToList, Id,
= lvlExpr ctxt_lvl envs fun `thenLvl` \ fun' ->
returnLvl (App fun' arg)
-lvlExpr ctxt_lvl envs (_, AnnSCC cc expr)
+lvlExpr ctxt_lvl envs (_, AnnNote note expr)
= lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
- returnLvl (SCC cc expr')
-
-lvlExpr ctxt_lvl envs (_, AnnCoerce c ty expr)
- = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
- returnLvl (Coerce c ty expr')
+ returnLvl (Note note expr')
-- We don't split adjacent lambdas. That is, given
-- \x y -> (x+1,y)
import FloatIn ( floatInwards )
import FloatOut ( floatOutwards )
import FoldrBuildWW ( mkFoldrBuildWW )
-import Id ( mkSysLocal, mkUserId, setIdVisibility, replaceIdInfo,
- replacePragmaInfo, getIdDemandInfo, idType,
- getIdInfo, getPragmaInfo, mkIdWithNewUniq,
+import MkId ( mkSysLocal, mkUserId )
+import Id ( setIdVisibility,
+ getIdDemandInfo, idType,
nullIdEnv, addOneToIdEnv, delOneFromIdEnv,
lookupIdEnv, IdEnv,
Id
import LiberateCase ( liberateCase )
import MagicUFs ( MagicUnfoldingFun )
import PprCore
-import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-},
- nmbrType
- )
+import PprType ( nmbrType )
import SAT ( doStaticArgs )
import SimplMonad ( zeroSimplCount, showSimplCount, SimplCount )
import SimplPgm ( simplifyPgm )
import Specialise
-import SpecUtils ( pprSpecErrs )
import StrictAnal ( saWwTopBinds )
import TyVar ( TyVar, nameTyVar )
import Unique ( Unique{-instance Eq-}, Uniquable(..),
where
(bndrs, rhss) = unzip pairs
-tidyCoreExpr (SCC cc body)
+tidyCoreExpr (Note (Coerce to_ty from_ty) body)
= tidyCoreExprEta body `thenTM` \ body' ->
- returnTM (SCC cc body')
+ tidyTy to_ty `thenTM` \ to_ty' ->
+ tidyTy from_ty `thenTM` \ from_ty' ->
+ returnTM (Note (Coerce to_ty' from_ty') body')
-tidyCoreExpr (Coerce coercion ty body)
+tidyCoreExpr (Note note body)
= tidyCoreExprEta body `thenTM` \ body' ->
- tidyTy ty `thenTM` \ ty' ->
- returnTM (Coerce coercion ty' body')
+ returnTM (Note note body')
-- Wierd case for par, seq, fork etc. See notes above.
tidyCoreExpr (Case scrut@(Prim op args) (PrimAlts _ (BindDefault binder rhs)))
-- of the binder will print the correct way (i.e. as a global not a local)
mungeTopBinder :: Id -> (Id -> TopTidyM a) -> TopTidyM a
mungeTopBinder id thing_inside mod env us
- = case lookupIdEnv env id of
- Just (ValBinder global) -> thing_inside global mod env us -- Already bound
-
- other -> -- Give it a new print-name unless it's an exported thing
- -- setNameVisibility also does the local/global thing
- let
- (id', us') | isExported id = (id, us)
- | otherwise
- = (setIdVisibility (Just mod) us id,
- incrUnique us)
-
- new_env = addToUFM env id (ValBinder id')
- in
- thing_inside id' mod new_env us'
+ = -- Give it a new print-name unless it's an exported thing
+ -- setNameVisibility also does the local/global thing
+ let
+ (id', us') | isExported id = (id, us)
+ | otherwise
+ = (setIdVisibility (Just mod) us id,
+ incrUnique us)
+ new_env = addToUFM env id (ValBinder id')
+ in
+ thing_inside id' mod new_env us'
mungeTopBinders [] k = k []
mungeTopBinders (b:bs) k = mungeTopBinder b $ \ b' ->
#include "HsVersions.h"
import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc,
- okToInline, isOneFunOcc,
+ isOneFunOcc,
BinderInfo
)
import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold,
)
import CoreSyn
import CoreUnfold ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom,
+ okToInline,
Unfolding(..), FormSummary(..),
calcUnfoldingGuidance )
import CoreUtils ( coreExprCc )
\begin{code}
-mkSimplUnfoldingGuidance chkr out_id rhs
- = calcUnfoldingGuidance (getInlinePragma out_id) opt_UnfoldingCreationThreshold rhs
-
extendEnvGivenUnfolding :: SimplEnv -> OutId -> BinderInfo -> Unfolding -> SimplEnv
extendEnvGivenUnfolding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) con_apps)
out_id occ_info rhs_info
occ_info out_id rhs
= SimplEnv chkr encl_cc ty_env (new_in_scope_ids, id_subst) new_con_apps
where
- new_in_scope_ids | okToInline (whnfOrBottom form)
+ new_in_scope_ids | okToInline out_id
+ (whnfOrBottom form)
(couldBeSmallEnoughToInline out_id guidance)
occ_info
= env_with_unfolding
form = _scc_ "eegnr.form_sum"
mkFormSummary rhs
guidance = _scc_ "eegnr.guidance"
- mkSimplUnfoldingGuidance chkr out_id rhs
+ calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
-- Attach a cost centre to the RHS if necessary
rhs_w_cc | currentOrSubsumedCosts encl_cc
|| not (noCostCentreAttached (coreExprCc rhs))
= rhs
| otherwise
- = SCC encl_cc rhs
+ = Note (SCC encl_cc) rhs
\end{code}
#include "HsVersions.h"
-import Id ( GenId, mkSysLocal, mkIdWithNewUniq, Id )
+import MkId ( mkSysLocal )
+import Id ( mkIdWithNewUniq, Id )
import SimplEnv
import SrcLoc ( noSrcLoc )
import TyVar ( TyVar )
import CmdLineOpts ( opt_DoEtaReduction, SimplifierSwitch(..) )
import CoreSyn
import CoreUnfold ( mkFormSummary, exprIsTrivial, FormSummary(..) )
-import Id ( idType, isBottomingId, mkSysLocal,
+import MkId ( mkSysLocal )
+import Id ( idType, isBottomingId, getIdArity,
addInlinePragma, addIdDemandInfo,
idWantsToBeINLINEd, dataConArgTys, Id,
- getIdArity,
)
import IdInfo ( ArityInfo(..), DemandInfo )
import Maybes ( maybeToBool )
floatExposesHNF
:: Bool -- Float let(rec)s out of rhs
-> Bool -- Float cheap primops out of rhs
- -> Bool -- OK to duplicate code
-> GenCoreExpr bdr Id flexi
-> Bool
-floatExposesHNF float_lets float_primops ok_to_dup rhs
+floatExposesHNF float_lets float_primops rhs
= try rhs
where
try (Case (Prim _ _) (PrimAlts alts deflt) )
- | float_primops && (null alts || ok_to_dup)
+ | float_primops && null alts
= or (try_deflt deflt : map try_alt alts)
try (Let bind body) | float_lets = try body
residual_ok (App fun arg)
| arg `mentions` bndr = False
| otherwise = residual_ok fun
- residual_ok (Coerce coercion ty body)
- | TyArg ty `mentions` bndr = False
- | otherwise = residual_ok body
+ residual_ok (Note (Coerce to_ty from_ty) body)
+ | TyArg to_ty `mentions` bndr
+ || TyArg from_ty `mentions` bndr = False
+ | otherwise = residual_ok body
residual_ok other = False -- Safe answer
-- This last clause may seem conservative, but consider:
\begin{code}
manifestlyCheap :: GenCoreExpr bndr Id flexi -> Bool
-manifestlyCheap (Var _) = True
-manifestlyCheap (Lit _) = True
-manifestlyCheap (Con _ _) = True
-manifestlyCheap (SCC _ e) = manifestlyCheap e
-manifestlyCheap (Coerce _ _ e) = manifestlyCheap e
-manifestlyCheap (Lam x e) = if isValBinder x then True else manifestlyCheap e
-manifestlyCheap (Prim op _) = primOpIsCheap op
+manifestlyCheap (Var _) = True
+manifestlyCheap (Lit _) = True
+manifestlyCheap (Con _ _) = True
+manifestlyCheap (Note _ e) = manifestlyCheap e
+manifestlyCheap (Lam x e) = if isValBinder x then True else manifestlyCheap e
+manifestlyCheap (Prim op _) = primOpIsCheap op
manifestlyCheap (Let bind body)
= manifestlyCheap body && all manifestlyCheap (rhssOfBind bind)
import CmdLineOpts ( switchIsOn, SimplifierSwitch(..) )
import CoreSyn
import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
- FormSummary, whnfOrBottom,
+ FormSummary, whnfOrBottom, okToInline,
smallEnoughToInline )
import CoreUtils ( coreExprCc )
-import BinderInfo ( BinderInfo, noBinderInfo, okToInline )
+import BinderInfo ( BinderInfo, noBinderInfo )
import CostCentre ( CostCentre, noCostCentreAttached, isCurrentCostCentre )
-import Id ( idType, getIdInfo, getIdUnfolding,
+import Id ( idType, getIdUnfolding,
getIdSpecialisation, setIdSpecialisation,
idMustBeINLINEd, idHasNoFreeTyVars,
mkIdWithNewUniq, mkIdWithNewType,
This where all the heavy-duty unfolding stuff comes into its own.
\begin{code}
-completeVar env var args result_ty
+completeVar env inline_call var args result_ty
| maybeToBool maybe_magic_result
= tick MagicUnfold `thenSmpl_`
-- If "essential_unfoldings_only" is true we do no inlinings at all,
-- EXCEPT for things that absolutely have to be done
-- (see comments with idMustBeINLINEd)
- && ok_to_inline
+ && (inline_call || ok_to_inline)
&& costCentreOk (getEnclosingCC env) (coreExprCc unf_template)
=
{-
tickUnfold var `thenSmpl_`
simplExpr unf_env unf_template args result_ty
+ | inline_call -- There was an InlineCall note, but we didn't inline!
+ = returnSmpl (mkGenApp (Note InlineCall (Var var')) args)
+
| otherwise
= returnSmpl (mkGenApp (Var var') args)
sw_chkr = getSwitchChecker env
essential_unfoldings_only = switchIsOn sw_chkr EssentialUnfoldingsOnly
is_case_scrutinee = switchIsOn sw_chkr SimplCaseScrutinee
- ok_to_inline = okToInline (whnfOrBottom form) small_enough occ_info
+ ok_to_inline = okToInline var (whnfOrBottom form) small_enough occ_info
small_enough = smallEnoughToInline var arg_evals is_case_scrutinee guidance
arg_evals = [is_evald arg | arg <- args, isValArg arg]
Variables
~~~~~~~~~
-Check if there's a macro-expansion, and if so rattle on. Otherwise do
-the more sophisticated stuff.
\begin{code}
simplExpr env (Var var) args result_ty
- = case lookupIdSubst env var of
-
- Just (SubstExpr ty_subst id_subst expr)
- -> simplExpr (setSubstEnvs env (ty_subst, id_subst)) expr args result_ty
-
- Just (SubstLit lit) -- A boring old literal
- -> ASSERT( null args )
- returnSmpl (Lit lit)
-
- Just (SubstVar var') -- More interesting! An id!
- -> completeVar env var' args result_ty
-
- Nothing -- Not in the substitution; hand off to completeVar
- -> completeVar env var args result_ty
+ = simplVar env False {- No InlineCall -} var args result_ty
\end{code}
Literals
Coercions
~~~~~~~~~
\begin{code}
-simplExpr env (Coerce coercion ty body) args result_ty
- = simplCoerce env coercion ty body args result_ty
-\end{code}
-
-
-Set-cost-centre
-~~~~~~~~~~~~~~~
-
-1) Eliminating nested sccs ...
-We must be careful to maintain the scc counts ...
-
-\begin{code}
-simplExpr env (SCC cc1 (SCC cc2 expr)) args result_ty
- | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ -> True; _ -> False }
- -- eliminate inner scc if no call counts and same cc as outer
- = simplExpr env (SCC cc1 expr) args result_ty
+simplExpr env (Note (Coerce to_ty from_ty) body) args result_ty
+ = simplCoerce env to_ty from_ty body args result_ty
- | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
- -- eliminate outer scc if no call counts associated with either ccs
- = simplExpr env (SCC cc2 expr) args result_ty
-\end{code}
-
-2) Moving sccs inside lambdas ...
-
-\begin{code}
-simplExpr env (SCC cc (Lam binder@(ValBinder _) body)) args result_ty
- | not (isSccCountCostCentre cc)
- -- move scc inside lambda only if no call counts
- = simplExpr env (Lam binder (SCC cc body)) args result_ty
+simplExpr env (Note (SCC cc) body) args result_ty
+ = simplSCC env cc body args result_ty
-simplExpr env (SCC cc (Lam binder body)) args result_ty
- -- always ok to move scc inside type/usage lambda
- = simplExpr env (Lam binder (SCC cc body)) args result_ty
-\end{code}
+-- InlineCall is simple enough to deal with on the spot
+-- The only complication is that we slide the InlineCall
+-- inwards past any function arguments
+simplExpr env (Note InlineCall expr) args result_ty
+ = go expr args
+ where
+ go (Var v) args = simplVar env True {- InlineCall -} v args result_ty
-3) Eliminating dict sccs ...
+ go (App fun arg) args = simplArg env arg `appEager` \ arg' ->
+ go fun (arg' : args)
-\begin{code}
-simplExpr env (SCC cc expr) args result_ty
- | squashableDictishCcExpr cc expr
- -- eliminate dict cc if trivial dict expression
- = simplExpr env expr args result_ty
+ go other args = -- Unexpected discard; report it
+ pprTrace "simplExpr: discarding InlineCall" (ppr expr) $
+ simplExpr env other args result_ty
\end{code}
-4) Moving arguments inside the body of an scc ...
-This moves the cost of doing the application inside the scc
-(which may include the cost of extracting methods etc)
-\begin{code}
-simplExpr env (SCC cost_centre body) args result_ty
- = let
- new_env = setEnclosingCC env cost_centre
- in
- simplExpr new_env body args result_ty `thenSmpl` \ body' ->
- returnSmpl (SCC cost_centre body')
-\end{code}
%************************************************************************
%* *
\end{code}
+%************************************************************************
+%* *
+\subsection[Simplify-var]{Variables}
+%* *
+%************************************************************************
+
+Check if there's a macro-expansion, and if so rattle on. Otherwise do
+the more sophisticated stuff.
+
+\begin{code}
+simplVar env inline_call var args result_ty
+ = case lookupIdSubst env var of
+
+ Just (SubstExpr ty_subst id_subst expr)
+ -> simplExpr (setSubstEnvs env (ty_subst, id_subst)) expr args result_ty
+
+ Just (SubstLit lit) -- A boring old literal
+ -> ASSERT( null args )
+ returnSmpl (Lit lit)
+
+ Just (SubstVar var') -- More interesting! An id!
+ -> completeVar env inline_call var' args result_ty
+
+ Nothing -- Not in the substitution; hand off to completeVar
+ -> completeVar env inline_call var args result_ty
+\end{code}
+
%************************************************************************
%* *
\begin{code}
-- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
-simplCoerce env coercion ty expr@(Case scrut alts) args result_ty
+simplCoerce env to_ty from_ty expr@(Case scrut alts) args result_ty
= simplCase env scrut (getSubstEnvs env, alts)
- (\env rhs -> simplCoerce env coercion ty rhs args result_ty)
+ (\env rhs -> simplCoerce env to_ty from_ty rhs args result_ty)
result_ty
-- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
-simplCoerce env coercion ty (Let bind body) args result_ty
- = simplBind env bind (\env -> simplCoerce env coercion ty body args result_ty) result_ty
+simplCoerce env to_ty from_ty (Let bind body) args result_ty
+ = simplBind env bind (\env -> simplCoerce env to_ty from_ty body args result_ty) result_ty
-- Default case
-simplCoerce env coercion ty expr args result_ty
- = simplTy env ty `appEager` \ ty' ->
- simplTy env expr_ty `appEager` \ expr_ty' ->
- simplExpr env expr [] expr_ty' `thenSmpl` \ expr' ->
- returnSmpl (mkGenApp (mkCoerce coercion ty' expr') args)
- where
- expr_ty = coreExprType (unTagBinders expr) -- Rather like simplCase other_scrut
+-- NB: we do *not* push the argments inside the coercion
+simplCoerce env to_ty from_ty expr args result_ty
+ = simplTy env to_ty `appEager` \ to_ty' ->
+ simplTy env from_ty `appEager` \ from_ty' ->
+ simplExpr env expr [] from_ty' `thenSmpl` \ expr' ->
+ returnSmpl (mkGenApp (mkCoerce to_ty' from_ty' expr') args)
+ where
-- Try cancellation; we do this "on the way up" because
-- I think that's where it'll bite best
- mkCoerce (CoerceOut con1) ty1 (Coerce (CoerceIn con2) ty2 body) | con1 == con2 = body
- mkCoerce coercion ty body = Coerce coercion ty body
+ mkCoerce to_ty1 from_ty1 (Note (Coerce to_ty2 from_ty2) body)
+ = ASSERT( from_ty1 == to_ty2 )
+ mkCoerce to_ty1 from_ty2 body
+ mkCoerce to_ty from_ty body
+ | to_ty == from_ty = body
+ | otherwise = Note (Coerce to_ty from_ty) body
+\end{code}
+
+
+%************************************************************************
+%* *
+\subsection[Simplify-scc]{SCC expressions
+%* *
+%************************************************************************
+
+1) Eliminating nested sccs ...
+We must be careful to maintain the scc counts ...
+
+\begin{code}
+simplSCC env cc1 (Note (SCC cc2) expr) args result_ty
+ | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ -> True; _ -> False }
+ -- eliminate inner scc if no call counts and same cc as outer
+ = simplSCC env cc1 expr args result_ty
+
+ | not (isSccCountCostCentre cc2) && not (isSccCountCostCentre cc1)
+ -- eliminate outer scc if no call counts associated with either ccs
+ = simplSCC env cc2 expr args result_ty
+\end{code}
+
+2) Moving sccs inside lambdas ...
+
+\begin{code}
+simplSCC env cc (Lam binder@(ValBinder _) body) args result_ty
+ | not (isSccCountCostCentre cc)
+ -- move scc inside lambda only if no call counts
+ = simplExpr env (Lam binder (Note (SCC cc) body)) args result_ty
+
+simplSCC env cc (Lam binder body) args result_ty
+ -- always ok to move scc inside type/usage lambda
+ = simplExpr env (Lam binder (Note (SCC cc) body)) args result_ty
+\end{code}
+
+3) Eliminating dict sccs ...
+
+\begin{code}
+simplSCC env cc expr args result_ty
+ | squashableDictishCcExpr cc expr
+ -- eliminate dict cc if trivial dict expression
+ = simplExpr env expr args result_ty
+\end{code}
+
+4) Moving arguments inside the body of an scc ...
+This moves the cost of doing the application inside the scc
+(which may include the cost of extracting methods etc)
+
+\begin{code}
+simplSCC env cc body args result_ty
+ = let
+ new_env = setEnclosingCC env cc
+ in
+ simplExpr new_env body args result_ty `thenSmpl` \ body' ->
+ returnSmpl (Note (SCC cc) body')
\end{code}
-- Dead code is now discarded by the occurrence analyser,
simplNonRec env binder@(id,_) rhs body_c body_ty
- | inlineUnconditionally ok_to_dup binder
+ | inlineUnconditionally binder
= -- The binder is used in definitely-inline way in the body
-- So add it to the environment, drop the binding, and continue
body_c (bindIdToExpr env binder rhs)
= tick CaseFloatFromLet `thenSmpl_`
-- First, bind large let-body if necessary
- if ok_to_dup || isSingleton (nonErrorRHSs alts)
+ if isSingleton (nonErrorRHSs alts)
then
simplCase env scrut (getSubstEnvs env, alts)
(\env rhs -> simpl_bind env rhs) body_ty
-- All this stuff is computed at the start of the simpl_bind loop
float_lets = switchIsSet env SimplFloatLetsExposingWHNF
float_primops = switchIsSet env SimplOkToFloatPrimOps
- ok_to_dup = switchIsSet env SimplOkToDupCode
always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
try_let_to_case = switchIsSet env SimplLetToCase
no_float = switchIsSet env SimplNoLetFromStrictLet
ValueForm -> True
other -> False
- float_exposes_hnf = floatExposesHNF float_lets float_primops ok_to_dup rhs
+ float_exposes_hnf = floatExposesHNF float_lets float_primops rhs
let_floating_ok = (will_be_demanded && not no_float) ||
always_float_let_from_let ||
= returnSmpl ([], env)
simplRecursiveGroup env (new_id : new_ids) ((binder, rhs) : pairs)
- | inlineUnconditionally ok_to_dup binder
+ | inlineUnconditionally binder
= -- Single occurrence, so drop binding and extend env with the inlining
-- This is a little delicate, because what if the unique occurrence
-- is *before* this binding? This'll never happen, because
in
simplRecursiveGroup new_env new_ids pairs `thenSmpl` \ (new_pairs, final_env) ->
returnSmpl (new_binds' ++ new_pairs, final_env)
- where
- ok_to_dup = switchIsSet env SimplOkToDupCode
\end{code}
-- fltRhs has same invariant as fltBind
fltRhs rhs
| (always_float_let_from_let ||
- floatExposesHNF True False False rhs)
+ floatExposesHNF True False rhs)
= fltExpr rhs
| otherwise
import StgSyn
import Bag ( Bag, emptyBag, unionBags, unitBag, snocBag, bagToList )
-import Id ( idType, mkSysLocal, addIdArity,
+import MkId ( mkSysLocal )
+import Id ( idType, addIdArity,
mkIdSet, unitIdSet, minusIdSet, setIdVisibility,
unionManyIdSets, idSetToList, IdSet,
nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv,
GenId{-instance Eq/Outputable -}, Id
)
import Maybes ( maybeToBool )
-import PprType ( GenType{-instance Outputable-} )
import ErrUtils ( doIfSet )
import UniqSupply ( splitUniqSupply, UniqSupply )
import Util ( mapAccumL, panic, assertPanic )
import Maybes ( maybeToBool )
import Name ( isLocallyDefined )
import BasicTypes ( Arity )
-import PprType ( GenType{-instance Outputable-} )
import Outputable
infixr 9 `thenLne`, `thenLne_`
import Prelude hiding ( lookup )
import StgSyn
+import MkId ( mkSysLocal )
import Id ( IdEnv, growIdEnv, addOneToIdEnv, combineIdEnvs, nullIdEnv,
unitIdEnv, mkIdEnv, rngIdEnv, lookupIdEnv,
IdSet,
- getIdUpdateInfo, addIdUpdateInfo, mkSysLocal, idType, isImportedId,
+ getIdUpdateInfo, addIdUpdateInfo, idType,
externallyVisibleId,
- Id, GenId
+ Id
)
import IdInfo ( UpdateInfo, UpdateSpec, mkUpdateInfo, updateInfoMaybe )
+import Name ( isLocallyDefined )
import Type ( splitFunTys, splitSigmaTy )
import UniqSet
import Unique ( getBuiltinUniques )
\begin{code}
lookup v
- | isImportedId v
- = const (case updateInfoMaybe (getIdUpdateInfo v) of
- Nothing -> unknownClosure
- Just spec -> convertUpdateSpec spec)
- | otherwise
+ | isLocallyDefined v
= \p -> case lookup_IdEnv p v of
Just b -> b
Nothing -> unknownClosure
+
+ | otherwise
+ = const (case updateInfoMaybe (getIdUpdateInfo v) of
+ Nothing -> unknownClosure
+ Just spec -> convertUpdateSpec spec)
\end{code}
%-----------------------------------------------------------------------------
\begin{code}
module SpecEnv (
SpecEnv,
- emptySpecEnv, isEmptySpecEnv, specEnvValues,
+ emptySpecEnv, isEmptySpecEnv,
+ specEnvValues, specEnvToList,
addToSpecEnv, lookupSpecEnv, substSpecEnv
) where
#include "HsVersions.h"
import Type ( Type, GenType, mkTyVarTy, matchTys, tyVarsOfTypes, applyToTyVars )
-import TyVar ( TyVar, TyVarEnv, tyVarFlexi, setTyVarFlexi, lookupTyVarEnv, tyVarSetToList )
+import TyVar ( TyVar, GenTyVar, TyVarEnv, tyVarFlexi, setTyVarFlexi, lookupTyVarEnv, tyVarSetToList )
import Unify ( Subst, unifyTyListsX )
import Maybes
import Util ( assertPanic )
%************************************************************************
\begin{code}
-type TemplateType = GenType Bool
+type TemplateTyVar = GenTyVar Bool
+type TemplateType = GenType Bool
-- The Bool is True for template type variables;
-- that is, ones that can be bound
specEnvValues :: SpecEnv value -> [value]
specEnvValues EmptySE = []
specEnvValues (SpecEnv alist) = map snd alist
+
+specEnvToList :: SpecEnv value -> [([TemplateTyVar], [TemplateType], value)]
+specEnvToList EmptySE = []
+specEnvToList (SpecEnv alist)
+ = map do_item alist
+ where
+ do_item (tys, val) = (tyvars, tys, val)
+ where
+ tyvars = filter tyVarFlexi (tyVarSetToList (tyVarsOfTypes tys))
\end{code}
In some SpecEnvs overlap is prohibited; that is, no pair of templates unify.
import Maybes ( maybeToBool, catMaybes, firstJust )
import Name ( OccName, pprOccName, modAndOcc, NamedThing(..) )
import Outputable
-import PprType ( pprParendGenType, pprMaybeTy, TyCon )
+import PprType ( pprParendType, pprMaybeTy, TyCon )
import TyCon ( tyConTyVars )
import Type ( mkSigmaTy, instantiateTauTy, instantiateThetaTy,
splitSigmaTy, mkTyVarTy, mkForAllTys,
then Nothing
else Just (sep [ptext SLIT("Spec and Arg Types Inconsistent:"),
ptext SLIT("spectys="), sep [pprMaybeTy ty | ty <- spec_tys],
- ptext SLIT("argtys="), sep [pprParendGenType ty | ty <- arg_tys]])
+ ptext SLIT("argtys="), sep [pprParendType ty | ty <- arg_tys]])
where
match (Nothing:spec_tys) (arg:arg_tys)
= not (isUnboxedType arg) &&
pp_tyspec pp_mod (_, tycon, tys)
= hsep [pp_mod,
text "{-# SPECIALIZE data",
- ppr tycon, hsep (map pprParendGenType spec_tys),
+ ppr tycon, hsep (map pprParendType spec_tys),
text "-} {- Essential -}"
]
where
ppr clsop, text "::",
pprGenType spec_ty,
text "#-} {- IN instance",
- pprOccName (getOccName cls), pprParendGenType clsty,
+ pprOccName (getOccName cls), pprParendType clsty,
text "-}", pp_essential ]
| is_default_method_id
#include "HsVersions.h"
-import Id ( Id, DictVar, idType, mkUserLocal,
+import MkId ( mkUserLocal )
+import Id ( Id, DictVar, idType,
getIdSpecialisation, setIdSpecialisation,
specExpr e@(Con _ _) = returnSM (e, emptyUDs)
specExpr e@(Prim _ _) = returnSM (e, emptyUDs)
-specExpr (Coerce co ty body)
+specExpr (Note note body)
= specExpr body `thenSM` \ (body', uds) ->
- returnSM (Coerce co ty body', uds)
-
-specExpr (SCC cc body)
- = specExpr body `thenSM` \ (body', uds) ->
- returnSM (SCC cc body', uds)
+ returnSM (Note note body', uds)
---------------- Applications might generate a call instance --------------------
go (Var v) = Var (lookupId id_env v)
go (Lit l) = Lit l
go (Con con args) = Con con (map go_arg args)
- go (Coerce c t e) = Coerce c (instantiateTy ty_env t) (go e)
+ go (Note n e) = Note (go_note n) (go e)
go (Case e alts) = Case (go e) alts -- See comment below re alts
go other = pprPanic "instantiateDictRhs" (ppr rhs)
+ go_note (Coerce t1 t2) = Coerce (instantiateTy ty_env t1) (instantiateTy ty_env t2)
+ go_note note = note
dictRhsFVs :: CoreExpr -> IdSet
-- Cheapo function for simple RHSs
go (Var v) = unitIdSet v
go (Lit l) = emptyIdSet
go (Con _ args) = mkIdSet [id | VarArg id <- args]
- go (Coerce _ _ e) = go e
+ go (Note _ e) = go e
go (Case e _) = go e -- Claim: no free dictionaries in the alternatives
-- These case expressions are of the form
import Bag ( emptyBag, unitBag, unionBags, unionManyBags, bagToList )
import CoreUtils ( coreExprType )
import CostCentre ( noCostCentre )
-import Id ( mkSysLocal, idType, isBottomingId,
+import MkId ( mkSysLocal )
+import Id ( idType, isBottomingId,
externallyVisibleId, mkIdWithNewUniq,
-
nullIdEnv, addOneToIdEnv, lookupIdEnv, growIdEnvList,
- IdEnv, GenId{-instance NamedThing-}, Id
+ IdEnv, Id
)
import Literal ( mkMachInt, Literal(..) )
import PrelVals ( unpackCStringId, unpackCString2Id,
(StgApp (StgVarArg fun_id) stg_args bOGUS_LVs))
where
-- Collect arguments, discarding type/usage applications
- collect_args (App e (TyArg _)) args = collect_args e args
- collect_args (App fun arg) args = collect_args fun (arg:args)
- collect_args (Coerce _ _ expr) args = collect_args expr args
- collect_args fun args = (fun, args)
+ collect_args (App e (TyArg _)) args = collect_args e args
+ collect_args (App fun arg) args = collect_args fun (arg:args)
+ collect_args (Note (Coerce _ _) expr) args = collect_args expr args
+ collect_args (Note InlineCall expr) args = collect_args expr args
+ collect_args fun args = (fun, args)
\end{code}
%************************************************************************
%* *
%************************************************************************
+
+******* TO DO TO DO: fix what follows
+
+Special case for
+
+ case (op x1 ... xn) of
+ y -> e
+
+where the type of the case scrutinee is a multi-constuctor algebraic type.
+Then we simply compile code for
+
+ let y = op x1 ... xn
+ in
+ e
+
+In this case:
+
+ case (op x1 ... xn) of
+ C a b -> ...
+ y -> e
+
+where the type of the case scrutinee is a multi-constuctor algebraic type.
+we just bomb out at the moment. It never happens in practice.
+
+**** END OF TO DO TO DO
+
\begin{code}
+coreExprToStg env (Case scrut@(Prim op args) (AlgAlts alts (BindDefault binder rhs)))
+ = if not (null alts) then
+ panic "cgCase: case on PrimOp with default *and* alts\n"
+ -- For now, die if alts are non-empty
+ else
+ coreExprToStg env (Let (NonRec binder scrut) rhs)
+
coreExprToStg env (Case discrim alts)
= coreExprToStg env discrim `thenUs` \ stg_discrim ->
alts_to_stg discrim alts `thenUs` \ stg_alts ->
Covert core @scc@ expression directly to STG @scc@ expression.
\begin{code}
-coreExprToStg env (SCC cc expr)
+coreExprToStg env (Note (SCC cc) expr)
= coreExprToStg env expr `thenUs` \ stg_expr ->
returnUs (StgSCC (coreExprType expr) cc stg_expr)
\end{code}
\begin{code}
-coreExprToStg env (Coerce c ty expr) = coreExprToStg env expr
+coreExprToStg env (Note other_note expr) = coreExprToStg env expr
\end{code}
import Maybes ( catMaybes )
import Name ( isLocallyDefined, getSrcLoc )
import ErrUtils ( ErrMsg )
-import PprType ( GenType{-instance Outputable-}, TyCon )
import PrimOp ( primOpType )
import SrcLoc ( SrcLoc{-instance Outputable-} )
import Type ( mkFunTys, splitFunTys, splitAlgTyConApp_maybe,
isTyVarTy, Type
)
-import TyCon ( isDataTyCon )
+import TyCon ( TyCon, isDataTyCon )
import Util ( zipEqual )
import GlaExts ( trace )
import Outputable
in
absEval anal body new_env
-absEval anal (SCC cc expr) env = absEval anal expr env
-absEval anal (Coerce c ty expr) env = absEval anal expr env
+absEval anal (Note note expr) env = absEval anal expr env
\end{code}
\begin{code}
import CoreSyn ( CoreExpr )
import Id ( nullIdEnv, addOneToIdEnv, growIdEnvList,
lookupIdEnv, IdEnv,
- GenId{-instance Outputable-}, Id
+ Id
)
import IdInfo ( StrictnessInfo(..) )
import Demand ( Demand{-instance Outputable-} )
import Outputable
-import PprType ( GenType{-instance Outputable-} )
\end{code}
%************************************************************************
import CmdLineOpts ( opt_D_dump_stranal, opt_D_simplifier_stats
)
import CoreSyn
-import Id ( idType, addIdStrictness, isWrapperId,
+import Id ( idType, addIdStrictness,
getIdDemandInfo, addIdDemandInfo,
- GenId{-instance Outputable-}, Id
+ Id
)
import IdInfo ( mkStrictnessInfo, mkBottomStrictnessInfo,
mkDemandInfo, willBeDemanded, DemandInfo
)
import PprCore ( pprCoreBinding )
-import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
import SaAbsInt
import SaLib
-import TyVar ( GenTyVar{-instance Eq-} )
import WorkWrap -- "back-end" of strictness analyser
import Unique ( Unique{-instance Eq -} )
import UniqSupply ( UniqSupply )
= saExpr str_env abs_env fun `thenSa` \ new_fun ->
returnSa (App new_fun arg)
-saExpr str_env abs_env (SCC cc expr)
+saExpr str_env abs_env (Note note expr)
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
- returnSa (SCC cc new_expr)
-
-saExpr str_env abs_env (Coerce c ty expr)
- = saExpr str_env abs_env expr `thenSa` \ new_expr ->
- returnSa (Coerce c ty new_expr)
+ returnSa (Note note new_expr)
saExpr str_env abs_env (Case expr (AlgAlts alts deflt))
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
import CmdLineOpts ( opt_UnfoldingCreationThreshold )
import CoreUtils ( coreExprType )
-import Id ( getInlinePragma, getIdStrictness, mkWorkerId,
+import MkId ( mkWorkerId )
+import Id ( getInlinePragma, getIdStrictness,
addIdStrictness, addInlinePragma,
IdSet, emptyIdSet, addOneToIdSet,
GenId, Id
)
-import IdInfo ( noIdInfo, addUnfoldInfo,
- mkStrictnessInfo, addStrictnessInfo, StrictnessInfo(..)
- )
+import IdInfo ( noIdInfo, mkStrictnessInfo, setStrictnessInfo, StrictnessInfo(..) )
import SaLib
import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM )
import WwLib
= wwExpr f `thenUs` \ new_f ->
returnUs (App new_f a)
-wwExpr (SCC cc expr)
- = wwExpr expr `thenUs` \ new_expr ->
- returnUs (SCC cc new_expr)
-
-wwExpr (Coerce c ty expr)
+wwExpr (Note note expr)
= wwExpr expr `thenUs` \ new_expr ->
- returnUs (Coerce c ty new_expr)
+ returnUs (Note note new_expr)
wwExpr (Let bind expr)
= wwBind False{-not top-level-} bind `thenUs` \ intermediate_bind ->
-- wrapper.
tryWW fn_id rhs
| (certainlySmallEnoughToInline fn_id $
- calcUnfoldingGuidance (getInlinePragma fn_id)
- opt_UnfoldingCreationThreshold
- rhs
+ calcUnfoldingGuidance opt_UnfoldingCreationThreshold rhs
)
-- No point in worker/wrappering something that is going to be
-- INLINEd wholesale anyway. If the strictness analyser is run
let
work_rhs = work_fn body
work_id = mkWorkerId work_uniq fn_id (coreExprType work_rhs) work_info
- work_info = noIdInfo `addStrictnessInfo` mkStrictnessInfo work_demands False
+ work_info = mkStrictnessInfo work_demands False `setStrictnessInfo` noIdInfo
wrap_rhs = wrap_fn work_id
wrap_id = addInlinePragma (fn_id `addIdStrictness`
go (Lam _ body) = go body
go (Case _ (AlgAlts [(con,_,rhs)] _)) = let (wrap_id, cons) = go rhs
in (wrap_id, cons `addOneToIdSet` con)
+{-
+ -- Coercions don't mention the construtor now,
+ -- so I don't think we need this
go (Let (NonRec _ (Coerce (CoerceOut con) _ _)) body)
= let (wrap_id, cons) = go body
in (wrap_id, cons `addOneToIdSet` con)
+-}
go other = (get_work_id other, emptyIdSet)
get_work_id (App fn _) = get_work_id fn
#include "HsVersions.h"
import CoreSyn
-import Id ( GenId, idType, mkSysLocal, dataConArgTys, isDataCon, isNewCon, Id )
+import MkId ( mkSysLocal )
+import Id ( idType, dataConArgTys, isDataCon, isNewCon, Id )
import IdInfo ( Demand(..) )
import PrelVals ( aBSENT_ERROR_ID, voidId )
import TysPrim ( voidTy )
import TyCon ( isNewTyCon, isDataTyCon )
import BasicTypes ( NewOrData(..) )
import TyVar ( TyVar )
-import PprType ( GenType, GenTyVar )
import UniqSupply ( returnUs, thenUs, getUniques, getUnique, UniqSM )
import Util ( zipEqual, zipWithEqual )
import Outputable
mk_unpk_case NewType arg unpk_args boxing_con boxing_tycon body
-- A newtype! Use a coercion not a case
= ASSERT( null other_args && isNewTyCon boxing_tycon )
- Let (NonRec unpk_arg (Coerce (CoerceOut boxing_con) (idType unpk_arg) (Var arg)))
+ Let (NonRec unpk_arg (Note (Coerce (idType unpk_arg) (idType arg)) (Var arg)))
body
where
(unpk_arg:other_args) = unpk_args
mk_pk_let NewType arg boxing_con con_tys unpk_args body
= ASSERT( null other_args && isNewCon boxing_con )
- Let (NonRec arg (Coerce (CoerceIn boxing_con) (idType arg) (Var unpk_arg))) body
+ Let (NonRec arg (Note (Coerce (idType arg) (idType unpk_arg)) (Var unpk_arg))) body
where
(unpk_arg:other_args) = unpk_args
import Class ( classInstEnv,
Class, ClassInstEnv
)
-import Id ( idType, mkUserLocal, mkSysLocal, Id,
+import MkId ( mkUserLocal, mkSysLocal )
+import Id ( Id, idType, mkId,
GenIdSet, elementOfIdSet
)
import PrelInfo ( isStandardClass, isCcallishClass, isNoDictClass )
import Unify ( unifyTauTy, unifyTauTyLists )
import Kind ( isUnboxedTypeKind, mkTypeKind, isTypeKind, mkBoxedTypeKind )
-import Id ( idType, mkUserId, replacePragmaInfo )
-import IdInfo ( noIdInfo )
+import MkId ( mkUserId )
+import Id ( idType, idName, idInfo, replaceIdInfo )
+import IdInfo ( IdInfo, noIdInfo, setInlinePragInfo, InlinePragInfo(..) )
import Maybes ( maybeToBool, assocMaybe )
import Name ( getOccName, getSrcLoc, Name )
-import PragmaInfo ( PragmaInfo(..) )
import Type ( mkTyVarTy, mkTyVarTys, isTyVarTy, tyVarsOfTypes,
splitSigmaTy, mkForAllTys, mkFunTys, getTyVar, mkDictTy,
- splitRhoTy, mkForAllTy, splitForAllTys )
-import TyVar ( GenTyVar, TyVar, tyVarKind, mkTyVarSet, minusTyVarSet, emptyTyVarSet,
- elementOfTyVarSet, unionTyVarSets, tyVarSetToList )
+ splitRhoTy, mkForAllTy, splitForAllTys
+ )
+import TyVar ( TyVar, tyVarKind, mkTyVarSet, minusTyVarSet, emptyTyVarSet,
+ elementOfTyVarSet, unionTyVarSets, tyVarSetToList
+ )
import Bag ( bagToList, foldrBag, )
import Util ( isIn, hasNoDups, assoc )
import Unique ( Unique )
-> RenamedMonoBinds
-> [TcSigInfo s]
-> RecFlag
- -> (Name -> PragmaInfo)
+ -> (Name -> IdInfo)
-> TcM s (TcMonoBinds s, LIE s, [TcIdBndr s])
tcBindWithSigs top_lvl binder_names mbind tc_ty_sigs is_rec prag_info_fn
where
maybe_sig = maybeSig tc_ty_sigs binder_name
Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _) = maybe_sig
- poly_id = replacePragmaInfo (mkUserId binder_name poly_ty) (prag_info_fn binder_name)
+ poly_id = replaceIdInfo (mkUserId binder_name poly_ty) (prag_info_fn binder_name)
poly_ty = mkForAllTys real_tyvars_to_gen_list $ mkFunTys dict_tys $ zonked_mono_id_ty
-- It's important to build a fully-zonked poly_ty, because
-- we'll slurp out its free type variables when extending the
\begin{code}
-tcTySig :: (Name -> PragmaInfo)
+tcTySig :: (Name -> IdInfo)
-> RenamedSig
-> TcM s (TcSigInfo s)
-- Convert from Type to TcType
tcInstSigType sigma_ty `thenNF_Tc` \ sigma_tc_ty ->
let
- poly_id = replacePragmaInfo (mkUserId v sigma_tc_ty) (prag_info_fn v)
+ poly_id = replaceIdInfo (mkUserId v sigma_tc_ty) (prag_info_fn v)
in
-- Instantiate this type
-- It's important to do this even though in the error-free case
moving them into place as is done for type signatures.
\begin{code}
-tcPragmaSigs :: [RenamedSig] -- The pragma signatures
- -> TcM s (Name -> PragmaInfo, -- Maps name to the appropriate PragmaInfo
+tcPragmaSigs :: [RenamedSig] -- The pragma signatures
+ -> TcM s (Name -> IdInfo, -- Maps name to the appropriate IdInfo
TcMonoBinds s,
LIE s)
-- For now we just deal with INLINE pragmas
tcPragmaSigs sigs = returnTc (prag_fn, EmptyMonoBinds, emptyLIE )
where
- prag_fn name | any has_inline sigs = IWantToBeINLINEd
- | otherwise = NoPragmaInfo
- where
- has_inline (InlineSig n _) = (n == name)
- has_inline other = False
-
-
-{-
-tcPragmaSigs sigs
- = mapAndUnzip3Tc tcPragmaSig sigs `thenTc` \ (names_w_id_infos, binds, lies) ->
- let
- name_to_info name = foldr ($) noIdInfo
- [info_fn | (n,info_fn) <- names_w_id_infos, n==name]
- in
- returnTc (name_to_info,
- foldr ThenBinds EmptyBinds binds,
- foldr plusLIE emptyLIE lies)
-\end{code}
-
-Here are the easy cases for tcPragmaSigs
+ prag_fn name = info
+ where
+ info | any has_inline sigs = IWantToBeINLINEd `setInlinePragInfo` noIdInfo
+ | otherwise = noIdInfo
-\begin{code}
-tcPragmaSig (InlineSig name loc)
- = returnTc ((name, addUnfoldInfo (iWantToBeINLINEd UnfoldAlways)), EmptyBinds, emptyLIE)
-tcPragmaSig (MagicUnfoldingSig name string loc)
- = returnTc ((name, addUnfoldInfo (mkMagicUnfolding string)), EmptyBinds, emptyLIE)
+ has_inline (InlineSig n _) = (n == name)
+ has_inline other = False
\end{code}
The interesting case is for SPECIALISE pragmas. There are two forms.
a bit of overkill.
\begin{code}
+{-
+tcPragmaSig :: RenamedSig -> TcM s ((Name, IdInfo -> IdInfo), TcMonoBinds s, LIE s)
+tcPragmaSig (InlineSig name loc)
+ = returnTc ((name, setInlinePragInfo IdWantsToBeINLINEd), EmptyBinds, emptyLIE)
+
tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc)
= tcAddSrcLoc src_loc $
tcAddErrCtxt (valSpecSigCtxt name spec_ty) $
-- Get and instantiate its alleged specialised type
tcHsType poly_ty `thenTc` \ sig_sigma ->
tcInstSigType sig_sigma `thenNF_Tc` \ sig_ty ->
- let
- (sig_tyvars, sig_theta, sig_tau) = splitSigmaTy sig_ty
- origin = ValSpecOrigin name
- in
- -- Check that the SPECIALIZE pragma had an empty context
- checkTc (null sig_theta)
- (panic "SPECIALIZE non-empty context (ToDo: msg)") `thenTc_`
+ -- Typecheck the RHS
+ -- f :: sig_ty
+ tcPolyExpr str (Var name) sig_ty `thenTc` \ (rhs, lie) ->
- -- Get and instantiate the type of the id mentioned
- tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id ->
- tcInstSigType [] (idType main_id) `thenNF_Tc` \ main_ty ->
+ -- If this succeeds, then the signature is indeed less general
+ -- than the main function
let
- (main_tyvars, main_rho) = splitForAllTys main_ty
- (main_theta,main_tau) = splitRhoTy main_rho
- main_arg_tys = mkTyVarTys main_tyvars
- in
+ (tyvars, tys, template)
+ = case rhs of
+ TyLam tyvars (DictLam dicts (HsLet (MonoBind dict_binds
+we can take apart the RHS,
+ -- which will be of very specific form
+
- -- Check that the specialised type is indeed an instance of
- -- the type of the main function.
- unifyTauTy sig_tau main_tau `thenTc_`
- checkSigTyVars sig_tyvars sig_tau `thenTc_`
-
- -- Check that the type variables of the polymorphic function are
- -- either left polymorphic, or instantiate to ground type.
- -- Also check that the overloaded type variables are instantiated to
- -- ground type; or equivalently that all dictionaries have ground type
- zonkTcTypes main_arg_tys `thenNF_Tc` \ main_arg_tys' ->
- zonkTcThetaType main_theta `thenNF_Tc` \ main_theta' ->
- tcAddErrCtxt (specGroundnessCtxt main_arg_tys')
- (checkTc (all isGroundOrTyVarTy main_arg_tys')) `thenTc_`
- tcAddErrCtxt (specContextGroundnessCtxt main_theta')
- (checkTc (and [isGroundTy ty | (_,ty) <- theta'])) `thenTc_`
+ tcLookupLocalValueOK "tcPragmaSig" name `thenNF_Tc` \ main_id ->
+ -- Check that the specialised signature is an instance
+ -- of the
+ let
+ rhs_name = case maybe_spec_name of
+ Just name -> name
+ other -> name
+ in
+
-- Build the SpecPragmaId; it is the thing that makes sure we
-- don't prematurely dead-code-eliminate the binding we are really interested in.
- newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_pragma_id ->
+ newSpecPragmaId name sig_ty `thenNF_Tc` \ spec_id ->
- -- Build a suitable binding; depending on whether we were given
- -- a value (Maybe Name) to be used as the specialisation.
- case using of
- Nothing -> -- No implementation function specified
-
- -- Make a Method inst for the occurrence of the overloaded function
- newMethodWithGivenTy (OccurrenceOf name)
- (TcId main_id) main_arg_tys main_rho `thenNF_Tc` \ (lie, meth_id) ->
-
- let
- pseudo_bind = VarMonoBind spec_pragma_id pseudo_rhs
- pseudo_rhs = mkHsTyLam sig_tyvars (HsVar (TcId meth_id))
- in
- returnTc (pseudo_bind, lie, \ info -> info)
-
- Just spec_name -> -- Use spec_name as the specialisation value ...
-
- -- Type check a simple occurrence of the specialised Id
- tcId spec_name `thenTc` \ (spec_body, spec_lie, spec_tau) ->
-
- -- Check that it has the correct type, and doesn't constrain the
- -- signature variables at all
- unifyTauTy sig_tau spec_tau `thenTc_`
- checkSigTyVars sig_tyvars sig_tau `thenTc_`
-
- -- Make a local SpecId to bind to applied spec_id
- newSpecId main_id main_arg_tys sig_ty `thenNF_Tc` \ local_spec_id ->
-
- let
- spec_rhs = mkHsTyLam sig_tyvars spec_body
- spec_binds = VarMonoBind local_spec_id spec_rhs
- `AndMonoBinds`
- VarMonoBind spec_pragma_id (HsVar (TcId local_spec_id))
- spec_info = SpecInfo spec_tys (length main_theta) local_spec_id
- in
- returnTc ((name, addSpecInfo spec_info), spec_binds, spec_lie)
+ returnTc ((name, ...),
+ VarMonoBind spec_id rhs,
+ lie)
-}
\end{code}
import TcType ( TcType, TcTyVar, TcTyVarSet, tcInstSigTyVars,
zonkSigTyVar, tcInstSigTcType
)
-import PragmaInfo ( PragmaInfo(..) )
-
+import FieldLabel ( firstFieldLabelTag )
import Bag ( unionManyBags )
import Class ( mkClass, classBigSig, Class )
import CmdLineOpts ( opt_GlasgowExts )
+import MkId ( mkDataCon, mkSuperDictSelId,
+ mkMethodSelId, mkDefaultMethodId
+ )
import Id ( Id, StrictnessMark(..),
- mkSuperDictSelId, mkMethodSelId,
- mkDefaultMethodId, getIdUnfolding, mkDataCon,
- idType
+ getIdUnfolding, idType
)
import CoreUnfold ( getUnfoldingTemplate )
import IdInfo
-- import TcPragmas ( tcGenPragmas, tcClassOpPragmas )
tcGenPragmas ty id ps = returnNF_Tc noIdInfo
-tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `setSpecInfo` spec,
+tcClassOpPragmas ty sel def spec ps = returnNF_Tc (spec `setSpecInfo` noIdInfo,
noIdInfo)
\end{code}
-- D_sc1, D_sc2
-- (We used to call them D_C, but now we can have two different
-- superclasses both called C!)
- mapTc mk_super_id (sc_theta `zip` [1..]) `thenTc` \ sc_sel_ids ->
+ mapTc mk_super_id (sc_theta `zip` [firstFieldLabelTag..]) `thenTc` \ sc_sel_ids ->
-- Done
returnTc (sc_theta, sc_tys, sc_sel_ids)
tcExtendGlobalTyVars inst_tyvars (
tcAddErrCtxt (methodCtxt sel_id) $
tcBindWithSigs NotTopLevel [bndr_name] meth_bind [sig_info]
- NonRecursive (\_ -> NoPragmaInfo)
+ NonRecursive (\_ -> noIdInfo)
) `thenTc` \ (binds, insts, _) ->
-- Now check that the instance type variables
import Bag ( Bag, emptyBag, unionBags, listToBag )
import Class ( classKey, Class )
import ErrUtils ( ErrMsg )
-import Id ( dataConArgTys, isNullaryDataCon, mkDictFunId )
+import MkId ( mkDictFunId )
+import Id ( dataConArgTys, isNullaryDataCon )
import PrelInfo ( needsDataDeclCtxtClassKeys )
import Maybes ( maybeToBool )
import Name ( isLocallyDefined, getSrcLoc, Provenance,
#include "HsVersions.h"
-import Id ( Id, GenId, idType, mkUserLocal, mkUserId, replaceIdInfo, getIdInfo )
-import PragmaInfo ( PragmaInfo(..) )
+import MkId ( mkUserLocal, mkUserId )
+import Id ( Id, GenId, idType, replaceIdInfo, idInfo )
import TcKind ( TcKind, kindToTcKind, Kind )
import TcType ( TcType, TcMaybe, TcTyVar, TcTyVarSet, TcThetaType,
newTyVarTys, tcInstTyVars, zonkTcTyVars, tcInstType
)
import TyVar ( mkTyVarSet, unionTyVarSets, emptyTyVarSet, TyVar )
-import PprType ( GenTyVar )
import Type ( tyVarsOfType, tyVarsOfTypes, splitForAllTys, splitRhoTy )
import TyCon ( TyCon, tyConKind, tyConArity, isSynTyCon, Arity )
import Class ( Class )
new_info = -- pprTrace "tcAdd" (ppr id) $
case tcExplicitLookupGlobal unf_env (getName id) of
Nothing -> noIdInfo
- Just imported_id -> getIdInfo imported_id
+ Just imported_id -> idInfo imported_id
-- ToDo: could check that types are the same
\end{code}
import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType )
import Id ( idType, dataConFieldLabels, dataConSig, recordSelectorFieldLabel,
isRecordSelector,
- Id, GenId
+ Id
)
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind )
import Name ( Name{-instance Eq-} )
thenMClassOpKey, zeroClassOpKey, returnMClassOpKey
)
import Outputable
-import PprType ( GenType, GenTyVar ) -- Instances
import Maybes ( maybeToBool )
import ListSetOps ( minusList )
import Util
-- tcPolyExpr is like tcExpr, except that the expected type
-- can be a polymorphic one.
+tcPolyExpr :: SDoc -- Just for error messages
+ -> RenamedHsExpr
+ -> TcType s -- Expected type
+ -> TcM s (TcExpr s, LIE s) -- Resulting type and LIE
+
tcPolyExpr str arg expected_arg_ty
| not (maybeToBool (splitForAllTy_maybe expected_arg_ty))
= -- The ordinary, non-rank-2 polymorphic case
-- Conclusion: include the free vars of the expected arg type in the
-- list of "free vars" for the signature check.
- tcAddErrCtxt (rank2ArgCtxt arg expected_arg_ty) $
tcExtendGlobalTyVars (tyVarSetToList (tyVarsOfType expected_arg_ty)) $
checkSigTyVars sig_tyvars sig_tau `thenTc` \ zonked_sig_tyvars ->
- newDicts Rank2Origin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
+ newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
-- ToDo: better origin
tcSimplifyAndCheck
HsLet (MonoBind inst_binds [] Recursive)
arg'
, free_insts
- )
+ )
\end{code}
%************************************************************************
-- friends:
import HsSyn -- oodles of it
-import Id ( GenId(..), IdDetails, -- Can meddle modestly with Ids
- dataConArgTys, Id
+import Id ( idType, dataConArgTys, mkIdWithNewType, Id
)
-- others:
\begin{code}
zonkTcId :: TcIdOcc s -> NF_TcM s (TcIdOcc s)
zonkTcId tc_id@(RealId id) = returnNF_Tc tc_id
-zonkTcId (TcId (Id u n ty details prags info))
- = zonkTcType ty `thenNF_Tc` \ ty' ->
- returnNF_Tc (TcId (Id u n ty' details prags info))
+zonkTcId (TcId id)
+ = zonkTcType (idType id) `thenNF_Tc` \ ty' ->
+ returnNF_Tc (TcId (mkIdWithNewType id ty'))
\end{code}
This zonking pass runs over the bindings
zonkIdBndr :: TyVarEnv Type -> TcIdOcc s -> NF_TcM s Id
zonkIdBndr te (RealId id) = returnNF_Tc id
-zonkIdBndr te (TcId (Id u n ty details prags info))
- = zonkTcTypeToType te ty `thenNF_Tc` \ ty' ->
- returnNF_Tc (Id u n ty' details prags info)
+zonkIdBndr te (TcId id)
+ = zonkTcTypeToType te (idType id) `thenNF_Tc` \ ty' ->
+ returnNF_Tc (mkIdWithNewType id ty')
zonkIdOcc :: TcIdOcc s -> NF_TcM s Id
new_id = case maybe_id' of
Just id' -> id'
Nothing -> pprTrace "zonkIdOcc: " (ppr id) $
- Id u n voidTy details prags info
- where
- Id u n _ details prags info = id
+ mkIdWithNewType id voidTy
in
returnNF_Tc new_id
\end{code}
import HsSyn ( HsDecl(..), IfaceSig(..) )
import TcMonad
-import TcMonoType ( tcHsType, tcHsTypeKind )
+import TcMonoType ( tcHsType, tcHsTypeKind, tcTyVarScope )
import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv,
tcLookupTyConByKey, tcLookupGlobalValueMaybe,
tcExplicitLookupGlobal
import WwLib ( mkWrapper )
import PrimOp ( PrimOp(..) )
-import Id ( GenId, mkImported, mkUserId, addInlinePragma,
- isPrimitiveId_maybe, dataConArgTys, Id )
+import MkId ( mkImportedId, mkUserId )
+import Id ( Id, addInlinePragma, isPrimitiveId_maybe, dataConArgTys )
+import IdInfo
+import SpecEnv ( addToSpecEnv )
import Type ( mkSynTy, splitAlgTyConApp )
import TyVar ( mkSysTyVar )
import Name ( Name )
import Unique ( rationalTyConKey, uniqueOf )
import TysWiredIn ( integerTy )
-import PragmaInfo ( PragmaInfo(..) )
import ErrUtils ( pprBagOfErrors )
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, MaybeErr(..) )
import Outputable
import Util ( zipWithEqual )
-import IdInfo
\end{code}
Ultimately, type signatures in interfaces will have pragmatic
= tcAddSrcLoc src_loc (
tcAddErrCtxt (ifaceSigCtxt name) (
tcHsType ty `thenTc` \ sigma_ty ->
- tcIdInfo unf_env name sigma_ty noIdInfo id_infos `thenTc` \ id_info' ->
- let
- imp_id = mkImported name sigma_ty id_info'
- sig_id | any inline_please id_infos = addInlinePragma imp_id
- | otherwise = imp_id
-
- inline_please (HsUnfold inline _) = inline
- inline_please (HsStrictness (HsStrictnessInfo _ (Just _))) = True -- Inline wrappers
- inline_please other = False
- in
- returnTc sig_id
+ tcIdInfo unf_env name sigma_ty noIdInfo id_infos `thenTc` \ id_info ->
+ returnTc (mkImportedId name sigma_ty id_info)
)) `thenTc` \ sig_id ->
tcInterfaceSigs unf_env rest `thenTc` \ sig_ids ->
returnTc (sig_id : sig_ids)
\begin{code}
tcIdInfo unf_env name ty info info_ins
- = go noIdInfo info_ins
+ = foldlTc tcPrag noIdInfo info_ins
where
- go info_so_far [] = returnTc info_so_far
- go info (HsArity arity : rest) = go (info `addArityInfo` arity) rest
- go info (HsUpdate upd : rest) = go (info `addUpdateInfo` upd) rest
- go info (HsFBType fb : rest) = go (info `addFBTypeInfo` fb) rest
- go info (HsArgUsage au : rest) = go (info `addArgUsageInfo` au) rest
-
- go info (HsUnfold inline expr : rest) = tcUnfolding unf_env name expr `thenNF_Tc` \ unfold_info ->
- go (info `addUnfoldInfo` unfold_info) rest
-
- go info (HsStrictness strict : rest) = tcStrictness unf_env ty info strict `thenTc` \ info' ->
- go info' rest
+ tcPrag info (HsArity arity) = returnTc (arity `setArityInfo` info)
+ tcPrag info (HsUpdate upd) = returnTc (upd `setUpdateInfo` info)
+ tcPrag info (HsFBType fb) = returnTc (fb `setFBTypeInfo` info)
+ tcPrag info (HsArgUsage au) = returnTc (au `setArgUsageInfo` info)
+
+ tcPrag info (HsUnfold inline expr)
+ = tcPragExpr unf_env name expr `thenNF_Tc` \ maybe_expr' ->
+ let
+ -- maybe_expr doesn't get looked at if the unfolding
+ -- is never inspected; so the typecheck doesn't even happen
+ unfold_info = case maybe_expr' of
+ Nothing -> NoUnfolding
+ Just expr' -> mkUnfolding expr'
+ info1 = unfold_info `setUnfoldingInfo` info
+
+ info2 | inline = IWantToBeINLINEd `setInlinePragInfo` info1
+ | otherwise = info1
+ in
+ returnTc info2
+
+ tcPrag info (HsStrictness strict)
+ = tcStrictness unf_env ty info strict
+
+ tcPrag info (HsSpecialise tyvars tys rhs)
+ = tcTyVarScope tyvars $ \ tyvars' ->
+ mapTc tcHsType tys `thenTc` \ tys' ->
+ tcPragExpr unf_env name rhs `thenNF_Tc` \ maybe_rhs' ->
+ let
+ -- If spec_env isn't looked at, none of this
+ -- actually takes place
+ spec_env = specInfo info
+ spec_env' = case maybe_rhs' of
+ Nothing -> spec_env
+ Just rhs' -> case addToSpecEnv True {- overlap ok -} spec_env tyvars' tys' rhs' of
+ Succeeded spec_env' -> spec_env'
+ Failed err -> pprTrace "tcIdInfo: bad specialisation"
+ (ppr name <+> ppr err) $
+ spec_env
+ in
+ returnTc (spec_env' `setSpecInfo` info)
\end{code}
\begin{code}
let
-- Watch out! We can't pull on maybe_worker_id too eagerly!
info' = case maybe_worker_id of
- Just worker_id -> info `addUnfoldInfo` mkUnfolding NoPragmaInfo (wrap_fn worker_id)
+ Just worker_id -> setUnfoldingInfo (mkUnfolding (wrap_fn worker_id)) $
+ setInlinePragInfo IWantToBeINLINEd info
+
Nothing -> info
+
has_worker = maybeToBool maybe_worker_id
in
- returnTc (info' `addStrictnessInfo` StrictnessInfo demands has_worker)
+ returnTc (StrictnessInfo demands has_worker `setStrictnessInfo` info')
-- Boring to write these out, but the result type differs from the arg type...
tcStrictness unf_env ty info HsBottom
- = returnTc (info `addStrictnessInfo` BottomGuaranteed)
+ = returnTc (BottomGuaranteed `setStrictnessInfo` info)
\end{code}
\begin{code}
an unfolding that isn't going to be looked at.
\begin{code}
-tcUnfolding unf_env name core_expr
+tcPragExpr unf_env name core_expr
= forkNF_Tc (
recoverNF_Tc no_unfolding (
tcSetEnv unf_env $
tcCoreExpr core_expr `thenTc` \ core_expr' ->
- returnTc (mkUnfolding NoPragmaInfo core_expr')
+ returnTc (Just core_expr')
))
where
-- The trace tells what wasn't available, for the benefit of
-- compiler hackers who want to improve it!
no_unfolding = getErrsTc `thenNF_Tc` \ (warns,errs) ->
returnNF_Tc (pprTrace "tcUnfolding failed with:"
- (hang (ppr name) 4 (pprBagOfErrors errs))
- NoUnfolding)
+ (hang (ppr name) 4 (pprBagOfErrors errs))
+ Nothing)
\end{code}
tcCoreAlts (coreExprType scrut') alts `thenTc` \ alts' ->
returnTc (Case scrut' alts')
-tcCoreExpr (UfSCC cc expr)
+tcCoreExpr (UfNote note expr)
= tcCoreExpr expr `thenTc` \ expr' ->
- returnTc (SCC cc expr')
-
-tcCoreExpr(UfCoerce coercion ty body)
- = tcCoercion coercion `thenTc` \ coercion' ->
- tcHsTypeKind ty `thenTc` \ (_,ty') ->
- tcCoreExpr body `thenTc` \ body' ->
- returnTc (Coerce coercion' ty' body')
+ case note of
+ UfCoerce to_ty -> tcHsTypeKind to_ty `thenTc` \ (_,to_ty') ->
+ returnTc (Note (Coerce to_ty' (coreExprType expr')) expr')
+ UfInlineCall -> returnTc (Note InlineCall expr')
+ UfSCC cc -> returnTc (Note (SCC cc) expr')
+
+tcCoreNote (UfSCC cc) = returnTc (SCC cc)
+tcCoreNote UfInlineCall = returnTc InlineCall
+\end{code}
+ returnTc (Note note' expr')
tcCoreExpr (UfLam bndr body)
= tcCoreLamBndr bndr $ \ bndr' ->
returnTc (BindDefault deflt_id rhs')
-tcCoercion (UfIn n) = tcVar n `thenTc` \ n' -> returnTc (CoerceIn n')
-tcCoercion (UfOut n) = tcVar n `thenTc` \ n' -> returnTc (CoerceOut n')
-
tcCorePrim (UfOtherOp op)
= tcVar op `thenTc` \ op_id ->
case isPrimitiveId_maybe op_id of
import RnMonad ( RnNameSupply )
import Inst ( Inst, InstOrigin(..),
newDicts, LIE, emptyLIE, plusLIE, plusLIEs )
-import PragmaInfo ( PragmaInfo(..) )
import TcDeriv ( tcDeriving )
import TcEnv ( tcExtendGlobalValEnv, tcAddImportedIdInfo )
import TcInstUtil ( InstInfo(..), mkInstanceRelatedIds, classDataCon )
NamedThing(..)
)
import PrelVals ( nO_METHOD_BINDING_ERROR_ID )
-import PprType ( pprParendGenType, pprConstraint )
+import PprType ( pprParendType, pprConstraint )
import SrcLoc ( SrcLoc, noSrcLoc )
import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings )
import Type ( Type, ThetaType, isUnpointedType,
(vcat [hsep [if null simpl_theta then empty else ppr simpl_theta,
if null simpl_theta then empty else ptext SLIT("=>"),
ppr clas,
- pprParendGenType inst_ty],
+ pprParendType inst_ty],
hsep [ptext SLIT(" derived from:"),
if null unspec_theta then empty else ppr unspec_theta,
if null unspec_theta then empty else ptext SLIT("=>"),
ppr clas,
- pprParendGenType unspec_inst_ty]])
+ pprParendType unspec_inst_ty]])
else id) (
returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta
import Bag ( bagToList, Bag )
import Class ( ClassInstEnv, Class, classBigSig )
-import Id ( mkDictFunId, Id )
+import MkId ( mkDictFunId )
+import Id ( Id )
import SpecEnv ( emptySpecEnv, addToSpecEnv )
import Maybes ( MaybeErr(..), mkLookupFunDef )
import Name ( getSrcLoc, Name )
import CmdLineOpts ( opt_IrrefutableTuples )
import Id ( GenId, idType, Id )
import Kind ( Kind, mkBoxedTypeKind, mkTypeKind )
-import PprType ( GenType, GenTyVar )
import Type ( splitFunTys, splitRhoTy,
splitFunTy_maybe, splitAlgTyConApp_maybe,
- Type, GenType
+ Type
)
-import TyVar ( GenTyVar )
import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
doublePrimTy, addrPrimTy
)
import TcKind ( TcKind, unifyKind, mkArrowKind, mkBoxedTypeKind )
import Class ( classInstEnv, Class )
-import Id ( mkDataCon, dataConSig, mkRecordSelId, idType,
+import MkId ( mkDataCon, mkRecordSelId )
+import Id ( dataConSig, idType,
dataConFieldLabels, dataConStrictMarks,
StrictnessMark(..), getIdUnfolding,
Id
\begin{code}
module PprType(
- GenTyVar, pprGenTyVar, pprTyVarBndr, pprTyVarBndrs,
+ pprTyVar, pprTyVarBndr, pprTyVarBndrs,
TyCon, pprTyCon, showTyCon,
- GenType,
- pprGenType, pprParendGenType,
pprType, pprParendType,
pprMaybeTy,
getTyDescription,
\begin{code}
instance Outputable (GenType flexi) where
- ppr ty = pprGenType ty
+ ppr ty = pprType ty
instance Outputable TyCon where
ppr tycon = pprTyCon tycon
ppr clas = ppr (getName clas)
instance Outputable (GenTyVar flexi) where
- ppr tv = pprGenTyVar tv
-
--- and two SPECIALIZEd ones:
-{-
-instance Outputable {-Type, i.e.:-}(GenType Unused) where
- ppr ty = pprGenType ty
-
-instance Outputable {-TyVar, i.e.:-}(GenTyVar Unused) where
- ppr ty = pprGenTyVar ty
--}
+ ppr tv = pprTyVar tv
\end{code}
%************************************************************************
| otherwise = parens pretty
\end{code}
-@pprGenType@ is the std @Type@ printer; the overloaded @ppr@ function is
-defined to use this. @pprParendGenType@ is the same, except it puts
-parens around the type, except for the atomic cases. @pprParendGenType@
+@pprType@ is the std @Type@ printer; the overloaded @ppr@ function is
+defined to use this. @pprParendType@ is the same, except it puts
+parens around the type, except for the atomic cases. @pprParendType@
works just by setting the initial context precedence very high.
\begin{code}
-pprGenType, pprParendGenType :: GenType flexi -> SDoc
-
-pprGenType ty = ppr_ty init_ppr_env tOP_PREC ty
-pprParendGenType ty = ppr_ty init_ppr_env tYCON_PREC ty
+pprType, pprParendType :: GenType flexi -> SDoc
-pprType, pprParendType :: Type -> SDoc
-pprType ty = ppr_ty init_ppr_env_type tOP_PREC ty
-pprParendType ty = ppr_ty init_ppr_env_type tYCON_PREC ty
+pprType ty = ppr_ty init_ppr_env tOP_PREC ty
+pprParendType ty = ppr_ty init_ppr_env tYCON_PREC ty
pprConstraint :: Class -> [GenType flexi] -> SDoc
-pprConstraint clas tys = hsep [ppr clas, hsep (map (pprParendGenType) tys)]
+pprConstraint clas tys = hsep [ppr clas, hsep (map (pprParendType) tys)]
pprTheta :: ThetaType -> SDoc
pprTheta theta = parens (hsep (punctuate comma (map ppr_dict theta)))
pprMaybeTy :: Maybe (GenType flexi) -> SDoc
pprMaybeTy Nothing = char '*'
-pprMaybeTy (Just ty) = pprParendGenType ty
+pprMaybeTy (Just ty) = pprParendType ty
\end{code}
\begin{code}
\end{code}
\begin{code}
- -- This one uses only "ppr"
init_ppr_env
- = initPprEnv b b b b (Just ppr) (Just ppr) b b b
- where
- b = panic "PprType:init_ppr_env"
-
- -- This one uses pprTyVarBndr, and thus is specific to GenTyVar's types
-init_ppr_env_type
= initPprEnv b b b b (Just pprTyVarBndr) (Just ppr) b b b
where
b = panic "PprType:init_ppr_env"
%************************************************************************
\begin{code}
-pprGenTyVar (TyVar uniq kind maybe_name _)
+pprTyVar (TyVar uniq kind maybe_name _)
= case maybe_name of
-- If the tyvar has a name we can safely use just it, I think
Just n -> pprOccName (getOccName n) <> ifPprDebug pp_debug
pprTyVarBndr tyvar@(TyVar uniq kind name _)
= getPprStyle $ \ sty ->
if ifaceStyle sty && not (isBoxedTypeKind kind) then
- hcat [pprGenTyVar tyvar, text " :: ", pprParendKind kind]
+ hcat [pprTyVar tyvar, text " :: ", pprParendKind kind]
-- See comments with ppDcolon in PprCore.lhs
else
- pprGenTyVar tyvar
+ pprTyVar tyvar
pprTyVarBndrs tyvars = hsep (map pprTyVarBndr tyvars)
\end{code}
projects / ghc-hetmet.git / commitdiff