From 2c8f04b5b883db74f449dfc8c224929fe28b027d Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 19 Mar 1998 23:57:01 +0000 Subject: [PATCH] [project @ 1998-03-19 23:54:49 by simonpj] Reorganisation of Id, IdInfo. Remove StdIdInfo, PragmaInfo; add basicTypes/MkId.lhs --- ghc/compiler/absCSyn/CLabel.lhs | 9 +- ghc/compiler/basicTypes/FieldLabel.lhs | 4 +- ghc/compiler/basicTypes/Id.hi-boot | 5 +- ghc/compiler/basicTypes/Id.lhs | 730 ++++++++----------------------- ghc/compiler/basicTypes/IdInfo.lhs | 209 +++++---- ghc/compiler/basicTypes/IdUtils.lhs | 3 +- ghc/compiler/basicTypes/Unique.lhs | 14 +- ghc/compiler/codeGen/CgBindery.lhs | 6 +- ghc/compiler/codeGen/CgCase.lhs | 44 +- ghc/compiler/coreSyn/AnnCoreSyn.lhs | 9 +- ghc/compiler/coreSyn/CoreLift.lhs | 14 +- ghc/compiler/coreSyn/CoreLint.lhs | 42 +- ghc/compiler/coreSyn/CoreSyn.lhs | 41 +- ghc/compiler/coreSyn/CoreUnfold.hi-boot | 2 +- ghc/compiler/coreSyn/CoreUnfold.lhs | 65 +-- ghc/compiler/coreSyn/CoreUtils.lhs | 19 +- ghc/compiler/coreSyn/FreeVars.lhs | 28 +- ghc/compiler/coreSyn/PprCore.lhs | 25 +- ghc/compiler/deSugar/DsBinds.lhs | 19 +- ghc/compiler/deSugar/DsCCall.lhs | 1 - ghc/compiler/deSugar/DsExpr.lhs | 4 +- ghc/compiler/deSugar/DsMonad.lhs | 7 +- ghc/compiler/deSugar/DsUtils.lhs | 4 +- ghc/compiler/deSugar/Match.lhs | 1 - ghc/compiler/hsSyn/HsCore.lhs | 13 +- ghc/compiler/hsSyn/HsDecls.lhs | 3 +- ghc/compiler/hsSyn/HsExpr.lhs | 10 +- ghc/compiler/hsSyn/HsMatches.lhs | 4 +- ghc/compiler/hsSyn/HsPat.lhs | 2 +- ghc/compiler/main/MkIface.lhs | 48 +- ghc/compiler/prelude/PrelVals.lhs | 76 ++-- ghc/compiler/prelude/PrimOp.lhs | 6 +- ghc/compiler/prelude/TysWiredIn.lhs | 3 +- ghc/compiler/profiling/SCCfinal.lhs | 3 +- ghc/compiler/reader/Lex.lhs | 8 +- ghc/compiler/rename/ParseIface.y | 17 +- ghc/compiler/rename/RnSource.lhs | 21 +- ghc/compiler/simplCore/AnalFBWW.lhs | 14 +- ghc/compiler/simplCore/BinderInfo.lhs | 54 ++- ghc/compiler/simplCore/FloatIn.lhs | 36 +- ghc/compiler/simplCore/FloatOut.lhs | 18 +- ghc/compiler/simplCore/FoldrBuildWW.lhs | 7 +- ghc/compiler/simplCore/LiberateCase.lhs | 6 +- ghc/compiler/simplCore/OccurAnal.lhs | 13 +- ghc/compiler/simplCore/SAT.lhs | 8 +- ghc/compiler/simplCore/SATMonad.lhs | 3 +- ghc/compiler/simplCore/SetLevels.lhs | 11 +- ghc/compiler/simplCore/SimplCore.lhs | 46 +- ghc/compiler/simplCore/SimplEnv.lhs | 13 +- ghc/compiler/simplCore/SimplMonad.lhs | 3 +- ghc/compiler/simplCore/SimplUtils.lhs | 29 +- ghc/compiler/simplCore/SimplVar.lhs | 15 +- ghc/compiler/simplCore/Simplify.lhs | 208 +++++---- ghc/compiler/simplStg/LambdaLift.lhs | 3 +- ghc/compiler/simplStg/SimplStg.lhs | 1 - ghc/compiler/simplStg/StgVarInfo.lhs | 1 - ghc/compiler/simplStg/UpdAnal.lhs | 17 +- ghc/compiler/specialise/SpecEnv.lhs | 17 +- ghc/compiler/specialise/SpecUtils.lhs | 8 +- ghc/compiler/specialise/Specialise.lhs | 17 +- ghc/compiler/stgSyn/CoreToStg.lhs | 52 ++- ghc/compiler/stgSyn/StgLint.lhs | 3 +- ghc/compiler/stranal/SaAbsInt.lhs | 3 +- ghc/compiler/stranal/SaLib.lhs | 3 +- ghc/compiler/stranal/StrictAnal.lhs | 14 +- ghc/compiler/stranal/WorkWrap.lhs | 25 +- ghc/compiler/stranal/WwLib.lhs | 8 +- ghc/compiler/typecheck/Inst.lhs | 3 +- ghc/compiler/typecheck/TcBinds.lhs | 152 +++---- ghc/compiler/typecheck/TcClassDcl.lhs | 16 +- ghc/compiler/typecheck/TcDeriv.lhs | 3 +- ghc/compiler/typecheck/TcEnv.lhs | 7 +- ghc/compiler/typecheck/TcExpr.lhs | 13 +- ghc/compiler/typecheck/TcHsSyn.lhs | 19 +- ghc/compiler/typecheck/TcIfaceSig.lhs | 117 +++-- ghc/compiler/typecheck/TcInstDcls.lhs | 7 +- ghc/compiler/typecheck/TcInstUtil.lhs | 3 +- ghc/compiler/typecheck/TcPat.lhs | 4 +- ghc/compiler/typecheck/TcTyDecls.lhs | 3 +- ghc/compiler/types/PprType.lhs | 50 +-- 80 files changed, 1079 insertions(+), 1493 deletions(-) diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 296bde8..1b760eb 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -55,16 +55,15 @@ import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl ) 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} diff --git a/ghc/compiler/basicTypes/FieldLabel.lhs b/ghc/compiler/basicTypes/FieldLabel.lhs index 683d8fd..e868385 100644 --- a/ghc/compiler/basicTypes/FieldLabel.lhs +++ b/ghc/compiler/basicTypes/FieldLabel.lhs @@ -24,6 +24,8 @@ data FieldLabel -- 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!) @@ -36,7 +38,7 @@ firstFieldLabelTag :: FieldLabelTag firstFieldLabelTag = 1 allFieldLabelTags :: [FieldLabelTag] -allFieldLabelTags = [1..] +allFieldLabelTags = [firstFieldLabelTag..] fieldLabelName (FieldLabel n _ _) = n fieldLabelType (FieldLabel _ ty _) = ty diff --git a/ghc/compiler/basicTypes/Id.hi-boot b/ghc/compiler/basicTypes/Id.hi-boot index 7b3f99d..7db3363 100644 --- a/ghc/compiler/basicTypes/Id.hi-boot +++ b/ghc/compiler/basicTypes/Id.hi-boot @@ -1,14 +1,11 @@ _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 ;; diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 5f12c46..f8c92bc 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -6,29 +6,17 @@ \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, @@ -36,6 +24,7 @@ module Id ( idUnique, idName, + -- Extracting pieces of particular sorts of Ids dataConRepType, dataConArgTys, dataConNumFields, @@ -56,30 +45,19 @@ module Id ( 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, @@ -87,13 +65,13 @@ module Id ( addIdUpdateInfo, getIdArity, getIdDemandInfo, - getIdInfo, getIdStrictness, getIdUnfolding, getIdUpdateInfo, - getPragmaInfo, - replaceIdInfo, replacePragmaInfo, + replaceIdInfo, addInlinePragma, nukeNoInlinePragma, addNoInlinePragma, + getIdSpecialisation, + setIdSpecialisation, -- IdEnvs AND IdSets IdEnv, GenIdSet, IdSet, @@ -129,41 +107,34 @@ module Id ( #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 ) @@ -181,14 +152,13 @@ in its @IdDetails@. 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 @@ -198,19 +168,12 @@ data IdDetails ---------------- 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. @@ -232,22 +195,16 @@ data IdDetails | 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, 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 @@ -256,113 +213,60 @@ type DictFun = Id 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} %************************************************************************ %* * @@ -371,60 +275,38 @@ properties, but they may not. %************************************************************************ \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 @@ -434,13 +316,12 @@ omitIfaceSigForId :: 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; @@ -450,47 +331,19 @@ omitIfaceSigForId (Id _ name _ details _ _) (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 @@ -502,150 +355,15 @@ local-ness precisely so that the test here would be easy \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} %************************************************************************ %* * @@ -659,12 +377,11 @@ besides the code-generator need arity info!) \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} %************************************************************************ @@ -673,49 +390,6 @@ addIdArity (Id u n ty details pinfo info) arity %* * %************************************************************************ -\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 @@ -736,20 +410,20 @@ isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience \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 @@ -772,7 +446,7 @@ dataConSig (Id _ _ _ (TupleConId arity) _ _) -- 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 @@ -780,26 +454,20 @@ 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 } @@ -815,37 +483,14 @@ dataConArgTys con_id inst_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} @@ -855,44 +500,51 @@ Notice the ``big lambdas'' and type arguments to @Con@---we are producing \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} @@ -905,63 +557,38 @@ addNoInlinePragma id@(Id u sn ty details _ info) \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} %************************************************************************ @@ -973,8 +600,7 @@ addIdStrictness (Id u n ty details prags info) strict_info 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} @@ -1008,27 +634,23 @@ Default printing code (not used for interfaces): \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 diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 85c5640..10720f0 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -13,32 +13,43 @@ module IdInfo ( 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" @@ -73,29 +84,55 @@ The @IdInfo@ gives information about the value, or definition, of the \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} @@ -103,23 +140,12 @@ ppIdInfo :: Bool -- True <=> print specialisations, please -> 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} @@ -134,60 +160,34 @@ data ArityInfo = 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} %************************************************************************ %* * @@ -227,13 +227,6 @@ might have a specialisation 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} - %************************************************************************ %* * @@ -292,11 +285,6 @@ mkBottomStrictnessInfo = BottomGuaranteed 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_") @@ -314,16 +302,38 @@ workerExists other = False %************************************************************************ %* * -\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@} @@ -352,18 +362,6 @@ updateInfoMaybe (SomeUpdateInfo u) = Just u 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)) @@ -379,10 +377,10 @@ ppUpdateInfo (SomeUpdateInfo spec) = (<>) (ptext SLIT("_U_ ")) (hcat (map int sp 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} @@ -396,11 +394,6 @@ getArgUsage (SomeArgUsageInfo u) = u \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) @@ -415,6 +408,7 @@ ppArgUsageType aut = hcat char '"' ] \end{code} + %************************************************************************ %* * \subsection[FBType-IdInfo]{Type of an expression through Foldr/build's eyes} @@ -441,11 +435,6 @@ getFBType (SomeFBTypeInfo u) = Just u \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) diff --git a/ghc/compiler/basicTypes/IdUtils.lhs b/ghc/compiler/basicTypes/IdUtils.lhs index fe04abf..b5cacf0 100644 --- a/ghc/compiler/basicTypes/IdUtils.lhs +++ b/ghc/compiler/basicTypes/IdUtils.lhs @@ -10,9 +10,8 @@ module IdUtils ( primOpName ) where 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 ) diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 44a0612..22a8556 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -1,7 +1,4 @@ -% -% (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 @@ -57,6 +54,7 @@ module Unique ( charDataConKey, charPrimTyConKey, charTyConKey, + coerceIdKey, composeIdKey, consDataConKey, doubleDataConKey, @@ -92,6 +90,7 @@ module Unique ( functorClassKey, geClassOpKey, gtDataConKey, + inlineIdKey, intDataConKey, intPrimTyConKey, intTyConKey, @@ -139,6 +138,7 @@ module Unique ( realWorldPrimIdKey, realWorldTyConKey, recConErrorIdKey, + recSelErrIdKey, recUpdErrorIdKey, return2GMPsDataConKey, return2GMPsTyConKey, @@ -638,6 +638,7 @@ errorIdKey = mkPreludeMiscIdUnique 7 foldlIdKey = mkPreludeMiscIdUnique 8 foldrIdKey = mkPreludeMiscIdUnique 9 forkIdKey = mkPreludeMiscIdUnique 10 +recSelErrIdKey = mkPreludeMiscIdUnique 11 integerMinusOneIdKey = mkPreludeMiscIdUnique 12 integerPlusOneIdKey = mkPreludeMiscIdUnique 13 integerPlusTwoIdKey = mkPreludeMiscIdUnique 14 @@ -703,3 +704,8 @@ returnMClassOpKey = mkPreludeMiscIdUnique 66 otherwiseIdKey = mkPreludeMiscIdUnique 67 toEnumClassOpKey = mkPreludeMiscIdUnique 68 \end{code} + +\begin{code} +inlineIdKey = mkPreludeMiscIdUnique 69 +coerceIdKey = mkPreludeMiscIdUnique 70 +\end{code} diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 9e3040b..26510c5 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -35,7 +35,7 @@ import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument, LambdaFormInfo ) import HeapOffs ( VirtualHeapOffset, VirtualSpAOffset, VirtualSpBOffset ) -import Id ( idPrimRep, toplevelishId, +import Id ( idPrimRep, mkIdEnv, rngIdEnv, IdEnv, idSetToList, Id @@ -231,8 +231,8 @@ getCAddrMode name \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! diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index 85cc41c..e5a7adf 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -46,14 +46,12 @@ import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon ) 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(..) ) @@ -142,46 +140,6 @@ cgCase :: StgExpr 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 diff --git a/ghc/compiler/coreSyn/AnnCoreSyn.lhs b/ghc/compiler/coreSyn/AnnCoreSyn.lhs index 7c74fd7..9ab2224 100644 --- a/ghc/compiler/coreSyn/AnnCoreSyn.lhs +++ b/ghc/compiler/coreSyn/AnnCoreSyn.lhs @@ -57,11 +57,7 @@ data AnnCoreExpr' val_bdr val_occ flexi annot | 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} @@ -91,8 +87,7 @@ deAnnotate (_, AnnCon con args) = Con con args 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) diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs index eb284c1..bd583f3 100644 --- a/ghc/compiler/coreSyn/CoreLift.lhs +++ b/ghc/compiler/coreSyn/CoreLift.lhs @@ -18,10 +18,10 @@ module CoreLift ( 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-} ) @@ -123,13 +123,9 @@ liftCoreExpr expr@(Var var) 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 -> diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 919b6e8..10d33e3 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -30,7 +30,6 @@ import Name ( isLocallyDefined, getSrcLoc, Name{-instance NamedThing-}, NamedThing(..) ) import PprCore import ErrUtils ( doIfSet, ghcExit ) -import PprType ( GenType, GenTyVar, TyCon ) import PrimOp ( primOpType ) import PrimRep ( PrimRep(..) ) import SrcLoc ( SrcLoc ) @@ -39,7 +38,7 @@ import Type ( mkFunTy, splitFunTy_maybe, mkForAllTy, 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 ) @@ -205,10 +204,16 @@ lintCoreExpr (Var var) | 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 -> @@ -297,7 +302,8 @@ lintCoreArg e ty (VarArg v) 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 @@ -406,19 +412,17 @@ lintDeflt deflt@(BindDefault binder rhs) ty %************************************************************************ %* * -\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} @@ -571,10 +575,6 @@ mkConErrMsg e = ($$) (ptext SLIT("Application of newtype constructor:")) (ppr e) -mkCoerceErrMsg e - = ($$) (ptext SLIT("Coercion using a datatype constructor:")) - (ppr e) - mkCaseAltMsg :: CoreCaseAlts -> ErrMsg mkCaseAltMsg alts @@ -665,4 +665,10 @@ mkRhsPrimMsg binder rhs 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} diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index a6fe32d..3972e55 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -7,8 +7,7 @@ module CoreSyn ( GenCoreBinding(..), GenCoreExpr(..), GenCoreArg(..), GenCoreBinder(..), GenCoreCaseAlts(..), - GenCoreCaseDefault(..), - Coercion(..), + GenCoreCaseDefault(..), CoreNote(..), bindersOf, pairsFromCoreBinds, rhssOfBind, @@ -54,7 +53,7 @@ module CoreSyn ( #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 ) @@ -171,31 +170,35 @@ scoping. -- 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} diff --git a/ghc/compiler/coreSyn/CoreUnfold.hi-boot b/ghc/compiler/coreSyn/CoreUnfold.hi-boot index 2c20727..f3e50fd 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.hi-boot +++ b/ghc/compiler/coreSyn/CoreUnfold.hi-boot @@ -4,5 +4,5 @@ CoreUnfold Unfolding UnfoldingGuidance mkUnfolding noUnfolding; _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 ;; diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 54fb905..6449cda 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -22,11 +22,9 @@ module CoreUnfold ( noUnfolding, mkMagicUnfolding, mkUnfolding, getUnfoldingTemplate, smallEnoughToInline, couldBeSmallEnoughToInline, - certainlySmallEnoughToInline, inlineUnconditionally, + certainlySmallEnoughToInline, inlineUnconditionally, okToInline, - calcUnfoldingGuidance, - - PragmaInfo(..) -- Re-export + calcUnfoldingGuidance ) where #include "HsVersions.h" @@ -42,9 +40,9 @@ import Constants ( uNFOLDING_CHEAP_OP_COST, 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 ) @@ -52,9 +50,9 @@ import OccurAnal ( occurAnalyseGlobalExpr ) 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 ) @@ -89,10 +87,10 @@ data Unfolding \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 @@ -172,8 +170,7 @@ mkFormSummary expr 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 @@ -209,7 +206,7 @@ simple variables and constants, and type applications. 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} @@ -217,7 +214,7 @@ exprIsTrivial other = False 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 @@ -236,16 +233,11 @@ exprSmallEnoughToDup expr \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 @@ -285,8 +277,7 @@ sizeExpr (I# bOMB_OUT_SIZE) args expr 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; @@ -456,7 +447,7 @@ is more accurate (see @sizeExpr@ above for how this discount size 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 @@ -519,17 +510,33 @@ certain that every use can be inlined. So, notably, any ArgOccs 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} diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 3a1af2f..838a61f 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -21,8 +21,9 @@ module CoreUtils ( 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 @@ -67,10 +68,10 @@ coreExprType (Var var) = idType var 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 of a PrimOp @@ -145,9 +146,10 @@ It looks inside lambdas because (scc "foo" \x.e) = \x.scc "foo" e \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} %************************************************************************ @@ -242,8 +244,7 @@ bop_expr f (Con con args) = Con con args 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) diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs index 6140164..cba7069 100644 --- a/ghc/compiler/coreSyn/FreeVars.lhs +++ b/ghc/compiler/coreSyn/FreeVars.lhs @@ -287,19 +287,20 @@ fvExpr id_cands tyvar_cands (Let (Rec binds) body) 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} @@ -476,13 +477,8 @@ addExprFVs fv_cand in_scope (Let binds body) (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} diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index ca2f4e6..489d2e3 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -18,14 +18,14 @@ module PprCore ( 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-} ) @@ -120,7 +120,7 @@ init_ppr_env tvbndr pbdr pocc (Just tvbndr) -- tyvar binders (Just ppr) -- tyvar occs - (Just pprParendGenType) -- types + (Just pprParendType) -- types (Just pbdr) (Just pocc) -- value vars where @@ -271,15 +271,16 @@ ppr_expr pe (Let bind expr) 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 @@ -337,7 +338,7 @@ pprCoreBinder LetBind binder = 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 @@ -348,7 +349,7 @@ pprIfaceBinder 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. -- diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index 21cd4f3..19e5ff3 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -182,13 +182,13 @@ addAutoScc auto_scc_candidate pair@(bndr, core_expr) | 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 ": @@ -200,18 +200,9 @@ addDictScc var rhs || 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} diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 7e1bc0e..bac1e98 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -17,7 +17,6 @@ import TcHsSyn ( maybeBoxedPrimType ) 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, diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 9548bd5..1e374ce 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -257,7 +257,7 @@ dsExpr (CCall label args may_gc is_asm result_ty) 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 $ @@ -340,7 +340,7 @@ dsExpr (ExplicitTuple expr_list) 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 diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index bf18761..19a4c33 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -28,11 +28,10 @@ import Bag ( emptyBag, snocBag, bagToList, Bag ) 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 ) diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index d82217d..2685e65 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -201,9 +201,7 @@ mkCoAlgCaseMatchResult var alts -- 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 diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 064ac86..d7c3bdb 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -32,7 +32,6 @@ import Id ( idType, dataConFieldLabels, 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 diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 53d16be..ae3380e 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -12,7 +12,7 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and \begin{code} module HsCore ( - UfExpr(..), UfAlts(..), UfBinder(..), UfCoercion(..), + UfExpr(..), UfAlts(..), UfBinder(..), UfNote(..), UfDefault(..), UfBinding(..), UfArg(..), UfPrimOp(..) ) where @@ -46,8 +46,7 @@ data UfExpr name | UfApp (UfExpr name) (UfArg name) | UfCase (UfExpr name) (UfAlts name) | UfLet (UfBinding name) (UfExpr name) - | UfSCC CostCentre (UfExpr name) - | UfCoerce (UfCoercion name) (HsType name) (UfExpr name) + | UfNote (UfNote name) (UfExpr name) data UfPrimOp name = UfCCallOp FAST_STRING -- callee @@ -59,7 +58,9 @@ data UfPrimOp name | 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)] @@ -138,8 +139,8 @@ instance Outputable name => Outputable (UfExpr name) where where pp_pair (b,rhs) = hsep [ppr b, equals, ppr rhs] - ppr (UfSCC uf_cc body) - = hsep [ptext SLIT("_scc_ "), 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) diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index ce68cef..4503e05 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -380,7 +380,8 @@ data HsIdInfo name | HsUpdate UpdateInfo | HsArgUsage ArgUsageInfo | HsFBType FBTypeInfo - -- ToDo: specialisations + | HsSpecialise [HsTyVar name] [HsType name] (UfExpr name) + data HsStrictnessInfo name = HsStrictnessInfo [Demand] diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index b4483da..5c7e72e 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -20,7 +20,9 @@ import HsTypes ( HsType ) 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} @@ -273,13 +275,13 @@ ppr_expr (ExplicitList exprs) = 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) @@ -313,7 +315,7 @@ ppr_expr (TyLam tyvars expr) 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) diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs index 63a783a..88c8b8c 100644 --- a/ghc/compiler/hsSyn/HsMatches.lhs +++ b/ghc/compiler/hsSyn/HsMatches.lhs @@ -15,8 +15,8 @@ import HsExpr ( HsExpr, Stmt ) 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 ) diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index ffbd373..dc1c547 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -27,7 +27,7 @@ import Id ( Id, dataConTyCon, GenId ) import Maybes ( maybeToBool ) import Outputable import TyCon ( maybeTyConSingleCon ) -import PprType ( GenType ) +import Type ( GenType ) import Name ( NamedThing ) \end{code} diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index cc8dc37..0f8c657 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -29,19 +29,17 @@ import WorkWrap ( getWorkerIdAndCons ) 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 ) @@ -53,6 +51,7 @@ import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, tyConTheta, tyConTyVars, tyConDataCons ) import Class ( Class, classBigSig ) +import SpecEnv ( specEnvToList ) import FieldLabel ( fieldLabelName, fieldLabelType ) import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, mkTyVarTys, Type, ThetaType @@ -262,14 +261,14 @@ ifaceId get_idinfo needed_ids is_rec id rhs 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) @@ -296,20 +295,31 @@ ifaceId get_idinfo needed_ids is_rec id rhs 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` @@ -344,9 +354,9 @@ ifaceBinds hdl needed_ids final_ids binds 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 diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index be0072f..b22559b 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -10,7 +10,7 @@ module PrelVals where import {-# SOURCE #-} CoreUnfold ( mkUnfolding ) -import Id ( Id, mkImported ) +import Id ( Id, mkVanillaId, mkTemplateLocals ) import SpecEnv ( SpecEnv, emptySpecEnv ) -- friends: @@ -22,7 +22,6 @@ import TysWiredIn 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 @@ -32,14 +31,17 @@ import Util ( panic ) \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 @@ -73,7 +75,7 @@ templates, but we don't ever expect to generate code for it. 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 @@ -82,6 +84,8 @@ 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 @@ -119,7 +123,7 @@ and make a jolly old mess. \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} @@ -141,7 +145,7 @@ unpackCStringId = 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 @@ -153,9 +157,7 @@ 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#") @@ -164,9 +166,7 @@ unpackCStringFoldrId 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, @@ -209,7 +209,7 @@ integerMinusOneId 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 [ @@ -244,7 +244,7 @@ seqId = pcMiscPrelId seqIdKey pRELUDE SLIT("seq") 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 [ @@ -267,7 +267,7 @@ parId = pcMiscPrelId parIdKey cONC_BASE SLIT("par") 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 [ @@ -291,7 +291,7 @@ GranSim ones: 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] @@ -315,7 +315,7 @@ parLocalId = pcMiscPrelId parLocalIdKey cONC_BASE SLIT("parLocal") 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] @@ -341,7 +341,7 @@ parAtId = pcMiscPrelId parAtIdKey cONC_BASE SLIT("parAt") (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] @@ -366,7 +366,7 @@ parAtId = pcMiscPrelId parAtIdKey cONC_BASE SLIT("parAt") 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] @@ -391,7 +391,7 @@ parAtAbsId = pcMiscPrelId parAtAbsIdKey cONC_BASE SLIT("parAtAbs") 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] @@ -417,7 +417,7 @@ parAtForNowId = pcMiscPrelId parAtForNowIdKey cONC_BASE SLIT("parAtForNow") (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] @@ -445,7 +445,7 @@ parAtForNowId = pcMiscPrelId parAtForNowIdKey cONC_BASE SLIT("parAtForNow") 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] @@ -460,7 +460,7 @@ copyableId = pcMiscPrelId copyableIdKey cONC_BASE SLIT("copyable") 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] @@ -496,11 +496,12 @@ voidId = pc_bottoming_Id voidIdKey pREL_BASE SLIT("void") voidTy \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: @@ -541,10 +542,11 @@ mkBuild ty tv c n g expr \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: @@ -564,12 +566,13 @@ foldrId = pcMiscPrelId foldrIdKey pREL_BASE SLIT("foldr") 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 @@ -578,12 +581,13 @@ foldlId = pcMiscPrelId foldlIdKey pREL_LIST SLIT("foldl") 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: diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index 59d20ce..9e1c65c 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -37,13 +37,13 @@ import CStrings ( identToC ) 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-} ) @@ -1821,7 +1821,7 @@ pprPrimOp (CCallOp fun is_casm may_gc arg_tys res_ty) = 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] diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 7f1d624..4df3241 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -92,7 +92,8 @@ module TysWiredIn ( #include "HsVersions.h" -import {-# SOURCE #-} Id ( Id, mkDataCon, mkTupleCon, StrictnessMark(..) ) +import {-# SOURCE #-} MkId ( mkDataCon, mkTupleCon ) +import {-# SOURCE #-} Id ( Id, StrictnessMark(..) ) -- friends: import PrelMods diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 0b644dc..c848f5f 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -31,7 +31,8 @@ import StgSyn 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 ) diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs index 181a93f..643bb53 100644 --- a/ghc/compiler/reader/Lex.lhs +++ b/ghc/compiler/reader/Lex.lhs @@ -213,8 +213,9 @@ data IfaceToken | 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 @@ -756,8 +757,9 @@ ifaceKeywordsFM = listToUFM $ ,("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) diff --git a/ghc/compiler/rename/ParseIface.y b/ghc/compiler/rename/ParseIface.y index b29cddf..f5a5576 100644 --- a/ghc/compiler/rename/ParseIface.y +++ b/ghc/compiler/rename/ParseIface.y @@ -83,6 +83,7 @@ import Outputable TYPE_PART { ITtysig _ _ } ARITY_PART { ITarity } UNFOLD_PART { ITunfold $$ } + SPECIALISE { ITspecialise } BOTTOM { ITbottom } LAM { ITlam } BIGLAM { ITbiglam } @@ -92,11 +93,11 @@ import Outputable 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 $$ } @@ -485,6 +486,8 @@ id_info_item : ARITY_PART arity_info { HsArity $2 } | 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) } @@ -517,8 +520,6 @@ core_expr : qvar_name { UfVar $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 @@ -526,16 +527,14 @@ core_expr : qvar_name { UfVar $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 } diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 97798b7..d4d73fb 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -616,15 +616,10 @@ rnCoreExpr (UfCase scrut alts) 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' -> @@ -697,8 +692,12 @@ rnCoreDefault (UfBindDefault bndr rhs) = bindLocalsRn "unfolding default" [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' -> diff --git a/ghc/compiler/simplCore/AnalFBWW.lhs b/ghc/compiler/simplCore/AnalFBWW.lhs index f635585..bc97044 100644 --- a/ghc/compiler/simplCore/AnalFBWW.lhs +++ b/ghc/compiler/simplCore/AnalFBWW.lhs @@ -135,12 +135,11 @@ analExprFBWW (Lam (id,_) e) env = 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 @@ -216,8 +215,7 @@ annotateExprFBWW (Lam (id,_) e) env 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') diff --git a/ghc/compiler/simplCore/BinderInfo.lhs b/ghc/compiler/simplCore/BinderInfo.lhs index eb3110e..782f514 100644 --- a/ghc/compiler/simplCore/BinderInfo.lhs +++ b/ghc/compiler/simplCore/BinderInfo.lhs @@ -20,7 +20,8 @@ module BinderInfo ( getBinderInfoArity, setBinderInfoArityToZero, - okToInline, isOneOcc, isOneFunOcc, isOneSafeFunOcc, isDeadOcc, + isOneOcc, isOneFunOcc, isOneSafeFunOcc, isOneSameSCCFunOcc, + isDeadOcc, isInlinableOcc, isFun, isDupDanger -- for Simon Marlow deforestation ) where @@ -111,10 +112,29 @@ isOneFunOcc :: BinderInfo -> Bool 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 @@ -130,30 +150,6 @@ isDupDanger _ = False \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 ~~~~~~~~~~~~~ diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 8db461a..877304d 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -163,11 +163,11 @@ fiExpr to_drop (_,AnnLam b@(TyBinder tyvar) body) 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 @@ -183,18 +183,24 @@ fiExpr to_drop (_,AnnApp fun arg) 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} diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs index c687716..654986c 100644 --- a/ghc/compiler/simplCore/FloatOut.lhs +++ b/ghc/compiler/simplCore/FloatOut.lhs @@ -15,14 +15,12 @@ import CoreSyn 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 @@ -236,7 +234,7 @@ floatExpr env lvl (Lam (ValBinder (arg,incd_lvl)) rhs) 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 @@ -244,7 +242,7 @@ floatExpr env lvl (SCC cc expr) 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 @@ -257,18 +255,18 @@ floatExpr env lvl (SCC cc expr) 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) -> diff --git a/ghc/compiler/simplCore/FoldrBuildWW.lhs b/ghc/compiler/simplCore/FoldrBuildWW.lhs index 73c4406..50d7f05 100644 --- a/ghc/compiler/simplCore/FoldrBuildWW.lhs +++ b/ghc/compiler/simplCore/FoldrBuildWW.lhs @@ -72,12 +72,9 @@ wwExpr (App f atom) = 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' -> diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs index 8d21ed0..7fdd871 100644 --- a/ghc/compiler/simplCore/LiberateCase.lhs +++ b/ghc/compiler/simplCore/LiberateCase.lhs @@ -15,8 +15,9 @@ import Util ( panic ) 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 @@ -201,8 +202,7 @@ libCase env (CoTyApp fun ty) = CoTyApp (libCase env fun) ty 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) diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 2d37a9d..4f55e08 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -554,16 +554,17 @@ If we aren't careful we duplicate the (expensive x) call! 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 diff --git a/ghc/compiler/simplCore/SAT.lhs b/ghc/compiler/simplCore/SAT.lhs index d4fb6e6..f06b416 100644 --- a/ghc/compiler/simplCore/SAT.lhs +++ b/ghc/compiler/simplCore/SAT.lhs @@ -163,13 +163,9 @@ satExpr (Let (Rec binds) 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} diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs index ac39df4..f7f67fa 100644 --- a/ghc/compiler/simplCore/SATMonad.lhs +++ b/ghc/compiler/simplCore/SATMonad.lhs @@ -35,7 +35,8 @@ import Type ( mkTyVarTy, mkSigmaTy, TyVarTemplate, Class, ThetaType, SigmaType, InstTyEnv(..) ) -import Id ( mkSysLocal, idType ) +import MkId ( mkSysLocal ) +import Id ( idType ) import SrcLoc ( SrcLoc, noSrcLoc ) import UniqSupply import Util diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 1c068f0..165cf95 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -26,7 +26,8 @@ import CoreSyn 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, @@ -258,13 +259,9 @@ lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnApp fun arg) = 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) diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index e21e0f0..a7f0eb3 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -33,9 +33,9 @@ import FiniteMap ( FiniteMap, emptyFM ) 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 @@ -57,14 +57,11 @@ import TysWiredIn ( stringTy, isIntegerTy ) 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(..), @@ -391,14 +388,15 @@ tidyCoreExpr (Let (Rec pairs) body) 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))) @@ -613,20 +611,16 @@ mapTM f (x:xs) = f x `thenTM` \ r -> -- 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' -> diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index 8602354..7f81320 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -43,7 +43,7 @@ module SimplEnv ( #include "HsVersions.h" import BinderInfo ( orBinderInfo, andBinderInfo, noBinderInfo, isOneOcc, - okToInline, isOneFunOcc, + isOneFunOcc, BinderInfo ) import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold, @@ -51,6 +51,7 @@ import CmdLineOpts ( switchIsOn, intSwitchSet, opt_UnfoldingCreationThreshold, ) import CoreSyn import CoreUnfold ( mkFormSummary, couldBeSmallEnoughToInline, whnfOrBottom, + okToInline, Unfolding(..), FormSummary(..), calcUnfoldingGuidance ) import CoreUtils ( coreExprCc ) @@ -435,9 +436,6 @@ isEvaluated other = False \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 @@ -614,7 +612,8 @@ extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) 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 @@ -664,12 +663,12 @@ extendEnvGivenBinding env@(SimplEnv chkr encl_cc ty_env (in_scope_ids, id_subst) 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} diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 85cc2fb..1a067b1 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -20,7 +20,8 @@ module SimplMonad ( #include "HsVersions.h" -import Id ( GenId, mkSysLocal, mkIdWithNewUniq, Id ) +import MkId ( mkSysLocal ) +import Id ( mkIdWithNewUniq, Id ) import SimplEnv import SrcLoc ( noSrcLoc ) import TyVar ( TyVar ) diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index c72b2c4..b46ad32 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -25,10 +25,10 @@ import BinderInfo 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 ) @@ -82,15 +82,14 @@ desired strategy. 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 @@ -310,9 +309,10 @@ etaCoreExpr expr@(Lam bndr 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: @@ -409,13 +409,12 @@ which aren't WHNF but are ``cheap'' are: \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) diff --git a/ghc/compiler/simplCore/SimplVar.lhs b/ghc/compiler/simplCore/SimplVar.lhs index 7ed82de..92cd7cf 100644 --- a/ghc/compiler/simplCore/SimplVar.lhs +++ b/ghc/compiler/simplCore/SimplVar.lhs @@ -16,13 +16,13 @@ import {-# SOURCE #-} Simplify ( simplExpr ) 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, @@ -53,7 +53,7 @@ import Outputable 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_` @@ -76,7 +76,7 @@ completeVar env var args result_ty -- 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) = {- @@ -94,6 +94,9 @@ completeVar env var args result_ty 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) @@ -135,7 +138,7 @@ completeVar env var args result_ty 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] diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 03c9495..a4f7a79 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -242,25 +242,10 @@ applied to the specified arguments. 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 @@ -408,62 +393,29 @@ simplExpr env expr@(Case scrut alts) args result_ty 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} %************************************************************************ %* * @@ -702,6 +654,33 @@ simplValLam env expr min_no_of_args expr_ty \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} + %************************************************************************ %* * @@ -711,28 +690,88 @@ simplValLam env expr min_no_of_args expr_ty \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} @@ -894,7 +933,7 @@ Notice that let to case occurs only if x is used strictly in its body -- 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) @@ -949,7 +988,7 @@ simplNonRec env binder@(id,_) rhs body_c body_ty = 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 @@ -977,7 +1016,6 @@ simplNonRec env binder@(id,_) rhs body_c 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 @@ -995,7 +1033,7 @@ simplNonRec env binder@(id,_) rhs body_c body_ty 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 || @@ -1202,7 +1240,7 @@ simplRecursiveGroup env new_ids [] = 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 @@ -1224,8 +1262,6 @@ simplRecursiveGroup env (new_id : new_ids) ((binder, rhs) : pairs) 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} @@ -1289,7 +1325,7 @@ floatBind env top_level bind -- 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 diff --git a/ghc/compiler/simplStg/LambdaLift.lhs b/ghc/compiler/simplStg/LambdaLift.lhs index 1f54bad..f342664 100644 --- a/ghc/compiler/simplStg/LambdaLift.lhs +++ b/ghc/compiler/simplStg/LambdaLift.lhs @@ -11,7 +11,8 @@ module LambdaLift ( liftProgram ) where 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, diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 2b37c43..e843a6f 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -30,7 +30,6 @@ import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv, 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 ) diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs index aef731c..aa0f524 100644 --- a/ghc/compiler/simplStg/StgVarInfo.lhs +++ b/ghc/compiler/simplStg/StgVarInfo.lhs @@ -27,7 +27,6 @@ import IdInfo ( ArityInfo(..) ) import Maybes ( maybeToBool ) import Name ( isLocallyDefined ) import BasicTypes ( Arity ) -import PprType ( GenType{-instance Outputable-} ) import Outputable infixr 9 `thenLne`, `thenLne_` diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs index 32394b8..b05872c 100644 --- a/ghc/compiler/simplStg/UpdAnal.lhs +++ b/ghc/compiler/simplStg/UpdAnal.lhs @@ -15,14 +15,16 @@ module UpdAnal ( updateAnalyse ) where 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 ) @@ -123,14 +125,15 @@ repeatedly applied to different environments after that. \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} %----------------------------------------------------------------------------- diff --git a/ghc/compiler/specialise/SpecEnv.lhs b/ghc/compiler/specialise/SpecEnv.lhs index af66c9b..9569bd1 100644 --- a/ghc/compiler/specialise/SpecEnv.lhs +++ b/ghc/compiler/specialise/SpecEnv.lhs @@ -6,14 +6,15 @@ \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 ) @@ -28,7 +29,8 @@ 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 @@ -39,6 +41,15 @@ data SpecEnv value 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. diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index 4c03f1c..7fc0352 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -32,7 +32,7 @@ import Id ( Id ) 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, @@ -184,7 +184,7 @@ argTysMatchSpecTys_error spec_tys arg_tys 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) && @@ -296,7 +296,7 @@ pp_tyspec :: SDoc -> (OccName, TyCon, [Maybe Type]) -> SDoc 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 @@ -328,7 +328,7 @@ pp_idspec pp_mod (_, id, tys, is_err) 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 diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 6c6f9d2..a3ad502 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -11,7 +11,8 @@ module Specialise ( #include "HsVersions.h" -import Id ( Id, DictVar, idType, mkUserLocal, +import MkId ( mkUserLocal ) +import Id ( Id, DictVar, idType, getIdSpecialisation, setIdSpecialisation, @@ -734,13 +735,9 @@ specExpr e@(Lit _) = returnSM (e, emptyUDs) 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 -------------------- @@ -1179,10 +1176,12 @@ instantiateDictRhs ty_env id_env rhs 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 @@ -1194,7 +1193,7 @@ dictRhsFVs e 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 diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index abcd7dd..d899067 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -20,11 +20,11 @@ import StgSyn -- output 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, @@ -322,10 +322,11 @@ coreExprToStg env expr@(App _ _) (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} %************************************************************************ @@ -334,7 +335,40 @@ coreExprToStg env expr@(App _ _) %* * %************************************************************************ + +******* 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 -> @@ -398,13 +432,13 @@ coreExprToStg env (Let bind body) 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} diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index a2d37a6..6a06265 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -21,13 +21,12 @@ import Literal ( literalType, Literal{-instance Outputable-} ) 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 diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index bc3f8c8..534eb5c 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -606,8 +606,7 @@ absEval anal (Let (Rec pairs) body) env 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} diff --git a/ghc/compiler/stranal/SaLib.lhs b/ghc/compiler/stranal/SaLib.lhs index 563ecc6..9b6751c 100644 --- a/ghc/compiler/stranal/SaLib.lhs +++ b/ghc/compiler/stranal/SaLib.lhs @@ -20,12 +20,11 @@ module SaLib ( 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} %************************************************************************ diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 70204b1..8eaecfa 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -14,18 +14,16 @@ module StrictAnal ( saWwTopBinds ) where 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 ) @@ -248,13 +246,9 @@ saExpr str_env abs_env (App fun arg) = 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 -> diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index ebea69b..be4a89b 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -13,14 +13,13 @@ import CoreUnfold ( Unfolding, certainlySmallEnoughToInline, calcUnfoldingGuidan 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 @@ -109,13 +108,9 @@ wwExpr (App f a) = 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 -> @@ -185,9 +180,7 @@ tryWW :: Id -- The fn binder -- 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 @@ -209,7 +202,7 @@ tryWW fn_id rhs 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` @@ -241,9 +234,13 @@ getWorkerIdAndCons wrap_id wrapper_fn 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 diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 237667a..ed3710a 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -14,7 +14,8 @@ module WwLib ( #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 ) @@ -27,7 +28,6 @@ import Type ( isUnpointedType, mkTyVarTys, mkFunTys, 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 @@ -368,7 +368,7 @@ mk_absent_let arg body 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 @@ -383,7 +383,7 @@ mk_unpk_case DataType arg unpk_args boxing_con boxing_tycon body 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 diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index fa54823..c34869c 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -47,7 +47,8 @@ import Bag ( emptyBag, unitBag, unionBags, unionManyBags, 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 ) diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 02e55fb..6d87eb9 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -44,16 +44,18 @@ import TcType ( TcType, TcThetaType, TcTauType, 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 ) @@ -226,7 +228,7 @@ tcBindWithSigs -> 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 @@ -339,7 +341,7 @@ tcBindWithSigs top_lvl binder_names mbind tc_ty_sigs is_rec prag_info_fn where maybe_sig = maybeSig tc_ty_sigs binder_name Just (TySigInfo _ sig_poly_id sig_tyvars _ _ _) = maybe_sig - poly_id = 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 @@ -619,7 +621,7 @@ maybeSig (sig@(TySigInfo sig_name _ _ _ _ _) : sigs) name \begin{code} -tcTySig :: (Name -> PragmaInfo) +tcTySig :: (Name -> IdInfo) -> RenamedSig -> TcM s (TcSigInfo s) @@ -630,7 +632,7 @@ tcTySig prag_info_fn (Sig v ty src_loc) -- Convert from Type to TcType tcInstSigType sigma_ty `thenNF_Tc` \ sigma_tc_ty -> let - poly_id = 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 @@ -789,40 +791,21 @@ part of a binding because then the same machinery can be used for 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. @@ -874,6 +857,11 @@ and the simplifer won't discard SpecIds for exporte things anyway, so maybe this 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) $ @@ -881,80 +869,38 @@ tcPragmaSig (SpecSig name poly_ty maybe_spec_name src_loc) -- 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} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 39ac7de..f9f28b3 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -31,15 +31,15 @@ import TcSimplify ( tcSimplifyAndCheck ) 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 @@ -59,7 +59,7 @@ import Maybes ( assocMaybe, maybeToBool ) -- import TcPragmas ( tcGenPragmas, tcClassOpPragmas ) tcGenPragmas ty id ps = returnNF_Tc noIdInfo -tcClassOpPragmas ty sel def spec ps = returnNF_Tc (noIdInfo `setSpecInfo` spec, +tcClassOpPragmas ty sel def spec ps = returnNF_Tc (spec `setSpecInfo` noIdInfo, noIdInfo) \end{code} @@ -188,7 +188,7 @@ tcClassContext rec_class rec_tyvars context pragmas -- 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) @@ -488,7 +488,7 @@ tcMethodBind clas origin inst_tys inst_tyvars sel_id meth_bind 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 diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 17c48cf..f83767c 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -30,7 +30,8 @@ import RnMonad ( RnM, RnDown, SDown, RnNameSupply(..), 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, diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index a2137dc..5ba7bf4 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -24,14 +24,13 @@ module TcEnv( #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 ) @@ -371,7 +370,7 @@ tcAddImportedIdInfo unf_env id 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} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 5176fde..4675575 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -47,7 +47,7 @@ import Class ( Class ) 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-} ) @@ -74,7 +74,6 @@ import Unique ( Unique, cCallableClassKey, cReturnableClassKey, thenMClassOpKey, zeroClassOpKey, returnMClassOpKey ) import Outputable -import PprType ( GenType, GenTyVar ) -- Instances import Maybes ( maybeToBool ) import ListSetOps ( minusList ) import Util @@ -699,6 +698,11 @@ tcArg the_fun (arg, expected_arg_ty, arg_no) -- 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 @@ -734,11 +738,10 @@ tcPolyExpr str arg expected_arg_ty -- 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 @@ -754,7 +757,7 @@ tcPolyExpr str arg expected_arg_ty HsLet (MonoBind inst_binds [] Recursive) arg' , free_insts - ) + ) \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 086e58d..ea7ccc1 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -36,8 +36,7 @@ module TcHsSyn ( -- friends: import HsSyn -- oodles of it -import Id ( GenId(..), IdDetails, -- Can meddle modestly with Ids - dataConArgTys, Id +import Id ( idType, dataConArgTys, mkIdWithNewType, Id ) -- others: @@ -151,9 +150,9 @@ maybeBoxedPrimType ty \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 @@ -180,9 +179,9 @@ extend_te te tyvars = growTyVarEnvList te [(tyvar, mkTyVarTy tyvar) | tyvar <- t 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 @@ -193,9 +192,7 @@ zonkIdOcc (TcId 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} diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 1218e41..94e42b7 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -10,7 +10,7 @@ module TcIfaceSig ( tcInterfaceSigs ) where import HsSyn ( HsDecl(..), IfaceSig(..) ) import TcMonad -import TcMonoType ( tcHsType, tcHsTypeKind ) +import TcMonoType ( tcHsType, tcHsTypeKind, tcTyVarScope ) import TcEnv ( tcExtendTyVarEnv, tcExtendGlobalValEnv, tcLookupTyConByKey, tcLookupGlobalValueMaybe, tcExplicitLookupGlobal @@ -28,20 +28,20 @@ import MagicUFs ( MagicUnfoldingFun ) 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 @@ -61,17 +61,8 @@ tcInterfaceSigs unf_env (SigD (IfaceSig name ty id_infos src_loc) : rest) = 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) @@ -83,19 +74,48 @@ tcInterfaceSigs unf_env [] = returnTc [] \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} @@ -105,15 +125,18 @@ tcStrictness unf_env ty info (HsStrictnessInfo demands maybe_worker) 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} @@ -133,20 +156,20 @@ For unfoldings we try to do the job lazily, so that we never type check an unfolding that isn't going to be looked at. \begin{code} -tcUnfolding 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} @@ -212,15 +235,18 @@ tcCoreExpr (UfCase scrut alts) 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' -> @@ -317,9 +343,6 @@ tcCoreDefault scrut_ty (UfBindDefault name rhs) 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 diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 18df0c8..85d6071 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -31,7 +31,6 @@ import TcMonad 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 ) @@ -54,7 +53,7 @@ import Name ( nameOccName, mkLocalName, 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, @@ -602,12 +601,12 @@ tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc (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 diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index 86d31bd..0c52ae8 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -23,7 +23,8 @@ import Inst ( InstanceMapper ) 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 ) diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 061b09a..e1155b0 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -29,12 +29,10 @@ import Bag ( Bag ) 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 ) diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index b7c8910..0e83986 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -35,7 +35,8 @@ import TcMonad 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 diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 3762e63..799f52e 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -5,10 +5,8 @@ \begin{code} module PprType( - GenTyVar, pprGenTyVar, pprTyVarBndr, pprTyVarBndrs, + pprTyVar, pprTyVarBndr, pprTyVarBndrs, TyCon, pprTyCon, showTyCon, - GenType, - pprGenType, pprParendGenType, pprType, pprParendType, pprMaybeTy, getTyDescription, @@ -44,7 +42,7 @@ import Util \begin{code} instance Outputable (GenType flexi) where - ppr ty = pprGenType ty + ppr ty = pprType ty instance Outputable TyCon where ppr tycon = pprTyCon tycon @@ -54,16 +52,7 @@ instance Outputable Class where 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} %************************************************************************ @@ -93,23 +82,19 @@ maybeParen ctxt_prec inner_prec pretty | 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))) @@ -118,7 +103,7 @@ 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} @@ -212,14 +197,7 @@ ppr_dict env ctxt (clas, tys) = ppr_class env clas <+> \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" @@ -235,7 +213,7 @@ ppr_class env clas = ppr clas %************************************************************************ \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 @@ -256,10 +234,10 @@ We print type-variable binders with their kinds in interface files. 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} -- 1.7.10.4